shithub: femtolisp

Download patch

ref: 0278b152b887c495dbd4d9c4feb75e384cd996e2
parent: 57c066fcdfd6058cf51154ae00e24d6a74f3a192
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Mon Jul 20 23:42:15 EDT 2009

fixing a case where tail position was not properly observed


--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -808,11 +808,9 @@
 #ifdef USE_COMPUTED_GOTO
 #define OP(x) L_##x:
 #define NEXT_OP goto *vm_labels[*ip++]
-#define DISPATCH goto *vm_labels[op]
 #else
 #define OP(x) case x:
 #define NEXT_OP goto next_op
-#define DISPATCH goto dispatch
 #endif
 
 /*
@@ -831,6 +829,7 @@
 static value_t apply_cl(uint32_t nargs)
 {
     VM_LABELS;
+    VM_APPLY_LABELS;
     uint32_t top_frame = curr_frame;
     // frame variables
     uint32_t n, captured;
@@ -839,7 +838,9 @@
     fixnum_t s, hi;
 
     // temporary variables (not necessary to preserve across calls)
+#ifndef USE_COMPUTED_GOTO
     uint32_t op;
+#endif
     uint32_t i;
     symbol_t *sym;
     static cons_t *c;
@@ -877,6 +878,7 @@
 #endif
         OP(OP_ARGC)
             n = *ip++;
+        do_argc:
             if (nargs != n) {
                 if (nargs > n)
                     lerror(ArgError, "apply: too many arguments");
@@ -916,13 +918,7 @@
             NEXT_OP;
         OP(OP_LARGC)
             n = GET_INT32(ip); ip+=4;
-            if (nargs != n) {
-                if (nargs > n)
-                    lerror(ArgError, "apply: too many arguments");
-                else
-                    lerror(ArgError, "apply: too few arguments");
-            }
-            NEXT_OP;
+            goto do_argc;
         OP(OP_LVARGC)
             i = GET_INT32(ip); ip+=4;
             goto do_vargc;
@@ -941,20 +937,62 @@
         OP(OP_TCALL)
             n = *ip++;  // nargs
         do_tcall:
-            if (isfunction(Stack[SP-n-1])) {
-                curr_frame = Stack[curr_frame-4];
-                for(s=-1; s < (fixnum_t)n; s++)
-                    Stack[bp+s] = Stack[SP-n+s];
-                SP = bp+n;
-                nargs = n;
-                goto apply_cl_top;
+            func = Stack[SP-n-1];
+            if (tag(func) == TAG_FUNCTION) {
+                if (func > (N_BUILTINS<<3)) {
+                    curr_frame = Stack[curr_frame-4];
+                    for(s=-1; s < (fixnum_t)n; s++)
+                        Stack[bp+s] = Stack[SP-n+s];
+                    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)
             n = *ip++;  // nargs
         do_call:
             func = Stack[SP-n-1];
-            s = SP;
             if (tag(func) == TAG_FUNCTION) {
                 if (func > (N_BUILTINS<<3)) {
                     Stack[curr_frame-2] = (uptrint_t)ip;
@@ -963,40 +1001,43 @@
                 }
                 else {
                     i = uintval(func);
-                    if (i > OP_ASET)
-                        type_error("apply", "function", func);
-                    op = (uint8_t)i;
-                    s = builtin_arg_counts[op];
-                    if (s >= 0)
-                        argcount(builtin_names[op], n, s);
-                    else if (s != ANYARGS && (signed)n < -s)
-                        argcount(builtin_names[op], n, -s);
-                    // remove function arg
-                    for(s=SP-n-1; s < (int)SP-1; s++)
-                        Stack[s] = Stack[s+1];
-                    SP--;
-                    switch (op) {
-                    case OP_LIST:   goto apply_list;
-                    case OP_VECTOR: goto apply_vector;
-                    case OP_APPLY:  goto apply_apply;
-                    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:
-                        DISPATCH;
+                    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
+                        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_apply;
+                        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
                     }
                 }
             }
             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;
             }
-            else {
-                type_error("apply", "function", func);
-            }
-            SP = s-n;
-            Stack[SP-1] = v;
-            NEXT_OP;
+            type_error("apply", "function", func);
         OP(OP_JMP) ip += (ptrint_t)GET_INT16(ip); NEXT_OP;
         OP(OP_BRF)
             v = POP();
@@ -1129,10 +1170,19 @@
             NEXT_OP;
 
         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)
-#ifdef USE_COMPUTED_GOTO
-            op = ip[-1];
-#endif
             n = *ip++;
         apply_apply:
             v = POP();     // arglist
@@ -1144,8 +1194,7 @@
                 v = cdr_(v);
             }
             n = SP-n;
-            if (op==OP_TAPPLY) goto do_tcall;
-            else goto do_call;
+            goto do_call;
 
         OP(OP_ADD)
             n = *ip++;
@@ -1594,12 +1643,10 @@
             break;
         case OP_LARGC:
             n = GET_INT32(ip); ip+=4;
-            sp += (n+2);
             break;
         case OP_LVARGC:
-            // move extra arguments from list to stack
             n = GET_INT32(ip); ip+=4;
-            sp += (n+3);
+            sp += (n+2);
             break;
         case OP_LET: break;
 
--- a/femtolisp/opcodes.h
+++ b/femtolisp/opcodes.h
@@ -68,8 +68,30 @@
     &&L_OP_LVARGC,                                                      \
     &&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
 #define VM_LABELS
+#define VM_APPLY_LABELS
 #endif
 
 #endif
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1040,7 +1040,6 @@
   . largs instruction to move args after MAX_ARGS from list to stack
 * maxstack calculation, make Stack growable
   * stack traces and better debugging support
-  - make maxstack calculation robust against invalid bytecode
 * improve internal define
 * try removing MAX_ARGS trickery
 - apply optimization, avoid redundant list copying calling vararg fns