changing boot file format; the old one did not preserve sharing

between top-level functions
making colon at the end also valid for keywords
adding keyword? predicate
fixing bug in map
adding functions to emulate values and call-with-values
adding receive macro
improving equal? on closures
adding lambda-lifting optimization to the compiler

femtolisp/builtins.c

@@ -138,6 +138,14 @@ static value_t fl_symbol(value_t *args, u_int32_t nargs)
     return symbol(cvalue_data(args[0]));
 }
 
+static value_t fl_keywordp(value_t *args, u_int32_t nargs)
+{
+    argcount("keyword?", nargs, 1);
+    symbol_t *sym = tosymbol(args[0], "keyword?");
+    char *str = sym->name;
+    return fl_is_keyword_name(str, strlen(str)) ? FL_T : FL_F;
+}
+
 static value_t fl_top_level_value(value_t *args, u_int32_t nargs)
 {
     argcount("top-level-value", nargs, 1);
@@ -417,6 +425,7 @@ static builtinspec_t builtin_info[] = {
     { "raise", fl_raise },
     { "exit", fl_exit },
     { "symbol", fl_symbol },
+    { "keyword?", fl_keywordp },
 
     { "fixnum", fl_fixnum },
     { "truncate", fl_truncate },

femtolisp/compiler.lsp

@@ -46,10 +46,11 @@
          :aref     2      :aset!    3
 	 :div0     2))
 
-(define (make-code-emitter) (vector () (table) 0))
+(define (make-code-emitter) (vector () (table) 0 +inf.0))
 (define (bcode:code   b) (aref b 0))
 (define (bcode:ctable b) (aref b 1))
 (define (bcode:nconst b) (aref b 2))
+(define (bcode:cdepth b d) (aset! b 3 (min (aref b 3) d)))
 ; get an index for a referenced value in a bytecode object
 (define (bcode:indexfor b v)
   (let ((const-to-idx (bcode:ctable b))
@@ -205,11 +206,16 @@
 			(if (or arg? (null? curr)) lev (+ lev 1))
 			#f)))))
 
+; number of non-nulls
+(define (nnn e) (count (lambda (x) (not (null? x))) e))
+
 (define (compile-sym g env s Is)
   (let ((loc (lookup-sym s env 0 #t)))
     (case (car loc)
       (arg     (emit g (aref Is 0) (cadr loc)))
-      (closed  (emit g (aref Is 1) (cadr loc) (caddr loc)))
+      (closed  (emit g (aref Is 1) (cadr loc) (caddr loc))
+	       ; update index of most distant captured frame
+	       (bcode:cdepth g (- (nnn (cdr env)) 1 (cadr loc))))
       (else    (emit g (aref Is 2) s)))))
 
 (define (compile-if g env tail? x)
@@ -345,7 +351,9 @@
 	(args (cdr x)))
     (unless (length= args (length (cadr head)))
 	    (error (string "apply: incorrect number of arguments to " head)))
-    (emit g :loadv (compile-f env head #t))
+    (receive (the-f dept) (compile-f- env head #t)
+      (emit g :loadv the-f)
+      (bcode:cdepth g dept))
     (let ((nargs (compile-arglist g env args)))
       (emit g :copyenv)
       (emit g (if tail? :tcall :call) (+ 1 nargs)))))
@@ -428,8 +436,11 @@
 	   (if       (compile-if g env tail? x))
 	   (begin    (compile-begin g env tail? (cdr x)))
 	   (prog1    (compile-prog1 g env x))
-	   (lambda   (begin (emit g :loadv (compile-f env x))
+	   (lambda   (receive (the-f dept) (compile-f- env x)
-			    (emit g :closure)))
+		       (begin (emit g :loadv the-f)
+			      (bcode:cdepth g dept)
+			      (if (< dept (nnn env))
+				  (emit g :closure)))))
 	   (and      (compile-and g env tail? (cdr x)))
 	   (or       (compile-or  g env tail? (cdr x)))
 	   (while    (compile-while g env (cadr x) (cons 'begin (cddr x))))
@@ -446,6 +457,11 @@
 	   (else   (compile-app g env tail? x))))))
 
 (define (compile-f env f . let?)
+  (receive (ff ignore)
+	   (apply compile-f- env f let?)
+	   ff))
+
+(define (compile-f- env f . let?)
   (let ((g    (make-code-emitter))
 	(args (cadr f)))
     (cond ((not (null? let?))      (emit g :let))
@@ -456,8 +472,9 @@
 	  (else  (emit g :vargc (if (atom? args) 0 (length args)))))
     (compile-in g (cons (to-proper args) env) #t (caddr f))
     (emit g :ret)
-    (function (encode-byte-code (bcode:code g))
+    (values (function (encode-byte-code (bcode:code g))
-	      (const-to-idx-vec g) (lastcdr f))))
+		      (const-to-idx-vec g) (lastcdr f))
+	    (aref g 3))))
 
 (define (compile f) (compile-f () f))
 

femtolisp/equal.c

@@ -89,9 +89,18 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
         }
         break;
     case TAG_FUNCTION:
-        if (uintval(a) > N_BUILTINS || uintval(b) > N_BUILTINS)
-            return fixnum(1);
         if (tagb == TAG_FUNCTION) {
+            if (uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS) {
+                function_t *fa = (function_t*)ptr(a);
+                function_t *fb = (function_t*)ptr(b);
+                d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq);
+                if (d==NIL || numval(d) != 0) return d;
+                d = bounded_compare(fa->vals, fb->vals, bound-1, eq);
+                if (d==NIL || numval(d) != 0) return d;
+                d = bounded_compare(fa->env, fb->env, bound-1, eq);
+                if (d==NIL || numval(d) != 0) return d;
+                return fixnum(0);
+            }
             return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
         }
         break;
@@ -122,12 +131,12 @@ static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
         xb = vector_elt(b,i);
         if (leafp(xa) || leafp(xb)) {
             d = bounded_compare(xa, xb, 1, eq);
-            if (numval(d)!=0) return d;
+            if (d!=NIL && numval(d)!=0) return d;
         }
-        else if (cmptag(xa) < cmptag(xb)) {
+        else if (tag(xa) < tag(xb)) {
             return fixnum(-1);
         }
-        else if (cmptag(xa) > cmptag(xb)) {
+        else if (tag(xa) > tag(xb)) {
             return fixnum(1);
         }
     }
@@ -142,7 +151,7 @@ static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
     for (i = 0; i < m; i++) {
         xa = vector_elt(a,i);
         xb = vector_elt(b,i);
-        if (!leafp(xa) && !leafp(xb)) {
+        if (!leafp(xa) || tag(xa)==TAG_FUNCTION) {
             d = cyc_compare(xa, xb, table, eq);
             if (numval(d)!=0)
                 return d;
@@ -156,6 +165,7 @@ static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
 
 static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
 {
+    value_t d, ca, cb;
  cyc_compare_top:
     if (a==b)
         return fixnum(0);
@@ -163,12 +173,11 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
         if (iscons(b)) {
             value_t aa = car_(a); value_t da = cdr_(a);
             value_t ab = car_(b); value_t db = cdr_(b);
-            int tagaa = cmptag(aa); int tagda = cmptag(da);
+            int tagaa = tag(aa); int tagda = tag(da);
-            int tagab = cmptag(ab); int tagdb = cmptag(db);
+            int tagab = tag(ab); int tagdb = tag(db);
-            value_t d, ca, cb;
             if (leafp(aa) || leafp(ab)) {
                 d = bounded_compare(aa, ab, 1, eq);
-                if (numval(d)!=0) return d;
+                if (d!=NIL && numval(d)!=0) return d;
             }
             else if (tagaa < tagab)
                 return fixnum(-1);
@@ -176,7 +185,7 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
                 return fixnum(1);
             if (leafp(da) || leafp(db)) {
                 d = bounded_compare(da, db, 1, eq);
-                if (numval(d)!=0) return d;
+                if (d!=NIL && numval(d)!=0) return d;
             }
             else if (tagda < tagdb)
                 return fixnum(-1);
@@ -202,6 +211,24 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
     else if (isvector(a) && isvector(b)) {
         return cyc_vector_compare(a, b, table, eq);
     }
+    else if (isclosure(a) && isclosure(b)) {
+        function_t *fa = (function_t*)ptr(a);
+        function_t *fb = (function_t*)ptr(b);
+        d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
+        if (numval(d) != 0) return d;
+        
+        ca = eq_class(table, a);
+        cb = eq_class(table, b);
+        if (ca!=NIL && ca==cb)
+            return fixnum(0);
+        
+        eq_union(table, a, b, ca, cb);
+        d = cyc_compare(fa->vals, fb->vals, table, eq);
+        if (numval(d) != 0) return d;
+        a = fa->env;
+        b = fb->env;
+        goto cyc_compare_top;
+    }
     return bounded_compare(a, b, 1, eq);
 }
 

femtolisp/flisp.c

@@ -224,6 +224,11 @@ SAFECAST_OP(string,char*,    cvalue_data)
 
 symbol_t *symtab = NULL;
 
+int fl_is_keyword_name(char *str, size_t len)
+{
+    return ((str[0] == ':' || str[len-1] == ':') && str[1] != '\0');
+}
+
 static symbol_t *mk_symbol(char *str)
 {
     symbol_t *sym;
@@ -232,7 +237,7 @@ static symbol_t *mk_symbol(char *str)
     sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1);
     assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8
     sym->left = sym->right = NULL;
-    if (str[0] == ':') {
+    if (fl_is_keyword_name(str, len)) {
         value_t s = tagptr(sym, TAG_SYM);
         setc(s, s);
     }
@@ -774,11 +779,6 @@ static value_t do_trycatch()
     return v;
 }
 
-#define fn_bcode(f) (((value_t*)ptr(f))[0])
-#define fn_vals(f) (((value_t*)ptr(f))[1])
-#define fn_env(f) (((value_t*)ptr(f))[2])
-#define fn_name(f) (((value_t*)ptr(f))[3])
-
 #if _BYTE_ORDER == __BIG_ENDIAN
 #define GET_INT32(a)                            \
     ((((int32_t)a[0])<<0)  |                    \
@@ -2050,7 +2050,7 @@ extern value_t fl_file(value_t *args, uint32_t nargs);
 
 int main(int argc, char *argv[])
 {
-    value_t e, v;
+    value_t e;
     int saveSP;
     symbol_t *sym;
     char fname_buf[1024];
@@ -2083,10 +2083,15 @@ int main(int argc, char *argv[])
                 SP = saveSP;
             }
             else {
-                // stage 1 format: symbol/value pairs
+                // stage 1 format: list alternating symbol/value
-                sym = tosymbol(e, "bootstrap");
+                while (iscons(e)) {
-                v = read_sexpr(Stack[SP-1]);
+                    sym = tosymbol(car_(e), "bootstrap");
-                sym->binding = v;
+                    e = cdr_(e);
+                    (void)tocons(e, "bootstrap");
+                    sym->binding = car_(e);
+                    e = cdr_(e);
+                }
+                break;
             }
         }
         ios_close(value2c(ios_t*,Stack[SP-1]));

femtolisp/flisp.h

@@ -81,6 +81,10 @@ typedef struct _symbol_t {
 #define cdr_(v) (((cons_t*)ptr(v))->cdr)
 #define car(v)  (tocons((v),"car")->car)
 #define cdr(v)  (tocons((v),"cdr")->cdr)
+#define fn_bcode(f) (((value_t*)ptr(f))[0])
+#define fn_vals(f) (((value_t*)ptr(f))[1])
+#define fn_env(f) (((value_t*)ptr(f))[2])
+#define fn_name(f) (((value_t*)ptr(f))[3])
 
 #define set(s, v)  (((symbol_t*)ptr(s))->binding = (v))
 #define setc(s, v) do { ((symbol_t*)ptr(s))->isconst = 1; \
@@ -135,6 +139,7 @@ value_t list2(value_t a, value_t b);
 value_t listn(size_t n, ...);
 value_t symbol(char *str);
 char *symbol_name(value_t v);
+int fl_is_keyword_name(char *str, size_t len);
 value_t alloc_vector(size_t n, int init);
 size_t llength(value_t v);
 value_t compare(value_t a, value_t b);  // -1, 0, or 1

femtolisp/system.lsp

@@ -35,8 +35,8 @@
   (define (mapn f lsts)
     (if (null? (car lsts))
 	()
-	(cons (apply f (map1 car lsts))
+	(cons (apply f (map1 car lsts (list ())))
-	      (mapn  f (map1 cdr lsts)))))
+	      (mapn  f (map1 cdr lsts (list ()))))))
   (if (null? lsts)
       (map1 f lst (list ()))
       (mapn f (cons lst lsts))))
@@ -158,6 +158,19 @@
 (define (cdddr x) (cdr (cdr (cdr x))))
 (define (cadddr x) (car (cdr (cdr (cdr x)))))
 
+(let ((*values* (list '*values*)))
+  (set! values
+	(lambda vs
+	  (if (and (pair? vs) (null? (cdr vs)))
+	      (car vs)
+	      (cons *values* vs))))
+  (set! call-with-values
+	(lambda (producer consumer)
+	  (let ((res (producer)))
+	    (if (and (pair? res) (eq? *values* (car res)))
+		(apply consumer (cdr res))
+		(consumer res))))))
+
 ; list utilities --------------------------------------------------------------
 
 (define (every pred lst)
@@ -401,6 +414,11 @@
 			     (,loop ,@steps))))))
        (,loop ,@inits))))
 
+; SRFI 8
+(define-macro (receive formals expr . body)
+  `(call-with-values (lambda () ,expr)
+     (lambda ,formals ,@body)))
+
 (define-macro (dotimes var . body)
   (let ((v (car var))
         (cnt (cadr var)))
@@ -807,18 +825,17 @@
 	(pp *print-pretty*))
     (set! *print-pretty* #f)
     (unwind-protect
-     (for-each (lambda (s)
+     (let ((syms (filter (lambda (s)
-		 (if (and (bound? s)
+			   (and (bound? s)
-			  (not (constant? s))
+				(not (constant? s))
-			  (or (not (builtin? (top-level-value s)))
+				(or (not (builtin? (top-level-value s)))
-			      (not (equal? (string s) ; alias of builtin
+				    (not (equal? (string s) ; alias of builtin
-					   (string (top-level-value s)))))
+						 (string (top-level-value s)))))
-			  (not (memq s excludes))
+				(not (memq s excludes))
-			  (not (iostream? (top-level-value s))))
+				(not (iostream? (top-level-value s)))))
-		     (begin
+			 (simple-sort (environment)))))
-		       (io.print f s) (io.write f "\n")
+       (io.print f (apply nconc (map list syms (map top-level-value syms))))
-		       (io.print f (top-level-value s)) (io.write f "\n"))))
+       (io.write f *linefeed*))
-	       (reverse! (simple-sort (environment))))
      (begin
        (io.close f)
        (set! *print-pretty* pp)))))

femtolisp/todo

@@ -976,6 +976,8 @@ consolidated todo list as of 7/8:
 - remaining c types
 - remaining cvalues functions
 - finish ios
+- optional and keyword arguments
+- some kind of record, struct, or object system
 
 - special efficient reader for #array
 - reimplement vectors as (array lispvalue)
@@ -1037,11 +1039,12 @@ new evaluator todo:
   . 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
 - let eversion
-- lambda lifting
+* lambda lifting
 * let optimization
-- fix equal? on functions
+* fix equal? on functions
-- store function name
+* store function name
 * have macroexpand use its own global syntax table
 * be able to create/load an image file
 * fix trace and untrace