ref: 46009027c2dc5478c1f7a627d08e66f78849180a
parent: 2e9a8c21ccb52cd4726e7c6a0c92cabf1d0e26f8
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sat May 8 20:42:37 EDT 2010
fixing a 64-bit issue and a nan issue
--- 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)
--- 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;" [emitoptargs 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;_;" [definecaadr 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.substring.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>)--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -845,7 +845,7 @@
}
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)
@@ -852,9 +852,9 @@
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 @@
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]))
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -712,7 +712,7 @@
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 &&
--- a/llt/operators.c
+++ b/llt/operators.c
@@ -205,6 +205,7 @@
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 @@
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 @@
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 @@
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);
}
}
--- 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)