ref: c42ee12d4cbbf57cdefd27cb4b881e185030d60d
parent: 1ee81e2625d31562e3a43df2f935598e8dd31068
author: JeffBezanson <[email protected]>
date: Fri May 29 00:38:50 EDT 2009
allowing multiple expressions in lambda making cond a macro increasing size limit for cvalues on the managed heap, and inline allocated hashtables
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -180,19 +180,6 @@
(closed (emit g (aref Is 1) (cadr loc) (caddr loc)))
(else (emit g (aref Is 2) s)))))
-(define (cond->if form)
- (cond-clauses->if (cdr form)))
-(define (cond-clauses->if lst)
- (if (atom? lst)
- #f
- (let ((clause (car lst)))
- (if (or (eq? (car clause) 'else)
- (eq? (car clause) #t))
- (cons 'begin (cdr clause))
- `(if ,(car clause)
- ,(cons 'begin (cdr clause))
- ,(cond-clauses->if (cdr lst)))))))
-
(define (compile-if g env tail? x)
(let ((elsel (make-label g))
(endl (make-label g)))
@@ -393,7 +380,6 @@
(else
(case (car x)
(quote (emit g :loadv (cadr x)))
- (cond (compile-in g env tail? (cond->if x)))
(if (compile-if g env tail? x))
(begin (compile-begin g env tail? (cdr x)))
(prog1 (compile-prog1 g env x))
--- a/femtolisp/cps.lsp
+++ b/femtolisp/cps.lsp
@@ -4,16 +4,6 @@
((null? (cdr e)) (car e))
(#t (cons 'begin e))))
-(define (cond->if form)
- (cond-clauses->if (cdr form)))
-(define (cond-clauses->if lst)
- (if (atom? lst)
- #f
- (let ((clause (car lst)))
- `(if ,(car clause)
- ,(cond-body (cdr clause))
- ,(cond-clauses->if (cdr lst))))))
-
(define (begin->cps forms k)
(cond ((atom? forms) `(,k ,forms))
((null? (cdr forms)) (cps- (car forms) k))
@@ -94,9 +84,6 @@
((eq (car form) 'begin)
(begin->cps (cdr form) k))
- ((eq (car form) 'cond)
- (cps- (cond->if form) k))
-
((eq (car form) 'if)
(let ((test (cadr form))
(then (caddr form))
@@ -255,7 +242,7 @@
(#t form)))
(define-macro (with-delimited-continuations . code)
- (cps (f-body code)))
+ (cps `((lambda () ,@code))))
(define-macro (define-generator form . body)
(let ((ko (gensym))
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -123,7 +123,7 @@
make-code-emitter
#function("n0_e030`Z3;" [table])macroexpand-in
-#function("n2f0?6;0f0;c0e1f0Mf132q42;" [#function("rf06M0e0e1f031g00NQ2e2f03142;c3e4g0031q42;" [macroexpand-in cadr caddr #function("rf06F0e0f0g10NQ2g1142;g10Mc1<6T0g10;g10Mc2<6\x810e3c2e4g1031e0e5g1031g1132e6g103144;g10Mc7<6\xa30c8e4g1031e9e:g103131q43;e;c<mg1042;" [macroexpand-in quote lambda nlist* cadr caddr cdddr let-syntax #function("re0f1e1e2c3mf032g213242;" [macroexpand-in nconc map #function("n1f0Me0e1f031g3132g31L3;" [macroexpand-in cadr])]) f-body cddr map #function("n1e0f0g2142;" [macroexpand-in])]) macrocall?]) assq])+#function("n2f0?6;0f0;c0e1f0Mf132q42;" [#function("rf06M0e0e1f031g00NQ2e2f03142;c3e4g0031q42;" [macroexpand-in cadr caddr #function("rf06F0e0f0g10NQ2g1142;g10Mc1<6T0g10;g10Mc2<6\x920c3e4g1031F6\x8d0e5g1031F6\x830c6e4g1031K5\x8a0e7g10315\x8e0^q42;g10Mc8<6\xc10c9e:g1031e;c2L1_L1e<e4g10313133L1q43;e=c>mg1042;" [macroexpand-in quote lambda #function("rc0e1f031e2f0g2132q43;" [#function("re0c1e2g3031f0A6G0f15Y0c1f0f1L3e3c4mf032Ke5g303144;" [nlist* lambda cadr map #function("n1^;" []) cdddr]) get-defined-vars macroexpand-in]) cddr cdddr begin caddr let-syntax #function("re0f1e1e2c3mf032g213242;" [macroexpand-in nconc map #function("n1f0Me0e1f031g3132g31L3;" [macroexpand-in cadr])]) cadr nconc copy-list map #function("n1e0f0g2142;" [macroexpand-in])]) macrocall?]) assq])macroexpand-1
#function("n1f0?6;0f0;c0e1f031q42;" [#function("rf06?0f0g00Nt2;g00;" []) macrocall?])macroexpand
@@ -184,8 +184,6 @@
#function("n1f0I16O02e0f0b\xb03216O02e1f0b\xaf42;" [>= <=])filter
#function("n2g00f0f1_43;" [] #0=[#function("n3f1A6;0f2;f0f1M316V0g00f0f1Nf1Mf2K43;g00f0f1Nf243;" [] #0#) ()])-f-body
-#function("n1c0g00f031q42;" [#function("rc0e1f031q42;" [#function("rf0A6;0g00;c0f0g00L3e1c2mf032K;" [lambda map #function("n1^;" [])]) get-defined-vars])] [#function("n1f0?6:0^;f0N_<6F0f0M;c0f0K;" [begin]) ()])expand
#function("n1e0f041;" [macroexpand])every
@@ -218,10 +216,6 @@
#function("n1f0?6;0f0;f0Me0f0N31K;" [copy-list])const-to-idx-vec
#function("n1c0e1f0b2[31q42;" [#function("re0c1mg00a[322f0;" [table.foreach #function("n2g00f1f0\\;" [])]) vector.alloc])-cond-clauses->if
-#function("n1f0?6:0^;c0f0Mq42;" [#function("rf0Mc0<17A02f0M]<6K0c1f0NK;c2f0Mc1f0NKe3g00N31L4;" [else begin if cond-clauses->if])])-cond->if
-#function("n1e0f0N41;" [cond-clauses->if])compile-while
#function("n4c0e1f031e1f031q43;" [#function("re0g00g01^^342e1g00f0322e0g00g01^g02342e2g00e3f1332e2g00e4322e0g00g01^g03342e2g00e5f0332e1g00f142;" [compile-in mark-label emit :brf :pop :jmp]) make-label])compile-thunk
@@ -237,7 +231,7 @@
compile-let
#function("n4c0f3Mf3Nq43;" [#function("re0f1e1e2f03131326H0^5T0e3e4c5f032312e6g00e7e8g01f0]33332c9e:g00g01f133q42;" [length= length cadr error string "apply: incorrect number of arguments to " emit :loadv compile-f #function("re0g10e1322e0g10g126K0e25M0e3af0u43;" [emit :copyenv :tcall :call]) compile-arglist])])compile-in
-#function("n4f3C6E0e0f0f1f3c144;f3?6\xba0f3`<6[0e2f0e342;f3a<6k0e2f0e442;f3]<6{0e2f0e542;f3^<6\x8b0e2f0e642;f3_<6\x9b0e2f0e742;e8f3316\xaf0e2f0e9f343;e2f0e:f343;c;f3Mq42;" [compile-sym [:loada :loadc :loadg] emit :load0 :load1 :loadt :loadf :loadnil fits-i8 :loadi8 :loadv #function("rf0c0=6J0e1g00e2e3g033143;f0c4=6g0e5g00g01g02e6g033144;f0c7=6\x800e8g00g01g02g0344;f0c9=6\x9a0e:g00g01g02g03N44;f0c;=6\xb00e<g00g01g0343;f0c==6\xd60e1g00e2e>g01g0332332e1g00e?42;f0c@=6\xf00eAg00g01g02g03N44;f0cB=6\x0a0eCg00g01g02g03N44;f0cD=6.0eEg00g01e3g0331c9eFg0331K44;f0cG=6V1eHg00g01e3g0331eIg0331eJg033145;f0cK=6{1e5g00g01]e3g0331342e1g00eL42;f0cM=6\xaa1e5g00g01^eIg0331342eNg00g01e3g0331cO44;f0cP=6\x001e5g00g01^c=_e3g0331L3342eQeIg0331316\xdc1^5\xe21eRcS312e5g00g01^eIg0331342e1g00eT42;eUg00g01g02g0344;" [quote emit :loadv cadr cond compile-in cond->if if compile-if begin compile-begin prog1 compile-prog1 lambda compile-f :closure and compile-and or compile-or while compile-while cddr for compile-for caddr cadddr return :ret set! compile-sym [:seta :setc :setg] trycatch 1arg-lambda? error "trycatch: second form must be a 1-argument lambda" :trycatch compile-app])])+#function("n4f3C6E0e0f0f1f3c144;f3?6\xba0f3`<6[0e2f0e342;f3a<6k0e2f0e442;f3]<6{0e2f0e542;f3^<6\x8b0e2f0e642;f3_<6\x9b0e2f0e742;e8f3316\xaf0e2f0e9f343;e2f0e:f343;c;f3Mq42;" [compile-sym [:loada :loadc :loadg] emit :load0 :load1 :loadt :loadf :loadnil fits-i8 :loadi8 :loadv #function("rf0c0=6J0e1g00e2e3g033143;f0c4=6c0e5g00g01g02g0344;f0c6=6}0e7g00g01g02g03N44;f0c8=6\x930e9g00g01g0343;f0c:=6\xb90e1g00e2e;g01g0332332e1g00e<42;f0c==6\xd30e>g00g01g02g03N44;f0c?=6\xed0e@g00g01g02g03N44;f0cA=6\x110eBg00g01e3g0331c6eCg0331K44;f0cD=691eEg00g01e3g0331eFg0331eGg033145;f0cH=6^1eIg00g01]e3g0331342e1g00eJ42;f0cK=6\x8d1eIg00g01^eFg0331342eLg00g01e3g0331cM44;f0cN=6\xe31eIg00g01^c:_e3g0331L3342eOeFg0331316\xbf1^5\xc51ePcQ312eIg00g01^eFg0331342e1g00eR42;eSg00g01g02g0344;" [quote emit :loadv cadr if compile-if begin compile-begin prog1 compile-prog1 lambda compile-f :closure and compile-and or compile-or while compile-while cddr for compile-for caddr cadddr return compile-in :ret set! compile-sym [:seta :setc :setg] trycatch 1arg-lambda? error "trycatch: second form must be a 1-argument lambda" :trycatch compile-app])])compile-if
#function("n4c0e1f031e1f031q43;" [#function("re0g00g01^e1g0331342e2g00e3f0332e0g00g01g02e4g0331342g026w0e2g00e5325\x820e2g00e6f1332e7g00f0322e0g00g01g02e8g0331F6\xad0e9g03315\xae0^342e7g00f142;" [compile-in cadr emit :brf caddr :ret :jmp mark-label cdddr cadddr]) make-label])compile-for
@@ -337,6 +331,6 @@
*whitespace*
"\t\n\v\f\r \u0085 \u2028\u2029 "
*syntax-environment*
-#table(define #function("o1f0C6B0c0f0f1ML3;c0f0Mc1f0Ne2f131L3L3;" [set! lambda f-body]) letrec #function("o1c0e1e2f032e3e4e1c5mf032f13231L3e1c6mf032K;" [lambda map car f-body nconc #function("n1c0f0K;" [set!]) #function("n1^;" [])]) backquote #function("n1e0f041;" [bq-process]) assert #function("n1c0f0]c1c2c3f0L2L2L2L4;" [if raise quote assert-failed]) label #function("n2c0f0L1c1f0f1L3L3^L2;" [lambda set!]) do #function("o2c0e130f1Me2e3f032e2e4f032e2c5mf032q46;" [#function("rc0f0c1f2c2f1e3c4L1e5g01N3132e3c4L1e5g0231e3f0L1e5f43132L133L4L3L2L1e3f0L1e5f33132L3;" [letrec lambda if nconc begin copy-list]) gensym map car cadr #function("n1e0f031F6C0e1f041;f0M;" [cddr caddr])]) when #function("o1c0f0e1f131^L4;" [if f-body]) dotimes #function("o1c0f0Me1f031q43;" [#function("rc0`c1f1aL3c2f0L1e3g0131L3L4;" [for - lambda f-body]) cadr]) unwind-protect #function("n2c0e130e130q43;" [#function("rc0f1c1_g01L3L2L1c2c3g00c1f0L1c4f1L1c5f0L2L3L3L3f1L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) define-macro #function("o1c0c1f0ML2c2f0Ne3f131L3L3;" [set-syntax! quote lambda f-body]) unless #function("o1c0f0^e1f131L4;" [if f-body]) let #function("o1c0^q42;" [#function("rg00C6P0g00j02g01Mk002g01Nk015Q0^2c0c1e2c3mg0032e4g0131L3e2c5mg0032q43;" [#function("rg006C0c0g00f0L35E0f0f1K;" [label]) lambda map #function("n1f0F6<0f0M;f0;" []) f-body #function("n1f0F6?0e0f041;^;" [cadr])])]) throw #function("n2c0c1c2c3L2f0f1L4L2;" [raise list quote thrown-value]) time #function("n1c0e130q42;" [#function("rc0f0c1L1L2L1c2g00c3c4c5c1L1f0L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("o1f0?6?0e0f141;c1e2f031L1e3c4L1f0NL1e5f13133L3e6f031L2;" [f-body lambda caar nconc let* copy-list cadar]) case #function("o1c0^q42;" [#function("rc0mj02c1e230q42;" [#function("n2f1c0<6=0c0;f1A6E0^;f1?6X0c1f0e2f131L3;f1NA6m0c1f0e2f1M31L3;c3f0c4f1L2L3;" [else eqv? quote-value memv quote]) #function("rc0f0g10L2L1e1c2L1e3e4c5mg11323132L3;" [let nconc cond copy-list map #function("n1g10g00f0M32f0NK;" [])]) gensym])]) catch #function("n2c0e130q42;" [#function("rc0g01c1f0L1c2c3c4f0L2c5c6f0L2c7c8L2L3c5c9f0L2g00L3L4c:f0L2c;f0L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym]))+#table(define #function("o1f0C6B0c0f0f1ML3;c0f0Mc1f0Nf1KKL3;" [set! lambda]) letrec #function("o1c0e1e2f032e3e1c4mf032f132KKe1c5mf032K;" [lambda map car nconc #function("n1c0f0K;" [set!]) #function("n1^;" [])]) backquote #function("n1e0f041;" [bq-process]) assert #function("n1c0f0]c1c2c3f0L2L2L2L4;" [if raise quote assert-failed]) label #function("n2c0f0L1c1f0f1L3L3^L2;" [lambda set!]) do #function("o2c0e130f1Me2e3f032e2e4f032e2c5mf032q46;" [#function("rc0f0c1f2c2f1e3c4L1e5g01N3132e3c4L1e5g0231e3f0L1e5f43132L133L4L3L2L1e3f0L1e5f33132L3;" [letrec lambda if nconc begin copy-list]) gensym map car cadr #function("n1e0f031F6C0e1f041;f0M;" [cddr caddr])]) when #function("o1c0f0c1f1K^L4;" [if begin]) unwind-protect #function("n2c0e130e130q43;" [#function("rc0f1c1_g01L3L2L1c2c3g00c1f0L1c4f1L1c5f0L2L3L3L3f1L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) dotimes #function("o1c0f0Me1f031q43;" [#function("rc0`c1f1aL3e2c3L1f0L1L1e4g013133L4;" [for - nconc lambda copy-list]) cadr]) define-macro #function("o1c0c1f0ML2c2f0Nf1KKL3;" [set-syntax! quote lambda]) unless #function("o1c0f0^c1f1KL4;" [if begin]) let #function("o1c0^q42;" [#function("rg00C6P0g00j02g01Mk002g01Nk015Q0^2c0c1e2c3mg0032g01KKe2c4mg0032q43;" [#function("rg006C0c0g00f0L35E0f0f1K;" [label]) lambda map #function("n1f0F6<0f0M;f0;" []) #function("n1f0F6?0e0f041;^;" [cadr])])]) cond #function("o0c0^q42;" [#function("rc0mj02f0g0041;" [#function("n1f0?6:0^;c0f0Mq42;" [#function("rf0Mc0<17A02f0M]<6K0c1f0NK;c2f0Mc1f0NKg10g00N31L4;" [else begin if])])])]) throw #function("n2c0c1c2c3L2f0f1L4L2;" [raise list quote thrown-value]) time #function("n1c0e130q42;" [#function("rc0f0c1L1L2L1c2g00c3c4c5c1L1f0L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("o1f0?6L0e0c1L1_L1e2f13133L1;e0c1L1e3f031L1L1e2f0NF6}0e0c4L1f0NL1e2f13133L15\x7F0f13133e5f031L2;" [nconc lambda copy-list caar let* cadar]) case #function("o1c0^q42;" [#function("rc0mj02c1e230q42;" [#function("n2f1c0<6=0c0;f1A6E0^;f1?6X0c1f0e2f131L3;f1NA6m0c1f0e2f1M31L3;c3f0c4f1L2L3;" [else eqv? quote-value memv quote]) #function("rc0f0g10L2L1e1c2L1e3e4c5mg11323132L3;" [let nconc cond copy-list map #function("n1g10g00f0M32f0NK;" [])]) gensym])]) catch #function("n2c0e130q42;" [#function("rc0g01c1f0L1c2c3c4f0L2c5c6f0L2c7c8L2L3c5c9f0L2g00L3L4c:f0L2c;f0L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym]))*banner*
"; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n"
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -216,7 +216,7 @@
} function_t;
#define CPRIM_NWORDS 2
-#define MAX_INL_SIZE 96
+#define MAX_INL_SIZE 384
#define CV_OWNED_BIT 0x1
#define CV_PARENT_BIT 0x2
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -8,23 +8,15 @@
(set! set-syntax!
(lambda (s v) (put! *syntax-environment* s v)))
-; convert a sequence of body statements to a single expression.
-; this allows define, defun, defmacro, let, etc. to contain multiple
-; body expressions.
-(set! f-body (lambda (e)
- (cond ((atom? e) #f)
- ((eq (cdr e) ()) (car e))
- (#t (cons 'begin e)))))
-
(set-syntax! 'define-macro
(lambda (form . body)
(list 'set-syntax! (list 'quote (car form))
- (list 'lambda (cdr form) (f-body body)))))
+ (cons 'lambda (cons (cdr form) body)))))
(define-macro (define form . body)
(if (symbol? form)
(list 'set! form (car body))
- (list 'set! (car form) (list 'lambda (cdr form) (f-body body)))))
+ (list 'set! (car form) (cons 'lambda (cons (cdr form) body)))))
(define (symbol-syntax s) (get *syntax-environment* s #f))
@@ -47,19 +39,32 @@
(list 'label lname thelambda)
thelambda)
theargs))
- (list 'lambda
- (map (lambda (c) (if (pair? c) (car c) c)) binds)
- (f-body body))
+ (cons 'lambda
+ (cons (map (lambda (c) (if (pair? c) (car c) c)) binds)
+ body))
(map (lambda (c) (if (pair? c) (cadr c) #f)) binds))))
#f))
(define-macro (letrec binds . body)
- (cons (list 'lambda (map car binds)
- (f-body
- (nconc (map (lambda (b) (cons 'set! b)) binds)
- body)))
- (map (lambda (x) #f) binds)))
+ (cons (cons 'lambda (cons (map car binds)
+ (nconc (map (lambda (b) (cons 'set! b)) binds)
+ body)))
+ (map (lambda (x) #f) binds)))
+(define-macro (cond . clauses)
+ (define (cond-clauses->if lst)
+ (if (atom? lst)
+ #f
+ (let ((clause (car lst)))
+ (if (or (eq? (car clause) 'else)
+ (eq? (car clause) #t))
+ (cons 'begin (cdr clause))
+ (list 'if
+ (car clause)
+ (cons 'begin (cdr clause))
+ (cond-clauses->if (cdr lst)))))))
+ (cond-clauses->if clauses))
+
; standard procedures ---------------------------------------------------------
(define (append2 l d)
@@ -200,36 +205,36 @@
(set-car! lst (f (car lst)))
(set! lst (cdr lst)))))
-(letrec ((mapcar-
- (lambda (f lsts)
- (cond ((null? lsts) (f))
- ((atom? (car lsts)) (car lsts))
- (#t (cons (apply f (map car lsts))
- (mapcar- f (map cdr lsts))))))))
- (set! mapcar
- (lambda (f . lsts) (mapcar- f lsts))))
+(define mapcar
+ (letrec ((mapcar-
+ (lambda (f lsts)
+ (cond ((null? lsts) (f))
+ ((atom? (car lsts)) (car lsts))
+ (#t (cons (apply f (map car lsts))
+ (mapcar- f (map cdr lsts))))))))
+ (lambda (f . lsts) (mapcar- f lsts))))
(define (transpose M) (apply mapcar list M))
-(letrec ((filter-
- (lambda (pred lst accum)
- (cond ((null? lst) accum)
- ((pred (car lst))
- (filter- pred (cdr lst) (cons (car lst) accum)))
- (#t
- (filter- pred (cdr lst) accum))))))
- (set! filter
- (lambda (pred lst) (filter- pred lst ()))))
+(define filter
+ (letrec ((filter-
+ (lambda (pred lst accum)
+ (cond ((null? lst) accum)
+ ((pred (car lst))
+ (filter- pred (cdr lst) (cons (car lst) accum)))
+ (#t
+ (filter- pred (cdr lst) accum))))))
+ (lambda (pred lst) (filter- pred lst ()))))
-(letrec ((separate-
- (lambda (pred lst yes no)
- (cond ((null? lst) (cons yes no))
- ((pred (car lst))
- (separate- pred (cdr lst) (cons (car lst) yes) no))
- (#t
- (separate- pred (cdr lst) yes (cons (car lst) no)))))))
- (set! separate
- (lambda (pred lst) (separate- pred lst () ()))))
+(define separate
+ (letrec ((separate-
+ (lambda (pred lst yes no)
+ (cond ((null? lst) (cons yes no))
+ ((pred (car lst))
+ (separate- pred (cdr lst) (cons (car lst) yes) no))
+ (#t
+ (separate- pred (cdr lst) yes (cons (car lst) no)))))))
+ (lambda (pred lst) (separate- pred lst () ()))))
(define (nestlist f zero n)
(if (<= n 0) ()
@@ -272,35 +277,6 @@
(cons elt
(delete-duplicates tail))))))
-(letrec ((get-defined-vars-
- (lambda (expr)
- (cond ((atom? expr) ())
- ((and (eq? (car expr) 'define)
- (pair? (cdr expr)))
- (or (and (symbol? (cadr expr))
- (list (cadr expr)))
- (and (pair? (cadr expr))
- (symbol? (caadr expr))
- (list (caadr expr)))
- ()))
- ((eq? (car expr) 'begin)
- (apply append (map get-defined-vars- (cdr expr))))
- (else ())))))
- (set! get-defined-vars
- (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
-
-; redefine f-body to support internal define
-(let ((f-body- f-body))
- (set! f-body
- (lambda (e)
- ((lambda (B)
- ((lambda (V)
- (if (null? V)
- B
- (cons (list 'lambda V B) (map (lambda (x) #f) V))))
- (get-defined-vars B)))
- (f-body- e)))))
-
; backquote -------------------------------------------------------------------
(define (revappend l1 l2) (nconc (reverse l1) l2))
@@ -371,9 +347,11 @@
(list 'quote v)))
(define-macro (let* binds . body)
- (if (atom? binds) (f-body body)
+ (if (atom? binds) `((lambda () ,@body))
`((lambda (,(caar binds))
- (let* ,(cdr binds) ,@body))
+ ,@(if (pair? (cdr binds))
+ `((let* ,(cdr binds) ,@body))
+ body))
,(cadar binds))))
(define-macro (when c . body) (list 'if c (cons 'begin body) #f))
@@ -416,7 +394,7 @@
(let ((v (car var))
(cnt (cadr var)))
`(for 0 (- ,cnt 1)
- (lambda (,v) ,(f-body body)))))
+ (lambda (,v) ,@body))))
(define (map-int f n)
(if (<= n 0)
@@ -464,12 +442,12 @@
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
-(letrec ((sample-traced-lambda (lambda args (begin (println (cons 'x args))
- (apply #.apply args)))))
- (set! traced?
- (lambda (f)
- (equal? (function:code f)
- (function:code sample-traced-lambda)))))
+(define traced?
+ (letrec ((sample-traced-lambda (lambda args (begin (println (cons 'x args))
+ (apply #.apply args)))))
+ (lambda (f)
+ (equal? (function:code f)
+ (function:code sample-traced-lambda)))))
(define (trace sym)
(let* ((func (top-level-value sym))
@@ -611,6 +589,23 @@
; toplevel --------------------------------------------------------------------
+(define get-defined-vars
+ (letrec ((get-defined-vars-
+ (lambda (expr)
+ (cond ((atom? expr) ())
+ ((and (eq? (car expr) 'define)
+ (pair? (cdr expr)))
+ (or (and (symbol? (cadr expr))
+ (list (cadr expr)))
+ (and (pair? (cadr expr))
+ (symbol? (caadr expr))
+ (list (caadr expr)))
+ ()))
+ ((eq? (car expr) 'begin)
+ (apply append (map get-defined-vars- (cdr expr))))
+ (else ())))))
+ (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
+
(define (macrocall? e) (and (symbol? (car e))
(get *syntax-environment* (car e) #f)))
@@ -632,12 +627,23 @@
(macroexpand-in (apply f (cdr e)) env)
(cond ((eq (car e) 'quote) e)
((eq (car e) 'lambda)
- (nlist* 'lambda (cadr e)
- (macroexpand-in (caddr e) env)
- (cdddr e)))
+ (let ((B (if (pair? (cddr e))
+ (if (pair? (cdddr e))
+ (cons 'begin (cddr e))
+ (caddr e))
+ #f)))
+ (let ((V (get-defined-vars B))
+ (Be (macroexpand-in B env)))
+ (nlist* 'lambda
+ (cadr e)
+ (if (null? V)
+ Be
+ (cons (list 'lambda V Be)
+ (map (lambda (x) #f) V)))
+ (cdddr e)))))
((eq (car e) 'let-syntax)
(let ((binds (cadr e))
- (body (f-body (cddr e))))
+ (body `((lambda () ,@(cddr e)))))
(macroexpand-in
body
(nconc
--- a/femtolisp/test.lsp
+++ b/femtolisp/test.lsp
@@ -43,6 +43,7 @@
(list piv)
(sort (cdr halves))))))
+#|
(define-macro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
@@ -49,7 +50,7 @@
`(let ((,v 0))
(while (< ,v ,cnt)
(prog1
- ,(f-body body)
+ ,(cons 'begin body)
(set! ,v (+ ,v 1)))))))
(define (map-int f n)
@@ -63,6 +64,7 @@
(begin (set-cdr! acc (cons (f i) ()))
(map-int- (cdr acc) (+ i 1) n)))))
first 1 n))))
+|#
(define-macro (labl name fn)
`((lambda (,name) (set! ,name ,fn)) ()))
--- a/llt/htable.h
+++ b/llt/htable.h
@@ -1,7 +1,7 @@
#ifndef __HTABLE_H_
#define __HTABLE_H_
-#define HT_N_INLINE 16
+#define HT_N_INLINE 32
typedef struct {size_t size;