contrib/sb-gmp/tests.lisp

   1 (defpackage "SB-GMP-TESTS"
   2   (:use "COMMON-LISP" "SB-GMP" "SB-RT"))
   3
   4 (in-package "SB-GMP-TESTS")
   5
   6 (defparameter *state* (make-gmp-rstate))
   7 (rand-seed *state* 1234)
   8
   9 (defmacro defgenerator (name arguments &body body)
  10   `(defun ,name ,arguments
  11      (lambda () ,@body)))
  12
  13 (defgenerator gen-mpz (&key (limbs 5) sign nonzero)
  14   (let ((integer (random-bitcount *state*
  15                                   (* limbs sb-vm:n-word-bits))))
  16     (when (and nonzero (zerop integer))
  17       (setf integer 1))
  18     (ecase sign
  19       ((+ nil) integer)
  20       (- (- integer))
  21       ((t random) (if (zerop (random 2))
  22                       integer
  23                       (- integer))))))
  24
  25 (defun gen-mpq (&key (limbs 5) sign nonzero)
  26   (let ((numerator (gen-mpz :limbs limbs :sign sign
  27                             :nonzero nonzero))
  28         (denominator (gen-mpz :limbs limbs :nonzero t)))
  29     (lambda ()
  30       (/ (funcall numerator) (funcall denominator)))))
  31
  32 (defun maybe-apply (maybe-function &optional arguments)
  33   (if (typep maybe-function '(or function symbol))
  34       (apply maybe-function arguments)
  35       maybe-function))
  36
  37 (defun test-one-case (base tested &rest arguments)
  38   (let* ((initial-hashes (mapcar #'sxhash arguments))
  39          (base-values (let ((*gmp-disabled* t))
  40                         (multiple-value-list (maybe-apply base arguments))))
  41          (test-values (let ((*gmp-disabled* nil))
  42                         (multiple-value-list (apply tested arguments))))
  43          (final-hashes (mapcar #'sxhash arguments)))
  44     (unless (and (= (length base-values) (length test-values))
  45                  (every #'eql base-values test-values))
  46       (error "Failed test: ~S returned ~S; expected ~S"
  47              (cons tested arguments) test-values base-values))
  48     (unless (every #'eql initial-hashes final-hashes)
  49       (error "Failed test: ~S modified arguments ~{~A~^, ~} ~
  50               (printed modified values)"
  51              (cons tested arguments)
  52              (loop for i upfrom 0
  53                    for initial in initial-hashes
  54                    for final in final-hashes
  55                    unless (eql initial final)
  56                      collect i))))
  57   nil)
  58
  59 ;; Really just the most basic smoke test, otherwise
  60 ;; build times ballon up a bit on slow machines.
  61 (defvar *iteration-count* 3)
  62
  63 (defun test-n-cases (base tested &rest argument-generators)
  64   (let ((*random-state* (sb-ext:seed-random-state 54321)))
  65     (loop repeat *iteration-count* do
  66       (apply 'test-one-case base tested
  67              (mapcar #'maybe-apply argument-generators)))))
  68
  69 (defmacro define-gmp-test ((name &key (repeat 1) limbs (gmp-seed 1234))
  70                            &body body)
  71   `(deftest ,name
  72        (let ((*random-state* (sb-ext:seed-random-state 54321)))
  73          (rand-seed *state* ,gmp-seed)
  74          (handler-case
  75              (dotimes (i ,repeat)
  76                ;; try to get small failures first
  77                (let ((limbs (case i
  78                               (0 ,(subst `(lambda (x)
  79                                             x 0)
  80                                          'random
  81                                          limbs))
  82                               (1 ,(subst `(lambda (x)
  83                                             (if (> x 1) 1 0))
  84                                          'random
  85                                          limbs))
  86                               (t ,limbs))))
  87                  (declare (ignorable limbs))
  88                  ,@body))
  89            (error (c)
  90              (format t "~&~A~%" c)
  91              nil)
  92            (:no-error (&rest _) _ t)))
  93      t))
  94
  95 (define-gmp-test (mpz-add :repeat 7 :limbs (+ (random #xFFFFF) 2))
  96   (test-n-cases '+ 'mpz-add
  97                     (gen-mpz :limbs limbs :sign t)
  98                     (gen-mpz :limbs limbs :sign t)))
  99
 100 (define-gmp-test (mpz-sub :repeat 7 :limbs (+ (random #x1FFFF) 2))
 101   (test-n-cases '- 'mpz-sub
 102                 (gen-mpz :limbs limbs :sign t)
 103                 (gen-mpz :limbs limbs :sign t)))
 104
 105 (define-gmp-test (mpz-mul :repeat 7 :limbs (+ (random #x253F) 2))
 106   (test-n-cases '* 'mpz-mul
 107                 (gen-mpz :limbs limbs :sign t)
 108                 (gen-mpz :limbs limbs :sign t)))
 109
 110 (define-gmp-test (mpz-tdiv :repeat 7 :limbs (+ (random #x253F) 2))
 111   (test-n-cases 'truncate 'mpz-tdiv
 112                 (gen-mpz :limbs limbs :sign t)
 113                 (gen-mpz :limbs limbs :sign t :nonzero t)))
 114
 115 (define-gmp-test (mpz-fdiv :repeat 7 :limbs (+ (random #x253F) 2))
 116   (test-n-cases 'floor 'mpz-fdiv
 117                 (gen-mpz :limbs limbs :sign t)
 118                 (gen-mpz :limbs limbs :sign t :nonzero t)))
 119
 120 (define-gmp-test (mpz-cdiv :repeat 7 :limbs (+ (random #x253F) 2))
 121   (test-n-cases 'ceiling 'mpz-cdiv
 122                 (gen-mpz :limbs limbs :sign t)
 123                 (gen-mpz :limbs limbs :sign t :nonzero t)))
 124
 125 (define-gmp-test (mpz-gcd :repeat 7 :limbs (+ (random #x253F) 2))
 126   (test-n-cases 'gcd 'mpz-gcd
 127                 (gen-mpz :limbs limbs :sign t)
 128                 (gen-mpz :limbs limbs :sign t)))
 129
 130 (define-gmp-test (mpz-lcm :repeat 7 :limbs (+ (random #x253F) 2))
 131   (test-n-cases 'lcm 'mpz-lcm
 132                 (gen-mpz :limbs limbs :sign t)
 133                 (gen-mpz :limbs limbs :sign t)))
 134
 135 (define-gmp-test (isqrt :repeat 7 :limbs (+ (random #x253F) 2))
 136   (test-n-cases 'isqrt 'mpz-sqrt (gen-mpz :limbs limbs)))
 137
 138 (define-gmp-test (mpz-mod :repeat 7 :limbs (1+ (random #x253F)))
 139   (test-n-cases 'mod 'mpz-mod
 140                 (gen-mpz :limbs limbs :sign t)
 141                 (gen-mpz :limbs limbs :sign t :nonzero t)))
 142
 143 (define-gmp-test (mpz-powm :repeat 7 :limbs (1+ (random #x253F)))
 144   (test-n-cases (lambda (base exponent mod)
 145                   (let ((*gmp-disabled* nil)) ; atrociously slow otherwise
 146                     (mod (expt base exponent) mod)))
 147                 'mpz-powm
 148                 (gen-mpz :limbs limbs :sign t)
 149                 (lambda ()
 150                   (1+ (random 40)))
 151                 (gen-mpz :limbs (ceiling limbs 2) :nonzero t)))
 152
 153 ;; bugs that have been fixed
 154 (define-gmp-test (sign-conversion)
 155   (test-one-case '+ 'mpz-add #x7FFFFFFFFFFFFFFF #x7FFFFFFFFFFFFFFF))
 156 (define-gmp-test (truncate-1)
 157   (test-one-case 'truncate 'mpz-tdiv
 158                  30951488519636377404900619671461408624764773310745985021994671444676860083493
 159                  200662724990805535745252242839121922075))
 160 (define-gmp-test (truncate-2)
 161   (test-one-case 'truncate 'mpz-tdiv
 162                  320613729464106236061704728914573914390
 163                  -285049280629101090500613812618405407883))
 164
 165 (define-gmp-test (mpz-nextprime :repeat 7
 166                                 :gmp-seed 6234
 167                                 :limbs (1+ (random #x2F)))
 168   (let ((a (gen-mpz :limbs limbs)))
 169     (dotimes (i *iteration-count*)
 170       (let* ((a (funcall a))
 171              (p (mpz-nextprime a)))
 172         (assert (>= p a))
 173         (assert (plusp (mpz-probably-prime-p p)))))))
 174
 175 (define-gmp-test (mpq-add :repeat 7 :limbs (1+ (random #x3FF))
 176                           :gmp-seed 1235)
 177   (test-n-cases '+ 'mpq-add
 178                 (gen-mpq :limbs limbs :sign t)
 179                 (gen-mpq :limbs limbs :sign t)))
 180
 181 (define-gmp-test (mpq-sub :repeat 7 :limbs (1+ (random #x1FF))
 182                           :gmp-seed 1235)
 183   (test-n-cases '- 'mpq-sub
 184                 (gen-mpq :limbs limbs :sign t)
 185                 (gen-mpq :limbs limbs :sign t)))
 186
 187 (define-gmp-test (mpq-mul :repeat 7 :limbs (1+ (random #x5FF))
 188                           :gmp-seed 6235)
 189   (test-n-cases '* 'mpq-mul
 190                 (gen-mpq :limbs limbs :sign t)
 191                 (gen-mpq :limbs limbs :sign t)))
 192
 193 (define-gmp-test (mpq-div :repeat 7 :limbs (1+ (random #x3FF))
 194                           :gmp-seed 7235)
 195   (test-n-cases '/ 'mpq-div
 196                 (gen-mpq :limbs limbs :sign t)
 197                 (gen-mpq :limbs limbs :sign t)))
 198
 199 (define-gmp-test (pow)
 200   (test-one-case 'expt 'mpz-pow
 201                  16 3))