From 46009027c2dc5478c1f7a627d08e66f78849180a Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Sun, 9 May 2010 00:42:37 +0000 Subject: [PATCH] fixing a 64-bit issue and a nan issue --- femtolisp/compiler.lsp | 25 +++++++++++++++++++------ femtolisp/flisp.boot | 23 ++++++++++++++--------- femtolisp/flisp.c | 8 +++++--- femtolisp/print.c | 2 +- llt/operators.c | 4 ++++ llt/ptrhash.c | 27 ++++++++++++++++++++++++++- 6 files changed, 69 insertions(+), 20 deletions(-) diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index ab51f3e..e4cb5d6 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -511,6 +511,10 @@ (string.sub s 0 (string.dec s (length s))))) k)) +(define (lambda-arg-names argl) + (map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s)) + (to-proper argl))) + (define (lambda-vars l) (define (check-formals l o opt kw) (cond ((or (null? l) (symbol? l)) #t) @@ -539,8 +543,7 @@ (error "compile error: invalid formal argument " l " in list " o))))) (check-formals l l #f #f) - (map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s)) - (to-proper l))) + (lambda-arg-names l)) (define (emit-optional-arg-inits g env opta vars i) ; i is the lexical var index of the opt arg to process next @@ -554,6 +557,15 @@ (mark-label g nxt) (emit-optional-arg-inits g env (cdr opta) vars (+ i 1))))) +(define (free-vars e) + (cond ((symbol? e) (list e)) + ((or (atom? e) (eq? (car e) 'quote)) ()) + ((eq? (car e) 'lambda) + (diff (free-vars (cddr e)) + (nconc (get-defined-vars (cons 'begin (cddr e))) + (lambda-arg-names (cadr e))))) + (else (delete-duplicates (apply nconc (map free-vars (cdr e))))))) + (define compile-f- (let ((*defines-processed-token* (gensym))) ; to eval a top-level expression we need to avoid internal define @@ -575,6 +587,10 @@ B (cons (list* 'lambda V B *defines-processed-token*) (map (lambda (x) (void)) V)))))) + (define (lam:body f) + (if (eq? (lastcdr f) *defines-processed-token*) + (caddr f) + (lambda-body f))) (let ((g (make-code-emitter)) (args (cadr f)) @@ -610,10 +626,7 @@ ((null? opta) (emit g 'argc nargs))) ; compile body and return - (compile-in g (cons vars env) #t - (if (eq? (lastcdr f) *defines-processed-token*) - (caddr f) - (lambda-body f))) + (compile-in g (cons vars env) #t (lam:body f)) (emit g 'ret) (values (function (encode-byte-code (bcode:code g)) (const-to-idx-vec g) name) diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index c104c2e..f4e279a 100644 --- a/femtolisp/flisp.boot +++ b/femtolisp/flisp.boot @@ -143,14 +143,15 @@ apply tapply])]) get arg-counts] compile-builtin-call) compile-f #fn("8000r2e0c1qc242;" [call-with-values #fn("8000r0e0~\x7f42;" [compile-f-]) #fn("6000r2|;" [])] compile-f) - compile-f- #fn("7000r2c0q]41;" [#fn(">000r1c0qm02c1qe230\x7f\x84e3\x7f\x8431e4\x7f\x8431e5c6\x7f\x8432e3\x7f31i10\x8270c7570e3\x7f3146;" [#fn("9000r1c0qe1|31F6N0e2|31F6=0c3e1|31K570e4|31560e53041;" [#fn("8000r1c0qe1|3141;" [#fn(":000r1|\x8540~;e0c1|~i4034e2c3|32K;" [list* + compile-f- #fn("8000r2c0q]]42;" [#fn(">000r2c0qm02c1qm12c2qe330\x7f\x84e4\x7f\x8431e5\x7f\x8431e6c7\x7f\x8432e4\x7f31i10\x8270c8570e4\x7f3146;" [#fn("9000r1c0qe1|31F6N0e2|31F6=0c3e1|31K570e4|31560e53041;" [#fn("8000r1c0qe1|3141;" [#fn(":000r1|\x8540~;e0c1|~i4034e2c3|32K;" [list* lambda map #fn("6000r1e040;" [void])]) get-defined-vars]) cddr cdddr begin - caddr void] lambda-body) #fn("9000r6c0q}?660`570e1}3141;" [#fn("9000r1c0q|e1i0431x41;" [#fn("9000r1c0qe1e2i143241;" [#fn("D000r1i24\x87\xa90|\x85O0e0i20c1~i22\x8580i10560i10y345s0e2i20e3e4c5e4c6|32e7e8|31313331322e0i20c9~e8|31i22\x8580i10560i10y352e:i20i40i24i23~35530]2e;i10c<326L0e0i20i22\x8570c=540c>i10335]0i22\x87A0e0i20c?i10335H0i24\x85A0e0i20c@i1033530^2eAi20i23i40K]eBi4131i50\x82<0eCi41315:0i30i4131342e0i20cD322eEeFeGeHi203131eIi2031i2533i20b3[42;" [emit + caddr void] lambda-body) #fn("7000r1e0|31i20\x8280e1|41;~|41;" [lastcdr caddr] lam:body) + #fn("9000r6c0q}?660`570e1}3141;" [#fn("9000r1c0q|e1i0431x41;" [#fn("9000r1c0qe1e2i143241;" [#fn("C000r1i24\x87\xa90|\x85O0e0i20c1~i22\x8580i10560i10y345s0e2i20e3e4c5e4c6|32e7e8|31313331322e0i20c9~e8|31i22\x8580i10560i10y352e:i20i40i24i23~35530]2e;i10c<326L0e0i20i22\x8570c=540c>i10335]0i22\x87A0e0i20c?i10335H0i24\x85A0e0i20c@i1033530^2eAi20i23i40K]i31i4131342e0i20cB322eCeDeEeFi203131eGi2031i2533i20b3[42;" [emit optargs bcode:indexfor make-perfect-hash-table map #.cons #.car iota length - keyargs emit-optional-arg-inits > 255 largc lvargc vargc argc compile-in - lastcdr caddr ret values function encode-byte-code bcode:code - const-to-idx-vec]) filter keyword-arg?]) length]) length]) make-code-emitter - lastcdr lambda-vars filter #.pair? lambda])] #0=[#:g704 ()]) + keyargs emit-optional-arg-inits > 255 largc lvargc vargc argc compile-in ret + values function encode-byte-code bcode:code const-to-idx-vec]) filter + keyword-arg?]) length]) length]) make-code-emitter lastcdr lambda-vars filter + #.pair? lambda])] #0=[#:g711 ()]) compile-for #fn(":000r5e0g4316X0e1|}^g2342e1|}^g3342e1|}^g4342e2|c342;e4c541;" [1arg-lambda? compile-in emit for error "for: third form must be a 1-argument lambda"] compile-for) compile-if #fn("<000r4c0qe1|31e1|31g3\x84e2g331e3g331F6;0e4g331560e53045;" [#fn(";000r5g2]\x82>0e0~\x7fi02g344;g2^\x82>0e0~\x7fi02g444;e0~\x7f^g2342e1~c2|332e0~\x7fi02g3342i026<0e1~c3325:0e1~c4}332e5~|322e0~\x7fi02g4342e5~}42;" [compile-in @@ -251,6 +252,9 @@ foldl #fn(":000r3g2\x8540};e0||g2M}32g2N43;" [foldl] foldl) foldr #fn(";000r3g2\x8540};|g2Me0|}g2N3342;" [foldr] foldr) for-each #fn(";000s2c0q]41;" [#fn(":000r1c0qm02i02\x85J0]\x7fF6A02~\x7fM312\x7fNo015\x1e/5;0|~\x7fi02K322];" [#fn(":000r2}MF6I0|e0c1}32Q22~|e0c2}3242;];" [map #.car #.cdr] for-each-n)])] for-each) + free-vars #fn("<000r1|C660|L1;|?17802|Mc0<640_;|Mc1\x82V0e2e3e4|3131e5e6c7e4|31K31e8|\x84313242;e9e5e:e3|N32Q241;" [quote + lambda diff free-vars cddr nconc get-defined-vars begin lambda-arg-names + delete-duplicates map] free-vars) get-defined-vars #fn("8000r1e0~|3141;" [delete-duplicates] #1=[#fn("9000r1|?640_;|Mc0<16602|NF6d0|\x84C16702|\x84L117S02|\x84F16E02e1|31C16:02e1|31L117402_;|Mc2\x82>0e3e4~|N32v2;_;" [define caadr begin nconc map] #1#) ()]) hex5 #fn("9000r1e0e1|b@32b5c243;" [string.lpad number->string #\0] hex5) @@ -266,12 +270,13 @@ #fn("9000r1e0|316@0e1c2e3|313141;|;" [keyword? symbol #fn("<000r1e0|`e1|e2|313243;" [string.sub string.dec length]) string] keyword->symbol) keyword-arg? #fn("7000r1|F16902e0|M41;" [keyword?] keyword-arg?) - lambda-vars #fn("7000r1c0q]41;" [#fn(":000r1c0qm02|~~^^342e1c2e3~3142;" [#fn(";000r4|A17502|C640];|F16602|MC6S0g217502g36<0e0c1}c243;~|N}g2g344;|F16602|MF6\x870e3|Mb23216902e4|31C660^5=0e0c5|Mc6}342e7e4|31316<0~|N}g2]44;g36<0e0c1}c843;~|N}]g344;|F6>0e0c9|Mc6}44;|}\x82:0e0c1}42;e0c9|c6}44;" [error + lambda-arg-names #fn("9000r1e0c1e2|3142;" [map! #fn("7000r1|F690e0|M41;|;" [keyword->symbol]) + to-proper] lambda-arg-names) + lambda-vars #fn("7000r1c0q]41;" [#fn(":000r1c0qm02|~~^^342e1~41;" [#fn(";000r4|A17502|C640];|F16602|MC6S0g217502g36<0e0c1}c243;~|N}g2g344;|F16602|MF6\x870e3|Mb23216902e4|31C660^5=0e0c5|Mc6}342e7e4|31316<0~|N}g2]44;g36<0e0c1}c843;~|N}]g344;|F6>0e0c9|Mc6}44;|}\x82:0e0c1}42;e0c9|c6}44;" [error "compile error: invalid argument list " ". optional arguments must come after required." length= caar "compile error: invalid optional argument " " in list " keyword? ". keyword arguments must come last." - "compile error: invalid formal argument "] check-formals) map! #fn("7000r1|F690e0|M41;|;" [keyword->symbol]) - to-proper])] lambda-vars) + "compile error: invalid formal argument "] check-formals) lambda-arg-names])] lambda-vars) last-pair #fn("7000r1|N?640|;e0|N41;" [last-pair] last-pair) lastcdr #fn("7000r1|?640|;e0|31N;" [last-pair] lastcdr) length= #fn("9000r2}`X640^;}`W650|?;|?660}`W;e0|N}ax42;" [length=] length=) length> #fn("9000r2}`X640|;}`W6;0|F16402|;|?660}`X;e0|N}ax42;" [length>] length>) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index a7e204b..b50ce68 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -845,16 +845,16 @@ static uint32_t process_keys(value_t kwtable, } if (i >= nargs) goto no_kw; // now process keywords - uint32_t n = vector_size(kwtable)/2; + uptrint_t n = vector_size(kwtable)/2; do { i++; if (i >= nargs) lerrorf(ArgError, "keyword %s requires an argument", symbol_name(v)); value_t hv = fixnum(((symbol_t*)ptr(v))->hash); - uint32_t x = 2*(abs(numval(hv)) % n); + uptrint_t x = 2*(labs(numval(hv)) % n); if (vector_elt(kwtable, x) == v) { - uint32_t idx = numval(vector_elt(kwtable, x+1)); + uptrint_t idx = numval(vector_elt(kwtable, x+1)); assert(idx < nkw); idx += nopt; if (args[idx] == UNBOUND) { @@ -2010,6 +2010,8 @@ void assign_global_builtins(builtinspec_t *b) static value_t fl_function(value_t *args, uint32_t nargs) { + if (nargs == 1 && issymbol(args[0])) + return fl_builtin(args, nargs); if (nargs < 2 || nargs > 4) argcount("function", nargs, 2); if (!fl_isstring(args[0])) diff --git a/femtolisp/print.c b/femtolisp/print.c index f50bb78..7ef8dab 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -712,7 +712,7 @@ static void cvalue_print(ios_t *f, value_t v) if (print_princ) outs(symbol_name(label), f); else - HPOS += ios_printf(f, "#builtin(%s)", symbol_name(label)); + HPOS += ios_printf(f, "#fn(%s)", symbol_name(label)); } } else if (cv_class(cv)->vtable != NULL && diff --git a/llt/operators.c b/llt/operators.c index 3ef7f8e..28041c9 100644 --- a/llt/operators.c +++ b/llt/operators.c @@ -205,6 +205,7 @@ int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag) return ((int64_t)*(uint64_t*)a < *(int64_t*)b); } else if (btag == T_DOUBLE) { + if (db != db) return 0; return (*(uint64_t*)a < (uint64_t)*(double*)b); } } @@ -213,6 +214,7 @@ int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag) return (*(int64_t*)a < (int64_t)*(uint64_t*)b); } else if (btag == T_DOUBLE) { + if (db != db) return 0; return (*(int64_t*)a < (int64_t)*(double*)b); } } @@ -221,6 +223,7 @@ int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag) return ((int64_t)*(uint64_t*)b > *(int64_t*)a); } else if (atag == T_DOUBLE) { + if (da != da) return 0; return (*(uint64_t*)b > (uint64_t)*(double*)a); } } @@ -229,6 +232,7 @@ int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag) return (*(int64_t*)b > (int64_t)*(uint64_t*)a); } else if (atag == T_DOUBLE) { + if (da != da) return 0; return (*(int64_t*)b > (int64_t)*(double*)a); } } diff --git a/llt/ptrhash.c b/llt/ptrhash.c index c9b9bb1..40874d6 100644 --- a/llt/ptrhash.c +++ b/llt/ptrhash.c @@ -15,6 +15,31 @@ #define OP_EQ(x,y) ((x)==(y)) +#ifdef BITS64 +static u_int64_t _pinthash(u_int64_t key) +{ + key = (~key) + (key << 21); // key = (key << 21) - key - 1; + key = key ^ (key >> 24); + key = (key + (key << 3)) + (key << 8); // key * 265 + key = key ^ (key >> 14); + key = (key + (key << 2)) + (key << 4); // key * 21 + key = key ^ (key >> 28); + key = key + (key << 31); + return key; +} +#else +static u_int32_t _pinthash(u_int32_t a) +{ + a = (a+0x7ed55d16) + (a<<12); + a = (a^0xc761c23c) ^ (a>>19); + a = (a+0x165667b1) + (a<<5); + a = (a+0xd3a2646c) ^ (a<<9); + a = (a+0xfd7046c5) + (a<<3); + a = (a^0xb55a4f09) ^ (a>>16); + return a; +} +#endif + #include "htable.inc" -HTIMPL(ptrhash, inthash, OP_EQ) +HTIMPL(ptrhash, _pinthash, OP_EQ)