From 2e9a8c21ccb52cd4726e7c6a0c92cabf1d0e26f8 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Wed, 5 May 2010 05:31:46 +0000 Subject: [PATCH] porting over some improvements: now fl_applyn can handle any function (lambda wrappers for opcodes) faster separate --- femtolisp/flisp.boot | 86 +++++++++++++++++++++++++++++++------------- femtolisp/flisp.c | 13 +++++-- femtolisp/flisp.h | 1 + femtolisp/iostream.c | 9 +++++ femtolisp/read.c | 2 +- femtolisp/system.lsp | 65 +++++++++++++++++++++++---------- 6 files changed, 130 insertions(+), 46 deletions(-) diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index 444ff5a..c104c2e 100644 --- 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;" [])]) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index a477daf..a7e204b 100644 --- a/femtolisp/flisp.c +++ b/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++) { diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 7cb7492..e0eff7d 100644 --- a/femtolisp/flisp.h +++ b/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); diff --git a/femtolisp/iostream.c b/femtolisp/iostream.c index feac00f..46841bd 100644 --- a/femtolisp/iostream.c +++ b/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; } diff --git a/femtolisp/read.c b/femtolisp/read.c index b7dcc4f..e3aae72 100644 --- a/femtolisp/read.c +++ b/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); diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index ad69de5..809b943 100644 --- 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)