tests/bignum-test.lisp

   1 ;;;; some stuff to check that bignum operations are returning correct
   2 ;;;; results
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!BIGNUM")
  14
  15 (file-comment
  16   "$Header$")
  17
  18 (defvar *in-bignum-wrapper* nil)
  19
  20 (defmacro def-bignum-wrapper (name lambda-list &body body)
  21   (let ((var-name (sb!int:symbolicate "*OLD-" name "*"))
  22         (wrap-name (sb!int:symbolicate "WRAP-" name))
  23         (args (mapcar #'(lambda (x)
  24                           (if (listp x) (car x) x))
  25                       (remove-if #'(lambda (x)
  26                                      (member x lambda-list-keywords))
  27                                  lambda-list))))
  28     `(progn
  29        (defvar ,var-name (fdefinition ',name))
  30        (defun ,wrap-name ,lambda-list
  31          (if *in-bignum-wrapper*
  32              (funcall ,var-name ,@args)
  33              (let ((*in-bignum-wrapper* t))
  34                ,@body)))
  35        (setf (fdefinition ',name) #',wrap-name))))
  36
  37 (defun big= (x y)
  38   (= (if (typep x 'bignum)
  39          (%normalize-bignum x (%bignum-length x))
  40          x)
  41      (if (typep y 'bignum)
  42          (%normalize-bignum y (%bignum-length y))
  43          y)))
  44
  45 (def-bignum-wrapper add-bignums (x y)
  46   (let ((res (funcall *old-add-bignums* x y)))
  47     (assert (big= (- res y) x))
  48     res))
  49
  50 (def-bignum-wrapper multiply-bignums (x y)
  51   (let ((res (funcall *old-multiply-bignums* x y)))
  52     (if (zerop x)
  53         (assert (zerop res))
  54         (multiple-value-bind (q r) (truncate res x)
  55           (assert (and (zerop r) (big= q y)))))
  56     res))
  57
  58 (def-bignum-wrapper negate-bignum (x &optional (fully-normalized t))
  59   (let ((res (funcall *old-negate-bignum* x fully-normalized)))
  60     (assert (big= (- res) x))
  61     res))
  62
  63 (def-bignum-wrapper subtract-bignum (x y)
  64   (let ((res (funcall *old-subtract-bignum* x y)))
  65     (assert (big= (+ res y) x))
  66     res))
  67
  68 (def-bignum-wrapper multiply-bignum-and-fixnum (x y)
  69   (let ((res (funcall *old-multiply-bignum-and-fixnum* x y)))
  70     (if (zerop x)
  71         (assert (zerop res))
  72         (multiple-value-bind (q r) (truncate res x)
  73           (assert (and (zerop r) (big= q y)))))
  74     res))
  75
  76 (def-bignum-wrapper multiply-fixnums (x y)
  77   (let ((res (funcall *old-multiply-fixnums* x y)))
  78     (if (zerop x)
  79         (assert (zerop res))
  80         (multiple-value-bind (q r) (truncate res x)
  81           (assert (and (zerop r) (big= q y)))))
  82     res))
  83
  84 (def-bignum-wrapper bignum-ashift-right (x shift)
  85   (let ((res (funcall *old-bignum-ashift-right* x shift)))
  86     (assert (big= (ash res shift) (logand x (ash -1 shift))))
  87     res))
  88
  89 (def-bignum-wrapper bignum-ashift-left (x shift)
  90   (let ((res (funcall *old-bignum-ashift-left* x shift)))
  91     (assert (big= (ash res (- shift)) x))
  92     res))
  93
  94 (def-bignum-wrapper bignum-truncate (x y)
  95   (multiple-value-bind (q r) (funcall *old-bignum-truncate* x y)
  96     (assert (big= (+ (* q y) r) x))
  97     (values q r)))
  98
  99 (def-bignum-wrapper bignum-compare (x y)
 100   (let ((res (funcall *old-bignum-compare* x y)))
 101     (assert (big= (signum (- x y)) res))
 102     res))