changing semantics to respect lexical scope more strictly; now

anything can be shadowed by closer nested variables
fixing bugs in let-syntax and expanding optional arg default values
improving expansion algorithm on internal define
some small optimizations to the compiler
maintaining interpreter for bootstrapping

femtolisp/compiler.lsp

@@ -220,7 +220,10 @@
 	((eq? item (car lst)) start)
 	(else (index-of item (cdr lst) (+ start 1)))))
 
-(define (in-env? s env) (any (lambda (e) (memq s e)) env))
+(define (in-env? s env)
+  (and (pair? env)
+       (or (memq s (car env))
+	   (in-env? s (cdr env)))))
 
 (define (lookup-sym s env lev arg?)
   (if (null? env)
@@ -229,8 +232,8 @@
 	     (i    (index-of s curr 0)))
 	(if i
 	    (if arg?
-		`(arg ,i)
+		i
-		`(closed ,lev ,i))
+		(cons lev i))
 	    (lookup-sym s
 			(cdr env)
 			(if (or arg? (null? curr)) lev (+ lev 1))
@@ -239,20 +242,20 @@
 ; number of non-nulls
 (define (nnn e) (count (lambda (x) (not (null? x))) e))
 
-(define (printable? x) (not (iostream? x)))
+(define (printable? x) (not (or (iostream? x)
+				(eof-object? x))))
 
 (define (compile-sym g env s Is)
   (let ((loc (lookup-sym s env 0 #t)))
-    (case (car loc)
+    (cond ((number? loc)       (emit g (aref Is 0) loc))
-      (arg     (emit g (aref Is 0) (cadr loc)))
+	  ((number? (car loc)) (emit g (aref Is 1) (car loc) (cdr loc))
-      (closed  (emit g (aref Is 1) (cadr loc) (caddr loc))
+			       ; update index of most distant captured frame
-	       ; update index of most distant captured frame
+	                       (bcode:cdepth g (- (nnn (cdr env)) 1 (car loc))))
-	       (bcode:cdepth g (- (nnn (cdr env)) 1 (cadr loc))))
+	  (else
-      (else
+	   (if (and (constant? s)
-       (if (and (constant? s)
+		    (printable? (top-level-value s)))
-		(printable? (top-level-value s)))
+	       (emit g 'loadv (top-level-value s))
-	   (emit g 'loadv (top-level-value s))
+	       (emit g (aref Is 2) s))))))
-	   (emit g (aref Is 2) s))))))
 
 (define (compile-if g env tail? x)
   (let ((elsel (make-label g))
@@ -440,10 +443,16 @@
 	       ((eq? x #f)  (emit g 'loadf))
 	       ((eq? x ())  (emit g 'loadnil))
 	       ((fits-i8 x) (emit g 'loadi8 x))
+	       ((eof-object? x)
+		(compile-in g env tail? (list (top-level-value 'eof-object))))
 	       (else        (emit g 'loadv x))))
+	((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env))
+	 (compile-app g env tail? x))
 	(else
 	 (case (car x)
-	   (quote    (emit g 'loadv (cadr x)))
+	   (quote    (if (self-evaluating? (cadr x))
+			 (compile-in g env tail? (cadr x))
+			 (emit g 'loadv (cadr x))))
 	   (if       (compile-if g env tail? x))
 	   (begin    (compile-begin g env tail? (cdr x)))
 	   (prog1    (compile-prog1 g env x))
@@ -487,7 +496,7 @@
 			      (list (caadr expr)))
 			 ()))
 		    ((eq? (car expr) 'begin)
-		     (apply append (map get-defined-vars- (cdr expr))))
+		     (apply nconc (map get-defined-vars- (cdr expr))))
 		    (else ())))))
     (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
 

femtolisp/cps.lsp

@@ -66,8 +66,8 @@
 (define (cps form)
   (η-reduce
    (β-reduce
-    (macroexpand
+    (expand
-     (cps- (macroexpand form) *top-k*)))))
+     (cps- (expand form) *top-k*)))))
 (define (cps- form k)
   (let ((g (gensym)))
     (cond ((or (atom? form) (constant? form))
@@ -119,7 +119,7 @@
            (let ((test (cadr form))
                  (body (caddr form))
                  (lastval (gensym)))
-             (cps- (macroexpand
+             (cps- (expand
                     `(let ((,lastval #f))
                        ((label ,g (lambda ()
                                     (if ,test

femtolisp/cvalues.c

@@ -945,11 +945,7 @@ static void cvalues_init()
     ALIGN8   = sizeof(struct { char a; int64_t i; }) - 8;
     ALIGNPTR = sizeof(struct { char a; void   *i; }) - sizeof(void*);
 
-    cv_intern(pointer);
+    builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL, NULL);
-    cfunctionsym = symbol("c-function");
-
-    builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL,
-                                     NULL);
 
     ctor_cv_intern(int8);
     ctor_cv_intern(uint8);
@@ -968,9 +964,11 @@ static void cvalues_init()
 
     ctor_cv_intern(array);
     ctor_cv_intern(enum);
+    cv_intern(pointer);
     cv_intern(struct);
     cv_intern(union);
     cv_intern(void);
+    cfunctionsym = symbol("c-function");
 
     assign_global_builtins(cvalues_builtin_info);
 

femtolisp/mkboot0.lsp

@@ -2,6 +2,7 @@
 
 (if (not (bound? 'top-level-value)) (set! top-level-value %eval))
 (if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set))
+(if (not (bound? 'eof-object?)) (set! eof-object? (lambda (x) #f)))
 
 ;(load "compiler.lsp")
 

femtolisp/perf.lsp

@@ -12,8 +12,8 @@
 (set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
 (time (sort r))
 
-(princ "mexpand: ")
+(princ "expand: ")
-(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
+(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
 
 (define (my-append . lsts)
   (cond ((null? lsts) ())

femtolisp/system.lsp

@@ -16,14 +16,15 @@
 (define-macro (label name fn)
   `((lambda (,name) (set! ,name ,fn)) #f))
 
+(define (map1 f lst (acc (list ())))
+  (cdr
+   (prog1 acc
+    (while (pair? lst)
+	   (begin (set! acc
+			(cdr (set-cdr! acc (cons (f (car lst)) ()))))
+		  (set! lst (cdr lst)))))))
+
 (define (map f lst . lsts)
-  (define (map1 f lst acc)
-    (cdr
-     (prog1 acc
-      (while (pair? lst)
-	     (begin (set! acc
-			  (cdr (set-cdr! acc (cons (f (car lst)) ()))))
-		    (set! lst (cdr lst)))))))
   (define (mapn f lsts)
     (if (null? (car lsts))
 	()
@@ -332,8 +333,8 @@
              (let ((body (bq-process (vector->list x))))
                (if (eq (car body) 'list)
                    (cons vector (cdr body))
-                 (list apply vector body)))
+		   (list apply vector body)))
-           x))
+	     x))
         ((atom? x)                    (list 'quote x))
         ((eq (car x) 'backquote)      (bq-process (bq-process (cadr x))))
         ((eq (car x) '*comma*)        (cadr x))
@@ -342,7 +343,9 @@
                (forms (map bq-bracket1 x)))
            (if (null? lc)
                (cons 'list forms)
-             (nconc (cons 'list* forms) (list (bq-process lc))))))
+	       (if (null? (cdr forms))
+		   (list cons (car forms) (bq-process lc))
+		   (nconc (cons 'list* forms) (list (bq-process lc)))))))
         (#t (let ((p x) (q ()))
 	      (while (and (pair? p)
 			  (not (eq (car p) '*comma*)))
@@ -354,7 +357,11 @@
 			   (#t        (nreconc q (list (bq-process p)))))))
 		(if (null? (cdr forms))
 		    (car forms)
-		    (cons 'nconc forms)))))))
+		    (if (and (length= forms 2)
+			     (length= (car forms) 2)
+			     (eq? list (caar forms)))
+			(list cons (cadar forms) (cadr forms))
+			(cons 'nconc forms))))))))
 
 (define (bq-bracket x)
   (cond ((atom? x)                  (list list (bq-process x)))
@@ -671,42 +678,135 @@
 	(if f (apply f (cdr e))
 	    e))))
 
-(define (macroexpand e)
+(define (expand e)
-  (define (macroexpand-in e env)
+  ; symbol resolves to toplevel; i.e. has no shadowing definition
-    (if (atom? e) e
+  (define (top? s env) (not (or (bound? s) (assq s env))))
-	(let ((f (assq (car e) env)))
-	  (if f
-	      (macroexpand-in (apply (cadr f) (cdr e)) (caddr f))
-	      (let ((f (macrocall? e)))
-		(if f
-		    (macroexpand-in (apply f (cdr e)) env)
-		    (cond ((eq (car e) 'quote)  e)
-			  ((eq (car e) 'lambda)
-			   `(lambda ,(cadr e)
-			      ,.(map (lambda (x) (macroexpand-in x env))
-				     (cddr e))
-			      . ,(lastcdr e)))
-			  ((eq (car e) 'define)
-			   `(define ,(cadr e)
-			      ,.(map (lambda (x) (macroexpand-in x env))
-				     (cddr e))))
-			  ((eq (car e) 'let-syntax)
-			   (let ((binds (cadr e))
-				 (body  `((lambda () ,@(cddr e)))))
-			     (macroexpand-in
-			      body
-			      (nconc
-			       (map (lambda (bind)
-				      (list (car bind)
-					    (macroexpand-in (cadr bind) env)
-					    env))
-				    binds)
-			       env))))
-			  (else
-			   (map (lambda (x) (macroexpand-in x env)) e)))))))))
-  (macroexpand-in e ()))
   
-(define (expand x) (macroexpand x))
+  (define (splice-begin body)
+    (cond ((atom? body) body)
+	  ((equal? body '((begin)))
+	   body)
+	  ((and (pair? (car body))
+		(eq? (caar body) 'begin))
+	   (append (splice-begin (cdar body)) (splice-begin (cdr body))))
+	  (else
+	   (cons (car body) (splice-begin (cdr body))))))
+  
+  (define *expanded* (list '*expanded*))
+  
+  (define (expand-body body env)
+    (if (atom? body) body
+	(let* ((body  (if (top? 'begin env)
+			  (splice-begin body)
+			  body))
+	       (def?  (top? 'define env))
+	       (dvars (if def? (get-defined-vars body) ()))
+	       (env   (nconc (map1 list dvars) env)))
+	  (if (not def?)
+	      (map (lambda (x) (expand-in x env)) body)
+	      (let* ((ex-nondefs    ; expand non-definitions
+		      (let loop ((body body))
+			(cond ((atom? body) body)
+			      ((and (pair? (car body))
+				    (eq? 'define (caar body)))
+			       (cons (car body) (loop (cdr body))))
+			      (else
+			       (let ((form (expand-in (car body) env)))
+				 (set! env (nconc
+					    (map1 list (get-defined-vars form))
+					    env))
+				 (cons
+				  (cons *expanded* form)
+				  (loop (cdr body))))))))
+		     (body ex-nondefs))
+		(while (pair? body) ; now expand deferred definitions
+		       (if (not (eq? *expanded* (caar body)))
+			   (set-car! body (expand-in (car body) env))
+			   (set-car! body (cdar body)))
+		       (set! body (cdr body)))
+		ex-nondefs)))))
+  
+  (define (expand-lambda-list l env)
+    (nconc
+     (map (lambda (x) (if (and (pair? x) (pair? (cdr x)))
+			  (list (car x) (expand-in (cadr x) env))
+			  x))
+	  l)
+     (lastcdr l)))
+  
+  (define (l-vars l)
+    (cond ((atom? l) l)
+	  ((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
+	  (else (cons (car l) (l-vars (cdr l))))))
+  
+  (define (expand-lambda e env)
+    (let ((formals (cadr e))
+	  (name    (lastcdr e))
+	  (body    (cddr e))
+	  (vars    (l-vars (cadr e))))
+      (let ((env   (nconc (map1 list vars) env)))
+	`(lambda ,(expand-lambda-list formals env)
+	   ,.(expand-body body env)
+	   . ,name))))
+  
+  (define (expand-define e env)
+    (if (or (null? (cdr e)) (atom? (cadr e)))
+	(if (null? (cddr e))
+	    e
+	    `(define ,(cadr e) ,(expand-in (caddr e) env)))
+	(let ((formals (cdadr e))
+	      (name    (caadr e))
+	      (body    (cddr e))
+	      (vars    (l-vars (cdadr e))))
+	  (let ((env   (nconc (map1 list vars) env)))
+	    `(define ,(cons name (expand-lambda-list formals env))
+	       ,.(expand-body body env))))))
+  
+  (define (expand-let-syntax e env)
+    (let ((binds (cadr e)))
+      (cons 'begin
+	    (expand-body (cddr e)
+			 (nconc
+			  (map (lambda (bind)
+				 (list (car bind)
+				       ((compile-thunk
+					 (expand-in (cadr bind) env)))
+				       env))
+			       binds)
+			  env)))))
+  
+  ; given let-syntax definition environment (menv) and environment
+  ; at the point of the macro use (lenv), return the environment to
+  ; expand the macro use in. TODO
+  (define (local-expansion-env menv lenv) menv)
+  
+  (define (expand-in e env)
+    (if (atom? e) e
+	(let* ((head (car e))
+	       (bnd  (assq head env))
+	       (default (lambda ()
+			  (let loop ((e e))
+			    (if (atom? e) e
+				(cons (expand-in (car e) env)
+				      (loop (cdr e))))))))
+	  (cond ((and bnd (pair? (cdr bnd)))  ; local macro
+		 (expand-in (apply (cadr bnd) (cdr e))
+			    (local-expansion-env (caddr bnd) env)))
+		((or bnd                      ; bound lexical or toplevel var
+		     (not (symbol? head))
+		     (bound? head))
+		 (default))
+		(else
+		 (let ((f (macrocall? e)))
+		   (if f
+		       (expand-in (apply f (cdr e)) env)
+		       (cond ((eq head 'quote)      e)
+			     ((eq head 'lambda)     (expand-lambda e env))
+			     ((eq head 'define)     (expand-define e env))
+			     ((eq head 'let-syntax) (expand-let-syntax e env))
+			     (else
+			      (default))))))))))
+  (expand-in e ()))
 
 (define (eval x) ((compile-thunk (expand x))))
 

femtolisp/test.lsp

@@ -272,10 +272,9 @@
 	  '(emit encode-byte-code const-to-idx-vec
 	    index-of lookup-sym in-env? any every
 	    compile-sym compile-if compile-begin
-	    list-partition just-compile-args
+	    compile-arglist expand builtin->instruction
-	    compile-arglist macroexpand builtin->instruction
+	    compile-app separate nconc get-defined-vars
-	    compile-app compile-let compile-call
+	    compile-in compile compile-f delete-duplicates
-	    compile-in compile compile-f
 	    map length> length= count filter append
 	    lastcdr to-proper reverse reverse! list->vector
 	    table.foreach list-head list-tail assq memq assoc member
@@ -294,3 +293,10 @@
       (if (pred (car lst))
 	  (filto pred (cdr lst) (cons (car lst) accum))
 	  (filto pred (cdr lst) accum))))
+
+; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
+(define (pairwise? pred . args)
+  (or (null? args)
+      (let f ((a (car args)) (d (cdr args)))
+	(or (null? d)
+	    (and (pred a (car d)) (f (car d) (cdr d)))))))

femtolisp/tests/printcases.lsp

@@ -1,4 +1,4 @@
-macroexpand
+expand
 append
 bq-process
 

femtolisp/todo

@@ -983,6 +983,19 @@ consolidated todo list as of 7/8:
 - some kind of record, struct, or object system
 - improve test coverage
 
+expansion process bugs:
+* expand default expressions for opt/keyword args (as if lexically in body)
+* make bound identifiers (lambda and toplevel) shadow macro keywords
+* to expand a body:
+  1. splice begins
+  2. add defined vars to env
+  3. expand nondefinitions in the new env
+     . if one expands to a definition, add the var to the env
+  4. expand RHSes of definitions
+- add different spellings for builtin versions of core forms, like
+  $begin, $define, and $set!. they can be replaced when found during expansion,
+  and used when the compiler needs to generate them with known meanings.
+
 - special efficient reader for #array
 - reimplement vectors as (array lispvalue)
 - implement fast subvectors and subarrays