lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixing a 64-bit issue and a nan issue

This commit is contained in:
JeffBezanson 2010-05-09 00:42:37 +00:00
parent 2e9a8c21cc
commit 46009027c2
6 changed files with 69 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
femtolisp/compiler.lsp
View File

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

23
femtolisp/flisp.boot
View File

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

8
femtolisp/flisp.c
View File

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

2
femtolisp/print.c
View File

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

4
llt/operators.c
View File

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

27
llt/ptrhash.c
View File

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