diff --git a/femtolisp/bq.scm b/femtolisp/bq.scm new file mode 100644 index 0000000..806e80a --- /dev/null +++ b/femtolisp/bq.scm @@ -0,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 diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index e4cb5d6..4cc7e19 100644 --- 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) diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index f4e279a..8881728 100644 --- 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;" [nconc with-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 #.list get-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;" [quote lambda 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;_;" [define caadr 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.close raise 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 rand rand.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) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 5bba6ba..87bd2dc 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -99,7 +99,7 @@ static value_t NIL, LAMBDA, IF, TRYCATCH; 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 @@ value_t fl_stacktrace(value_t *args, u_int32_t nargs) 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 @@ static builtinspec_t core_builtin_info[] = { { "copy-list", fl_copylist }, { "append", fl_append }, { "list*", fl_liststar }, + { "map", fl_map1 }, { NULL, NULL } }; @@ -2201,7 +2268,7 @@ static void lisp_init(size_t initial_heapsize) 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"); diff --git a/femtolisp/perf.lsp b/femtolisp/perf.lsp index b7aec74..ae5f661 100644 --- 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)) diff --git a/femtolisp/print.c b/femtolisp/print.c index 1492d6d..047beec 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -196,7 +196,7 @@ static int specialindent(value_t head) { // 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 @@ static int indentevery(value_t v) // 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 @@ static void print_pair(ios_t *f, value_t v) } 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 @@ static void print_pair(ios_t *f, value_t v) (est!=-1 && (HPOS+est > SCR_WIDTH-2)) || - ((head == LAMBDA || head == labelsym) && !nextsmall) || + ((head == LAMBDA) && !nextsmall) || (n > 0 && always) || diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 809b943..a5a7aec 100644 --- 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 ())) diff --git a/femtolisp/todo b/femtolisp/todo index fe085d3..8658f60 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -1195,5 +1195,5 @@ what needs more test coverage: 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 diff --git a/llt/arraylist.c b/llt/arraylist.c index 253870d..f58bf4f 100644 --- a/llt/arraylist.c +++ b/llt/arraylist.c @@ -45,7 +45,7 @@ static void al_grow(arraylist_t *a, size_t n) 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; diff --git a/llt/bitvector.c b/llt/bitvector.c index 55a497f..11c3e9f 100644 --- a/llt/bitvector.c +++ b/llt/bitvector.c @@ -49,7 +49,7 @@ u_int32_t *bitvector_resize(u_int32_t *b, uint64_t oldsz, uint64_t newsz, 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 @@ static int ntz(uint32_t x) // 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) { diff --git a/llt/ios.c b/llt/ios.c index e8f7bb5..571aa42 100644 --- a/llt/ios.c +++ b/llt/ios.c @@ -586,11 +586,11 @@ char *ios_takebuf(ios_t *s, size_t *psize) 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