From ba49bda4e0d2ffe052a8ad6cb12a1d68f4c1e4c0 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@iro.umontreal.ca>
Date: Fri, 9 Oct 2009 10:54:59 -0400
Subject: [PATCH] Moved neg into the standard library. Moved the sign handling
 of multiplication and division to the standard library.

---
 bignums.c    |  6 ------
 dispatch.c   |  6 ++++--
 encoding.scm |  2 --
 env.scm      |  2 --
 library.scm  | 54 ++++++++++++++++++++++++++++++++++++++++++------------
 parser.scm   |  2 +-
 primitives.c | 29 +++++------------------------
 7 files changed, 52 insertions(+), 49 deletions(-)

diff --git a/bignums.c b/bignums.c
index d0a025c..a44db23 100644
--- a/bignums.c
+++ b/bignums.c
@@ -287,12 +287,6 @@ integer sub (integer x, integer y) {
   return result;
 }
 
-integer neg (integer x) {
-  /* neg(x) returns the integer -x */
-
-  return sub (ZERO, x);
-}
-
 integer scale (digit n, integer x) {
   /* scale(n,x) returns the integer n*x */
 
diff --git a/dispatch.c b/dispatch.c
index 6d8da7c..8b04a69 100644
--- a/dispatch.c
+++ b/dispatch.c
@@ -494,8 +494,10 @@ void interpreter () {
       arg2 = pop();  arg1 = pop();  prim_div ();      push_arg1();  break;
     case 5:
       arg2 = pop();  arg1 = pop();  prim_rem ();      push_arg1();  break;
-    case 6:
-      arg1 = pop();  prim_neg ();      push_arg1();  break;
+#if 0
+    case 6: // FREE
+      break;
+#endif
     case 7:
       arg2 = pop();  arg1 = pop();  prim_eq ();       push_arg1();  break;
     case 8:
diff --git a/encoding.scm b/encoding.scm
index e0def39..b1d228f 100644
--- a/encoding.scm
+++ b/encoding.scm
@@ -387,7 +387,6 @@
             (define (prim.*)               (prim 3))
             (define (prim.quotient)        (prim 4))
             (define (prim.remainder)       (prim 5))
-            (define (prim.neg)             (prim 6))
             (define (prim.=)               (prim 7))
             (define (prim.<)               (prim 8))
             (define (prim.>)               (prim 10))
@@ -580,7 +579,6 @@
                              ((#%*)               (prim.*))
                              ((#%quotient)        (prim.quotient))
                              ((#%remainder)       (prim.remainder))
-                             ((#%neg)             (prim.neg))
                              ((#%=)               (prim.=))
                              ((#%<)               (prim.<))
                              ((#%>)               (prim.>))
diff --git a/env.scm b/env.scm
index 0eedeaf..859968e 100644
--- a/env.scm
+++ b/env.scm
@@ -34,7 +34,6 @@
      (make-var '#%* #t '() '() '() #f (make-primitive 2 #f #f))
      (make-var '#%quotient #t '() '() '() #f (make-primitive 2 #f #f))
      (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f))
-     (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f))
      (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f))
      (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f))
      (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f))
@@ -89,7 +88,6 @@
 ;; (define foo car)
 (define substitute-primitives
   '((number? . #%number?)
-    (quotient . #%quotient)
     (remainder . #%remainder)
     (= . #%=)
     (< . #%<)
diff --git a/library.scm b/library.scm
index 5142131..577ffb4 100644
--- a/library.scm
+++ b/library.scm
@@ -24,7 +24,7 @@
 (define +
   (lambda (x . rest)
     (if (#%pair? rest)
-        (#%+-aux (#%+ x (#%car rest)) (#%cdr rest))
+        (#%+-aux x rest)
         x)))
 
 (define #%+-aux
@@ -33,11 +33,15 @@
         (#%+-aux (#%+ x (#%car rest)) (#%cdr rest))
         x)))
 
+(define neg
+  (lambda (x)
+    (- 0 x)))
+
 (define -
   (lambda (x . rest)
     (if (#%pair? rest)
-        (#%--aux (#%- x (#%car rest)) (#%cdr rest))
-        (#%neg x))))
+        (#%--aux x rest)
+        (neg x))))
 
 (define #%--aux
   (lambda (x rest)
@@ -48,18 +52,44 @@
 (define *
   (lambda (x . rest)
     (if (#%pair? rest)
-        (#%*-aux (#%* x (#%car rest)) (#%cdr rest))
+        (#%*-aux x rest)
         x)))
 
 (define #%*-aux
   (lambda (x rest)
     (if (#%pair? rest)
-        (#%*-aux (#%* x (#%car rest)) (#%cdr rest))
+        (#%*-aux (#%mul x (#%car rest)) (#%cdr rest))
         x)))
 
-(define quotient
+(define #%mul
+  (lambda (x y)
+    (let* ((x-neg? (< x 0))
+           (y-neg? (< y 0))
+           (x      (if x-neg? (neg x) x))
+           (y      (if y-neg? (neg y) y)))
+      (let ((prod   (#%* x y)))
+        (cond ((and x-neg? y-neg?)
+               prod)
+              ((or x-neg? y-neg?)
+               (neg prod))
+              (else
+               prod))))))
+
+(define / quotient)
+
+(define quotient ;; TODO similar to #%mul, abstract ?
   (lambda (x y)
-    (#%quotient x y)))
+    (let* ((x-neg? (< x 0))
+           (y-neg? (< y 0))
+           (x      (if x-neg? (neg x) x))
+           (y      (if y-neg? (neg y) y)))
+      (let ((quot   (#%quotient x y)))
+        (cond ((and x-neg? y-neg?)
+               quot)
+              ((or x-neg? y-neg?)
+               (neg quot))
+              (else
+               quot))))))
 
 (define remainder
   (lambda (x y)
@@ -172,7 +202,7 @@
 
 (define abs
   (lambda (x)
-    (if (#%< x 0) (#%neg x) x)))
+    (if (#%< x 0) (neg x) x)))
 
 (define modulo
   (lambda (x y)
@@ -393,15 +423,15 @@
   (lambda (n)
     (#%list->string
      (if (#%< n 0)
-         (#%cons #\- (#%number->string-aux (#%neg n) '()))
+         (#%cons #\- (#%number->string-aux (neg n) '()))
          (#%number->string-aux n '())))))
 
 (define #%number->string-aux
   (lambda (n lst)
-    (let ((rest (#%cons (#%+ #\0 (#%remainder n 10)) lst)))
+    (let ((rest (#%cons (#%+ #\0 (remainder n 10)) lst)))
       (if (#%< n 10)
           rest
-          (#%number->string-aux (#%quotient n 10) rest)))))
+          (#%number->string-aux (quotient n 10) rest)))))
 
 (define pp
   (lambda (x)
@@ -497,7 +527,7 @@
 ;; TODO add bitwise-and ? bitwise-not ?
 
 (define current-time (lambda () (#%clock)))
-(define time->seconds (lambda (t) (#%quotient t 100)))
+(define time->seconds (lambda (t) (quotient t 100)))
 
 (define u8vector
   (lambda x
diff --git a/parser.scm b/parser.scm
index 0401c74..df6327c 100644
--- a/parser.scm
+++ b/parser.scm
@@ -273,7 +273,7 @@
 	  ;; binary arthimetic operations can use primitives directly
 	  ((and (pair? expr)
 		(= (length (cdr expr)) 2)
-		(assoc (car expr) '((+ . #%+) (- . #%-) (* . #%*))))
+		(assoc (car expr) '((+ . #%+) (- . #%-))))
 	   =>
 	   (lambda (prim)
 	     (parse use
diff --git a/primitives.c b/primitives.c
index cb61ce8..603b0f3 100644
--- a/primitives.c
+++ b/primitives.c
@@ -17,12 +17,12 @@ char *prim_name[64] =
     "prim #%*",
     "prim #%quotient",
     "prim #%remainder",
-    "prim #%neg",
+    "prim 6",
     "prim #%=",
     "prim #%<",
-    "prim #%<=",
+    "prim 9",
     "prim #%>",
-    "prim #%>=",
+    "prim 11",
     "prim #%pair?",
     "prim #%cons",
     "prim #%car",
@@ -118,12 +118,7 @@ void prim_sub () {
 
 void prim_mul () {
 #ifdef INFINITE_PRECISION_BIGNUMS
-  a1 = negp (arg1);
-  a2 = negp (arg2); // -1 if negative
-  arg1 = mulnonneg (a1 ? neg(arg1) : arg1,
-		    a2 ? neg(arg2) : arg2);
-  if (a1 + a2 == 1) // only one of the 2 was negative
-    arg1 = neg(arg1);
+  arg1 = mulnonneg (arg1, arg2);
 #else
   decode_2_int_args ();
   arg1 = encode_int (a1 * a2);
@@ -135,12 +130,7 @@ void prim_div () {
 #ifdef INFINITE_PRECISION_BIGNUMS
   if (obj_eq(arg2, ZERO))
     ERROR("quotient", "divide by 0");
-  a1 = negp (arg1);
-  a2 = negp (arg2); // -1 if negative
-  arg1 = divnonneg (a1 ? neg(arg1) : arg1,
-		    a2 ? neg(arg2) : arg2);
-  if (a1 + a2 == 1) // only one of the 2 was negative
-    arg1 = neg(arg1);
+  arg1 = divnonneg (arg1, arg2);
 #else
   decode_2_int_args ();
   if (a2 == 0)
@@ -172,15 +162,6 @@ void prim_rem () {
   arg2 = OBJ_FALSE;
 }
 
-void prim_neg () {
-#ifdef INFINITE_PRECISION_BIGNUMS
-  arg1 = neg (arg1);
-#else
-  a1 = decode_int (arg1);
-  arg1 = encode_int (- a1);
-#endif
-}
-
 void prim_eq () {
 #ifdef INFINITE_PRECISION_BIGNUMS
   arg1 = encode_bool(cmp (arg1, arg2) == 1);
-- 
2.11.4.GIT