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

[Frode Vatvedt Fjeld]

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

Modified Files:
	bignums.lisp 
Log Message:
Wrote %bignum-subf.

Date: Sun Jul 18 01:45:39 2004
Author: ffjeld

Index: movitz/losp/muerte/bignums.lisp
diff -u movitz/losp/muerte/bignums.lisp:1.1 movitz/losp/muerte/bignums.lisp:1.2
--- movitz/losp/muerte/bignums.lisp:1.1	Sat Jul 17 12:30:09 2004
+++ movitz/losp/muerte/bignums.lisp	Sun Jul 18 01:45:39 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 19:42:57 2004
 ;;;;                
-;;;; $Id: bignums.lisp,v 1.1 2004/07/17 19:30:09 ffjeld Exp $
+;;;; $Id: bignums.lisp,v 1.2 2004/07/18 08:45:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -64,7 +64,7 @@
 
 (defun copy-bignum (old)
   (check-type old bignum)
-  (let* ((length (%bignum-bigits old))
+  (let* ((length (ceiling (integer-length old) 32))
 	 (new (malloc-non-pointer-words (1+ length))))
     (with-inline-assembly (:returns :eax)
       (:compile-two-forms (:eax :ebx) new old)
@@ -172,3 +172,55 @@
 	      add-bignum-done)))
        (do-it)))))
 
+(defun %bignum-subf (bignum delta)
+  "Destructively subtract (abs delta) from bignum."
+  (check-type bignum bignum)
+  (etypecase delta
+    (positive-fixnum
+     (%bignum-addf-fixnum bignum (- delta)))
+    (negative-fixnum
+     (%bignum-addf-fixnum bignum delta))
+    (bignum
+     (macrolet
+	 ((do-it ()
+	    `(with-inline-assembly (:returns :eax)
+	      not-size1
+	       (:load-lexical (:lexical-binding bignum) :eax) ; EAX = bignum
+	       (:load-lexical (:lexical-binding delta) :ebx) ;  EBX = delta
+	       (:xorl :edx :edx)	; Counter
+	       (:xorl :ecx :ecx)	; Carry
+	      sub-bignum-loop
+	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
+	       (:jbe '(:sub-program (overflow) (:int 4)))
+	       (:addl (:ebx :edx (:offset movitz-bignum :bigit0))
+		      :ecx)
+	       (:jz 'carry+digit-overflowed) ; If CF=1, then ECX=0.
+	       (:subl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
+	      carry+digit-overflowed
+	       (:sbbl :ecx :ecx)
+	       (:negl :ecx)		; ECX = Add's Carry.
+	       (:addl 4 :edx)
+	       (:cmpw :dx (:ebx (:offset movitz-bignum length)))
+	       (:ja 'sub-bignum-loop)
+	       ;; Now, if there's a carry we must propagate it.
+	       (:jecxz 'sub-bignum-done)
+	      carry-propagate-loop
+	       (:cmpw :dx (:eax (:offset movitz-bignum length)))
+	       (:jbe '(:sub-program (overflow) (:int 4)))
+	       (:addl 4 :edx)
+	       (:subl 1 (:eax :edx (:offset movitz-bignum bigit0 -4)))
+	       (:jc 'carry-propagate-loop)
+      sub-bignum-done)))
+       (do-it)))))
+
+(defun %bignum-set-zerof (bignum)
+  (check-type bignum bignum)
+  (dotimes (i (logior 1 (%bignum-bigits bignum)))
+    (setf (memref bignum -2 i :lisp) 0))
+  bignum)
+
+(defun %bignum= (x y)
+  (compiler-macro-call %bignum= x y))
+
+(defun %bignum< (x y)
+  (compiler-macro-call %bignum< x y))