ref: 2e9a8c21ccb52cd4726e7c6a0c92cabf1d0e26f8
parent: caf7f15f44bf0db2fa3fa9268e57216424d2b31b
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed May 5 01:31:46 EDT 2010
porting over some improvements: now fl_applyn can handle any function (lambda wrappers for opcodes) faster separate
--- a/femtolisp/flisp.boot
+++ b/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- 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- begin]) dotimes #fn(";000s1c0q|M|\x8442;" [#fn("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for+ #table(with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("A000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6c7e4\x7f31Kc7e4e2c8|g23331KL3L144;" [nconc+ 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+ 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 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])+ 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]) 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- with-bindings *output-stream* copy-list]) with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("A000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6c7e4\x7f31Kc7e4e2c8|g23331KL3L144;" [nconc- let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])])- map #.car cadr #fn("6000r1e040;" [gensym])]))+ time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #fn("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [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+ eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond)
+ #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)- #fn("<000r2}M\x8540_;|~c0}_L133Q2\x7f|~c1}_L13332K;" [#.car #.cdr] 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)+ 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)
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- reverse] separate-)])] separate)
+ 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) 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;" [])])--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -93,7 +93,7 @@
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 @@
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 @@
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 @@
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++) {--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -332,6 +332,7 @@
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);
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -70,6 +70,11 @@
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 @@
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 @@
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;
}
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -11,7 +11,7 @@
// 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);
--- a/femtolisp/system.lsp
+++ b/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)))
- ((pred (car lst))
- (separate- pred (cdr lst) (cons (car lst) yes) no))
- (else
- (separate- pred (cdr lst) yes (cons (car lst) no)))))
- (separate- pred lst () ()))
+ (let ((vals
+ (prog1
+ (cons yes no)
+ (while (pair? lst)
+ (begin (if (pred (car 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)