getting rid of label
adding optional, faster built-in map checking in soon-to-be code for quasiquote a couple library bug fixes
This commit is contained in:
JeffBezanson
parent
9e07001ae0
commit
4cd78cb562
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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) ||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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) {
|
||||
|
|
|
|||
Loading…
Reference in New Issue