head     1.2;
access   ;
symbols  mips:1;
locks    ; strict;
comment  @@;


1.2
date     90.07.12.12.43.35;  author wlott;  state Exp;
branches ;
next     1.1;

1.1
date     90.05.25.20.18.35;  author wlott;  state Exp;
branches ;
next     ;


desc
@Temporary bignum shifting code, until the compiler can deal better with
Bill's bignum ashift code.
@


1.2
log
@Changed word-shift to digit-shift so that it does not clash with the
constant vm:word-shift now that the bignum package uses the vm package.
@
text
@;;; -*- Log: code.log; Package: bignum -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@@CMUC). 
;;; **********************************************************************
;;;
;;; $Header: bignum-ash.lisp,v 1.1 90/05/25 20:18:35 wlott Locked $
;;;
;;; Temporary bignum shifting code, until the compile can deal better with
;;; Bill's bignum ashift code.
;;;

(in-package "BIGNUM")

(proclaim '(optimize (speed 3) (safety 0)))

(defun bignum-ashift-left (bignum shift)
  (declare (type bignum-type bignum)
	   (type bignum-index shift))
  (let* ((oldlen (%bignum-length bignum))
	 (bits (1+ (bignum-integer-length bignum)))
	 (newlen (ceiling (the fixnum (+ shift bits)) digit-size))
	 (result (%allocate-bignum newlen)))
    (declare (type bignum-type result)
	     (fixnum bits)
	     (type bignum-index oldlen newlen))
    (multiple-value-bind (digit-shift bit-shift)
			 (floor shift digit-size)
      (declare (type bignum-index digit-shift)
	       (type (mod #.digit-size) bit-shift))
      (if (zerop bit-shift)
	  (dotimes (index oldlen)
	    (declare (type bignum-index index))
	    (setf (%bignum-ref result (+ digit-shift index))
		  (%bignum-ref bignum index)))
	  (let ((merge-shift (- digit-size bit-shift))
		(sign-digit (%bignum-ref bignum (1- oldlen))))
	    (declare (type (integer 1 (#.digit-size)) merge-shift)
		     (type bignum-element-type sign-digit))
	    (multiple-value-bind
		(src-start high)
		(if (= (+ digit-shift oldlen) newlen)
		    (values (- oldlen 2) sign-digit)
		    (values (1- oldlen) (%ashr sign-digit 31)))
	      (declare (type bignum-index src-start)
		       (type bignum-element-type high))
	      (do ((src-index src-start (1- src-index))
		   (dst-index (1- newlen) (1- dst-index)))
		  ((minusp src-index)
		   (setf (%bignum-ref result dst-index)
			 (merge-bits merge-shift high 0)))
		(let ((low (%bignum-ref bignum src-index)))
		  (setf (%bignum-ref result dst-index)
			(merge-bits merge-shift high low))
		  (setf high low))))))
      (%normalize-bignum result newlen))))


(defun bignum-ashift-right (bignum shift)
  (declare (type bignum-type bignum)
	   (type bignum-index shift))
  (let ((bits (bignum-integer-length bignum)))
    (declare (fixnum bits))
    (if (>= shift bits)
	(if (%bignum-0-or-plusp bignum (%bignum-length bignum))
	    0
	    -1)
	(let* ((newlen (ceiling (1+ (- bits shift)) digit-size))
	       (result (%allocate-bignum newlen)))
	  (declare (type bignum-index newlen)
		   (type bignum-type result))
	  (multiple-value-bind (digit-shift bit-shift)
			       (floor shift digit-size)
	    (declare (type bignum-index digit-shift)
		     (type (mod #.digit-size) bit-shift))
	    (if (zerop bit-shift)
		(dotimes (index newlen)
		  (declare (type bignum-index index))
		  (setf (%bignum-ref result index)
			(%bignum-ref bignum (+ index digit-shift))))
		(let ((low (%bignum-ref bignum digit-shift))
		      (oldlen (%bignum-length bignum))
		      (src-index (1+ digit-shift)))
		  (declare (type bignum-element-type low)
			   (type bignum-index oldlen src-index))
		  (dotimes (dst-index newlen)
		    (declare (type bignum-index dst-index))
		    (let ((high (if (= src-index oldlen)
				    (%ashr low (1- digit-size))
				    (%bignum-ref bignum src-index))))
		      (declare (type bignum-element-type high))
		      (setf (%bignum-ref result dst-index)
			    (merge-bits bit-shift high low))
		      (setf low high))
		    (incf src-index))))
	    (%normalize-bignum result newlen))))))
@


1.1
log
@Initial revision
@
text
@d11 1
a11 1
;;; $Header$
d31 1
a31 1
    (multiple-value-bind (word-shift bit-shift)
d33 1
a33 1
      (declare (type bignum-index word-shift)
d38 1
a38 1
	    (setf (%bignum-ref result (+ word-shift index))
d46 1
a46 1
		(if (= (+ word-shift oldlen) newlen)
d76 1
a76 1
	  (multiple-value-bind (word-shift bit-shift)
d78 1
a78 1
	    (declare (type bignum-index word-shift)
d84 2
a85 2
			(%bignum-ref bignum (+ index word-shift))))
		(let ((low (%bignum-ref bignum word-shift))
d87 1
a87 1
		      (src-index (1+ word-shift)))
@