lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixing a case where tail position was not properly observed

This commit is contained in:
JeffBezanson 2009-07-21 03:42:15 +00:00
parent 57c066fcdf
commit 0278b152b8
3 changed files with 123 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
femtolisp/flisp.c
View File

@ -808,11 +808,9 @@ static value_t do_trycatch()
#ifdef USE_COMPUTED_GOTO #ifdef USE_COMPUTED_GOTO
#define OP(x) L_##x: #define OP(x) L_##x:
#define NEXT_OP goto *vm_labels[*ip++] #define NEXT_OP goto *vm_labels[*ip++]
#define DISPATCH goto *vm_labels[op]
#else #else
#define OP(x) case x: #define OP(x) case x:
#define NEXT_OP goto next_op #define NEXT_OP goto next_op
#define DISPATCH goto dispatch
#endif #endif
/* /*
@ -831,6 +829,7 @@ static value_t do_trycatch()
static value_t apply_cl(uint32_t nargs) static value_t apply_cl(uint32_t nargs)
{ {
VM_LABELS; VM_LABELS;
VM_APPLY_LABELS;
uint32_t top_frame = curr_frame; uint32_t top_frame = curr_frame;
// frame variables // frame variables
uint32_t n, captured; uint32_t n, captured;
@ -839,7 +838,9 @@ static value_t apply_cl(uint32_t nargs)
fixnum_t s, hi; fixnum_t s, hi;
// temporary variables (not necessary to preserve across calls) // temporary variables (not necessary to preserve across calls)
#ifndef USE_COMPUTED_GOTO
uint32_t op; uint32_t op;
#endif
uint32_t i; uint32_t i;
symbol_t *sym; symbol_t *sym;
static cons_t *c; static cons_t *c;
@ -877,6 +878,7 @@ static value_t apply_cl(uint32_t nargs)
#endif #endif
OP(OP_ARGC) OP(OP_ARGC)
n = *ip++; n = *ip++;
do_argc:
if (nargs != n) { if (nargs != n) {
if (nargs > n) if (nargs > n)
lerror(ArgError, "apply: too many arguments"); lerror(ArgError, "apply: too many arguments");
@ -916,13 +918,7 @@ static value_t apply_cl(uint32_t nargs)
NEXT_OP; NEXT_OP;
OP(OP_LARGC) OP(OP_LARGC)
n = GET_INT32(ip); ip+=4; n = GET_INT32(ip); ip+=4;
if (nargs != n) { goto do_argc;
if (nargs > n)
lerror(ArgError, "apply: too many arguments");
else
lerror(ArgError, "apply: too few arguments");
}
NEXT_OP;
OP(OP_LVARGC) OP(OP_LVARGC)
i = GET_INT32(ip); ip+=4; i = GET_INT32(ip); ip+=4;
goto do_vargc; goto do_vargc;
@ -941,20 +937,62 @@ static value_t apply_cl(uint32_t nargs)
OP(OP_TCALL) OP(OP_TCALL)
n = *ip++; // nargs n = *ip++; // nargs
do_tcall: do_tcall:
if (isfunction(Stack[SP-n-1])) { func = Stack[SP-n-1];
curr_frame = Stack[curr_frame-4]; if (tag(func) == TAG_FUNCTION) {
for(s=-1; s < (fixnum_t)n; s++) if (func > (N_BUILTINS<<3)) {
Stack[bp+s] = Stack[SP-n+s]; curr_frame = Stack[curr_frame-4];
SP = bp+n; for(s=-1; s < (fixnum_t)n; s++)
nargs = n; Stack[bp+s] = Stack[SP-n+s];
goto apply_cl_top; SP = bp+n;
nargs = n;
goto apply_cl_top;
}
else {
i = uintval(func);
if (i <= OP_ASET) {
s = builtin_arg_counts[i];
if (s >= 0)
argcount(builtin_names[i], n, s);
else if (s != ANYARGS && (signed)n < -s)
argcount(builtin_names[i], n, -s);
// remove function arg
for(s=SP-n-1; s < (int)SP-1; s++)
Stack[s] = Stack[s+1];
SP--;
#ifdef USE_COMPUTED_GOTO
if (i == OP_APPLY)
goto apply_tapply;
goto *vm_apply_labels[i];
#else
switch (i) {
case OP_LIST: goto apply_list;
case OP_VECTOR: goto apply_vector;
case OP_APPLY: goto apply_tapply;
case OP_ADD: goto apply_add;
case OP_SUB: goto apply_sub;
case OP_MUL: goto apply_mul;
case OP_DIV: goto apply_div;
default:
op = (uint8_t)i;
goto dispatch;
}
#endif
}
}
} }
goto do_call; else if (iscbuiltin(func)) {
s = SP;
v = (((builtin_t*)ptr(func))[3])(&Stack[SP-n], n);
SP = s-n;
Stack[SP-1] = v;
NEXT_OP;
}
type_error("apply", "function", func);
// WARNING: repeated code ahead
OP(OP_CALL) OP(OP_CALL)
n = *ip++; // nargs n = *ip++; // nargs
do_call: do_call:
func = Stack[SP-n-1]; func = Stack[SP-n-1];
s = SP;
if (tag(func) == TAG_FUNCTION) { if (tag(func) == TAG_FUNCTION) {
if (func > (N_BUILTINS<<3)) { if (func > (N_BUILTINS<<3)) {
Stack[curr_frame-2] = (uptrint_t)ip; Stack[curr_frame-2] = (uptrint_t)ip;
@ -963,40 +1001,43 @@ static value_t apply_cl(uint32_t nargs)
} }
else { else {
i = uintval(func); i = uintval(func);
if (i > OP_ASET) if (i <= OP_ASET) {
type_error("apply", "function", func); s = builtin_arg_counts[i];
op = (uint8_t)i; if (s >= 0)
s = builtin_arg_counts[op]; argcount(builtin_names[i], n, s);
if (s >= 0) else if (s != ANYARGS && (signed)n < -s)
argcount(builtin_names[op], n, s); argcount(builtin_names[i], n, -s);
else if (s != ANYARGS && (signed)n < -s) // remove function arg
argcount(builtin_names[op], n, -s); for(s=SP-n-1; s < (int)SP-1; s++)
// remove function arg Stack[s] = Stack[s+1];
for(s=SP-n-1; s < (int)SP-1; s++) SP--;
Stack[s] = Stack[s+1]; #ifdef USE_COMPUTED_GOTO
SP--; goto *vm_apply_labels[i];
switch (op) { #else
case OP_LIST: goto apply_list; switch (i) {
case OP_VECTOR: goto apply_vector; case OP_LIST: goto apply_list;
case OP_APPLY: goto apply_apply; case OP_VECTOR: goto apply_vector;
case OP_ADD: goto apply_add; case OP_APPLY: goto apply_apply;
case OP_SUB: goto apply_sub; case OP_ADD: goto apply_add;
case OP_MUL: goto apply_mul; case OP_SUB: goto apply_sub;
case OP_DIV: goto apply_div; case OP_MUL: goto apply_mul;
default: case OP_DIV: goto apply_div;
DISPATCH; default:
op = (uint8_t)i;
goto dispatch;
}
#endif
} }
} }
} }
else if (iscbuiltin(func)) { else if (iscbuiltin(func)) {
s = SP;
v = (((builtin_t*)ptr(func))[3])(&Stack[SP-n], n); v = (((builtin_t*)ptr(func))[3])(&Stack[SP-n], n);
SP = s-n;
Stack[SP-1] = v;
NEXT_OP;
} }
else { type_error("apply", "function", func);
type_error("apply", "function", func);
}
SP = s-n;
Stack[SP-1] = v;
NEXT_OP;
OP(OP_JMP) ip += (ptrint_t)GET_INT16(ip); NEXT_OP; OP(OP_JMP) ip += (ptrint_t)GET_INT16(ip); NEXT_OP;
OP(OP_BRF) OP(OP_BRF)
v = POP(); v = POP();
@ -1129,10 +1170,19 @@ static value_t apply_cl(uint32_t nargs)
NEXT_OP; NEXT_OP;
OP(OP_TAPPLY) OP(OP_TAPPLY)
n = *ip++;
apply_tapply:
v = POP(); // arglist
n = SP-(n-2); // n-2 == # leading arguments not in the list
while (iscons(v)) {
if (SP >= N_STACK)
grow_stack();
PUSH(car_(v));
v = cdr_(v);
}
n = SP-n;
goto do_tcall;
OP(OP_APPLY) OP(OP_APPLY)
#ifdef USE_COMPUTED_GOTO
op = ip[-1];
#endif
n = *ip++; n = *ip++;
apply_apply: apply_apply:
v = POP(); // arglist v = POP(); // arglist
@ -1144,8 +1194,7 @@ static value_t apply_cl(uint32_t nargs)
v = cdr_(v); v = cdr_(v);
} }
n = SP-n; n = SP-n;
if (op==OP_TAPPLY) goto do_tcall; goto do_call;
else goto do_call;
OP(OP_ADD) OP(OP_ADD)
n = *ip++; n = *ip++;
@ -1594,12 +1643,10 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
break; break;
case OP_LARGC: case OP_LARGC:
n = GET_INT32(ip); ip+=4; n = GET_INT32(ip); ip+=4;
sp += (n+2);
break; break;
case OP_LVARGC: case OP_LVARGC:
// move extra arguments from list to stack
n = GET_INT32(ip); ip+=4; n = GET_INT32(ip); ip+=4;
sp += (n+3); sp += (n+2);
break; break;
case OP_LET: break; case OP_LET: break;

22
femtolisp/opcodes.h
View File

@ -68,8 +68,30 @@ enum {
&&L_OP_LVARGC, \ &&L_OP_LVARGC, \
&&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01 \ &&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01 \
} }
#define VM_APPLY_LABELS \
static void *vm_apply_labels[] = { \
&&L_OP_NOP, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
&&L_OP_BRF, &&L_OP_BRT, \
&&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
\
&&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \
&&L_OP_NULLP, &&L_OP_BOOLEANP, \
&&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \
&&L_OP_BUILTINP, &&L_OP_VECTORP, \
&&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
\
&&L_OP_CONS, &&apply_list, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \
&&L_OP_SETCDR, &&apply_apply, \
\
&&apply_add, &&apply_sub, &&apply_mul, &&apply_div, &&L_OP_IDIV, &&L_OP_NUMEQ, \
&&L_OP_LT, &&L_OP_COMPARE, \
\
&&apply_vector, &&L_OP_AREF, &&L_OP_ASET \
}
#else #else
#define VM_LABELS #define VM_LABELS
#define VM_APPLY_LABELS
#endif #endif
#endif #endif

1
femtolisp/todo
View File

@ -1040,7 +1040,6 @@ new evaluator todo:
. largs instruction to move args after MAX_ARGS from list to stack . largs instruction to move args after MAX_ARGS from list to stack
* maxstack calculation, make Stack growable * maxstack calculation, make Stack growable
* stack traces and better debugging support * stack traces and better debugging support
- make maxstack calculation robust against invalid bytecode
* improve internal define * improve internal define
* try removing MAX_ARGS trickery * try removing MAX_ARGS trickery
- apply optimization, avoid redundant list copying calling vararg fns - apply optimization, avoid redundant list copying calling vararg fns