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" (*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* *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 - 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! 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 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 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 begin or => 1arg-lambda? caddr #fn("=000r1c0|~ML2L1c1|c2e3e4~3131Ki20i10N31L4L3;" [let
if begin cddr caddr]) caadr #fn("<000r1c0|~ML2L1c1|e2~31|L2i20i10N31L4L3;" [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 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 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+ *whitespace* "\t\n\v\f\r \u0085  \u2028\u2029 " 1+
#fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda? #fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda?
#fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda
@ -274,10 +309,12 @@
*print-readably* *print-readably*
*print-level* *print-level*
*print-length* *os-name*)] make-system-image) *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 mark-label #fn("9000r2e0|c1}43;" [emit label] mark-label) max
#fn("<000s1}\x8540|;e0c1|}43;" [foldl #fn("7000r2|}X640};|;" [])] max) #fn("<000s1}\x8540|;e0c1|}43;" [foldl #fn("7000r2|}X640};|;" [])] max)
member #fn("8000r2}?640^;}M|>640};e0|}N42;" [member] member) memv 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!) #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? self-evaluating? #fn("8000r1|?16602|C@17K02e0|3116A02|C16:02|e1|31<;" [constant?
top-level-value] self-evaluating?) 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!) set-syntax! #fn("9000r2e0e1|}43;" [put! *syntax-environment*] set-syntax!)
simple-sort #fn("7000r1|A17602|NA640|;c0q|M41;" [#fn("8000r1e0c1qc2q42;" [call-with-values simple-sort #fn("7000r1|A17602|NA640|;c0q|M41;" [#fn("8000r1e0c1qc2q42;" [call-with-values
#fn("8000r0e0c1qi10N42;" [separate #fn("7000r1|~X;" [])]) #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 IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error, KeyError, EnumerationError; value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
value_t printwidthsym, printreadablysym, printprettysym, printlengthsym; 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 NIL, LAMBDA, IF, TRYCATCH;
static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION; static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
@ -627,6 +627,11 @@ static value_t _applyn(uint32_t n)
else if (isfunction(f)) { else if (isfunction(f)) {
v = apply_cl(n); 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 { else {
type_error("apply", "function", f); type_error("apply", "function", f);
} }
@ -1728,7 +1733,10 @@ static value_t apply_cl(uint32_t nargs)
else { else {
PUSH(Stack[bp]); // env has already been captured; share 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 e = Stack[SP-2]; // closure to copy
assert(isfunction(e)); assert(isfunction(e));
pv[0] = ((value_t*)ptr(e))[0]; 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(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
set(printlengthsym=symbol("*print-length*"), FL_F); set(printlengthsym=symbol("*print-length*"), FL_F);
set(printlevelsym=symbol("*print-level*"), FL_F); set(printlevelsym=symbol("*print-level*"), FL_F);
builtins_table_sym = symbol("*builtins*");
fl_lasterror = NIL; fl_lasterror = NIL;
i = 0; i = 0;
for (i=OP_EQ; i <= OP_ASET; i++) { 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_isnumber(value_t v);
int fl_isgensym(value_t v); int fl_isgensym(value_t v);
int fl_isiostream(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); 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); 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); 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) value_t fl_file(value_t *args, uint32_t nargs)
{ {
if (nargs < 1) if (nargs < 1)
@ -333,7 +338,9 @@ value_t fl_ioreaduntil(value_t *args, u_int32_t nargs)
if (dest.buf != data) { if (dest.buf != data) {
// outgrew initial space // outgrew initial space
cv->data = dest.buf; cv->data = dest.buf;
#ifndef BOEHM_GC
cv_autorelease(cv); cv_autorelease(cv);
#endif
} }
((char*)cv->data)[n] = '\0'; ((char*)cv->data)[n] = '\0';
if (n == 0 && ios_eof(src)) 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--; char *b = ios_takebuf(st, &n); n--;
b[n] = '\0'; b[n] = '\0';
str = cvalue_from_ref(stringtype, b, n, FL_NIL); str = cvalue_from_ref(stringtype, b, n, FL_NIL);
#ifndef BOEHM_GC
cv_autorelease((cvalue_t*)ptr(str)); cv_autorelease((cvalue_t*)ptr(str));
#endif
} }
return str; return str;
} }

View File

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

View File

@ -5,6 +5,27 @@
(define (void) #t) ; the unspecified value (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*)) (if (not (bound? '*syntax-environment*))
(define *syntax-environment* (table))) (define *syntax-environment* (table)))
@ -18,7 +39,6 @@
(define-macro (label name fn) (define-macro (label name fn)
`((lambda (,name) (set! ,name ,fn)) #f)) `((lambda (,name) (set! ,name ,fn)) #f))
(define (map f lst . lsts)
(define (map1 f lst acc) (define (map1 f lst acc)
(cdr (cdr
(prog1 acc (prog1 acc
@ -26,11 +46,14 @@
(begin (set! acc (begin (set! acc
(cdr (set-cdr! acc (cons (f (car lst)) ())))) (cdr (set-cdr! acc (cons (f (car lst)) ()))))
(set! lst (cdr lst))))))) (set! lst (cdr lst)))))))
(define (mapn f lsts) (define (mapn f lsts)
(if (null? (car lsts)) (if (null? (car lsts))
() ()
(cons (apply f (map1 car lsts (list ()))) (cons (apply f (map1 car lsts (list ())))
(mapn f (map1 cdr lsts (list ())))))) (mapn f (map1 cdr lsts (list ()))))))
(define (map f lst . lsts)
(if (null? lsts) (if (null? lsts)
(map1 f lst (list ())) (map1 f lst (list ()))
(mapn f (cons lst lsts)))) (mapn f (cons lst lsts))))
@ -265,12 +288,18 @@
(define (separate pred lst) (define (separate pred lst)
(define (separate- pred lst yes no) (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)
(define (count- f l n) (define (count- f l n)