porting over some improvements: now fl_applyn can handle any function

(lambda wrappers for opcodes)
faster separate
This commit is contained in:
JeffBezanson 2010-05-05 05:31:46 +00:00
parent caf7f15f44
commit 2e9a8c21cc
6 changed files with 130 additions and 46 deletions

View File

@ -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;" [])])

View File

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

View File

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

View File

@ -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;
}

View File

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

View File

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