getting rid of label

adding optional, faster built-in map
checking in soon-to-be code for quasiquote
a couple library bug fixes

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

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)

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
+								copy-list])  unwind-protect #fn("8000r2c0qe130e13042;" [#fn("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let
-  - nconc lambda 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
-  lambda prog1 trycatch begin raise]) gensym])  define-macro #fn("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax!
+  - 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
+	  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])])
+  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!
+	  map! #fn("9000r2}]}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int
-	  #fn("9000r2}]}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int #fn("8000r2e0}`32640_;c1q|`31_K_42;" [<=
+	  #fn("8000r2e0}`32640_;c1q|`31_K_42;" [<= #fn(":000r2|m12a\x7faxc0qu2|;" [#fn("8000r1\x7fi10|31_KP2\x7fNo01;" [])])] map-int)
-  #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)
 	  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)

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

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)
+        (else (letrec ((append2 (lambda (l d)
-				(if (null? l) d
+				  (if (null? l) d
-				    (cons (car l)
+				      (cons (car l)
-					  (append2 (cdr l) d)))))
+					    (append2 (cdr l) d))))))
-	       (car lsts) (apply my-append (cdr lsts))))))
+		(append2 (car lsts) (apply my-append (cdr lsts)))))))
 
 (princ "append: ")
 (set! L (map-int (lambda (x) (map-int identity 20)) 20))

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

femtolisp/system.lsp

@@ -36,10 +36,7 @@
   `(set-syntax! ',(car form)
 		(lambda ,(cdr form) ,@body)))
 
-(define-macro (label name fn)
+#;(define (map1 f lst acc)
-  `((lambda (,name) (set! ,name ,fn)) #f))
-
-(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 ()))

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

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;

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

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