lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

allowing multiple expressions in lambda 

making cond a macro
increasing size limit for cvalues on the managed heap, and inline
  allocated hashtables
This commit is contained in:
JeffBezanson 2009-05-29 04:38:50 +00:00
parent 1ee81e2625
commit c42ee12d4c
7 changed files with 101 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
femtolisp/compiler.lsp
View File

@ -180,19 +180,6 @@
(closed (emit g (aref Is 1) (cadr loc) (caddr loc))) (closed (emit g (aref Is 1) (cadr loc) (caddr loc)))
(else (emit g (aref Is 2) s))))) (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) (define (compile-if g env tail? x)
(let ((elsel (make-label g)) (let ((elsel (make-label g))
(endl (make-label g))) (endl (make-label g)))
@ -393,7 +380,6 @@
(else (else
(case (car x) (case (car x)
(quote (emit g :loadv (cadr x))) (quote (emit g :loadv (cadr x)))
(cond (compile-in g env tail? (cond->if x)))
(if (compile-if g env tail? x)) (if (compile-if g env tail? x))
(begin (compile-begin g env tail? (cdr x))) (begin (compile-begin g env tail? (cdr x)))
(prog1 (compile-prog1 g env x)) (prog1 (compile-prog1 g env x))

15
femtolisp/cps.lsp
View File

@ -4,16 +4,6 @@
((null? (cdr e)) (car e)) ((null? (cdr e)) (car e))
(#t (cons 'begin 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) (define (begin->cps forms k)
(cond ((atom? forms) `(,k ,forms)) (cond ((atom? forms) `(,k ,forms))
((null? (cdr forms)) (cps- (car forms) k)) ((null? (cdr forms)) (cps- (car forms) k))
@ -94,9 +84,6 @@
((eq (car form) 'begin) ((eq (car form) 'begin)
(begin->cps (cdr form) k)) (begin->cps (cdr form) k))
((eq (car form) 'cond)
(cps- (cond->if form) k))
((eq (car form) 'if) ((eq (car form) 'if)
(let ((test (cadr form)) (let ((test (cadr form))
(then (caddr form)) (then (caddr form))
@ -255,7 +242,7 @@
(#t form))) (#t form)))
(define-macro (with-delimited-continuations . code) (define-macro (with-delimited-continuations . code)
(cps (f-body code))) (cps `((lambda () ,@code))))
(define-macro (define-generator form . body) (define-macro (define-generator form . body)
(let ((ko (gensym)) (let ((ko (gensym))

12
femtolisp/flisp.boot
View File

@ -123,7 +123,7 @@ make-enum-table
make-code-emitter make-code-emitter
#function("n0_e030`Z3;" [table]) #function("n0_e030`Z3;" [table])
macroexpand-in 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 macroexpand-1
#function("n1f0?6;0f0;c0e1f031q42;" [#function("rf06?0f0g00Nt2;g00;" []) macrocall?]) #function("n1f0?6;0f0;c0e1f031q42;" [#function("rf06?0f0g00Nt2;g00;" []) macrocall?])
macroexpand macroexpand
@ -184,8 +184,6 @@ fits-i8
#function("n1f0I16O02e0f0b\xb03216O02e1f0b\xaf42;" [>= <=]) #function("n1f0I16O02e0f0b\xb03216O02e1f0b\xaf42;" [>= <=])
filter filter
#function("n2g00f0f1_43;" [] #0=[#function("n3f1A6;0f2;f0f1M316V0g00f0f1Nf1Mf2K43;g00f0f1Nf243;" [] #0#) ()]) #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 expand
#function("n1e0f041;" [macroexpand]) #function("n1e0f041;" [macroexpand])
every every
@ -218,10 +216,6 @@ copy-list
#function("n1f0?6;0f0;f0Me0f0N31K;" [copy-list]) #function("n1f0?6;0f0;f0Me0f0N31K;" [copy-list])
const-to-idx-vec const-to-idx-vec
#function("n1c0e1f0b2[31q42;" [#function("re0c1mg00a[322f0;" [table.foreach #function("n2g00f1f0\\;" [])]) vector.alloc]) #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 compile-while
#function("n4c0e1f031e1f031q43;" [#function("re0g00g01^^342e1g00f0322e0g00g01^g02342e2g00e3f1332e2g00e4322e0g00g01^g03342e2g00e5f0332e1g00f142;" [compile-in mark-label emit :brf :pop :jmp]) make-label]) #function("n4c0e1f031e1f031q43;" [#function("re0g00g01^^342e1g00f0322e0g00g01^g02342e2g00e3f1332e2g00e4322e0g00g01^g03342e2g00e5f0332e1g00f142;" [compile-in mark-label emit :brf :pop :jmp]) make-label])
compile-thunk compile-thunk
@ -237,7 +231,7 @@ compile-or
compile-let 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])]) #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 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 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]) #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 compile-for
@ -337,6 +331,6 @@ Instructions
*whitespace* *whitespace*
"\t\n\v\f\r \u0085  ᠎           \u2028\u2029  　" "\t\n\v\f\r \u0085  ᠎           \u2028\u2029  　"
*syntax-environment* *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* *banner*
"; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n"

2
femtolisp/flisp.h
View File

@ -216,7 +216,7 @@ typedef struct {
} function_t; } function_t;
#define CPRIM_NWORDS 2 #define CPRIM_NWORDS 2
#define MAX_INL_SIZE 96 #define MAX_INL_SIZE 384
#define CV_OWNED_BIT 0x1 #define CV_OWNED_BIT 0x1
#define CV_PARENT_BIT 0x2 #define CV_PARENT_BIT 0x2

178
femtolisp/system.lsp
View File

@ -8,23 +8,15 @@
(set! set-syntax! (set! set-syntax!
(lambda (s v) (put! *syntax-environment* s v))) (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 (set-syntax! 'define-macro
(lambda (form . body) (lambda (form . body)
(list 'set-syntax! (list 'quote (car form)) (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) (define-macro (define form . body)
(if (symbol? form) (if (symbol? form)
(list 'set! form (car body)) (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)) (define (symbol-syntax s) (get *syntax-environment* s #f))
@ -47,18 +39,31 @@
(list 'label lname thelambda) (list 'label lname thelambda)
thelambda) thelambda)
theargs)) theargs))
(list 'lambda (cons 'lambda
(map (lambda (c) (if (pair? c) (car c) c)) binds) (cons (map (lambda (c) (if (pair? c) (car c) c)) binds)
(f-body body)) body))
(map (lambda (c) (if (pair? c) (cadr c) #f)) binds)))) (map (lambda (c) (if (pair? c) (cadr c) #f)) binds))))
#f)) #f))
(define-macro (letrec binds . body) (define-macro (letrec binds . body)
(cons (list 'lambda (map car binds) (cons (cons 'lambda (cons (map car binds)
(f-body (nconc (map (lambda (b) (cons 'set! b)) binds)
(nconc (map (lambda (b) (cons 'set! b)) binds) body)))
body))) (map (lambda (x) #f) binds)))
(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 --------------------------------------------------------- ; standard procedures ---------------------------------------------------------
@ -200,36 +205,36 @@
(set-car! lst (f (car lst))) (set-car! lst (f (car lst)))
(set! lst (cdr lst))))) (set! lst (cdr lst)))))
(letrec ((mapcar- (define mapcar
(lambda (f lsts) (letrec ((mapcar-
(cond ((null? lsts) (f)) (lambda (f lsts)
((atom? (car lsts)) (car lsts)) (cond ((null? lsts) (f))
(#t (cons (apply f (map car lsts)) ((atom? (car lsts)) (car lsts))
(mapcar- f (map cdr lsts)))))))) (#t (cons (apply f (map car lsts))
(set! mapcar (mapcar- f (map cdr lsts))))))))
(lambda (f . lsts) (mapcar- f lsts)))) (lambda (f . lsts) (mapcar- f lsts))))
(define (transpose M) (apply mapcar list M)) (define (transpose M) (apply mapcar list M))
(letrec ((filter- (define filter
(lambda (pred lst accum) (letrec ((filter-
(cond ((null? lst) accum) (lambda (pred lst accum)
((pred (car lst)) (cond ((null? lst) accum)
(filter- pred (cdr lst) (cons (car lst) accum))) ((pred (car lst))
(#t (filter- pred (cdr lst) (cons (car lst) accum)))
(filter- pred (cdr lst) accum)))))) (#t
(set! filter (filter- pred (cdr lst) accum))))))
(lambda (pred lst) (filter- pred lst ())))) (lambda (pred lst) (filter- pred lst ()))))
(letrec ((separate- (define separate
(lambda (pred lst yes no) (letrec ((separate-
(cond ((null? lst) (cons yes no)) (lambda (pred lst yes no)
((pred (car lst)) (cond ((null? lst) (cons yes no))
(separate- pred (cdr lst) (cons (car lst) yes) no)) ((pred (car lst))
(#t (separate- pred (cdr lst) (cons (car lst) yes) no))
(separate- pred (cdr lst) yes (cons (car lst) no))))))) (#t
(set! separate (separate- pred (cdr lst) yes (cons (car lst) no)))))))
(lambda (pred lst) (separate- pred lst () ())))) (lambda (pred lst) (separate- pred lst () ()))))
(define (nestlist f zero n) (define (nestlist f zero n)
(if (<= n 0) () (if (<= n 0) ()
@ -272,35 +277,6 @@
(cons elt (cons elt
(delete-duplicates tail)))))) (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 ------------------------------------------------------------------- ; backquote -------------------------------------------------------------------
(define (revappend l1 l2) (nconc (reverse l1) l2)) (define (revappend l1 l2) (nconc (reverse l1) l2))
@ -371,9 +347,11 @@
(list 'quote v))) (list 'quote v)))
(define-macro (let* binds . body) (define-macro (let* binds . body)
(if (atom? binds) (f-body body) (if (atom? binds) `((lambda () ,@body))
`((lambda (,(caar binds)) `((lambda (,(caar binds))
(let* ,(cdr binds) ,@body)) ,@(if (pair? (cdr binds))
`((let* ,(cdr binds) ,@body))
body))
,(cadar binds)))) ,(cadar binds))))
(define-macro (when c . body) (list 'if c (cons 'begin body) #f)) (define-macro (when c . body) (list 'if c (cons 'begin body) #f))
@ -416,7 +394,7 @@
(let ((v (car var)) (let ((v (car var))
(cnt (cadr var))) (cnt (cadr var)))
`(for 0 (- ,cnt 1) `(for 0 (- ,cnt 1)
(lambda (,v) ,(f-body body))))) (lambda (,v) ,@body))))
(define (map-int f n) (define (map-int f n)
(if (<= n 0) (if (<= n 0)
@ -464,12 +442,12 @@
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr)))) (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
(letrec ((sample-traced-lambda (lambda args (begin (println (cons 'x args)) (define traced?
(apply #.apply args))))) (letrec ((sample-traced-lambda (lambda args (begin (println (cons 'x args))
(set! traced? (apply #.apply args)))))
(lambda (f) (lambda (f)
(equal? (function:code f) (equal? (function:code f)
(function:code sample-traced-lambda))))) (function:code sample-traced-lambda)))))
(define (trace sym) (define (trace sym)
(let* ((func (top-level-value sym)) (let* ((func (top-level-value sym))
@ -611,6 +589,23 @@
; toplevel -------------------------------------------------------------------- ; 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)) (define (macrocall? e) (and (symbol? (car e))
(get *syntax-environment* (car e) #f))) (get *syntax-environment* (car e) #f)))
@ -632,12 +627,23 @@
(macroexpand-in (apply f (cdr e)) env) (macroexpand-in (apply f (cdr e)) env)
(cond ((eq (car e) 'quote) e) (cond ((eq (car e) 'quote) e)
((eq (car e) 'lambda) ((eq (car e) 'lambda)
(nlist* 'lambda (cadr e) (let ((B (if (pair? (cddr e))
(macroexpand-in (caddr e) env) (if (pair? (cdddr e))
(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) ((eq (car e) 'let-syntax)
(let ((binds (cadr e)) (let ((binds (cadr e))
(body (f-body (cddr e)))) (body `((lambda () ,@(cddr e)))))
(macroexpand-in (macroexpand-in
body body
(nconc (nconc

4
femtolisp/test.lsp
View File

@ -43,13 +43,14 @@
(list piv) (list piv)
(sort (cdr halves)))))) (sort (cdr halves))))))
#|
(define-macro (dotimes var . body) (define-macro (dotimes var . body)
(let ((v (car var)) (let ((v (car var))
(cnt (cadr var))) (cnt (cadr var)))
`(let ((,v 0)) `(let ((,v 0))
(while (< ,v ,cnt) (while (< ,v ,cnt)
(prog1 (prog1
,(f-body body) ,(cons 'begin body)
(set! ,v (+ ,v 1))))))) (set! ,v (+ ,v 1)))))))
(define (map-int f n) (define (map-int f n)
@ -63,6 +64,7 @@
(begin (set-cdr! acc (cons (f i) ())) (begin (set-cdr! acc (cons (f i) ()))
(map-int- (cdr acc) (+ i 1) n))))) (map-int- (cdr acc) (+ i 1) n)))))
first 1 n)))) first 1 n))))
|#
(define-macro (labl name fn) (define-macro (labl name fn)
`((lambda (,name) (set! ,name ,fn)) ())) `((lambda (,name) (set! ,name ,fn)) ()))

2
llt/htable.h
View File

@ -1,7 +1,7 @@
#ifndef __HTABLE_H_ #ifndef __HTABLE_H_
#define __HTABLE_H_ #define __HTABLE_H_
#define HT_N_INLINE 16 #define HT_N_INLINE 32
typedef struct { typedef struct {
size_t size; size_t size;