conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

some critical bug fixes

This commit is contained in:
JeffBezanson 2010-05-04 18:17:55 +00:00
parent 6bf5aa0c72
commit 271cf34e99
6 changed files with 48 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
femtolisp/cvalues.c
View File

@ -121,6 +121,8 @@ void cv_autorelease(cvalue_t *cv)
static value_t cprim(fltype_t *type, size_t sz) static value_t cprim(fltype_t *type, size_t sz)
{ {
assert(!ismanaged((uptrint_t)type));
assert(sz == type->size);
cprim_t *pcp = (cprim_t*)alloc_words(CPRIM_NWORDS-1+NWORDS(sz)); cprim_t *pcp = (cprim_t*)alloc_words(CPRIM_NWORDS-1+NWORDS(sz));
pcp->type = type; pcp->type = type;
return tagptr(pcp, TAG_CPRIM); return tagptr(pcp, TAG_CPRIM);
@ -412,6 +414,7 @@ static int cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
sz = elsize * cnt; sz = elsize * cnt;
if (isvector(arg)) { if (isvector(arg)) {
assert(cnt <= vector_size(arg));
for(i=0; i < cnt; i++) { for(i=0; i < cnt; i++) {
cvalue_init(eltype, vector_elt(arg,i), dest); cvalue_init(eltype, vector_elt(arg,i), dest);
dest += elsize; dest += elsize;

52
femtolisp/flisp.boot
View File

@ -1,34 +1,32 @@
(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" (*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n"
*interactive* #f *syntax-environment* *interactive* #f *syntax-environment*
#table(with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("A000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6c7e4\x7f31Kc7e4e2c8|g23331KL3L144;" [nconc #table(letrec #fn(">000s1e0c1L1e2c3|32L1e2c4|32e5}3134e2c6|32K;" [nconc
let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])]) 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
map #.car cadr #fn("6000r1e040;" [gensym])]) letrec #fn(">000s1e0c1L1e2c3|32L1e2c4|32e5}3134e2c6|32K;" [nconc begin]) dotimes #fn(";000s1c0q|M|\x8442;" [#fn("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for
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(":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("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])
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]) let* #fn("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) with-output-to #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [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 with-bindings *output-stream* copy-list]) with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("A000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6c7e4\x7f31Kc7e4e2c8|g23331KL3L144;" [nconc
eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])])
#fn(";000r1c0|i10L2L1c1e2c3qi1132KL3;" [let cond map #fn("8000r1i10~|M32|NK;" [])]) map #.car cadr #fn("6000r1e040;" [gensym])]))
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
@ -79,7 +77,7 @@
cadar #fn("6000r1|M\x84;" [] cadar) caddar cadar #fn("6000r1|M\x84;" [] cadar) caddar
#fn("6000r1|MN\x84;" [] caddar) cadddr #fn("6000r1|NN\x84;" [] cadddr) #fn("6000r1|MN\x84;" [] caddar) cadddr #fn("6000r1|NN\x84;" [] cadddr)
caddr #fn("6000r1|N\x84;" [] caddr) cadr caddr #fn("6000r1|N\x84;" [] caddr) cadr
#fn("6000r1|\x84;" [] cadr) call-with-values #fn("7000r2c0q|3041;" [#fn("7000r1|F16902i10|M<680\x7f|Nv2;\x7f|41;" [])] #3=[(*values*) #fn("6000r1|\x84;" [] cadr) call-with-values #fn("7000r2c0q|3041;" [#fn("7000r1|F16902i10|M<680\x7f|Nv2;\x7f|41;" [])] #2=[(*values*)
()]) ()])
cdaaar #fn("6000r1|MMMN;" [] cdaaar) cdaadr cdaaar #fn("6000r1|MMMN;" [] cdaaar) cdaadr
#fn("6000r1|\x84MN;" [] cdaadr) cdaar #fn("6000r1|MMN;" [] cdaar) #fn("6000r1|\x84MN;" [] cdaadr) cdaar #fn("6000r1|MMN;" [] cdaar)
@ -340,11 +338,11 @@
#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(":000r2~|}__44;" [] #2=[#fn(";000r4}\x8580g2g3K;|}M316@0~|}N}Mg2Kg344;~|}Ng2}Mg3K44;" [] #2#) separate #fn("7000r2c0q]41;" [#fn(":000r1c0qm02|~\x7f__44;" [#fn(";000r4}\x85;0e0g2g342;|}M316@0~|}N}Mg2Kg344;~|}Ng2}Mg3K44;" [values] 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("9000r1c0qe1c2q~N3241;" [#fn(":000r1e0e1|M31~L1e1|N3143;" [nconc simple-sort #fn("7000r1|A17602|NA640|;c0q|M41;" [#fn("8000r1e0c1qc2q42;" [call-with-values
simple-sort]) separate #fn("7000r1|~X;" [])])] simple-sort) #fn("8000r0e0c1qi10N42;" [separate #fn("7000r1|~X;" [])])
#fn(":000r2e0e1|31~L1e1}3143;" [nconc simple-sort])])] simple-sort)
string.join #fn("7000r2|\x8550c0;c1qe23041;" ["" #fn("8000r1e0|~M322e1c2q~N322e3|41;" [io.write string.join #fn("7000r2|\x8550c0;c1qe23041;" ["" #fn("8000r1e0|~M322e1c2q~N322e3|41;" [io.write
for-each #fn("8000r1e0~i11322e0~|42;" [io.write]) io.tostring!]) buffer] string.join) for-each #fn("8000r1e0~i11322e0~|42;" [io.write]) io.tostring!]) buffer] string.join)
string.lpad #fn(";000r3e0e1g2}e2|31x32|42;" [string string.rep string.lpad #fn(";000r3e0e1g2}e2|31x32|42;" [string string.rep
@ -382,7 +380,7 @@
x newline #.apply]) ()]) x newline #.apply]) ()])
untrace #fn("8000r1c0qe1|3141;" [#fn("9000r1e0|316@0e1~e2|31b2[42;];" [traced? untrace #fn("8000r1c0qe1|3141;" [#fn("9000r1e0|316@0e1~e2|31b2[42;];" [traced?
set-top-level-value! function:vals]) top-level-value] untrace) set-top-level-value! function:vals]) top-level-value] untrace)
values #fn("9000s0|F16602|NA650|M;~|K;" [] #3#) vector->list values #fn("9000s0|F16602|NA650|M;~|K;" [] #2#) vector->list
#fn("8000r1c0qe1|31_42;" [#fn(":000r2a|c0qu2};" [#fn("8000r1i10~|x[\x7fKo01;" [])]) #fn("8000r1c0qe1|31_42;" [#fn(":000r2a|c0qu2};" [#fn("8000r1i10~|x[\x7fKo01;" [])])
length] vector->list) length] vector->list)
vector.map #fn("8000r2c0qe1}3141;" [#fn("8000r1c0qe1|3141;" [#fn(":000r1`~axc0qu2|;" [#fn(":000r1~|i20i21|[31\\;" [])]) vector.map #fn("8000r2c0qe1}3141;" [#fn("8000r1c0qe1|3141;" [#fn(":000r1`~axc0qu2|;" [#fn(":000r1~|i20i21|[31\\;" [])])

17
femtolisp/flisp.c
View File

@ -487,6 +487,7 @@ static value_t relocate(value_t v)
nfn->env = relocate(fn->env); nfn->env = relocate(fn->env);
nfn->vals = relocate(nfn->vals); nfn->vals = relocate(nfn->vals);
nfn->bcode = relocate(nfn->bcode); nfn->bcode = relocate(nfn->bcode);
assert(!ismanaged(fn->name));
nfn->name = fn->name; nfn->name = fn->name;
return nc; return nc;
} }
@ -553,10 +554,17 @@ void gc(int mustgrow)
relocate_typetable(); relocate_typetable();
rs = readstate; rs = readstate;
while (rs) { while (rs) {
for(i=0; i < rs->backrefs.size; i++) value_t ent;
rs->backrefs.table[i] = (void*)relocate((value_t)rs->backrefs.table[i]); for(i=0; i < rs->backrefs.size; i++) {
for(i=0; i < rs->gensyms.size; i++) ent = (value_t)rs->backrefs.table[i];
rs->gensyms.table[i] = (void*)relocate((value_t)rs->gensyms.table[i]); if (ent != HT_NOTFOUND)
rs->backrefs.table[i] = (void*)relocate(ent);
}
for(i=0; i < rs->gensyms.size; i++) {
ent = (value_t)rs->gensyms.table[i];
if (ent != HT_NOTFOUND)
rs->gensyms.table[i] = (void*)relocate(ent);
}
rs->source = relocate(rs->source); rs->source = relocate(rs->source);
rs = rs->prev; rs = rs->prev;
} }
@ -1697,6 +1705,7 @@ static value_t apply_cl(uint32_t nargs)
v = Stack[bp+nargs]; v = Stack[bp+nargs];
while (s--) while (s--)
v = vector_elt(v, vector_size(v)-1); v = vector_elt(v, vector_size(v)-1);
assert(i < vector_size(v));
vector_elt(v, i) = Stack[SP-1]; vector_elt(v, i) = Stack[SP-1];
NEXT_OP; NEXT_OP;

2
femtolisp/flisp.h
View File

@ -75,7 +75,7 @@ typedef struct _symbol_t {
#define vector_size(v) (((size_t*)ptr(v))[0]>>2) #define vector_size(v) (((size_t*)ptr(v))[0]>>2)
#define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2)) #define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2))
#define vector_elt(v,i) (((value_t*)ptr(v))[1+(i)]) #define vector_elt(v,i) (((value_t*)ptr(v))[1+(i)])
#define vector_grow_amt(x) ((x)<8 ? 4 : 6*((x)>>3)) #define vector_grow_amt(x) ((x)<8 ? 5 : 6*((x)>>3))
// functions ending in _ are unsafe, faster versions // functions ending in _ are unsafe, faster versions
#define car_(v) (((cons_t*)ptr(v))->car) #define car_(v) (((cons_t*)ptr(v))->car)
#define cdr_(v) (((cons_t*)ptr(v))->cdr) #define cdr_(v) (((cons_t*)ptr(v))->cdr)

2
femtolisp/flmain.c
View File

@ -18,7 +18,7 @@
static value_t argv_list(int argc, char *argv[]) static value_t argv_list(int argc, char *argv[])
{ {
int i; int i;
value_t lst, temp; value_t lst=FL_NIL, temp;
fl_gc_handle(&lst); fl_gc_handle(&lst);
fl_gc_handle(&temp); fl_gc_handle(&temp);
for(i=argc-1; i >= 0; i--) { for(i=argc-1; i >= 0; i--) {

6
femtolisp/read.c
View File

@ -377,6 +377,7 @@ static value_t vector_grow(value_t v)
size_t i, s = vector_size(v); size_t i, s = vector_size(v);
size_t d = vector_grow_amt(s); size_t d = vector_grow_amt(s);
PUSH(v); PUSH(v);
assert(s+d > s);
value_t newv = alloc_vector(s+d, 1); value_t newv = alloc_vector(s+d, 1);
v = Stack[SP-1]; v = Stack[SP-1];
for(i=0; i < s; i++) for(i=0; i < s; i++)
@ -408,6 +409,7 @@ static value_t read_vector(value_t label, u_int32_t closer)
} }
elt = do_read_sexpr(UNBOUND); elt = do_read_sexpr(UNBOUND);
v = Stack[SP-1]; v = Stack[SP-1];
assert(i < vector_size(v));
vector_elt(v,i) = elt; vector_elt(v,i) = elt;
i++; i++;
} }
@ -521,7 +523,7 @@ static void read_list(value_t *pval, value_t label)
} }
*pc = c; *pc = c;
c = do_read_sexpr(UNBOUND); // must be on separate lines due to c = do_read_sexpr(UNBOUND); // must be on separate lines due to
car_(*pc) = c; // undefined evaluation order car_(*pc) = c; // undefined evaluation order
t = peek(); t = peek();
if (t == TOK_DOT) { if (t == TOK_DOT) {
@ -666,9 +668,11 @@ value_t fl_read_sexpr(value_t f)
state.source = f; state.source = f;
readstate = &state; readstate = &state;
assert(toktype == TOK_NONE); assert(toktype == TOK_NONE);
fl_gc_handle(&tokval);
v = do_read_sexpr(UNBOUND); v = do_read_sexpr(UNBOUND);
fl_free_gc_handles(1);
readstate = state.prev; readstate = state.prev;
free_readstate(&state); free_readstate(&state);
return v; return v;