From c38c47d264f11a1a1f1a2e6a2d23d9eb755f0127 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Thu, 14 May 2009 17:54:59 +0000 Subject: [PATCH] adding R6RS div, mod, div0, mod0 small improvement to cmp_eq explicit -fomit-frame-pointer was causing test failures with gcc4.3.2 --- femtolisp/Makefile | 2 +- femtolisp/compiler.lsp | 4 ++-- femtolisp/cvalues.c | 4 ++-- femtolisp/flisp.boot | 10 +++++++--- femtolisp/flisp.c | 2 +- femtolisp/system.lsp | 8 +++++++- llt/operators.c | 2 +- 7 files changed, 21 insertions(+), 11 deletions(-) diff --git a/femtolisp/Makefile b/femtolisp/Makefile index f8325c3..3369b5a 100644 --- a/femtolisp/Makefile +++ b/femtolisp/Makefile @@ -12,7 +12,7 @@ FLAGS = -falign-functions -Wall -Wextra -Wno-strict-aliasing -I$(LLTDIR) $(CFLAG LIBS = $(LLT) -lm DEBUGFLAGS = -g -DDEBUG $(FLAGS) -SHIPFLAGS = -O3 -DNDEBUG -fomit-frame-pointer -march=native $(FLAGS) +SHIPFLAGS = -O3 -DNDEBUG -march=native $(FLAGS) default: release test diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index 9a86049..625282c 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -16,7 +16,7 @@ :cons :list :car :cdr :set-car! :set-cdr! :apply - :+ :- :* :/ :div := :< :compare + :+ :- :* :/ :div0 := :< :compare :vector :aref :aset! @@ -41,7 +41,7 @@ :set-cdr! 2 := 2 :< 2 :compare 2 :aref 2 :aset! 3 - :div 2)) + :div0 2)) (define (make-code-emitter) (vector () (table) 0)) (define (emit e inst . args) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index cfd8b9a..5e67c8a 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -1303,9 +1303,9 @@ static value_t fl_idiv2(value_t a, value_t b) int64_t a64, b64; if (!num_to_ptr(a, &ai, &ta, &aptr)) - type_error("div", "number", a); + type_error("div0", "number", a); if (!num_to_ptr(b, &bi, &tb, &bptr)) - type_error("div", "number", b); + type_error("div0", "number", b); if (ta == T_UINT64) { if (tb == T_UINT64) { diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index d0b93a8..fda35bd 100644 --- a/femtolisp/flisp.boot +++ b/femtolisp/flisp.boot @@ -96,8 +96,10 @@ nestlist #function("n3e0f2`326>0_;f1e1f0f0f131f2av33K;" [<= nestlist]) negative? #function("n1f0`X;" []) -mod +mod0 #function("n2f0f0f1Vf1T2v;" []) +mod +#function("n2f0e0f0f132f1T2v;" [div]) memv #function("n2f1?6:0^;f1Mf0=6F0f1;e0f0f1N42;" [memv]) member @@ -200,6 +202,8 @@ emit-nothing #function("n1f0;" []) emit #function("o2e0f1c1326I0c2f0a[q325J0^2f0`e3f1f2Kf0`[32\\2f0;" [memq (:loadv :loadg :setg) #function("rc0g00b2[q42;" [#function("rc0g12Mq42;" [#function("rc0e1g10f0326K0e2g10f0325f0e3g10f0g00332g00auk002g00avq42;" [#function("rg30b2g10\\2f0L1k322e0f0c1326Z0c2g31q32k31;^;" [>= 256 #function("rf0e0=6<0e1;f0e2=6G0e3;f0e4=6R0e5;^;" [:loadv :loadv.l :loadg :loadg.l :setg :setg.l])]) has? get put!])])]) nreconc]) +div +#function("n2f0f1Vf0`X16Q02f1`X16J02a17Q02b/17W02`u;" []) display #function("n1e0f0312];" [princ]) disassemble @@ -297,7 +301,7 @@ array? argc-error #function("n2e0e1c2f0c3f1f1aW6J0c45L0c53541;" [error string "compile error: " " expects " " argument." " arguments."]) arg-counts -#table(:not 1 :set-cdr! 2 :div 2 :cons 2 :number? 1 :equal? 2 :cdr 1 :vector? 1 :eqv? 2 := 2 :atom? 1 :aref 2 :compare 2 :< 2 :null? 1 :eq? 2 :car 1 :set-car! 2 :builtin? 1 :aset! 3 :bound? 1 :boolean? 1 :pair? 1 :symbol? 1 :fixnum? 1) +#table(:not 1 :set-cdr! 2 :cons 2 :number? 1 :equal? 2 :cdr 1 :vector? 1 :eqv? 2 := 2 :div0 2 :atom? 1 :aref 2 :compare 2 :< 2 :null? 1 :eq? 2 :car 1 :set-car! 2 :builtin? 1 :aset! 3 :bound? 1 :boolean? 1 :pair? 1 :symbol? 1 :fixnum? 1) append2 #function("n2f0A6;0f1;f0Me0f0Nf132K;" [append2]) append @@ -315,7 +319,7 @@ __init_globals MAX_ARGS 127 Instructions -#table(:sub2 70 :nop 0 :set-cdr! 32 :/ 37 :setc 59 :tapply 68 :div 38 :cons 27 dummy_nil 74 :equal? 14 :cdr 30 :call 3 :eqv? 13 := 39 :setg.l 60 :list 28 :atom? 15 :aref 43 :load0 48 :let 66 dummy_t 72 :argc 62 :< 40 :null? 17 :loadg 53 :load1 49 :car 29 :brt.l 10 :vargc 63 :loada 54 :set-car! 31 :setg 57 :aset! 44 :bound? 21 :pair? 22 :symbol? 19 :fixnum? 25 :loadi8 50 :not 16 :* 36 :neg 71 :pop 2 :loadnil 47 :brf 6 :vector 42 :- 35 :loadv 51 :closure 61 dummy_f 73 :number? 20 :trycatch 64 :add2 69 :loadv.l 52 :vector? 24 :brf.l 9 :seta 58 :apply 33 :dup 1 :copyenv 65 :for 67 :loadc 55 :compare 41 :eq? 12 :function? 26 :+ 34 :jmp 5 :loadt 45 :brt 7 :builtin? 23 :loadg.l 56 :tcall 4 :ret 11 :boolean? 18 :loadf 46 :jmp.l 8) +#table(:sub2 70 :nop 0 :set-cdr! 32 :/ 37 :setc 59 :tapply 68 :cons 27 dummy_nil 74 :equal? 14 :cdr 30 :call 3 :eqv? 13 := 39 :setg.l 60 :list 28 :atom? 15 :aref 43 :load0 48 :let 66 dummy_t 72 :argc 62 :< 40 :null? 17 :loadg 53 :load1 49 :car 29 :brt.l 10 :vargc 63 :loada 54 :set-car! 31 :setg 57 :aset! 44 :bound? 21 :pair? 22 :symbol? 19 :fixnum? 25 :loadi8 50 :not 16 :* 36 :neg 71 :pop 2 :loadnil 47 :brf 6 :vector 42 :- 35 :loadv 51 :closure 61 dummy_f 73 :number? 20 :trycatch 64 :add2 69 :loadv.l 52 :vector? 24 :brf.l 9 :seta 58 :apply 33 :dup 1 :div0 38 :copyenv 65 :for 67 :loadc 55 :compare 41 :eq? 12 :function? 26 :+ 34 :jmp 5 :loadt 45 :brt 7 :builtin? 23 :loadg.l 56 :tcall 4 :ret 11 :boolean? 18 :loadf 46 :jmp.l 8) >= #function("n2f1f0X17A02f0f1W;" []) > diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index dbfb4f6..a6c87e8 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -67,7 +67,7 @@ static char *builtin_names[] = "apply", // arithmetic - "+", "-", "*", "/", "div", "=", "<", "compare", + "+", "-", "*", "/", "div0", "=", "<", "compare", // sequences "vector", "aref", "aset!", diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 098120a..34af5ee 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -102,8 +102,14 @@ (define (odd? x) (not (even? x))) (define (1+ n) (+ n 1)) (define (1- n) (- n 1)) +(define (mod0 x y) (- x (* (div0 x y) y))) +(define (div x y) (+ (div0 x y) + (or (and (< x 0) + (or (and (< y 0) 1) + -1)) + 0))) (define (mod x y) (- x (* (div x y) y))) -(define remainder mod) +(define remainder mod0) (define (random n) (if (integer? n) (mod (rand) n) diff --git a/llt/operators.c b/llt/operators.c index e5afc2d..3ef7f8e 100644 --- a/llt/operators.c +++ b/llt/operators.c @@ -238,7 +238,7 @@ int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag) int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag, int equalnans) { - if (atag==btag && !equalnans) + if (atag==btag && (!equalnans || atag < T_FLOAT)) return cmp_same_eq(a, b, atag); double da = conv_to_double(a, atag);