[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv29249

Modified Files:
	integers.lisp 
Log Message:
More bignum fixes. Added some slow-but-working implementations of *
and truncate for bignums.

Date: Mon Jul 12 19:29:15 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.47 movitz/losp/muerte/integers.lisp:1.48
--- movitz/losp/muerte/integers.lisp:1.47	Mon Jul 12 07:17:14 2004
+++ movitz/losp/muerte/integers.lisp	Mon Jul 12 19:29:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.47 2004/07/12 14:17:14 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.48 2004/07/13 02:29:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -68,6 +68,36 @@
 (defun oddp (x)
   (not (evenp x)))
 
+
+
+;;; Types
+
+(define-typep integer (x &optional (min '*) (max '*))
+  (and (typep x 'integer)
+       (or (eq min '*) (<= min x))
+       (or (eq max '*) (<= x max))))
+
+(deftype signed-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    'integer)
+   ((typep size '(integer 1 *))
+    (list 'integer
+	  (- (ash 1 (1- size)))
+	  (1- (ash 1 (1- size)))))
+   (t (error "Illegal size for signed-byte."))))
+
+(deftype unsigned-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    '(integer 0))
+   ((typep size '(integer 1 *))
+    (list 'integer 0 (1- (ash 1 size))))
+   (t (error "Illegal size for unsigned-byte."))))
+
+(define-simple-typep (bit bitp) (x)
+  (or (eq x 0) (eq x 1)))
+
 ;;; Addition
 
 (define-compiler-macro + (&whole form &rest operands &environment env)
@@ -400,7 +430,7 @@
 			(:movl (:eax ,movitz:+other-type-offset+) :ecx)
 			(:cmpb ,(movitz:tag :bignum) :cl)
 			(:jne 'not-a-number)
-			(:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx)
+			(:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx)
 			(:jne 'not-most-negative-fixnum)
 			(:cmpl ,(- most-negative-fixnum)
 			 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
@@ -423,15 +453,50 @@
 		)))
 	(do-it)))
    (2 (minuend subtrahend)
-      (cond
-       ((eq 0 minuend)
-	(- subtrahend))
-       (t (check-type minuend fixnum)
-	  (check-type subtrahend fixnum)
-	  (with-inline-assembly (:returns :eax :side-effects nil)
-	    (:compile-two-forms (:eax :ebx) minuend subtrahend)
-	    (:subl :ebx :eax)
-	    (:into)))))
+      (macrolet
+	  ((do-it ()
+	     `(number-double-dispatch (minuend subtrahend)
+		((t (eql 0))
+		 minuend)
+		(((eql 0) t)
+		 (- subtrahend))
+		((fixnum fixnum)
+		 (with-inline-assembly (:returns :eax :side-effects nil)
+		   (:compile-two-forms (:eax :ebx) minuend subtrahend)
+		   (:subl :ebx :eax)
+		   (:into)))
+		((bignum fixnum)
+		 (+ (- subtrahend) minuend))
+		((fixnum bignum)
+		 (- (+ (- minuend) subtrahend)))
+		((positive-bignum positive-bignum)
+		 (cond
+		  ((= minuend subtrahend)
+		   0)
+		  ((< minuend subtrahend)
+		   (- (- subtrahend minuend)))
+		  (t (%bignum-canonicalize
+		      (with-inline-assembly (:returns :eax)
+			(:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend)
+			(:xorl :edx :edx) ; counter
+			(:xorl :ecx :ecx) ; carry
+		       sub-loop
+			(:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))
+			       :ecx)
+			(:sbbl :ecx
+			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:sbbl :ecx :ecx)
+			(:negl :ecx)
+			(:addl 4 :edx)
+			(:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)))
+			(:jne 'sub-loop)
+			(:subl :ecx
+			       (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))
+			(:jc '(:sub-program (should-not-happen)
+			       (:int 107)))
+			)))))
+		)))
+	(do-it)))
    (t (minuend &rest subtrahends)
       (declare (dynamic-extent subtrahends))
       (if subtrahends
@@ -1025,34 +1090,6 @@
 ;;;      (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al)))
 ;;;   (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count)))))
 
-;;; Types
-
-(define-typep integer (x &optional (min '*) (max '*))
-  (and (typep x 'integer)
-       (or (eq min '*) (<= min x))
-       (or (eq max '*) (<= x max))))
-
-(deftype signed-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    'integer)
-   ((typep size '(integer 1 *))
-    (list 'integer
-	  (- (ash 1 (1- size)))
-	  (1- (ash 1 (1- size)))))
-   (t (error "Illegal size for signed-byte."))))
-
-(deftype unsigned-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    '(integer 0))
-   ((typep size '(integer 1 *))
-    (list 'integer 0 (1- (ash 1 size))))
-   (t (error "Illegal size for unsigned-byte."))))
-
-(define-simple-typep (bit bitp) (x)
-  (or (eq x 0) (eq x 1)))
-
 ;;;;
 
 (defun integer-length (integer)
@@ -1267,10 +1304,11 @@
 		    positive-result
 		     )))
 		((positive-bignum positive-bignum)
-		 (do ((f y)
+		 (do ((mx (* most-positive-fixnum x))
+		      (f y)
 		      (r 0))
 		     ((typep f 'fixnum) (+ r (* f x)))
-		   (setf r (+ r (* most-positive-fixnum x)))
+		   (setf r (+ r mx))
 		   (setf f (- f most-positive-fixnum))))
 		)))
 	(do-it)))
@@ -1402,7 +1440,9 @@
 	 (cond
 	  ((= number divisor) (values 1 0))
 	  ((< number divisor) (values 0 number))
-	  (t (error "Don't know how to divide ~S with ~S." number divisor))))
+	  (t (do ((q 0 (1+ q))
+		  (r number (- r divisor)))
+		 ((< r divisor) (values q r))))))
 	))))
 
 (defun / (number &rest denominators)