ref: 332235231c0d230e1ea93e943e32e1b33ff79989
parent: 97c05e8eb4b7b2266faa062bd5ec48cab7cf5d05
author: JeffBezanson <[email protected]>
date: Wed Aug 12 00:56:32 EDT 2009
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
--- a/femtolisp/compiler.lsp
+++ b/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)
- `(closed ,lev ,i))
+ 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)
- (arg (emit g (aref Is 0) (cadr 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
- (if (and (constant? s)
- (printable? (top-level-value s)))
- (emit g 'loadv (top-level-value s))
- (emit g (aref Is 2) s))))))
+ (cond ((number? loc) (emit g (aref Is 0) loc))
+ ((number? (car loc)) (emit g (aref Is 1) (car loc) (cdr loc))
+ ; update index of most distant captured frame
+ (bcode:cdepth g (- (nnn (cdr env)) 1 (car loc))))
+ (else
+ (if (and (constant? s)
+ (printable? (top-level-value s)))
+ (emit g 'loadv (top-level-value 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)))))
--- a/femtolisp/cps.lsp
+++ b/femtolisp/cps.lsp
@@ -66,8 +66,8 @@
(define (cps form)
(η-reduce
(β-reduce
- (macroexpand
- (cps- (macroexpand form) *top-k*)))))
+ (expand
+ (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
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -945,12 +945,8 @@
ALIGN8 = sizeof(struct { char a; int64_t i; }) - 8; ALIGNPTR = sizeof(struct { char a; void *i; }) - sizeof(void*);- cv_intern(pointer);
- cfunctionsym = symbol("c-function");+ builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL, NULL);
- builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL,
- NULL);
-
ctor_cv_intern(int8);
ctor_cv_intern(uint8);
ctor_cv_intern(int16);
@@ -968,9 +964,11 @@
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);
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -1,1 +1,1 @@
-(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" *interactive* #f *syntax-environment* #table(with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("B000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6e0c7L1e4\x7f3132e0c7L1e4e2c8|g2333132L3L144;" [nconc let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])]) map #.car cadr #fn("6000r1e040;" [gensym])]) letrec #fn("?000s1e0e0c1L1e2c3|32L1e2c4|32e5}3134L1e2c6|3242;" [nconc lambda map #.car #fn("9000r1e0c1L1e2|3142;" [nconc set! copy-list]) copy-list #fn("6000r1^;" [])]) backquote #fn("7000r1e0|41;" [bq-process]) assert #fn("<000r1c0|]c1c2c3|L2L2L2L4;" [if raise quote assert-failed]) label #fn(":000r2c0|L1c1|}L3L3^L2;" [lambda set!]) do #fn("A000s2c0qe130}Me2c3|32e2e4|32e2c5|3245;" [#fn("B000r5c0|c1g2c2}e3c4L1e5\x7fN3132e3c4L1e5i0231e3|L1g432L133L4L3L2L1e3|L1g332L3;" [letrec lambda if nconc begin copy-list]) gensym map #.car cadr #fn("7000r1e0|31F680e1|41;|M;" [cddr caddr])]) when #fn("<000s1c0|c1}K^L4;" [if begin]) with-input-from #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc with-bindings *input-stream* copy-list]) dotimes #fn(";000s1c0q|M|\x8442;" [#fn("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for - nconc lambda copy-list])]) unwind-protect #fn("8000r2c0qe130e13042;" [#fn("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) define-macro #fn("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax! quote nconc lambda copy-list]) receive #fn("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values lambda nconc copy-list]) unless #fn("=000s1c0|^c1}KL4;" [if begin]) let #fn(":000s1c0q^41;" [#fn("<000r1~C6D0~m02\x7fMo002\x7fNo01530^2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#fn("8000r2~6;0c0~|L3530|}K;" [label]) nconc lambda map #fn("6000r1|F650|M;|;" []) copy-list #fn("6000r1|F650|\x84;^;" [])])]) cond #fn("9000s0c0q^41;" [#fn("7000r1c0qm02|~41;" [#fn("7000r1|?640^;c0q|M41;" [#fn(";000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;c3|Mc1|NKi10~N31L4;" [else begin or if])] cond-clauses->if)])]) throw #fn(":000r2c0c1c2c3L2|}L4L2;" [raise list quote thrown-value]) time #fn("7000r1c0qe13041;" [#fn(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #fn("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc lambda copy-list caar let* cadar]) case #fn(":000s1c0q^41;" [#fn("7000r1c0m02c1qe23041;" [#fn(";000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) #fn("<000r1c0|i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #fn("8000r1i10~|M32|NK;" [])]) gensym])]) with-output-to #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc with-bindings *output-stream* copy-list]) catch #fn("7000r2c0qe13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " 1+ #fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda? #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda length=] 1arg-lambda?) <= #fn("7000r2|}X17602|}W;" [] <=) > #fn("7000r2}|X;" [] >) >= #fn("7000r2}|X17602|}W;" [] >=) Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 69 loadc00 78 pop 2 pair? 22 cadr 84 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 87 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l\ No newline at end of file
+(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" *interactive* #f *syntax-environment* #table(with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("A000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6c7e4\x7f31Kc7e4e2c8|g23331KL3L144;" [nconc let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])]) map #.car cadr #fn("6000r1e040;" [gensym])]) letrec #fn(">000s1e0c1L1e2c3|32L1e2c4|32e5}3134e2c6|32K;" [nconc lambda map #.car #fn("8000r1c0e1|31K;" [set! copy-list]) copy-list #fn("6000r1^;" [])]) backquote #fn("7000r1e0|41;" [bq-process]) assert #fn("<000r1c0|]c1c2c3|L2L2L2L4;" [if raise quote assert-failed]) label #fn(":000r2c0|L1c1|}L3L3^L2;" [lambda set!]) do #fn("A000s2c0qe130}Me2c3|32e2e4|32e2c5|3245;" [#fn("A000r5c0|c1g2c2}c3e4\x7fN31Ke5c3L1e4i0231|g4KL133L4L3L2L1|g3KL3;" [letrec lambda if begin copy-list nconc]) gensym map #.car cadr #fn("7000r1e0|31F680e1|41;|M;" [cddr caddr])]) when #fn("<000s1c0|c1}K^L4;" [if begin]) with-input-from #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc with-bindings *input-stream* copy-list]) dotimes #fn(";000s1c0q|M|\x8442;" [#fn("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for - nconc lambda copy-list])]) unwind-protect #fn("8000r2c0qe130e13042;" [#fn("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) define-macro #fn("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax! quote nconc lambda copy-list]) receive #fn("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values lambda nconc copy-list]) unless #fn("=000s1c0|^c1}KL4;" [if begin]) let #fn(":000s1c0q^41;" [#fn("<000r1~C6D0~m02\x7fMo002\x7fNo01530^2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#fn("8000r2~6;0c0~|L3530|}K;" [label]) nconc lambda map #fn("6000r1|F650|M;|;" []) copy-list #fn("6000r1|F650|\x84;^;" [])])]) cond #fn("9000s0c0q^41;" [#fn("7000r1c0qm02|~41;" [#fn("7000r1|?640^;c0q|M41;" [#fn(";000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;c3|Mc1|NKi10~N31L4;" [else begin or if])] cond-clauses->if)])]) throw #fn(":000r2c0c1c2c3L2|}L4L2;" [raise list quote thrown-value]) time #fn("7000r1c0qe13041;" [#fn(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #fn("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc lambda copy-list caar let* cadar]) case #fn(":000s1c0q^41;" [#fn("7000r1c0m02c1qe23041;" [#fn(";000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) #fn(";000r1c0|i10L2L1c1e2c3qi1132KL3;" [let cond map #fn("8000r1i10~|M32|NK;" [])]) gensym])]) with-output-to #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc with-bindings *output-stream* copy-list]) catch #fn("7000r2c0qe13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " 1+ #fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda? #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda length=] 1arg-lambda?) <= #fn("7000r2|}X17602|}W;" [] <=) > #fn("7000r2}|X;" [] >) >= #fn("7000r2}|X17602|}W;" [] >=) Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 69 loadc00 78 pop 2 pair? 22 cadr 84 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 87 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l 10 tapply 70 dummy_nil 94 loada0 76 brbound 90 \ No newline at end of file
--- a/femtolisp/mkboot0.lsp
+++ b/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")
--- a/femtolisp/perf.lsp
+++ b/femtolisp/perf.lsp
@@ -12,8 +12,8 @@
(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
(time (sort r))
-(princ "mexpand: ")
-(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
+(princ "expand: ")
+(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
(define (my-append . lsts)
(cond ((null? lsts) ())
--- a/femtolisp/system.lsp
+++ b/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)))
- x))
+ (list apply vector body)))
+ 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 (macroexpand-in e env)
- (if (atom? e) e
- (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)
+(define (expand e)
+ ; symbol resolves to toplevel; i.e. has no shadowing definition
+ (define (top? s env) (not (or (bound? s) (assq s env))))
+
+ (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))
- binds)
- env))))
- (else
- (map (lambda (x) (macroexpand-in x env)) e)))))))))
- (macroexpand-in e ()))
-
-(define (expand x) (macroexpand x))
+ (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))))
--- a/femtolisp/test.lsp
+++ b/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 macroexpand builtin->instruction
- compile-app compile-let compile-call
- compile-in compile compile-f
+ compile-arglist expand builtin->instruction
+ compile-app separate nconc get-defined-vars
+ compile-in compile compile-f delete-duplicates
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)))))))
--- a/femtolisp/tests/printcases.lsp
+++ b/femtolisp/tests/printcases.lsp
@@ -1,4 +1,4 @@
-macroexpand
+expand
append
bq-process
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -983,6 +983,19 @@
- 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