moving (length) out of core

changing another recursive call to goto
adding special cases in compiler for 0 and 1 argument versions of some
  vararg builtins
beginning implementation of bytecode interpreter

femtolisp/builtins.c

@@ -78,6 +78,35 @@ static value_t fl_memq(value_t *args, u_int32_t nargs)
     return FL_F;
 }
 
+static value_t fl_length(value_t *args, u_int32_t nargs)
+{
+    argcount("length", nargs, 1);
+    value_t a = args[0];
+    cvalue_t *cv;
+    if (isvector(a)) {
+        return fixnum(vector_size(a));
+    }
+    else if (iscprim(a)) {
+        cv = (cvalue_t*)ptr(a);
+        if (cp_class(cv) == bytetype)
+            return fixnum(1);
+        else if (cp_class(cv) == wchartype)
+            return fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
+    }
+    else if (iscvalue(a)) {
+        cv = (cvalue_t*)ptr(a);
+        if (cv_class(cv)->eltype != NULL)
+            return size_wrap(cvalue_arraylen(a));
+    }
+    else if (a == NIL) {
+        return fixnum(0);
+    }
+    else if (iscons(a)) {
+        return fixnum(llength(a));
+    }
+    type_error("length", "sequence", a);
+}
+
 static value_t fl_raise(value_t *args, u_int32_t nargs)
 {
     argcount("raise", nargs, 1);
@@ -387,6 +416,7 @@ static builtinspec_t builtin_info[] = {
     { "nconc", fl_nconc },
     { "assq", fl_assq },
     { "memq", fl_memq },
+    { "length", fl_length },
 
     { "vector.alloc", fl_vector_alloc },
 

femtolisp/compiler.lsp

@@ -18,13 +18,13 @@
 
     :+ :- :* :/ :< :compare
 
-    :vector :aref :aset! :length :for
+    :vector :aref :aset! :for
 
     :loadt :loadf :loadnil :load0 :load1 :loadv :loadv.l
     :loadg :loada :loadc :loadg.l
     :setg  :seta  :setc  :setg.l
 
-    :closure :trycatch :tcall :tapply]))
+    :closure :trycatch :tcall :tapply :argc :vargc]))
 
 (define arg-counts
   (table :eq?      2      :eqv?     2
@@ -40,7 +40,7 @@
 	 :eval*    1      :apply    2
 	 :<        2      :for      3
 	 :compare  2      :aref     2
-	 :aset!    3      :length   1))
+	 :aset!    3))
 
 (define 1/Instructions (table.invert Instructions))
 
@@ -121,7 +121,7 @@
 			 (set! i (+ i 1)))
 			
 			((:loada :seta :call :tcall :loadv :loadg :setg
-				 :list :+ :- :* :/ :vector)
+				 :list :+ :- :* :/ :vector :argc :vargc)
 			 (io.write bcode (uint8 nxt))
 			 (set! i (+ i 1)))
 			
@@ -154,7 +154,7 @@
       cvec)))
 
 (define (bytecode g)
-  (cons (encode-byte-code (aref g 0))
+  (cons (cvalue.pin (encode-byte-code (aref g 0)))
 	(const-to-idx-vec g)))
 
 (define (bytecode:code b) (car b))
@@ -185,7 +185,7 @@
 			#f)))))
 
 (define (compile-sym g env s Is)
-  (let ((loc (lookup-sym s env 0 #t)))
+  (let ((loc (lookup-sym s env -1 #t)))
     (case (car loc)
       (arg     (emit g (aref Is 0) (cadr loc)))
       (closed  (emit g (aref Is 1) (cadr loc) (caddr loc)))
@@ -303,6 +303,14 @@
 	(begin (just-compile-args g lst env)
 	       (length lst)))))
 
+(define (emit-nothing g) g)
+
+(define (argc-error head count)
+  (error (string "compile error: " head " expects " count
+		 (if (= count 1)
+		     " argument."
+		     " arguments."))))
+  
 (define (compile-app g env tail? x)
   (let ((head  (car x)))
     (let ((head
@@ -322,13 +330,24 @@
 	      (let ((count (get arg-counts b #f)))
 		(if (and count
 			 (not (length= (cdr x) count)))
-		    (error (string "compile error: " head " expects " count
+		    (argc-error head count))
-				   (if (= count 1)
+		(case b  ; handle special cases of vararg builtins
-				       " argument."
+		  (:list (if (= nargs 0) (emit g :loadnil) (emit g b nargs)))
-				       " arguments."))))
+		  (:+    (if (= nargs 0) (emit g :load0)
-		(if (memq b '(:list :+ :- :* :/ :vector))
+			     (if (= nargs 1) (emit-nothing g)
-		    (emit g b nargs)
+				 (emit g b nargs))))
-		    (emit g (if (and tail? (eq? b :apply)) :tapply b))))
+		  (:-    (if (= nargs 0)
+			     (argc-error head 1)
+			     (emit g b nargs)))
+		  (:*    (if (= nargs 0) (emit g :load1)
+			     (if (= nargs 1) (emit-nothing g)
+				 (emit g b nargs))))
+		  (:/    (if (= nargs 0)
+			     (argc-error head 1)
+			     (emit g b nargs)))
+		  (:vector   (emit g b nargs))
+		  (else
+		   (emit g (if (and tail? (eq? b :apply)) :tapply b)))))
 	      (emit g (if tail? :tcall :call) nargs)))))))
 
 (define (compile-in g env tail? x)
@@ -360,10 +379,14 @@
 	   (else   (compile-app g env tail? x))))))
 
 (define (compile-f env f)
-  (let ((g (make-code-emitter)))
+  (let ((g    (make-code-emitter))
-    (compile-in g (cons (to-proper (cadr f)) env) #t (caddr f))
+	(args (cadr f)))
+    (if (null? (lastcdr args))
+	(emit g :argc  (length args))
+	(emit g :vargc (length args)))
+    (compile-in g (cons (to-proper args) env) #t (caddr f))
     (emit g :ret)
-    `(compiled-lambda ,(cadr f) ,(bytecode g))))
+    `(compiled-lambda ,args ,(bytecode g))))
 
 (define (compile x)
   (bytecode (compile-in (make-code-emitter) () #t x)))
@@ -410,7 +433,8 @@
 		      (print-val (aref vals (aref code i)))
 		      (set! i (+ i 1)))
 
-		     ((:loada :seta :call :tcall :list :+ :- :* :/ :vector)
+		     ((:loada :seta :call :tcall :list :+ :- :* :/ :vector
+		       :argc :vargc)
 		      (princ (number->string (aref code i)))
 		      (set! i (+ i 1)))
 

femtolisp/cvalues.c

@@ -223,26 +223,17 @@ int isstring(value_t v)
 }
 
 // convert to malloc representation (fixed address)
-/*
+void cv_pin(cvalue_t *cv)
-static void cv_pin(cvalue_t *cv)
 {
-    if (!cv->flags.inlined)
+    if (!isinlined(cv))
         return;
-    size_t sz = cv->flags.inllen;
+    size_t sz = cv_len(cv);
+    if (cv_isstr(cv)) sz++;
     void *data = malloc(sz);
-    cv->flags.inlined = 0;
+    memcpy(data, cv_data(cv), sz);
-    // TODO: handle flags.cstring
+    cv->data = data;
-    if (cv->flags.prim) {
-        memcpy(data, (void*)(&((cprim_t*)cv)->data), sz);
-        ((cprim_t*)cv)->data = data;
-    }
-    else {
-        memcpy(data, (void*)(&cv->data), sz);
-        cv->data = data;
-    }
     autorelease(cv);
 }
-*/
 
 #define num_init(ctype, cnvt, tag)                              \
 static int cvalue_##ctype##_init(fltype_t *type, value_t arg,   \
@@ -703,6 +694,15 @@ value_t fl_copy(value_t *args, u_int32_t nargs)
     return cvalue_copy(args[0]);
 }
 
+value_t fl_cv_pin(value_t *args, u_int32_t nargs)
+{
+    argcount("cvalue.pin", nargs, 1);
+    if (!iscvalue(args[0]))
+        lerror(ArgError, "cvalue.pin: must be a byte array");
+    cv_pin((cvalue_t*)ptr(args[0]));
+    return args[0];
+}
+
 static void cvalue_init(fltype_t *type, value_t v, void *dest)
 {
     cvinitfunc_t f=type->init;
@@ -907,6 +907,7 @@ static builtinspec_t cvalues_builtin_info[] = {
     { "sizeof", cvalue_sizeof },
     { "builtin", fl_builtin },
     { "copy", fl_copy },
+    { "cvalue.pin", fl_cv_pin },
 
     { "logand", fl_logand },
     { "logior", fl_logior },

femtolisp/flisp.c

@@ -50,6 +50,7 @@
 #include <math.h>
 #include "llt.h"
 #include "flisp.h"
+#include "opcodes.h"
 
 static char *builtin_names[] =
     { // special forms
@@ -70,7 +71,7 @@ static char *builtin_names[] =
       "+", "-", "*", "/", "<", "compare",
 
       // sequences
-      "vector", "aref", "aset!", "length", "for",
+      "vector", "aref", "aset!", "for",
       "", "", "" };
 
 #define N_STACK 262144
@@ -88,7 +89,7 @@ stackseg_t stackseg0 = { StaticStack, 0, NULL };
 stackseg_t *current_stack_seg = &stackseg0;
 
 value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH;
-value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
+value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, COMPILEDLAMBDA;
 value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
 value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
 value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
@@ -96,6 +97,7 @@ value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
 value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym;
 
 static value_t eval_sexpr(value_t e, value_t *penv, int tail);
+static value_t apply_cl(uint32_t nargs);
 static value_t *alloc_words(int n);
 static value_t relocate(value_t v);
 
@@ -770,7 +772,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
     uint32_t saveSP, bp, envsz, nargs;
     int i, noeval=0;
     fixnum_t s, lo, hi;
-    cvalue_t *cv;
     int64_t accum;
 
     /*
@@ -1085,38 +1086,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
                 }
             }
             break;
-        case F_LENGTH:
-            argcount("length", nargs, 1);
-            if (isvector(Stack[SP-1])) {
-                v = fixnum(vector_size(Stack[SP-1]));
-                break;
-            }
-            else if (iscprim(Stack[SP-1])) {
-                cv = (cvalue_t*)ptr(Stack[SP-1]);
-                if (cp_class(cv) == bytetype) {
-                    v = fixnum(1);
-                    break;
-                }
-                else if (cp_class(cv) == wchartype) {
-                    v = fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
-                    break;
-                }
-            }
-            else if (iscvalue(Stack[SP-1])) {
-                cv = (cvalue_t*)ptr(Stack[SP-1]);
-                if (cv_class(cv)->eltype != NULL) {
-                    v = size_wrap(cvalue_arraylen(Stack[SP-1]));
-                    break;
-                }
-            }
-            else if (Stack[SP-1] == NIL) {
-                v = fixnum(0); break;
-            }
-            else if (iscons(Stack[SP-1])) {
-                v = fixnum(llength(Stack[SP-1])); break;
-            }
-            type_error("length", "sequence", Stack[SP-1]);
-            break;
         case F_AREF:
             argcount("aref", nargs, 2);
             v = Stack[SP-2];
@@ -1152,7 +1121,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
             break;
         case F_ATOM:
             argcount("atom?", nargs, 1);
-            v = ((!iscons(Stack[SP-1])) ? FL_T : FL_F);
+            v = (iscons(Stack[SP-1]) ? FL_F : FL_T);
             break;
         case F_CONSP:
             argcount("pair?", nargs, 1);
@@ -1325,24 +1294,23 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
             break;
         case F_EVAL:
             argcount("eval", nargs, 1);
-            v = Stack[SP-1];
+            e = Stack[SP-1];
-            if (selfevaluating(v)) { SP=saveSP; return v; }
+            if (selfevaluating(e)) { SP=saveSP; return e; }
             if (tail) {
                 assert((ulong_t)(penv-Stack)<N_STACK);
                 penv[-1] = fixnum(2);
                 penv[0] = NIL;
                 penv[1] = NIL;
                 SP = (penv-Stack) + 2;
-                e=v;
-                goto eval_top;
             }
             else {
                 PUSH(fixnum(2));
                 PUSH(NIL);
                 PUSH(NIL);
-                v = eval_sexpr(v, &Stack[SP-2], 1);
+                tail = 1;
+                penv = &Stack[SP-2];
             }
-            break;
+            goto eval_top;
         case F_EVALSTAR:
             argcount("eval*", nargs, 1);
             e = Stack[SP-1];
@@ -1404,9 +1372,14 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
         SP = saveSP;
         return v;
     }
+    f = Stack[bp+1];
     if (__likely(iscons(f))) {
+        if (car_(f) == COMPILEDLAMBDA) {
+            v = apply_cl(nargs);
+            SP = saveSP;
+            return v;
+        }
         // apply lambda expression
-        f = Stack[bp+1];
         f = Stack[bp+1] = cdr_(f);
         if (!iscons(f)) goto notpair;
         v = car_(f); // arglist
@@ -1422,18 +1395,16 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
                 lerror(ArgError, "apply: too many arguments");
         }
         else {
+            v = NIL;
             if (i > 0) {
                 list(&v, i, &NIL);
                 if (nargs > MAX_ARGS) {
                     c = (cons_t*)curheap;
                     (c-2)->cdr = (c-1)->car;
                 }
-                Stack[SP-i] = v;
-                SP -= (i-1);
-            }
-            else {
-                PUSH(NIL);
             }
+            Stack[SP-i] = v;
+            SP -= (i-1);
         }
         f = cdr_(Stack[bp+1]);
         if (!iscons(f)) goto notpair;
@@ -1477,6 +1448,503 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
     return NIL;
 }
 
+/*
+  stack on entry: <func>  <args...>
+  caller's responsibility:
+  - put the stack in this state
+  - provide arg count
+  - respect tail position
+  - call correct entry point (either eval_sexpr or apply_cl)
+
+  callee's responsibility:
+  - check arg counts
+  - allocate vararg array
+  - push closed env, set up new environment
+
+  ** need 'copyenv' instruction that moves env to heap, installs
+     heap version as the current env, and pushes the result vector.
+     this can be used to implement the copy-closure op in terms of
+     other ops. and it can be the first instruction in lambdas in
+     head position (let optimization).
+*/
+static value_t apply_cl(uint32_t nargs)
+{
+    uint32_t i, n, ip, bp;
+    fixnum_t s;
+    int64_t accum;
+    uint8_t op, *code;
+    value_t func, v, bcode, x, e, ftl;
+    value_t *penv, *pvals;
+    symbol_t *sym;
+    cons_t *c;
+
+ apply_cl_top:
+    func = Stack[SP-nargs-1];
+    ftl = cdr_(cdr_(func));
+    bcode = car_(ftl);
+    code = cv_data((cvalue_t*)ptr(car_(bcode)));
+    i = code[1];
+    if (nargs < i)
+        lerror(ArgError, "apply: too few arguments");
+    if (code[0] == OP_VARGC) {
+        s = (fixnum_t)nargs - (fixnum_t)i;
+        v = NIL;
+        if (s > 0) {
+            list(&v, s, &NIL);
+            if (nargs > MAX_ARGS) {
+                c = (cons_t*)curheap;
+                (c-2)->cdr = (c-1)->car;
+            }
+            // reload movable pointers
+            func = Stack[SP-nargs-1];
+            ftl = cdr_(cdr_(func));
+            bcode = car_(ftl);
+            code = cv_data((cvalue_t*)ptr(car_(bcode)));
+        }
+        Stack[SP-s] = v;
+        SP -= (s-1);
+        nargs = i+1;
+    }
+    else if (nargs > i) {
+        lerror(ArgError, "apply: too many arguments");
+    }
+
+    bp = SP-nargs;
+    x = cdr_(ftl);   // cloenv
+    Stack[bp-1] = car_(cdr_(func));  // lambda list
+    penv = &Stack[bp-1];
+    PUSH(x);
+    PUSH(cdr_(bcode));
+    pvals = &Stack[SP-1];
+
+    ip = 2;
+    while (1) {
+        op = code[ip++];
+        switch (op) {
+        case OP_NOP: break;
+        case OP_DUP: v = Stack[SP-1]; PUSH(v); break;
+        case OP_POP: (void)POP(); break;
+        case OP_TCALL:
+        case OP_CALL:
+            i = code[ip++];  // nargs
+        do_call:
+            s = SP;
+            func = Stack[SP-i-1];
+            if (isbuiltinish(func)) {
+                if (uintval(func) > N_BUILTINS) {
+                    v = ((builtin_t)ptr(func))(&Stack[SP-i], i);
+                }
+            }
+            else {
+                if (iscons(func) && car_(func) == COMPILEDLAMBDA) {
+                    if (op == OP_TCALL) {
+                        for(s=-1; s < (fixnum_t)i; s++)
+                            Stack[bp+s] = Stack[SP-i+s];
+                        SP = bp+i;
+                        nargs = i;
+                        goto apply_cl_top;
+                    }
+                    else {
+                        v = apply_cl(i);
+                    }
+                }
+            }
+            SP = s-i-1;
+            PUSH(v);
+            break;
+        case OP_JMP: ip = (uint32_t)*(uint16_t*)&code[ip]; break;
+        case OP_BRF:
+            v = POP();
+            if (v == FL_F) ip = (uint32_t)*(uint16_t*)&code[ip];
+            else ip += 2;
+            break;
+        case OP_BRT:
+            v = POP();
+            if (v != FL_F) ip = (uint32_t)*(uint16_t*)&code[ip];
+            else ip += 2;
+            break;
+        case OP_JMPL: ip = *(uint32_t*)&code[ip]; break;
+        case OP_BRFL:
+            v = POP();
+            if (v == FL_F) ip = *(uint32_t*)&code[ip];
+            else ip += 4;
+            break;
+        case OP_BRTL:
+            v = POP();
+            if (v != FL_F) ip = *(uint32_t*)&code[ip];
+            else ip += 4;
+            break;
+        case OP_RET: v = POP(); return v;
+
+        case OP_EQ:
+            Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F);
+            POP(); break;
+        case OP_EQV:
+            if (Stack[SP-2] == Stack[SP-1]) {
+                v = FL_T;
+            }
+            else if (!leafp(Stack[SP-2]) || !leafp(Stack[SP-1])) {
+                v = FL_F;
+            }
+            else {
+                v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
+                    FL_T : FL_F;
+            }
+            Stack[SP-2] = v; POP();
+            break;
+        case OP_EQUAL:
+            if (Stack[SP-2] == Stack[SP-1]) {
+                v = FL_T;
+            }
+            else if (eq_comparable(Stack[SP-2],Stack[SP-1])) {
+                v = FL_F;
+            }
+            else {
+                v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
+                    FL_T : FL_F;
+            }
+            Stack[SP-2] = v; POP();
+            break;
+        case OP_PAIRP:
+            Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_T : FL_F); break;
+        case OP_ATOMP:
+            Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_F : FL_T); break;
+        case OP_NOT:
+            Stack[SP-1] = ((Stack[SP-1]==FL_F) ? FL_T : FL_F); break;
+        case OP_NULLP:
+            Stack[SP-1] = ((Stack[SP-1]==NIL) ? FL_T : FL_F); break;
+        case OP_BOOLEANP:
+            v = Stack[SP-1];
+            Stack[SP-1] = ((v == FL_T || v == FL_F) ? FL_T : FL_F); break;
+        case OP_SYMBOLP:
+            Stack[SP-1] = (issymbol(Stack[SP-1]) ? FL_T : FL_F); break;
+        case OP_NUMBERP:
+            v = Stack[SP-1];
+            Stack[SP-1] = (isfixnum(v) || iscprim(v) ? FL_T : FL_F); break;
+        case OP_FIXNUMP:
+            Stack[SP-1] = (isfixnum(Stack[SP-1]) ? FL_T : FL_F); break;
+        case OP_BOUNDP:
+            sym = tosymbol(Stack[SP-1], "bound?");
+            Stack[SP-1] = ((sym->binding == UNBOUND) ? FL_F : FL_T);
+            break;
+        case OP_BUILTINP:
+            v = Stack[SP-1];
+            Stack[SP-1] = ((isbuiltinish(v) && v!=FL_F && v!=FL_T && v!=NIL)
+                           ? FL_T : FL_F);
+            break;
+        case OP_VECTORP:
+            Stack[SP-1] = (isvector(Stack[SP-1]) ? FL_T : FL_F); break;
+
+        case OP_CONS:
+            if (curheap > lim)
+                gc(0);
+            c = (cons_t*)curheap;
+            curheap += sizeof(cons_t);
+            c->car = Stack[SP-2];
+            c->cdr = Stack[SP-1];
+            Stack[SP-2] = tagptr(c, TAG_CONS);
+            POP(); break;
+        case OP_CAR:
+            c = tocons(Stack[SP-1], "car");
+            Stack[SP-1] = c->car;
+            break;
+        case OP_CDR:
+            c = tocons(Stack[SP-1], "cdr");
+            Stack[SP-1] = c->cdr;
+            break;
+        case OP_SETCAR:
+            car(Stack[SP-2]) = Stack[SP-1];
+            POP(); break;
+        case OP_SETCDR:
+            cdr(Stack[SP-2]) = Stack[SP-1];
+            POP(); break;
+        case OP_LIST:
+            i = code[ip++];
+            list(&v, i, &NIL);
+            POPN(i);
+            PUSH(v);
+            break;
+        case OP_EVAL:
+            v = toplevel_eval(POP());
+            PUSH(v);
+            break;
+        case OP_EVALSTAR:
+
+        case OP_TAPPLY:
+        case OP_APPLY:
+            v = POP();  // arglist
+            i = SP;
+            while (iscons(v)) {
+                if (SP-i == MAX_ARGS) {
+                    PUSH(v);
+                    break;
+                }
+                PUSH(car_(v));
+                v = cdr_(v);
+            }
+            i = SP-i;
+            if (op==OP_TAPPLY) op = OP_TCALL;
+            goto do_call;
+
+        case OP_ADD:
+            s = 0;
+            n = code[ip++];
+            i = SP-n;
+            if (n > MAX_ARGS) goto add_ovf;
+            for (; i < (int)SP; i++) {
+                if (__likely(isfixnum(Stack[i]))) {
+                    s += numval(Stack[i]);
+                    if (__unlikely(!fits_fixnum(s))) {
+                        i++;
+                        goto add_ovf;
+                    }
+                }
+                else {
+                add_ovf:
+                    v = fl_add_any(&Stack[i], SP-i, s);
+                    break;
+                }
+            }
+            if (i==SP)
+                v = fixnum(s);
+            POPN(n);
+            PUSH(v);
+            break;
+        case OP_SUB:
+            n = code[ip++];
+            if (__unlikely(n < 1)) lerror(ArgError, "-: too few arguments");
+            i = SP-n;
+            if (n == 1) {
+                if (__likely(isfixnum(Stack[i])))
+                    Stack[SP-1] = fixnum(-numval(Stack[i]));
+                else
+                    Stack[SP-1] = fl_neg(Stack[i]);
+                break;
+            }
+            if (n == 2) {
+                if (__likely(bothfixnums(Stack[i], Stack[i+1]))) {
+                    s = numval(Stack[i]) - numval(Stack[i+1]);
+                    if (__likely(fits_fixnum(s))) {
+                        POP();
+                        Stack[SP-1] = fixnum(s);
+                        break;
+                    }
+                    Stack[i+1] = fixnum(-numval(Stack[i+1]));
+                }
+                else {
+                    Stack[i+1] = fl_neg(Stack[i+1]);
+                }
+            }
+            else {
+                // we need to pass the full arglist on to fl_add_any
+                // so it can handle rest args properly
+                PUSH(Stack[i]);
+                Stack[i] = fixnum(0);
+                Stack[i+1] = fl_neg(fl_add_any(&Stack[i], n, 0));
+                Stack[i] = POP();
+            }
+            v = fl_add_any(&Stack[i], 2, 0);
+            POPN(n);
+            PUSH(v);
+            break;
+        case OP_MUL:
+            accum = 1;
+            n = code[ip++];
+            i = SP-n;
+            if (n > MAX_ARGS) goto mul_ovf;
+            for (; i < (int)SP; i++) {
+                if (__likely(isfixnum(Stack[i]))) {
+                    accum *= numval(Stack[i]);
+                }
+                else {
+                mul_ovf:
+                    v = fl_mul_any(&Stack[i], SP-i, accum);
+                    break;
+                }
+            }
+            if (i == SP) {
+                if (__likely(fits_fixnum(accum)))
+                    v = fixnum(accum);
+                else
+                    v = return_from_int64(accum);
+            }
+            POPN(n);
+            PUSH(v);
+            break;
+        case OP_DIV:
+            n = code[ip++];
+            if (__unlikely(n < 1)) lerror(ArgError, "/: too few arguments");
+            i = SP-n;
+            if (n == 1) {
+                Stack[SP-1] = fl_div2(fixnum(1), Stack[i]);
+            }
+            else {
+                if (n > 2) {
+                    PUSH(Stack[i]);
+                    Stack[i] = fixnum(1);
+                    Stack[i+1] = fl_mul_any(&Stack[i], n, 1);
+                    Stack[i] = POP();
+                }
+                v = fl_div2(Stack[i], Stack[i+1]);
+                POPN(n);
+                PUSH(v);
+            }
+            break;
+        case OP_LT:
+            if (bothfixnums(Stack[SP-2], Stack[SP-1])) {
+                v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? FL_T : FL_F;
+            }
+            else {
+                v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ?
+                    FL_T : FL_F;
+            }
+            POP();
+            Stack[SP-1] = v;
+            break;
+        case OP_COMPARE:
+            Stack[SP-2] = compare(Stack[SP-2], Stack[SP-1]);
+            POP();
+            break;
+
+        case OP_VECTOR:
+            n = code[ip++];
+            if (n > MAX_ARGS) {
+                i = llength(Stack[SP-1]);
+                n--;
+            }
+            else i = 0;
+            v = alloc_vector(n+i, 0);
+            memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t));
+            if (i > 0) {
+                e = POP();
+                POPN(n);
+                while (iscons(e)) {
+                    vector_elt(v,n) = car_(e);
+                    n++;
+                    e = cdr_(e);
+                }
+            }
+            PUSH(v);
+            break;
+
+        case OP_AREF:
+            v = Stack[SP-2];
+            if (isvector(v)) {
+                i = tofixnum(Stack[SP-1], "aref");
+                if (__unlikely((unsigned)i >= vector_size(v)))
+                    bounds_error("aref", v, Stack[SP-1]);
+                v = vector_elt(v, i);
+            }
+            else if (isarray(v)) {
+                v = cvalue_array_aref(&Stack[SP-2]);
+            }
+            else {
+                type_error("aref", "sequence", v);
+            }
+            POP();
+            Stack[SP-1] = v;
+            break;
+        case OP_ASET:
+            e = Stack[SP-3];
+            if (isvector(e)) {
+                i = tofixnum(Stack[SP-2], "aset!");
+                if (__unlikely((unsigned)i >= vector_size(e)))
+                    bounds_error("aset!", v, Stack[SP-1]);
+                vector_elt(e, i) = (v=Stack[SP-1]);
+            }
+            else if (isarray(e)) {
+                v = cvalue_array_aset(&Stack[SP-3]);
+            }
+            else {
+                type_error("aset!", "sequence", e);
+            }
+            POPN(2);
+            Stack[SP-1] = v;
+            break;
+        case OP_FOR:
+
+        case OP_LOADT: PUSH(FL_T); break;
+        case OP_LOADF: PUSH(FL_F); break;
+        case OP_LOADNIL: PUSH(NIL); break;
+        case OP_LOAD0: PUSH(fixnum(0)); break;
+        case OP_LOAD1: PUSH(fixnum(1)); break;
+        case OP_LOADV:
+            v = vector_elt(*pvals, code[ip]); ip++;
+            PUSH(v);
+            break;
+        case OP_LOADVL:
+            v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4;
+            PUSH(v);
+            break;
+        case OP_LOADGL:
+            v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4;
+            goto do_loadg;
+        case OP_LOADG:
+            v = vector_elt(*pvals, code[ip]); ip++;
+        do_loadg:
+            sym = (symbol_t*)ptr(v);
+            if (sym->binding == UNBOUND)
+                raise(list2(UnboundError, v));
+            PUSH(sym->binding);
+            break;
+
+        case OP_SETGL:
+            v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4;
+            goto do_setg;
+        case OP_SETG:
+            v = vector_elt(*pvals, code[ip]); ip++;
+        do_setg:
+            sym = (symbol_t*)ptr(v);
+            v = Stack[SP-1];
+            if (sym->syntax != TAG_CONST)
+                sym->binding = v;
+            break;
+
+        case OP_LOADA:
+            i = code[ip++];
+            if (penv[0] == NIL)
+                v = vector_elt(penv[1], i+1);
+            else
+                v = Stack[bp+i];
+            PUSH(v);
+            break;
+        case OP_SETA:
+            v = Stack[SP-1];
+            i = code[ip++];
+            if (penv[0] == NIL)
+                vector_elt(penv[1], i+1) = v;
+            else
+                Stack[bp+i] = v;
+            break;
+        case OP_LOADC:
+        case OP_SETC:
+            s = code[ip++];
+            i = code[ip++];
+            if (penv[0]==NIL) {
+                if (nargs > 0) {
+                    // current frame has been captured
+                    s++;
+                }
+                v = penv[1];
+            }
+            else {
+                v = penv[numval(penv[-1])-1];
+            }
+            while (s--)
+                v = vector_elt(v, vector_size(v)-1);
+            if (op == OP_SETC)
+                vector_elt(v, i) = Stack[SP-1];
+            else
+                PUSH(vector_elt(v, i));
+            break;
+
+        case OP_CLOSURE:
+        case OP_TRYCATCH:
+            break;
+        }
+    }
+}
+
 // initialization -------------------------------------------------------------
 
 extern void builtins_init();
@@ -1510,6 +1978,7 @@ static void lisp_init(void)
     FL_T = builtin(F_TRUE);
     FL_F = builtin(F_FALSE);
     LAMBDA = symbol("lambda");
+    COMPILEDLAMBDA = symbol("compiled-lambda");
     QUOTE = symbol("quote");
     TRYCATCH = symbol("trycatch");
     BACKQUOTE = symbol("backquote");

femtolisp/flisp.h

@@ -127,9 +127,9 @@ enum {
     F_EVAL, F_EVALSTAR, F_APPLY,
     F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_COMPARE,
 
-    F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_FOR,
+    F_VECTOR, F_AREF, F_ASET, F_FOR,
     F_TRUE, F_FALSE, F_NIL,
-    N_BUILTINS,
+    N_BUILTINS
 };
 #define isspecial(v) (uintval(v) <= (unsigned int)F_BEGIN)
 
@@ -274,6 +274,7 @@ extern fltype_t *builtintype;
 value_t cvalue(fltype_t *type, size_t sz);
 void add_finalizer(cvalue_t *cv);
 void cv_autorelease(cvalue_t *cv);
+void cv_pin(cvalue_t *cv);
 size_t ctype_sizeof(value_t type, int *palign);
 value_t cvalue_copy(value_t v);
 value_t cvalue_from_data(fltype_t *type, void *data, size_t sz);