Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

Diff of /contrib/sb-gmp/tests.lisp [000000] .. [1656e5] Maximize Restore

  Switch to unified view

a b/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)))