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

Modified Files: integers.lisp Log Message: Fixed a nasty bug in ash which failed to handle the situation when a bignum got shifted to zero. Also fixed a bug in truncate on negatives.

Date: Fri Jul 16 03:42:41 2004 Author: ffjeld

Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.67 movitz/losp/muerte/integers.lisp:1.68 --- movitz/losp/muerte/integers.lisp:1.67 Thu Jul 15 17:03:05 2004 +++ movitz/losp/muerte/integers.lisp Fri Jul 16 03:42:40 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.67 2004/07/16 00:03:05 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.68 2004/07/16 10:42:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -1133,21 +1133,23 @@ (:andl -4 :eax) (:cld))) (positive-bignum - (let* ((result-length (- (integer-length integer) count)) - (result (%make-bignum (truncate (+ result-length 31) 32)))) - (multiple-value-bind (long short) - (truncate count 16) - (let ((src-max-bigit (* 2 (%bignum-bigits integer)))) - (dotimes (i (* 2 (%bignum-bigits result))) - (let ((src (+ i long))) - (setf (memref result -2 i :unsigned-byte16) - (if (< src src-max-bigit) - (memref integer -2 src :unsigned-byte16) - 0))))) - (setf result (%bignum-canonicalize result)) - (dotimes (i short result) - (setf result (truncate result 2))) - result)))))))) + (let ((result-length (- (integer-length integer) count))) + (if (<= result-length 0) + 0 + (let ((result (%make-bignum (truncate (+ result-length 31) 32)))) + (multiple-value-bind (long short) + (truncate count 16) + (let ((src-max-bigit (* 2 (%bignum-bigits integer)))) + (dotimes (i (* 2 (%bignum-bigits result))) + (let ((src (+ i long))) + (setf (memref result -2 i :unsigned-byte16) + (if (< src src-max-bigit) + (memref integer -2 src :unsigned-byte16) + 0))))) + (setf result (%bignum-canonicalize result)) + (dotimes (i short result) + (setf result (truncate result 2))) + result))))))))))

;;;;

@@ -1540,12 +1542,12 @@ (%negatef r number divisor)))) (((integer 0 *) (integer * -1)) (multiple-value-bind (q r) - (truncate (- number) divisor) + (truncate number (- divisor)) (values (%negatef q number divisor) r))) (((integer * -1) (integer * -1)) (multiple-value-bind (q r) - (truncate (- number) divisor) + (truncate (- number) (- divisor)) (values q (%negatef r number divisor)))) ))))