From c42ee12d4cbbf57cdefd27cb4b881e185030d60d Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Fri, 29 May 2009 04:38:50 +0000 Subject: [PATCH] allowing multiple expressions in lambda making cond a macro increasing size limit for cvalues on the managed heap, and inline allocated hashtables --- femtolisp/compiler.lsp | 14 ---- femtolisp/cps.lsp | 15 +--- femtolisp/flisp.boot | 12 +-- femtolisp/flisp.h | 2 +- femtolisp/system.lsp | 178 +++++++++++++++++++++-------------------- femtolisp/test.lsp | 4 +- llt/htable.h | 2 +- 7 files changed, 101 insertions(+), 126 deletions(-) diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index 625282c..83ae55a 100644 --- 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)) diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index 2fe9eb2..ec4cd07 100644 --- 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)) diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index fda35bd..e1250fe 100644 --- a/femtolisp/flisp.boot +++ b/femtolisp/flisp.boot @@ -123,7 +123,7 @@ make-enum-table 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;cmg1042;" [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 @@ fits-i8 #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 @@ copy-list #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-or 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\xb00eg01g0332332e1g00e?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 @@ Instructions *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" diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 8b1b98c..beb7b8a 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -216,7 +216,7 @@ typedef struct { } 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 diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index ce2c5f9..f6ffd0a 100644 --- 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,18 +39,31 @@ (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 --------------------------------------------------------- @@ -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 diff --git a/femtolisp/test.lsp b/femtolisp/test.lsp index f39364b..2f3ed6f 100644 --- a/femtolisp/test.lsp +++ b/femtolisp/test.lsp @@ -43,13 +43,14 @@ (list piv) (sort (cdr halves)))))) +#| (define-macro (dotimes var . body) (let ((v (car var)) (cnt (cadr var))) `(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)) ())) diff --git a/llt/htable.h b/llt/htable.h index b9ea65e..3c1e5c9 100644 --- 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;