porting over some improvements: now fl_applyn can handle any function
(lambda wrappers for opcodes) faster separate
This commit is contained in:
JeffBezanson
parent
caf7f15f44
commit
2e9a8c21cc
|
|
@ -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;" [])])
|
||||
|
|
|
|||
|
|
@ -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++) {
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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,7 +39,6 @@
|
|||
(define-macro (label name fn)
|
||||
`((lambda (,name) (set! ,name ,fn)) #f))
|
||||
|
||||
(define (map f lst . lsts)
|
||||
(define (map1 f lst acc)
|
||||
(cdr
|
||||
(prog1 acc
|
||||
|
|
@ -26,11 +46,14 @@
|
|||
(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)
|
||||
(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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue