porting over some improvements: now fl_applyn can handle any function

(lambda wrappers for opcodes)
faster separate

femtolisp/flisp.boot

@@ -1,32 +1,67 @@
 (*banner* ";  _\n; |_ _ _ |_ _ |  . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n"
+	  *builtins* [0 0 0 0 0 0 0 0 0 0 0 0 #fn("7000r2|}<;" [])
+		      #fn("7000r2|}=;" [])
+		      #fn("7000r2|}>;" [])
+		      #fn("6000r1|?;" [])
+		      #fn("6000r1|@;" [])
+		      #fn("6000r1|A;" [])
+		      #fn("6000r1|B;" [])
+		      #fn("6000r1|C;" [])
+		      #fn("6000r1|D;" [])
+		      #fn("6000r1|E;" [])
+		      #fn("6000r1|F;" [])
+		      #fn("6000r1|G;" [])
+		      #fn("6000r1|H;" [])
+		      #fn("6000r1|I;" [])
+		      #fn("6000r1|J;" [])
+		      #fn("7000r2|}K;" [])
+		      #fn("9000s0c0|v2;" [#.list])
+		      #fn("6000r1|M;" [])
+		      #fn("6000r1|N;" [])
+		      #fn("7000r2|}O;" [])
+		      #fn("7000r2|}P;" [])
+		      #fn("9000s0c0|v2;" [#.apply])
+		      #fn("9000s0c0|v2;" [#.+])
+		      #fn("9000s0c0|v2;" [#.-])
+		      #fn("9000s0c0|v2;" [#.*])
+		      #fn("9000s0c0|v2;" [#./])
+		      #fn("9000s0c0|v2;" [#.div0])
+		      #fn("7000r2|}W;" [])
+		      #fn("7000r2|}X;" [])
+		      #fn("7000r2|}Y;" [])
+		      #fn("9000s0c0|v2;" [#.vector])
+		      #fn("7000r2|}[;" [])
+		      #fn("8000r3|}g2\\;" [])]
 	  *interactive* #f *syntax-environment*
-	  #table(letrec #fn(">000s1e0c1L1e2c3|32L1e2c4|32e5}3134e2c6|32K;" [nconc
+	  #table(with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("A000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6c7e4\x7f31Kc7e4e2c8|g23331KL3L144;" [nconc
-  lambda map #.car #fn("8000r1c0e1|31K;" [set! copy-list]) copy-list #fn("6000r1e040;" [void])])  quasiquote #fn("7000r1e0|41;" [bq-process])  when #fn("<000s1c0|c1}K^L4;" [if
+  let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])])
-  begin])  dotimes #fn(";000s1c0q|M|\x8442;" [#fn("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for
+  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
+  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!
   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("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc
+  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 copy-list caar let* cadar])  case #fn(":000s1c0q]41;" [#fn("7000r1c0m02c1qe23041;" [#fn("9000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else
-  eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond)
-  #fn(";000r1c0|i10L2L1c1e2c3qi1132KL3;" [let cond map #fn("8000r1i10~|M32|NK;" [])])
-  gensym])])  catch #fn("7000r2c0qe13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch
-  lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])  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
-  lambda if begin copy-list nconc]) gensym map #.car cadr #fn("7000r1e0|31F680e1|41;|M;" [cddr
-  caddr])])  with-input-from #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc
-								  with-bindings
-								  *input-stream*
-								  copy-list])  let #fn(":000s1c0q^41;" [#fn("<000r1~C6D0~m02\x7fMo002\x7fNo01530]2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#fn("8000r2~6;0c0~|L3530|}K;" [label])
   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
   if caddr]) gensym if])] cond-clauses->if)])])  throw #fn(":000r2c0c1c2c3L2|}L4L2;" [raise
   list quote thrown-value])  time #fn("7000r1c0qe13041;" [#fn(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let
-  time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym])  with-output-to #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc
+  time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym])  let* #fn("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc
-  with-bindings *output-stream* copy-list])  with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("A000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6c7e4\x7f31Kc7e4e2c8|g23331KL3L144;" [nconc
+  lambda copy-list caar let* cadar])  case #fn(":000s1c0q]41;" [#fn("7000r1c0m02c1qe23041;" [#fn("9000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else
-  let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])])
+  eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond)
-  map #.car cadr #fn("6000r1e040;" [gensym])]))
+  #fn(";000r1c0|i10L2L1c1e2c3qi1132KL3;" [let cond map #fn("8000r1i10~|M32|NK;" [])])
+  gensym])])  with-output-to #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc
+								  with-bindings
+								  *output-stream*
+								  copy-list])  catch #fn("7000r2c0qe13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch
+  lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym]))
 	  *whitespace* "\t\n\v\f\r \u0085  ᠎           \u2028\u2029  　" 1+
 	  #fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda?
 	  #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda
@@ -274,10 +309,12 @@
 						    *print-readably*
 						    *print-level*
 						    *print-length* *os-name*)] make-system-image)
-	  map #fn("<000s2c0q]]42;" [#fn("9000r2c0m02c1qm12i02\x85;0|~\x7f_L143;}~\x7fi02K42;" [#fn("9000r3g2]}F6H02g2|}M31_KPNm22}Nm15\x17/2N;" [] map1)
+	  map #fn("=000s2g2\x85<0e0|}_L143;e1|}g2K42;" [map1 mapn] map) map!
-  #fn("<000r2}M\x8540_;|~c0}_L133Q2\x7f|~c1}_L13332K;" [#.car #.cdr] mapn)])] map)
+	  #fn("9000r2}]}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int #fn("8000r2e0}`32640_;c1q|`31_K_42;" [<=
-	  map! #fn("9000r2}]}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int
+  #fn(":000r2|m12a\x7faxc0qu2|;" [#fn("8000r1\x7fi10|31_KP2\x7fNo01;" [])])] 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)
 	  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
@@ -338,8 +375,7 @@
 	  #fn("9000r1e0c1_|43;" [foldl #.cons] reverse) reverse! #fn("7000r1c0q_41;" [#fn("9000r1]~F6C02~N~|~m02P2o005\x1c/2|;" [])] reverse!)
 	  self-evaluating? #fn("8000r1|?16602|C@17K02e0|3116A02|C16:02|e1|31<;" [constant?
   top-level-value] self-evaluating?)
-	  separate #fn("7000r2c0q]41;" [#fn(":000r1c0qm02|~\x7f__44;" [#fn(";000r4}\x85C0e0e1g231e1g33142;|}M316@0~|}N}Mg2Kg344;~|}Ng2}Mg3K44;" [values
+	  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)
-  reverse] separate-)])] separate)
 	  set-syntax! #fn("9000r2e0e1|}43;" [put! *syntax-environment*] set-syntax!)
 	  simple-sort #fn("7000r1|A17602|NA640|;c0q|M41;" [#fn("8000r1e0c1qc2q42;" [call-with-values
   #fn("8000r0e0c1qi10N42;" [separate #fn("7000r1|~X;" [])])

femtolisp/flisp.c

@@ -93,7 +93,7 @@ value_t FL_NIL, FL_T, FL_F, FL_EOF, QUOTE;
 value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
 value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
 value_t printwidthsym, printreadablysym, printprettysym, printlengthsym;
-value_t printlevelsym;
+value_t printlevelsym, builtins_table_sym;
 
 static value_t NIL, LAMBDA, IF, TRYCATCH;
 static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
@@ -627,6 +627,11 @@ static value_t _applyn(uint32_t n)
     else if (isfunction(f)) {
         v = apply_cl(n);
     }
+    else if (isbuiltin(f)) {
+        value_t tab = symbol_value(builtins_table_sym);
+        Stack[SP-n-1] = vector_elt(tab, uintval(f));
+        v = apply_cl(n);
+    }
     else {
         type_error("apply", "function", f);
     }
@@ -1728,7 +1733,10 @@ static value_t apply_cl(uint32_t nargs)
             else {
                 PUSH(Stack[bp]); // env has already been captured; share
             }
-            pv = alloc_words(4);
+            if (curheap > lim-2)
+                gc(0);
+            pv = (value_t*)curheap;
+            curheap += (4*sizeof(value_t));
             e = Stack[SP-2];  // closure to copy
             assert(isfunction(e));
             pv[0] = ((value_t*)ptr(e))[0];
@@ -2206,6 +2214,7 @@ static void lisp_init(size_t initial_heapsize)
     set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
     set(printlengthsym=symbol("*print-length*"), FL_F);
     set(printlevelsym=symbol("*print-level*"), FL_F);
+    builtins_table_sym = symbol("*builtins*");
     fl_lasterror = NIL;
     i = 0;
     for (i=OP_EQ; i <= OP_ASET; i++) {

femtolisp/flisp.h

@@ -332,6 +332,7 @@ int fl_isstring(value_t v);
 int fl_isnumber(value_t v);
 int fl_isgensym(value_t v);
 int fl_isiostream(value_t v);
+ios_t *fl_toiostream(value_t v, char *fname);
 value_t cvalue_compare(value_t a, value_t b);
 int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname);
 

femtolisp/iostream.c

@@ -70,6 +70,11 @@ static ios_t *toiostream(value_t v, char *fname)
     return value2c(ios_t*, v);
 }
 
+ios_t *fl_toiostream(value_t v, char *fname)
+{
+    return toiostream(v, fname);
+}
+
 value_t fl_file(value_t *args, uint32_t nargs)
 {
     if (nargs < 1)
@@ -333,7 +338,9 @@ value_t fl_ioreaduntil(value_t *args, u_int32_t nargs)
     if (dest.buf != data) {
         // outgrew initial space
         cv->data = dest.buf;
+#ifndef BOEHM_GC
         cv_autorelease(cv);
+#endif
     }
     ((char*)cv->data)[n] = '\0';
     if (n == 0 && ios_eof(src))
@@ -378,7 +385,9 @@ value_t stream_to_string(value_t *ps)
         char *b = ios_takebuf(st, &n); n--;
         b[n] = '\0';
         str = cvalue_from_ref(stringtype, b, n, FL_NIL);
+#ifndef BOEHM_GC
         cv_autorelease((cvalue_t*)ptr(str));
+#endif
     }
     return str;
 }

femtolisp/read.c

@@ -11,7 +11,7 @@ enum {
 // exceptions are '.', which is an ordinary symbol character
 // unless it's the only character in the symbol, and '#', which is
 // an ordinary symbol character unless it's the first character.
-static int symchar(char c)
+static inline int symchar(char c)
 {
     static char *special = "()[]'\";`,\\| \f\n\r\t\v";
     return !strchr(special, c);

femtolisp/system.lsp

@@ -5,6 +5,27 @@
 
 (define (void) #t)  ; the unspecified value
 
+(define *builtins*
+  (vector
+   0 0 0 0 0 0 0 0 0 0 0 0
+   (lambda (x y) (eq? x y))          (lambda (x y) (eqv? x y))
+   (lambda (x y) (equal? x y))       (lambda (x) (atom? x))
+   (lambda (x) (not x))              (lambda (x) (null? x))
+   (lambda (x) (boolean? x))         (lambda (x) (symbol? x))
+   (lambda (x) (number? x))          (lambda (x) (bound? x))
+   (lambda (x) (pair? x))            (lambda (x) (builtin? x))
+   (lambda (x) (vector? x))          (lambda (x) (fixnum? x))
+   (lambda (x) (function? x))        (lambda (x y) (cons x y))
+   (lambda rest (apply list rest))   (lambda (x) (car x))
+   (lambda (x) (cdr x))              (lambda (x y) (set-car! x y))
+   (lambda (x y) (set-cdr! x y))     (lambda rest (apply apply rest))
+   (lambda rest (apply + rest))      (lambda rest (apply - rest))
+   (lambda rest (apply * rest))      (lambda rest (apply / rest))
+   (lambda rest (apply div0 rest))   (lambda (x y) (= x y))
+   (lambda (x y) (< x y))            (lambda (x y) (compare x y))
+   (lambda rest (apply vector rest)) (lambda (x y) (aref x y))
+   (lambda (x y z) (aset! x y z))))
+
 (if (not (bound? '*syntax-environment*))
     (define *syntax-environment* (table)))
 
@@ -18,19 +39,21 @@
 (define-macro (label name fn)
   `((lambda (,name) (set! ,name ,fn)) #f))
 
+(define (map1 f lst acc)
+  (cdr
+   (prog1 acc
+	  (while (pair? lst)
+		 (begin (set! acc
+			      (cdr (set-cdr! acc (cons (f (car lst)) ()))))
+			(set! lst (cdr lst)))))))
+
+(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 (map1 f lst acc)
-    (cdr
-     (prog1 acc
-      (while (pair? lst)
-	     (begin (set! acc
-			  (cdr (set-cdr! acc (cons (f (car lst)) ()))))
-		    (set! lst (cdr lst)))))))
-  (define (mapn f lsts)
-    (if (null? (car lsts))
-	()
-	(cons (apply f (map1 car lsts (list ())))
-	      (mapn  f (map1 cdr lsts (list ()))))))
   (if (null? lsts)
       (map1 f lst (list ()))
       (mapn f (cons lst lsts))))
@@ -265,12 +288,18 @@
 
 (define (separate pred lst)
   (define (separate- pred lst yes no)
-    (cond ((null? lst) (values (reverse yes) (reverse no)))
+    (let ((vals
-	  ((pred (car lst))
+	   (prog1
-	   (separate- pred (cdr lst) (cons (car lst) yes) no))
+	    (cons yes no)
-	  (else
+	    (while (pair? lst)
-	   (separate- pred (cdr lst) yes (cons (car lst) no)))))
+		   (begin (if (pred (car lst))
-  (separate- pred lst () ()))
+			      (set! yes
+				    (cdr (set-cdr! yes (cons (car lst) ()))))
+			      (set! no
+				    (cdr (set-cdr! no  (cons (car lst) ())))))
+			  (set! lst (cdr lst)))))))
+      (values (cdr (car vals)) (cdr (cdr vals)))))
+  (separate- pred lst (list ()) (list ())))
 
 (define (count f l)
   (define (count- f l n)