shithub: femtolisp

Info  •  Files  •  Log

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;" [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)

--- 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