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
parent
1ee81e2625
commit
c42ee12d4c
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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;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 @@ 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\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 @@ 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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)) ()))
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue