shithub: femtolisp

Download patch

ref: c38c47d264f11a1a1f1a2e6a2d23d9eb755f0127
parent: e365cb1d33f1642da25d46c76b44dee842357b37
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Thu May 14 13:54:59 EDT 2009 

adding R6RS div, mod, div0, mod0
small improvement to cmp_eq
explicit -fomit-frame-pointer was causing test failures with gcc4.3.2



--- a/femtolisp/Makefile
+++ b/femtolisp/Makefile
@@ -12,7 +12,7 @@
 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
 
--- 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)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -1303,9 +1303,9 @@
     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) {
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -96,8 +96,10 @@
 #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 @@
 #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 @@
 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 @@
 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;" [])
 >
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -67,7 +67,7 @@
       "apply",
 
       // arithmetic
-      "+", "-", "*", "/", "div", "=", "<", "compare",
+      "+", "-", "*", "/", "div0", "=", "<", "compare",
 
       // sequences
       "vector", "aref", "aset!",
--- 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)
--- a/llt/operators.c
+++ b/llt/operators.c
@@ -238,7 +238,7 @@
 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);