Skip to content
Snippets Groups Projects
Forked from cmucl / cmucl
6226 commits behind the upstream repository.
bignum-test.lisp 3.11 KiB
;;;; -*- Package: Bignum -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum-test.lisp,v 1.4 1994/10/31 04:11:27 ram Rel $")
;;;
;;; **********************************************************************
;;;
;;;    Some stuff to check that bignum operations are retuning the correct
;;; results.
;;; 
(in-package "BIGNUM")

(defvar *in-bignum-wrapper* nil)

(defmacro def-bignum-wrapper (name lambda-list &body body)
  (let ((var-name (ext:symbolicate "*OLD-" name "*"))
	(wrap-name (ext:symbolicate "WRAP-" name))
	(args (mapcar #'(lambda (x)
			  (if (listp x) (car x) x))
		      (remove-if #'(lambda (x)
				     (member x lambda-list-keywords))
				 lambda-list))))
    `(progn
       (defvar ,var-name (fdefinition ',name))
       (defun ,wrap-name ,lambda-list
	 (if *in-bignum-wrapper*
	     (funcall ,var-name ,@args)
	     (let ((*in-bignum-wrapper* t))
	       ,@body)))
       (setf (fdefinition ',name) #',wrap-name))))

(defun big= (x y)
  (= (if (typep x 'bignum)
	 (%normalize-bignum x (%bignum-length x))
	 x)
     (if (typep y 'bignum)
	 (%normalize-bignum y (%bignum-length y))
	 y)))

(def-bignum-wrapper add-bignums (x y)
  (let ((res (funcall *old-add-bignums* x y)))
    (assert (big= (- res y) x))
    res))

(def-bignum-wrapper multiply-bignums (x y)
  (let ((res (funcall *old-multiply-bignums* x y)))
    (if (zerop x)
	(assert (zerop res))
	(multiple-value-bind (q r) (truncate res x)
	  (assert (and (zerop r) (big= q y)))))
    res))

(def-bignum-wrapper negate-bignum (x &optional (fully-normalized t))
  (let ((res (funcall *old-negate-bignum* x fully-normalized)))
    (assert (big= (- res) x))
    res))

(def-bignum-wrapper subtract-bignum (x y)
  (let ((res (funcall *old-subtract-bignum* x y)))
    (assert (big= (+ res y) x))
    res))

(def-bignum-wrapper multiply-bignum-and-fixnum (x y)
  (let ((res (funcall *old-multiply-bignum-and-fixnum* x y)))
    (if (zerop x)
	(assert (zerop res))
	(multiple-value-bind (q r) (truncate res x)
	  (assert (and (zerop r) (big= q y)))))
    res))

(def-bignum-wrapper multiply-fixnums (x y)
  (let ((res (funcall *old-multiply-fixnums* x y)))
    (if (zerop x)
	(assert (zerop res))
	(multiple-value-bind (q r) (truncate res x)
	  (assert (and (zerop r) (big= q y)))))
    res))

(def-bignum-wrapper bignum-ashift-right (x shift)
  (let ((res (funcall *old-bignum-ashift-right* x shift)))
    (assert (big= (ash res shift) (logand x (ash -1 shift))))
    res))

(def-bignum-wrapper bignum-ashift-left (x shift)
  (let ((res (funcall *old-bignum-ashift-left* x shift)))
    (assert (big= (ash res (- shift)) x))
    res))

(def-bignum-wrapper bignum-truncate (x y)
  (multiple-value-bind (q r)
		       (funcall *old-bignum-truncate* x y)
    (assert (big= (+ (* q y) r) x))
    (values q r)))

(def-bignum-wrapper bignum-compare (x y)
  (let ((res (funcall *old-bignum-compare* x y)))
    (assert (big= (signum (- x y)) res))
    res))