ref: 4cd78cb562334a8106b94d690b31b53f43f81018
parent: 9e07001ae0fc0f4ea1049b27d17b68405b71d9a1
author: JeffBezanson <[email protected]>
date: Thu Dec 23 01:49:37 EST 2010
getting rid of label adding optional, faster built-in map checking in soon-to-be code for quasiquote a couple library bug fixes
--- /dev/null
+++ b/femtolisp/bq.scm
@@ -1,0 +1,122 @@
+(define (bq-process2 x d)
+ (define (splice-form? x)
+ (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
+ (eq? (car x) 'unquote-nsplicing)
+ (and (eq? (car x) 'unquote)
+ (length> x 2))))
+ (eq? x 'unquote)))
+ ;; bracket without splicing
+ (define (bq-bracket1 x)
+ (if (and (pair? x) (eq? (car x) 'unquote))
+ (if (= d 0)
+ (cadr x)
+ (list cons ''unquote
+ (bq-process2 (cdr x) (- d 1))))
+ (bq-process2 x d)))
+ (define (bq-bracket x)
+ (cond ((atom? x) (list list (bq-process2 x d)))
+ ((eq? (car x) 'unquote)
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process2 (cdr x) (- d 1))))))
+ ((eq? (car x) 'unquote-splicing)
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process2 (cadr x) (- d 1))))))
+ ((eq? (car x) 'unquote-nsplicing)
+ (if (= d 0)
+ (cadr x)
+ (list list (list list ''unquote-nsplicing
+ (bq-process2 (cadr x) (- d 1))))))
+ (else (list list (bq-process2 x d)))))
+ (cond ((symbol? x) (list 'quote x))
+ ((vector? x)
+ (let ((body (bq-process2 (vector->list x) d)))
+ (if (eq? (car body) list)
+ (cons vector (cdr body))
+ (list apply vector body))))
+ ((atom? x) x)
+ ((eq? (car x) 'quasiquote)
+ (list list ''quasiquote (bq-process2 (cadr x) (+ d 1))))
+ ((eq? (car x) 'unquote)
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process2 (cdr x) (- d 1)))))
+ ((or (> d 0) (not (any splice-form? x)))
+ (let ((lc (lastcdr x))
+ (forms (map bq-bracket1 x)))
+ (if (null? lc)
+ (cons list forms)
+ (if (null? (cdr forms))
+ (list cons (car forms) (bq-process2 lc d))
+ (nconc (cons list* forms) (list (bq-process2 lc d)))))))
+ (else
+ (let loop ((p x) (q ()))
+ (cond ((null? p) ;; proper list
+ (cons 'nconc (reverse! q)))
+ ((pair? p)
+ (cond ((eq? (car p) 'unquote)
+ ;; (... . ,x)
+ (cons 'nconc
+ (nreconc q
+ (if (= d 0)
+ (cdr p)
+ (list (list list ''unquote)
+ (bq-process2 (cdr p)
+ (- d 1)))))))
+ (else
+ (loop (cdr p) (cons (bq-bracket (car p)) q)))))
+ (else
+ ;; (... . x)
+ (cons 'nconc (reverse! (cons (bq-process2 p d) q)))))))))
+
+#|
+tests
+
+> ``(,a ,,a ,b ,@b ,,@b)
+`(,a ,1 ,b ,@b (unquote 2 3))
+> `(,a ,1 ,b ,@b (unquote 2 3))
+(1 1 (2 3) 2 3 2 3)
+
+(define a 1)
+
+(bq-process2 '`(,a (unquote unquote a)) 0)
+
+(define b '(unquote a))
+(define unquote 88)
+(bq-process2 '``(,a ,,,@b) 0)
+; etc. => (1 88 1)
+
+(define b '(a a))
+(bq-process2 '``(,a ,,,@b) 0)
+; etc. => (1 1 1)
+|#
+
+;; minimal version with no optimizations, vectors, or dotted lists
+(define (bq-process0 x d)
+ (define (bq-bracket x)
+ (cond ((and (pair? x) (eq? (car x) 'unquote))
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process0 (cdr x) (- d 1))))))
+ ((and (pair? x) (eq? (car x) 'unquote-splicing))
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process0 (cadr x) (- d 1))))))
+ (else (list list (bq-process0 x d)))))
+ (cond ((symbol? x) (list 'quote x))
+ ((atom? x) x)
+ ((eq? (car x) 'quasiquote)
+ (list list ''quasiquote (bq-process0 (cadr x) (+ d 1))))
+ ((eq? (car x) 'unquote)
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process0 (cdr x) (- d 1)))))
+ (else
+ (cons 'nconc (map bq-bracket x)))))
+
+#t
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -557,7 +557,7 @@
(mark-label g nxt)
(emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
-(define (free-vars e)
+#;(define (free-vars e)
(cond ((symbol? e) (list e))
((or (atom? e) (eq? (car e) 'quote)) ())
((eq? (car e) 'lambda)
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -37,17 +37,17 @@
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("6000r1e040;" [void])]) 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+ raise quote assert-failed]) 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])]) quasiquote #fn("7000r1e0|41;" [bq-process]) when #fn("<000s1c0|c1}K^L4;" [if begin]) with-input-from #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconcwith-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!+ copy-list]) unwind-protect #fn("8000r2c0qe130e13042;" [#fn("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let+ lambda prog1 trycatch begin raise]) gensym]) dotimes #fn(";000s1c0q|M|\x8442;" [#fn("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for+ - nconc lambda copy-list])]) 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])+ 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~|L2L1~L3530|}K;" [letrec]) nconc lambda map #fn("6000r1|F650|M;|;" []) copy-list #fn("6000r1|F650|\x84;e040;" [void])])]) 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;|\x84c3\x82W0e4e5|31316A0c6qe7e5|313141;c8qe93041;c:|Mc1|NKi10~N31L4;" [else begin or => 1arg-lambda? caddr #fn("=000r1c0|~ML2L1c1|c2e3e4~3131Ki20i10N31L4L3;" [let if begin cddr caddr]) caadr #fn("<000r1c0|~ML2L1c1|e2~31|L2i20i10N31L4L3;" [let@@ -151,7 +151,7 @@
keyargs emit-optional-arg-inits > 255 largc lvargc vargc argc compile-in ret
values function encode-byte-code bcode:code const-to-idx-vec]) filter
keyword-arg?]) length]) length]) make-code-emitter lastcdr lambda-vars filter
- #.pair? lambda])] #0=[#:g711 ()])
+ #.pair? lambda])] #0=[#:g700 ()])
compile-for #fn(":000r5e0g4316X0e1|}^g2342e1|}^g3342e1|}^g4342e2|c342;e4c541;" [1arg-lambda?compile-in emit for error "for: third form must be a 1-argument lambda"] compile-for)
compile-if #fn("<000r4c0qe1|31e1|31g3\x84e2g331e3g331F6;0e4g331560e53045;" [#fn(";000r5g2]\x82>0e0~\x7fi02g344;g2^\x82>0e0~\x7fi02g444;e0~\x7f^g2342e1~c2|332e0~\x7fi02g3342i026<0e1~c3325:0e1~c4}332e5~|322e0~\x7fi02g4342e5~}42;" [compile-in@@ -224,9 +224,9 @@
every #fn("8000r2}?17D02|}M3116:02e0|}N42;" [every] every) expand #fn("A000r1c0q]]]]]]]]]]]4;;" [#fn("8000r;c0m02c1qm12c2L1m22c3qm32c4qm42c5qm52c6qm62c7qm72c8qm82c9m92c:qm:2g:~_42;" [#fn("8000r2|E17902e0|}32@;" [assq] top?) #fn("9000r1|?640|;|c0>640|;|MF16;02e1|31c2<6D0e3\x7fe4|3131\x7f|N3142;|M\x7f|N31K;" [((begin))- caar begin append cdar] splice-begin) *expanded* #fn("9000r2|?640|;c0q~c1}32690\x7f|31530|41;" [#fn("9000r1c0qi10c1\x7f3241;" [#fn("8000r1c0q|6:0e1~31530_41;" [#fn(":000r1c0qe1e2c3|32i213241;" [#fn("8000r1i107=0e0c1qi2042;c2qc3q^31i203141;" [map+ caar begin append cdar] splice-begin) *expanded* #fn("9000r2|?640|;c0q~c1}32690\x7f|31530|41;" [#fn("9000r1c0qi10c1\x7f3241;" [#fn("8000r1c0q|6:0e1~31530_41;" [#fn(":000r1c0qe1e2c3|32i213241;" [#fn("8000r1i107=0e0c1qi2042;c2qc3q]31i203141;" [map #fn("8000r1i5:|~42;" []) #fn("7000r1c0q|41;" [#fn("9000r1]|F6]02i62e0|31<7A0|i6:|Mi1032O590|e1|31O2|Nm05\x02/2~;" [caar- cdar])]) #fn("6000r1c0qm0;" [#fn("9000r1|?640|;|MF16;02c0e1|31<6;0|M~|N31K;c2qi6:|Mi103241;" [define+ cdar])]) #fn("6000r1c0qm02|;" [#fn("9000r1|?640|;|MF16;02c0e1|31<6;0|M~|N31K;c2qi6:|Mi103241;" [define caar #fn(":000r1e0e1c2e3|3132i2032o202i72|Ki10~N31K;" [nconc map #.listget-defined-vars])])])])
nconc map #.list]) get-defined-vars]) define]) begin] expand-body)
@@ -242,7 +242,7 @@
#fn("6000r2|;" [] local-expansion-env) #fn("7000r2|?640|;c0q|M41;" [#fn("9000r1c0qe1|\x7f3241;" [#fn("7000r1c0qc1q41;" [#fn(":000r1~16602~NF6M0i3:~\x84i20NQ2i39e0~31i213242;~17A02i10C@17702i10E660|40;c1qe2i203141;" [caddr #fn("8000r1|6B0i4:|i30NQ2i3142;i20c0\x8260i30;i20c1\x82>0i46i30i3142;i20c2\x82>0i47i30i3142;i20c3\x82>0i48i30i3142;~40;" [quotelambda define let-syntax]) macrocall?])
- #fn("7000r0c0q^31i2041;" [#fn("6000r1c0qm0;" [#fn("9000r1|?640|;|M?670|M5<0i4:|Mi3132~|N31K;" [])])])])+ #fn("7000r0c0q]31i2041;" [#fn("6000r1c0qm02|;" [#fn("9000r1|?640|;|M?670|M5<0i4:|Mi3132~|N31K;" [])])])])assq])] expand-in)])] expand)
expand-define #fn("=000r1c0|\x84e1|31F6:0e1|315L0|\x84C6;0e230L15=0e3c4e5|313242;" [#fn("<000r2|C6:0c0|}ML3;c0|Me1c2L1|NL1e3}31|M34L3;" [set!nconc lambda copy-list]) cddr void error "compile error: invalid syntax "
@@ -252,9 +252,6 @@
foldl #fn(":000r3g2\x8540};e0||g2M}32g2N43;" [foldl] foldl) foldr #fn(";000r3g2\x8540};|g2Me0|}g2N3342;" [foldr] foldr) for-each #fn(";000s2c0q]41;" [#fn(":000r1c0qm02i02\x85J0]\x7fF6A02~\x7fM312\x7fNo015\x1e/5;0|~\x7fi02K322];" [#fn(":000r2}MF6I0|e0c1}32Q22~|e0c2}3242;];" [map#.car #.cdr] for-each-n)])] for-each)
- free-vars #fn("<000r1|C660|L1;|?17802|Mc0<640_;|Mc1\x82V0e2e3e4|3131e5e6c7e4|31K31e8|\x84313242;e9e5e:e3|N32Q241;" [quote- lambda diff free-vars cddr nconc get-defined-vars begin lambda-arg-names
- delete-duplicates map] free-vars)
get-defined-vars #fn("8000r1e0~|3141;" [delete-duplicates] #1=[#fn("9000r1|?640_;|Mc0<16602|NF6d0|\x84C16702|\x84L117S02|\x84F16E02e1|31C16:02e1|31L117402_;|Mc2\x82>0e3e4~|N32v2;_;" [definecaadr begin nconc map] #1#) ()])
hex5 #fn("9000r1e0e1|b@32b5c243;" [string.lpad number->string #\0] hex5)@@ -284,7 +281,7 @@
#fn(":000r2e0}`32640_;|Me1|N}ax32K;" [<= list-head] list-head) list-ref #fn("8000r2e0|}32M;" [list-tail] list-ref) list-tail #fn("9000r2e0}`32640|;e1|N}ax42;" [<= list-tail] list-tail) list? #fn("7000r1|A17@02|F16902e0|N41;" [list?] list?)- load #fn("9000r1c0qe1|c23241;" [#fn("7000r1c0qc1qt;" [#fn("9000r0c0q^31]]]43;" [#fn("6000r1c0qm0;" [#fn(":000r3e0i10317C0~e1i1031|e2}3143;e3i10312e2}41;" [io.eof?+ load #fn("9000r1c0qe1|c23241;" [#fn("7000r1c0qc1qt;" [#fn("9000r0c0q]31]]]43;" [#fn("6000r1c0qm02|;" [#fn(":000r3e0i10317C0~e1i1031|e2}3143;e3i10312e2}41;" [io.eof? read load-process io.close])])]) #fn("9000r1e0~312e1c2i10|L341;" [io.closeraise
load-error])])
@@ -298,8 +295,8 @@
macrocall?] macroexpand-1)
make-code-emitter #fn("9000r0_e030`c1Z4;" [table +inf.0] make-code-emitter) make-label #fn("6000r1e040;" [gensym] make-label)- make-perfect-hash-table #fn("7000r1c0q]41;" [#fn("8000r1c0m02c1q^31e2~3141;" [#fn("9000r2e0e1e2|3131}42;" [mod0- abs hash] $hash-keyword) #fn("6000r1c0qm0;" [#fn("9000r1c0qe1b2|T2^3241;" [#fn("7000r1c0q^31i3041;" [#fn("6000r1c0qm0;" [#fn("8000r1|F6=0c0qe1|3141;i10;" [#fn(":000r1c0qb2i50|i3032T241;" [#fn("9000r1i30|[6=0i50i40aw41;i30|~\\2i30|awe0i1031\\2i20i10N41;" [cdar])])+ make-perfect-hash-table #fn("7000r1c0q]41;" [#fn("8000r1c0m02c1q]31e2~3141;" [#fn("9000r2e0e1e2|3131}42;" [mod0+ abs hash] $hash-keyword) #fn("6000r1c0qm02|;" [#fn("9000r1c0qe1b2|T2^3241;" [#fn("7000r1c0q]31i3041;" [#fn("6000r1c0qm02|;" [#fn("8000r1|F6=0c0qe1|3141;i10;" [#fn(":000r1c0qb2i50|i3032T241;" [#fn("9000r1i30|[6=0i50i40aw41;i30|~\\2i30|awe0i1031\\2i20i10N41;" [cdar])])caar])])]) vector.alloc])]) length])] make-perfect-hash-table)
make-system-image #fn(";000r1c0e1|c2c3c434c542;" [#fn("8000r2c0qe1e242;" [#fn("7000r2]k02]k12c2qc3q41;" [*print-pretty* *print-readably* #fn("7000r1c0qc1qt|302;" [#fn(":000r0c0qe1c2qe3e4303132312e5i2041;" [#fn("=000r1e0e1e2c3|e2e4|3233Q2i20322e5i20e642;" [write@@ -314,12 +311,8 @@
*print-readably*
*print-level*
*print-length* *os-name*)] make-system-image)
- map #fn("=000s2g2\x85<0e0|}_L143;e1|}g2K42;" [map1 mapn] map) map!- #fn("9000r2}]}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int #fn("8000r2e0}`32640_;c1q|`31_K_42;" [<=- #fn(":000r2|m12a\x7faxc0qu2|;" [#fn("8000r1\x7fi10|31_KP2\x7fNo01;" [])])] map-int)- map1 #fn("9000r3g2]}F6H02g2|}M31_KPNm22}Nm15\x17/2N;" [] map1) mapn- #fn("<000r2}M\x8540_;|e0c1}_L133Q2e2|e0c3}_L13332K;" [map1 #.car mapn- #.cdr] mapn)
+ map! #fn("9000r2}]}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int+ #fn("8000r2e0}`32640_;c1q|`31_K_42;" [<= #fn(":000r2|m12a\x7faxc0qu2|;" [#fn("8000r1\x7fi10|31_KP2\x7fNo01;" [])])] map-int) mark-label #fn("9000r2e0|c1}43;" [emit label] mark-label) max #fn("<000s1}\x8540|;e0c1|}43;" [foldl #fn("7000r2|}X640};|;" [])] max) member #fn("8000r2}?640^;}M|>640};e0|}N42;" [member] member) memv@@ -362,7 +355,7 @@
random #fn("8000r1e0|316<0e1e230|42;e330|T2;" [integer? mod randrand.double] random)
read-all #fn("8000r1e0e1|42;" [read-all-of read] read-all)- read-all-of #fn("9000r2c0q^31_|}3142;" [#fn("6000r1c0qm0;" [#fn("9000r2e0i1131680e1|41;~}|Ki10i113142;" [io.eof?+ read-all-of #fn("9000r2c0q]31_|}3142;" [#fn("6000r1c0qm02|;" [#fn("9000r2e0i1131680e1|41;~}|Ki10i113142;" [io.eof?reverse!])])] read-all-of)
ref-int16-LE #fn(";000r2e0e1|}`w[`32e1|}aw[b832w41;" [int16 ash] ref-int16-LE) ref-int32-LE #fn("=000r2e0e1|}`w[`32e1|}aw[b832e1|}b2w[b@32e1|}b3w[bH32R441;" [int32@@ -377,7 +370,8 @@
#fn("7000r1e0|312];" [top-level-exception-handler])newline] reploop) newline])] repl)
revappend #fn("8000r2e0e1|31}42;" [nconc reverse] revappend) reverse- #fn("9000r1e0c1_|43;" [foldl #.cons] reverse) reverse! #fn("7000r1c0q_41;" [#fn("9000r1]~F6C02~N~|~m02P2o005\x1c/2|;" [])] reverse!)+ #fn("8000r1e0_|42;" [reverse-] reverse) reverse! #fn("7000r1c0q_41;" [#fn("9000r1]~F6C02~N~|~m02P2o005\x1c/2|;" [])] reverse!)+ reverse- #fn("8000r2}\x8540|;e0}M|K}N42;" [reverse-] reverse-) self-evaluating? #fn("8000r1|?16602|C@17K02e0|3116A02|C16:02|e1|31<;" [constant?top-level-value] self-evaluating?)
separate #fn("7000r2c0q]41;" [#fn(":000r1c0m02|~\x7f_L1_L144;" [#fn(";000r4c0g2g3K]}F6Z02|}M316?0g2}M_KPNm25<0g3}M_KPNm32}Nm15\x05/241;" [#fn("8000r1e0|MN|NN42;" [values])] separate-)])] separate)--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -99,7 +99,7 @@
static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
static value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
-static value_t definesym, defmacrosym, forsym, labelsym, setqsym;
+static value_t definesym, defmacrosym, forsym, setqsym;
static value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym, fnsym;
// for reading characters
static value_t nulsym, alarmsym, backspacesym, tabsym, linefeedsym, newlinesym;
@@ -2142,6 +2142,72 @@
return _stacktrace(fl_throwing_frame ? fl_throwing_frame : curr_frame);
}
+value_t fl_map1(value_t *args, u_int32_t nargs)
+{+ if (nargs < 2)
+ lerror(ArgError, "map: too few arguments");
+ if (!iscons(args[1])) return NIL;
+ value_t first, last, v;
+ if (nargs == 2) {+ if (SP+3 > N_STACK) grow_stack();
+ PUSH(args[0]);
+ PUSH(car_(args[1]));
+ v = _applyn(1);
+ PUSH(v);
+ v = mk_cons();
+ car_(v) = POP(); cdr_(v) = NIL;
+ last = first = v;
+ args[1] = cdr_(args[1]);
+ fl_gc_handle(&first);
+ fl_gc_handle(&last);
+ while (iscons(args[1])) {+ Stack[SP-2] = args[0];
+ Stack[SP-1] = car_(args[1]);
+ v = _applyn(1);
+ PUSH(v);
+ v = mk_cons();
+ car_(v) = POP(); cdr_(v) = NIL;
+ cdr_(last) = v;
+ last = v;
+ args[1] = cdr_(args[1]);
+ }
+ POPN(2);
+ fl_free_gc_handles(2);
+ }
+ else {+ size_t i;
+ while (SP+nargs+1 > N_STACK) grow_stack();
+ PUSH(args[0]);
+ for(i=1; i < nargs; i++) {+ PUSH(car(args[i]));
+ args[i] = cdr_(args[i]);
+ }
+ v = _applyn(nargs-1);
+ PUSH(v);
+ v = mk_cons();
+ car_(v) = POP(); cdr_(v) = NIL;
+ last = first = v;
+ fl_gc_handle(&first);
+ fl_gc_handle(&last);
+ while (iscons(args[1])) {+ Stack[SP-nargs] = args[0];
+ for(i=1; i < nargs; i++) {+ Stack[SP-nargs+i] = car(args[i]);
+ args[i] = cdr_(args[i]);
+ }
+ v = _applyn(nargs-1);
+ PUSH(v);
+ v = mk_cons();
+ car_(v) = POP(); cdr_(v) = NIL;
+ cdr_(last) = v;
+ last = v;
+ }
+ POPN(nargs);
+ fl_free_gc_handles(2);
+ }
+ return first;
+}
+
static builtinspec_t core_builtin_info[] = { { "function", fl_function }, { "function:code", fl_function_code },@@ -2155,6 +2221,7 @@
{ "copy-list", fl_copylist }, { "append", fl_append }, { "list*", fl_liststar },+ { "map", fl_map1 }, { NULL, NULL }};
@@ -2201,7 +2268,7 @@
vectorsym = symbol("vector"); builtinsym = symbol("builtin"); booleansym = symbol("boolean"); nullsym = symbol("null"); definesym = symbol("define"); defmacrosym = symbol("define-macro");- forsym = symbol("for"); labelsym = symbol("label");+ forsym = symbol("for"); setqsym = symbol("set!"); evalsym = symbol("eval"); vu8sym = symbol("vu8"); fnsym = symbol("fn"); nulsym = symbol("nul"); alarmsym = symbol("alarm");--- a/femtolisp/perf.lsp
+++ b/femtolisp/perf.lsp
@@ -18,11 +18,11 @@
(define (my-append . lsts)
(cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts))
- (else ((label append2 (lambda (l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d)))))
- (car lsts) (apply my-append (cdr lsts))))))
+ (else (letrec ((append2 (lambda (l d)
+ (if (null? l) d
+ (cons (car l)
+ (append2 (cdr l) d))))))
+ (append2 (car lsts) (apply my-append (cdr lsts)))))))
(princ "append: ")
(set! L (map-int (lambda (x) (map-int identity 20)) 20))
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -196,7 +196,7 @@
{// indent these forms 2 spaces, not lined up with the first argument
if (head == LAMBDA || head == TRYCATCH || head == definesym ||
- head == defmacrosym || head == forsym || head == labelsym)
+ head == defmacrosym || head == forsym)
return 2;
return -1;
}
@@ -241,7 +241,7 @@
// indent before every subform of a special form, unless every
// subform is "small"
value_t c = car_(v);
- if (c == LAMBDA || c == labelsym || c == setqsym)
+ if (c == LAMBDA || c == setqsym)
return 0;
if (c == IF) // TODO: others
return !allsmallp(cdr_(v));
@@ -303,7 +303,7 @@
}
if (!print_pretty ||
- ((head == LAMBDA || head == labelsym) && n == 0)) {+ ((head == LAMBDA) && n == 0)) {// never break line before lambda-list
ind = 0;
}
@@ -318,7 +318,7 @@
(est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
- ((head == LAMBDA || head == labelsym) && !nextsmall) ||
+ ((head == LAMBDA) && !nextsmall) ||
(n > 0 && always) ||
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -36,10 +36,7 @@
`(set-syntax! ',(car form)
(lambda ,(cdr form) ,@body)))
-(define-macro (label name fn)
- `((lambda (,name) (set! ,name ,fn)) #f))
-
-(define (map1 f lst acc)
+#;(define (map1 f lst acc)
(cdr
(prog1 acc
(while (pair? lst)
@@ -47,17 +44,23 @@
(cdr (set-cdr! acc (cons (f (car lst)) ()))))
(set! lst (cdr lst)))))))
-(define (mapn f lsts)
+#;(define (mapn f lsts)
(if (null? (car lsts))
()
(cons (apply f (map1 car lsts (list ())))
(mapn f (map1 cdr lsts (list ()))))))
-(define (map f lst . lsts)
+#;(define (map f lst . lsts)
(if (null? lsts)
(map1 f lst (list ()))
(mapn f (cons lst lsts))))
+(define-macro (letrec binds . body)
+ `((lambda ,(map car binds)
+ ,.(map (lambda (b) `(set! ,@b)) binds)
+ ,@body)
+ ,.(map (lambda (x) (void)) binds)))
+
(define-macro (let binds . body)
(let ((lname #f))
(if (symbol? binds)
@@ -71,16 +74,10 @@
(theargs
(map (lambda (c) (if (pair? c) (cadr c) (void))) binds)))
(cons (if lname
- `(label ,lname ,thelambda)
+ `(letrec ((,lname ,thelambda)) ,lname)
thelambda)
theargs))))
-(define-macro (letrec binds . body)
- `((lambda ,(map car binds)
- ,.(map (lambda (b) `(set! ,@b)) binds)
- ,@body)
- ,.(map (lambda (x) (void)) binds)))
-
(define-macro (cond . clauses)
(define (cond-clauses->if lst)
(if (atom? lst)
@@ -322,7 +319,11 @@
(if (null? lst) zero
(foldl f (f (car lst) zero) (cdr lst))))
-(define (reverse lst) (foldl cons () lst))
+(define (reverse- zero lst)
+ (if (null? lst) zero
+ (reverse- (cons (car lst) zero) (cdr lst))))
+
+(define (reverse lst) (reverse- () lst))
(define (reverse! l)
(let ((prev ()))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1195,5 +1195,5 @@
5/4/10 todo:
- flush and close open files on exit
-- make function versions of opcode builtins by wrapping in a lambda,
+* make function versions of opcode builtins by wrapping in a lambda,
stored in a table indexed by opcode. use in _applyn
--- a/llt/arraylist.c
+++ b/llt/arraylist.c
@@ -45,7 +45,7 @@
size_t nm = a->max*2;
if (nm == 0) nm = 1;
while (a->len+n > nm) nm*=2;
- void **p = LLT_REALLOC(a->items, nm);
+ void **p = LLT_REALLOC(a->items, nm*sizeof(void*));
if (p == NULL) return;
a->items = p;
a->max = nm;
--- a/llt/bitvector.c
+++ b/llt/bitvector.c
@@ -49,7 +49,7 @@
if (p == NULL) return NULL;
if (initzero && newsz>oldsz) {size_t osz = ((oldsz+31)>>5) * sizeof(uint32_t);
- memset(&p[osz], 0, sz-osz);
+ memset(&p[osz/sizeof(uint32_t)], 0, sz-osz);
}
return p;
}
@@ -95,16 +95,20 @@
// returns n if no set bits.
uint32_t bitvector_next(uint32_t *b, uint64_t n0, uint64_t n)
{- if (n == 0) return 0;
+ if (n0 >= n) return n;
uint32_t i = n0>>5;
uint32_t nb = n0&31;
uint32_t nw = (n+31)>>5;
+ uint32_t w;
- uint32_t w = b[i]>>nb;
+ if (i < nw-1 || (n&31)==0)
+ w = b[i]>>nb;
+ else
+ w = (b[i]&lomask(n&31))>>nb;
if (w != 0)
return ntz(w)+n0;
- if (nw == 1)
+ if (i == nw-1)
return n;
i++;
while (i < nw-1) {--- a/llt/ios.c
+++ b/llt/ios.c
@@ -586,11 +586,11 @@
return NULL;
if (s->size)
memcpy(buf, s->buf, s->size);
- buf[s->size] = '\0';
}
else {buf = s->buf;
}
+ buf[s->size] = '\0';
*psize = s->size+1; // buffer is actually 1 bigger for terminating NUL