cgit.sxemacs.org Git - sxemacs/blob - tests/automated/ent-tests.el

   1 ;;;  ent-tests.el -- Tests for Enhanced Number Types
   2 ;; Copyright (C) 2005 Sebastian Freundt
   3 ;;
   4 ;; Author: Sebastian Freundt <hroptatyr@sxemacs.org>
   5 ;; Keywords: tests
   6 ;;
   7 ;; This file is part of SXEmacs.
   8 ;;
   9 ;; SXEmacs is free software: you can redistribute it and/or modify it
  10 ;; under the terms of the GNU General Public License as published by the
  11 ;; Free Software Foundation, either version 3 of the License, or (at your
  12 ;; option) any later version.
  13
  14 ;; SXEmacs is distributed in the hope that it will be
  15 ;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21 ;;
  22 ;;; Synched up with: Not in FSF.
  23 ;;
  24 ;;; Commentary:
  25 ;; - test for conceptionally correct arithmetic
  26 ;; See test-harness.el for instructions on how to run these tests.
  27
  28 (eval-when-compile
  29   (condition-case nil
  30       (require 'test-harness)
  31     (file-error
  32      (push "." load-path)
  33      (when (and (boundp 'load-file-name) (stringp load-file-name))
  34        (push (file-name-directory load-file-name) load-path))
  35      (require 'test-harness))))
  36
  37 ;;-----------------------------------------------------
  38 ;; Test categories
  39 ;;-----------------------------------------------------
  40
  41 ;;; test simple syntaxes
  42 ;; this tests for `1' being read and coerced to a fixnum
  43 (let ((num 1))
  44   (Assert (intp num))
  45   (Assert (not (floatp num)))
  46   (Assert (integerp num))
  47   (Assert (rationalp num))
  48   (Assert (not (realp num)))
  49   (Assert (comparablep num))
  50   (Assert (not (complexp num)))
  51   (Assert (archimedeanp num))
  52   (Assert (numberp num))
  53
  54   (when (featurep 'bigz)
  55     (Assert (not (bigzp num))))
  56   (when (featurep 'bigq)
  57     (Assert (not (bigqp num))))
  58   (when (featurep 'bigf)
  59     (Assert (not (bigfp num))))
  60   (when (featurep 'bigfr)
  61     (Assert (not (bigfrp num))))
  62   (when (featurep 'bigg)
  63     (Assert (not (biggp num))))
  64   (when (featurep 'bigc)
  65     (Assert (not (bigcp num)))))
  66
  67
  68 ;; this tests for `1/2' being read and coerced to a fraction
  69 (when (featurep 'bigq)
  70   (let ((num 1/2))
  71     (Assert (not (intp num)))
  72     (Assert (not (floatp num)))
  73     (Assert (not (integerp num)))
  74     (Assert (rationalp num))
  75     (Assert (not (realp num)))
  76     (Assert (comparablep num))
  77     (Assert (not (complexp num)))
  78     (Assert (archimedeanp num))
  79     (Assert (numberp num))
  80
  81     (when (featurep 'bigz)
  82       (Assert (not (bigzp num))))
  83     (when (featurep 'bigq)
  84       (Assert (bigqp num)))
  85     (when (featurep 'bigf)
  86       (Assert (not (bigfp num))))
  87     (when (featurep 'bigfr)
  88       (Assert (not (bigfrp num))))
  89     (when (featurep 'bigg)
  90       (Assert (not (biggp num))))
  91     (when (featurep 'bigc)
  92       (Assert (not (bigcp num))))))
  93
  94
  95 ;; this tests for `1.0' being read and coerced to a float
  96 (let* ((read-real-as 'float)
  97        (num 1.0))
  98   (Assert (not (intp num)))
  99   (Assert (floatp num))
 100   (Assert (not (integerp num)))
 101   (Assert (not (rationalp num)))
 102   (Assert (realp num))
 103   (Assert (comparablep num))
 104   (Assert (not (complexp num)))
 105   (Assert (archimedeanp num))
 106   (Assert (numberp num))
 107
 108   (when (featurep 'bigz)
 109     (Assert (not (bigzp num))))
 110   (when (featurep 'bigq)
 111     (Assert (not (bigqp num))))
 112   (when (featurep 'bigf)
 113     (Assert (not (bigfp num))))
 114   (when (featurep 'bigfr)
 115     (Assert (not (bigfrp num))))
 116   (when (featurep 'bigg)
 117     (Assert (not (biggp num))))
 118   (when (featurep 'bigc)
 119     (Assert (not (bigcp num)))))
 120
 121
 122 ;; this tests for `1+i' being read and coerced to a Gaussian, if provided
 123 (when (featurep 'bigg)
 124   (let ((num 1+i))
 125     (Assert (not (intp num)))
 126     (Assert (not (floatp num)))
 127     (Assert (not (integerp num)))
 128     (Assert (not (rationalp num)))
 129     (Assert (not (realp num)))
 130     (Assert (not (comparablep num)))
 131     (Assert (complexp num))
 132     (Assert (archimedeanp num))
 133     (Assert (numberp num))
 134
 135     (when (featurep 'bigz)
 136       (Assert (not (bigzp num))))
 137     (when (featurep 'bigq)
 138       (Assert (not (bigqp num))))
 139     (when (featurep 'bigf)
 140       (Assert (not (bigfp num))))
 141     (when (featurep 'bigfr)
 142       (Assert (not (bigfrp num))))
 143     (Assert (biggp num))
 144     (when (featurep 'bigc)
 145       (Assert (not (bigcp num))))))
 146
 147
 148 ;; this tests for `1.0+0.0i' being read and coerced to a bigc if provided
 149 (when (featurep 'bigc)
 150   (let ((num 1.0+0.0i))
 151     (Assert (not (intp num)))
 152     (Assert (not (floatp num)))
 153     (Assert (not (integerp num)))
 154     (Assert (not (rationalp num)))
 155     (Assert (not (realp num)))
 156     (Assert (not (comparablep num)))
 157     (Assert (complexp num))
 158     (Assert (archimedeanp num))
 159     (Assert (numberp num))
 160
 161     (when (featurep 'bigz)
 162       (Assert (not (bigzp num))))
 163     (when (featurep 'bigq)
 164       (Assert (not (bigqp num))))
 165     (when (featurep 'bigf)
 166       (Assert (not (bigfp num))))
 167     (when (featurep 'bigfr)
 168       (Assert (not (bigfrp num))))
 169     (when (featurep 'bigg)
 170       (Assert (not (biggp num))))
 171     (Assert (bigcp num))))
 172
 173
 174 ;;-----------------------------------------------------
 175 ;; Testing coercions
 176 ;;-----------------------------------------------------
 177 (when (featurep 'bigz)
 178   (Assert (bigzp (coerce-number 0 'bigz)))
 179   (Assert (bigzp (coerce-number 1 'bigz)))
 180   (Assert (and (bigzp (factorial 100))
 181                (bigzp (coerce-number (factorial 100) 'bigz))))
 182   (Assert (bigzp (coerce-number 1.0 'bigz)))
 183   (Assert (intp (coerce-number (factorial 100) 'int)))
 184   (Assert (zerop (coerce-number (factorial 100) 'int)))
 185   (Assert (let ((more-than-mpf (1+ most-positive-fixnum)))
 186             (equal (coerce-number more-than-mpf 'float)
 187                    (1+ (coerce-number most-positive-fixnum 'float))))))
 188
 189 (when (featurep 'bigq)
 190   (Assert (bigqp (coerce-number 0 'bigq)))
 191   (Assert (bigqp (coerce-number 1 'bigq)))
 192   (Assert (and (bigqp 3/2)
 193                (bigqp (coerce-number 3/2 'bigq))))
 194   (Assert (bigqp (coerce-number 1.5 'bigq)))
 195   (Assert (intp (coerce-number 3/2 'int)))
 196   (Assert (bigzp (coerce-number 3/2 'bigz)))
 197   (Assert (bigqp (// 2)))
 198   (Assert (bigqp (// 2 3)))
 199   (Assert (intp (// 4 2)))
 200   (when (featurep 'bigz)
 201     (Assert (bigzp (numerator 3/2)))
 202     (Assert (bigzp (denominator 3/2)))))
 203
 204 (when (and (featurep 'bigg)
 205            (featurep 'bigc))
 206   (Assert (biggp (coerce-number 1.0+2.0i 'bigg)))
 207   (Assert (bigcp (coerce-number 1+2i 'bigc))))
 208
 209
 210
 211 ;;-----------------------------------------------------
 212 ;; Testing auto-coercion in operations
 213 ;;-----------------------------------------------------
 214 (when (featurep 'bigz)
 215   (let ((num1 2)
 216         (num2 2.0))
 217     ;; this test should reveal re-canonicalisation
 218     (eval `(Assert (intp (+ ,num1 (coerce-number ,num1 'bigz)))))
 219     (eval `(Assert (intp (* ,num1 (coerce-number ,num1 'bigz)))))
 220     (eval `(Assert (intp (- ,num1 (coerce-number ,num1 'bigz)))))
 221     (eval `(Assert (intp (/ ,num1 (coerce-number ,num1 'bigz)))))
 222     (eval `(Assert (intp (^ ,num1 (coerce-number ,num1 'bigz)))))
 223     (eval `(Assert (intp (+ (coerce-number ,num1 'bigz) ,num1))))
 224     (eval `(Assert (intp (* (coerce-number ,num1 'bigz) ,num1))))
 225     (eval `(Assert (intp (- (coerce-number ,num1 'bigz) ,num1))))
 226     (eval `(Assert (intp (/ (coerce-number ,num1 'bigz) ,num1))))
 227     (eval `(Assert (intp (^ (coerce-number ,num1 'bigz) ,num1))))
 228     ;; floats and bigz should always result in a float
 229     (eval `(Assert (floatp (+ ,num2 (coerce-number ,num1 'bigz)))))
 230     (eval `(Assert (floatp (* ,num2 (coerce-number ,num1 'bigz)))))
 231     (eval `(Assert (floatp (- ,num2 (coerce-number ,num1 'bigz)))))
 232     (eval `(Assert (floatp (/ ,num2 (coerce-number ,num1 'bigz)))))
 233 ;;     (when (featurep 'bigfr)
 234 ;;       (eval `(Assert (bigfrp (^ ,num2 (coerce-number ,num1 'bigz))))))
 235     (eval `(Assert (floatp (+ (coerce-number ,num1 'bigz) ,num2))))
 236     (eval `(Assert (floatp (* (coerce-number ,num1 'bigz) ,num2))))
 237     (eval `(Assert (floatp (- (coerce-number ,num1 'bigz) ,num2))))
 238     (eval `(Assert (floatp (/ (coerce-number ,num1 'bigz) ,num2))))
 239     ))
 240
 241 ;;-----------------------------------------------------
 242 ;; Testing selectors and constructors
 243 ;;-----------------------------------------------------
 244 (when (featurep 'bigg)
 245   (let ((read-real-as 'bigfr)
 246         (default-real-precision 128))
 247
 248     ;; testing bigg selector
 249     (Assert-Not-Equal (real-part (read "2+3i")) 2)
 250     (Assert-Not-Equal (imaginary-part (read "2+3i")) 3)
 251     (Assert-Not-Equal (real-part 2+3i) 2)
 252     (Assert-Not-Equal (imaginary-part 2+3i) 3)
 253     (Assert-Equal (real-part (read "2+3i")) (bigz 2))
 254     (Assert-Equal (imaginary-part (read "2+3i")) (bigz 3))
 255     (Assert-Equal (real-part 2+3i) (bigz 2))
 256     (Assert-Equal (imaginary-part 2+3i) (bigz 3))
 257     ;; use numerical equality
 258     (Assert (= (real-part (read "2+3i")) 2))
 259     (Assert (= (imaginary-part (read "2+3i")) 3))
 260     (Assert (= (real-part 2+3i) 2))
 261     (Assert (= (imaginary-part 2+3i) 3))
 262     (Assert (= (real-part (read "2+3i")) (bigz 2)))
 263     (Assert (= (imaginary-part (read "2+3i")) (bigz 3)))
 264     (Assert (= (real-part 2+3i) (bigz 2)))
 265     (Assert (= (imaginary-part 2+3i) (bigz 3)))
 266
 267     ;; testing bigg constructor
 268     (Assert-Not-Equal (real-part (make-bigg 1 2)) 1)
 269     (Assert-Not-Equal (imaginary-part (make-bigg 1 2)) 2)
 270     (Assert-Equal (real-part (make-bigg 1 2)) (bigz 1))
 271     (Assert-Equal (imaginary-part (make-bigg 1 2)) (bigz 2))
 272     (Assert (= (real-part (make-bigg 1 2)) 1))
 273     (Assert (= (imaginary-part (make-bigg 1 2)) 2))
 274
 275     ;; compare reader and constructor
 276     (Assert-Equal (make-bigg 1.0 2.0) (read "1+2i"))
 277     (Assert-Equal (make-bigg 1 2) (read "1+2i"))
 278     (Assert (and (= (real-part (make-bigg 1.0 2.0))
 279                     (real-part (read "1+2i")))
 280                  (= (imaginary-part (make-bigg 1.0 2.0))
 281                     (imaginary-part (read "1+2i")))))
 282     (Assert (and (= (real-part (make-bigg 1 2))
 283                     (real-part (read "1+2i")))
 284                  (= (imaginary-part (make-bigg 1 2))
 285                     (imaginary-part (read "1+2i")))))))
 286
 287 (when (featurep 'bigc)
 288   (let ((read-real-as 'bigfr)
 289         (default-real-precision 128))
 290
 291     ;; testing bigc selector
 292     (Assert-Equal (real-part (read "2.3+3.2i"))
 293                    (read "2.3"))
 294     (Assert-Equal (imaginary-part (read "2.3+3.2i"))
 295                    (read "3.2"))
 296     ;; use numerical equality
 297     (Assert (= (real-part (read "2.3+3.2i"))
 298                (read "2.3")))
 299     (Assert (= (imaginary-part (read "2.3+3.2i"))
 300                (read "3.2")))
 301
 302     ;; testing bigc constructor
 303     (Assert-Not-Equal (real-part (make-bigc 1 2)) 1)
 304     (Assert-Not-Equal (imaginary-part (make-bigc 1 2)) 2)
 305     (Assert-Equal (real-part (make-bigc 1 2)) (bigfr 1))
 306     (Assert-Equal (imaginary-part (make-bigc 1 2)) (bigfr 2))
 307     (Assert (= (real-part (make-bigc 1 2)) 1))
 308     (Assert (= (imaginary-part (make-bigc 1 2)) 2))
 309
 310     ;; now compare reader and constructor
 311     (Assert-Equal (make-bigc 1.0 2.0) (read "1.0+2.0i"))
 312     (Assert-Equal (make-bigc 1 2) (read "1.0+2.0i"))
 313     (Assert (and (= (real-part (make-bigc 1.0 2.0))
 314                     (real-part (read "1.0+2.0i")))
 315                  (= (imaginary-part (make-bigc 1.0 2.0))
 316                     (imaginary-part (read "1.0+2.0i")))))
 317     (Assert (and (= (real-part (make-bigc 1 2))
 318                     (real-part (read "1.0+2.0i")))
 319                  (= (imaginary-part (make-bigc 1 2))
 320                     (imaginary-part (read "1.0+2.0i")))))))
 321
 322
 323
 324
 325 ;;-----------------------------------------------------
 326 ;; Testing formatting output
 327 ;;-----------------------------------------------------
 328
 329 (Assert-Equal (format "%d" 2) "2")
 330 (Assert-Equal (format "%d" -2) "-2")
 331 (Assert-Equal (format "%2.2E" -2) "-2.00E+00")
 332
 333 (Assert-Equal (format "%x" 100) "64")
 334 (Assert-Equal (format "%#x" 100) "0x64")
 335 (Assert-Equal (format "%X" 122) "7A")
 336 (Assert-Equal (format "%.4X" 122) "007A")
 337 (Assert-Equal (format "%4o" 100) " 144")
 338 (Assert-Equal (format "%x" 10.58) "a")
 339 (Assert-Equal (format "%o" 10.58) "12")
 340 (Assert-Equal (format "%#o" 10.58) "0o12")
 341
 342 ;; floats
 343 (let ((forms
 344        '(1.0 1.00000 0.5 0.005 5.000005 4.0625 8.03125
 345              9876.54321 10000.00001 12004.40021
 346              1.5e+10 1.125e+11 1.0703125e+12
 347              1.1e+15 1.2e+16 1.4e+20 1.45e+24
 348              1.52e+28 1.55e+30 1.52105432e+31 1.5445633221e+32
 349              1.7777777777777e+33 1.7777777777777776e+33
 350              1.8999999999999e+33 1.999989999999999e+33
 351              1.99999999e+35 1.9999999999e+36 1.999999999999e+37
 352              1.99999999999999e+38 1.999999999999999e+39
 353              1.9999999999999999e+40 2.000000000000000000e+40
 354              2.000000000000001e+42 2.000000000000009e+44
 355              2.002000200002000002000000e+48
 356              2.000000200000200002000200e+50
 357              200000020000020000200020.0e+50
 358              12345555555555555555.999999999e+60
 359              12344444444444444444.999999999e+60
 360              1234545454545454545454545454545.000
 361              123454545454545454545454545454545454545454545.000
 362              4444444444444.55555555555e+100
 363              5555555555555.55555555555e+102
 364              5555555555555.44444444444e+104
 365              5555555555555.99999999998e+106
 366              50505050505050505050505.0e+200
 367              1e+300 1e+301 1e+302 -1e+300 -1e+301 -1e+302
 368              1e+304 -1e+304 1e+305 -1e+305 1e+306 -1e+306
 369              1e+307 2e+307 8e+307 -8e+307
 370              1e+308 -1e+308 8e+308 -8e+308
 371              1e+309 -1e+309 -8e+309 8e+309
 372              ;; we should be outta range of double floats
 373              1.00e+310 2.50e+310 2.55e+310
 374              2.125e+312 2.0004500045e+313 1.2e+314 1.2e+320
 375              1.22229e+320 100e+320 101e+321 102e+322
 376              ;; we're still alive?
 377              most-positive-float most-negative-float
 378              ;; the following two may not work correctly if the number
 379              ;; distribution has many subnormal numbers
 380              ;;(1+ most-positive-float) (1- most-negative-float)
 381              ;;(1- most-positive-float) (1+ most-negative-float)
 382              1.0e+340 1.0e+350 1.0e+380 1.0e+400
 383              1.2e+300 1.2e+310 1.2e+320 1.2e+400
 384              1.2e+2000 1.2e+3000 1.2e+4000 1.2e+5000))
 385        (failures
 386         ;; known errors (due to precision issues, not SXE's fault)
 387         '(1e-300 1e-301 1e-302 1e-303 1e-304 1e-305 1e-306
 388                  1e-307 1e-308 1e-309
 389                  2.5e-310 2.55e-311 2.55e-312
 390                  1.2e-320 1.201e-320 1.25e-320
 391                  1.22229e-320 100e-306 100e-307 100e-308 100e-309
 392                  100e-310 100e-311 100e-312 100e-313 100e-314 100e-315
 393                  100e-316 100e-317 100e-318 100e-319 100e-320 100e-321
 394                  100e-322 100e-323 100e-324 100e-325 100e-326 100e-327
 395                  100e-328 100e-329 100e-330 1.2e-330 1.25e-330
 396                  0.5e-306 0.5e-307 0.5e-308 0.5e-309 0.5e-310 0.5e-311
 397                  0.5e-312 0.5e-313 0.5e-314 0.5e-315 0.5e-316 0.5e-317
 398                  0.5e-318 0.5e-319 0.5e-320 0.5e-321 0.5e-322 0.5e-323)))
 399   (mapc-internal
 400    #'(lambda (str)
 401        (unless (or (infinityp (eval str)) (zerop (eval str)))
 402          (eval `(Assert (= (read (format "%f" ,str)) ,str)))
 403          (eval `(Assert (eql (read (format "%f" ,str)) ,str)))))
 404    forms)
 405   (mapc-internal
 406    #'(lambda (str)
 407        (unless (or (infinityp (eval str)) (zerop (eval str)))
 408          (eval `(Assert (not (= (read (format "%f" ,str)) ,str))))
 409          (eval `(Assert (not (eql (read (format "%f" ,str)) ,str))))))
 410    failures))
 411
 412 ;; now testing bigz formatting
 413 (when (featurep 'bigz)
 414   (let ((forms
 415          '((("%Z" 2) . "2")
 416            (("%2Z" 2) . " 2")
 417            (("%2Z" 200) . "200")
 418            (("%+Z" 2) . "+2")
 419            (("%+4Z" 2) . "  +2")
 420            (("% Z" 2) . " 2")
 421            (("%Z" -2) . "-2")
 422            (("% Z" -2) . "-2")
 423            (("%+Z" -2) . "-2")
 424            (("%-4Z" 2) . "2   ")
 425            (("%.2Z" 2) . "02")
 426            (("%4.2Z" 2) . "  02")
 427            (("%04.2Z" 2) . "  02")
 428            (("%-4.2Z" 2) . "02  ")
 429            (("%0-4.2Z" 2) . "02  ")
 430            (("%Z" (factorial 20)) .
 431             "2432902008176640000")
 432            (("%40Z" (factorial 20)) .
 433             "                     2432902008176640000")
 434            (("%-40Z" (factorial 20)) .
 435             "2432902008176640000                     ")
 436            (("%.40Z" (factorial 20)) .
 437             "0000000000000000000002432902008176640000")
 438            (("%040Z" (factorial 20)) .
 439             "0000000000000000000002432902008176640000")
 440            (("%.8Z" (factorial 20)) .
 441             "2432902008176640000")
 442            (("%08Z" (factorial 20)) .
 443             "2432902008176640000")
 444            (("%24.8Z" (factorial 20)) .
 445             "     2432902008176640000")
 446            (("%36.28Z" (factorial 20)) .
 447             "        0000000002432902008176640000")
 448            (("%036.28d" (factorial 20)) .
 449             "        0000000002432902008176640000")
 450            (("%0-36.28d" (factorial 20)) .
 451             "0000000002432902008176640000        ")
 452
 453            ;; now the same with the %d specifier
 454            (("%d" 2) . "2")
 455            (("%2d" 2) . " 2")
 456            (("%2d" 200) . "200")
 457            (("%+d" 2) . "+2")
 458            (("%+4d" 2) . "  +2")
 459            (("% d" 2) . " 2")
 460            (("%d" -2) . "-2")
 461            (("% d" -2) . "-2")
 462            (("%+d" -2) . "-2")
 463            (("%-4d" 2) . "2   ")
 464            (("%.2d" 2) . "02")
 465            (("%4.2d" 2) . "  02")
 466            (("%04.2d" 2) . "  02")
 467            (("%-4.2d" 2) . "02  ")
 468            (("%0-4.2d" 2) . "02  ")
 469            (("%d" (factorial 20)) . "2432902008176640000")
 470            (("%40d" (factorial 20)) .
 471             "                     2432902008176640000")
 472            (("%-40d" (factorial 20)) .
 473             "2432902008176640000                     ")
 474            (("%.40d" (factorial 20)) .
 475             "0000000000000000000002432902008176640000")
 476            (("%040d" (factorial 20)) .
 477             "0000000000000000000002432902008176640000")
 478            (("%.8d" (factorial 20)) . "2432902008176640000")
 479            (("%24.8d" (factorial 20)) . "     2432902008176640000")
 480            (("%36.28d" (factorial 20)) .
 481             "        0000000002432902008176640000")
 482            (("%036.28d" (factorial 20)) .
 483             "        0000000002432902008176640000")
 484            (("%0-36.28d" (factorial 20)) .
 485             "0000000002432902008176640000        ")
 486
 487            ;; testing base converters on big ints
 488            ;; moved to format-tests
 489            )))
 490
 491     (mapc #'(lambda (f)
 492               (let ((format (cons 'format (car f)))
 493                     (expected (cdr f)))
 494                 (eval `(Assert (string= ,format ,expected)))))
 495           forms)))
 496
 497
 498 ;; now testing bigq formatting
 499 (when (featurep 'bigq)
 500   (let ((forms
 501          '((("%Q" 2) . "2")
 502            (("%2Q" 2) . " 2")
 503            (("%2Q" 200) . "200")
 504            (("%+Q" 2) . "+2")
 505            (("% Q" 2) . " 2")
 506            (("% +Q" 2) . "+2")
 507            (("%+ Q" 2) . "+2")
 508            (("%Q" -2) . "-2")
 509            (("% Q" -2) . "-2")
 510            (("%+Q" -2) . "-2")
 511            (("% +Q" -2) . "-2")
 512            (("%+ Q" -2) . "-2")
 513            (("%-4Q" 2) . "2   ")
 514            (("%.2Q" 2) . "2")
 515            (("%4.2Q" 2) . "   2")
 516            (("%-4.2Q" 2) . "2   ")
 517
 518            ;; testing with proper fractions
 519            (("%Q" 2/3) . "2/3")
 520            (("%5Q" 2/3) . "  2/3")
 521            (("%5.5Q" 2/3) . "  2/3")
 522            (("%+Q" 2/3) . "+2/3")
 523            (("% Q" 2/3) . " 2/3")
 524            (("% +Q" 2/3) . "+2/3")
 525            (("%+ Q" 2/3) . "+2/3")
 526            (("%Q" (float 1.5)) . "3/2")
 527            (("%Q" (float 0.66666)) . "3002369727582815/4503599627370496")
 528            (("%-10Q" 2/3) . "2/3       ")
 529
 530            ;; testing coercion to Z
 531            (("%d" 4/3) . "1")
 532            (("%Z" 2/3) . "0"))))
 533
 534     (mapc #'(lambda (f)
 535               (let ((format (cons 'format (car f)))
 536                     (expected (cdr f)))
 537                 (eval `(Assert (string= ,format ,expected)))))
 538           forms)))
 539
 540
 541 (when (featurep 'bigfr)
 542   (let ((forms
 543          '((("%f" (exp 1)) . "2.718282")
 544            (("%2.2f" (exp 1)) . "2.72")
 545            ;; this test uses a wrong output string deliberately
 546            ;; it's wrong because the precision of IEEE-754 doubles is
 547            ;; not enough to have 20 correct digits in the fractional part
 548            ;; however, since we _can_ have long doubles now, this test
 549            ;; is no longer feasible since lisp should know a shit about
 550            ;; the internal representation of fpfloats. -hroptatyr
 551            ;;(("%2.20f" (exp 1)) . "2.71828182845904509080")
 552
 553            ;; now testing with %F
 554            (("%F" (exp 1)) . "2.718281828459045235360287471352662497759")
 555            (("%2.2F" (exp 1)) . "2.71")
 556            (("%+2.2F" (exp 1)) . "+2.71")
 557            (("%10.0F" (exp 1)) . "         2")
 558            (("%10.1F" (exp 1)) . "       2.7")
 559            (("%12.12F" (exp 1)) . "2.718281828459")
 560            (("%30.12F" (exp 1)) . "                2.718281828459")
 561            (("%5.5F" (exp 13)) . "442413.39200")
 562            (("%F" (/ (exp 1))) .
 563             "0.3678794411714423215955237701614608674462")
 564            (("%2.2F" (/ (exp 1))) . "0.36")
 565            (("%3.3F" (/ (exp 1))) . "0.367")
 566            (("%.5F" (bigfr 1)) . "1.00000")
 567
 568            (("%.4F" (bigfr 23213231 25)) . "23213231.0000")
 569            ;; stupid assumption
 570            ;;(("%.4F" (bigfr 23213231 8)) . "23200000.0000")
 571            (("%Z" (bigfr 23213231 25)) . "23213231")
 572            (("%Z" (bigfr 23213231 8)) . "23199744")
 573
 574            (("%+.4f" 2) . "+2.0000")
 575            (("%+.4F" 2) . "+2.0000")
 576            (("% .4F" 2) . " 2.0000")
 577            (("%+10.4F" 2) . "   +2.0000")))
 578         (default-real-precision 128))
 579
 580     (mapc #'(lambda (f)
 581               (let ((format (cons 'format (car f)))
 582                     (expected (cdr f)))
 583                 (eval `(Assert (string= ,format ,expected)))))
 584           forms)))
 585
 586 (when (featurep 'bigg)
 587   (let ((forms
 588          '((("%B" 2+i) . "2+1i")
 589            (("%+B" 2+i) . "+2+1i")
 590            (("% B" 2+i) . " 2+1i")
 591            (("%B" 2+i) .
 592             (format "%Z%+Zi" (real-part 2+i) (imaginary-part 2+i)))
 593            (("%B" 1) . "1+0i")
 594            (("%+10.4B" 1.2) . "     +0001     +0000i")
 595            (("%-10.4B" 0+2i) . "0000      +0002     i"))))
 596
 597     (mapc #'(lambda (f)
 598               (let ((format (cons 'format (car f)))
 599                     (expected (cdr f)))
 600                 (eval `(Assert (string= ,format ,expected)))))
 601           forms))
 602
 603   ;; Gaussian numbers shall not be coerced to comparables
 604   (Check-Error domain-error (format "%d" 1+i))
 605   (Check-Error domain-error (format "%f" 1+i))
 606   (when (featurep 'bigq)
 607     (Check-Error domain-error (format "%Q" 1+i)))
 608   (when (featurep 'bigfr)
 609     (Check-Error domain-error (format "%F" 1+i))))
 610
 611
 612 (when (featurep 'bigc)
 613   (let ((forms
 614          '((("%.2C" 2+i) . "2.00+1.00i")
 615            (("%+.2C" 2+i) . "+2.00+1.00i")
 616            (("% .2C" 2+i) . " 2.00+1.00i")
 617            (("%.2C" 2+i) .
 618             (format "%.2F%+.2Fi" (real-part 2+i) (imaginary-part 2+i)))
 619            (("%.2C" 1) . "1.00+0.00i")
 620            (("%+10.4C" 1.5) . "   +1.5000   +0.0000i")
 621            (("%-10.4C" 0+2i) . "0.0000    +2.0000   i"))))
 622
 623     (mapc #'(lambda (f)
 624               (let ((format (cons 'format (car f)))
 625                     (expected (cdr f)))
 626                 (eval `(Assert (string= ,format ,expected)))))
 627           forms))
 628
 629   ;; complex numbers shall not be coerced to comparables
 630   (Check-Error domain-error (format "%d" (sqrt -2)))
 631   (Check-Error domain-error (format "%f" (sqrt -2)))
 632   (when (featurep 'bigq)
 633     (Check-Error domain-error (format "%Q" (sqrt -2))))
 634   (when (featurep 'bigfr)
 635     (Check-Error domain-error (format "%F" (sqrt -2)))))
 636
 637
 638 ;;-----------------------------------------------------
 639 ;; Test arithmetic
 640 ;;-----------------------------------------------------
 641 (when (featurep 'bigz)
 642   ;;; addition
 643   (let ((sums '((1 2 3)
 644                 (12332112344321 10000000000000 22332112344321)
 645                 (12332112344321 1 12332112344322)
 646                 (1 12332112344321 12332112344322)
 647                 (10101010101010 1010101010101 11111111111111)
 648                 (-10101010101010 10101010101010 0)))
 649         (prods '((2 3 6)
 650                  (1002004002001 402010204 402815833253238418204)
 651                  (-1002004002001 402010204 -402815833253238418204)))
 652         (pows-!clslash
 653          '((2 2 4)
 654            (-4 4 256)
 655            (-4 5 -1024)
 656            (32 32 1461501637330902918203684832716283019655932542976)
 657            (32 -32 0)))
 658         (pows-clslash
 659          (when (featurep 'bigq)
 660            '((2 2 4)
 661              (-4 4 256)
 662              (-4 5 -1024)
 663              (32 32 1461501637330902918203684832716283019655932542976)
 664              (32 -32 1/1461501637330902918203684832716283019655932542976)))))
 665     (mapc #'(lambda (sum)
 666               (eval `(Assert (= (+ ,(car sum) ,(cadr sum)) ,(caddr sum))))
 667               (eval `(Assert (= (- ,(caddr sum) ,(cadr sum)) ,(car sum))))
 668               (unless (bigzp (caddr sum))
 669                 (eval `(Assert (= (bigz (+ (bigz ,(car sum))
 670                                            (bigz ,(cadr sum))))
 671                                   (bigz ,(caddr sum)))))
 672                 (eval `(Assert (= (bigz (- (bigz ,(caddr sum))
 673                                            (bigz ,(cadr sum))))
 674                                   (bigz ,(car sum)))))
 675                 ;; testing triangle inequality
 676                 ;; | a + b | <= |a| + |b|
 677                 (eval `(Assert (<= (abs (+ ,(car sum) ,(cadr sum)))
 678                                    (+ (abs ,(car sum)) (abs ,(cadr sum))))))))
 679           sums)
 680     (mapc #'(lambda (prod)
 681               (eval `(Assert (= (* ,(car prod) ,(cadr prod)) ,(caddr prod))))
 682               (eval `(Assert (= (/ ,(caddr prod) ,(cadr prod)) ,(car prod))))
 683               (unless (bigzp (caddr prod))
 684                 (eval `(Assert (= (bigz (* (bigz ,(car prod))
 685                                            (bigz ,(cadr prod))))
 686                                   (bigz ,(caddr prod)))))
 687                 (eval `(Assert (= (bigz (/ (bigz ,(caddr prod))
 688                                            (bigz ,(cadr prod))))
 689                                   (bigz ,(car prod)))))
 690                 ;; testing multiplicativiy of abs
 691                 ;; | a b | = |a| |b|
 692                 (eval `(Assert (= (abs (* ,(car prod) ,(cadr prod)))
 693                                   (* (abs ,(car prod)) (abs ,(cadr prod))))))))
 694           prods)
 695     (let ((common-lisp-slash nil))
 696       (mapc #'(lambda (pow)
 697                 (eval `(Assert (= (^ ,(car pow) ,(cadr pow)) ,(caddr pow))))
 698                 (unless (bigzp (caddr pow))
 699                   (eval `(Assert (= (bigz (^ (bigz ,(car pow))
 700                                              (bigz ,(cadr pow))))
 701                                     (bigz ,(caddr pow)))))))
 702             pows-!clslash))
 703     (let ((common-lisp-slash t))
 704       (mapc #'(lambda (pow)
 705                 (eval `(Assert (= (^ ,(car pow) ,(cadr pow)) ,(caddr pow))))
 706                 (unless (bigzp (caddr pow))
 707                   (eval `(Assert (= (bigz (^ (bigz ,(car pow))
 708                                              (bigz ,(cadr pow))))
 709                                     (bigz ,(caddr pow)))))))
 710             pows-clslash)))
 711
 712   ;; exponentiation overflows at some point
 713   ;; we use (factorial 400) which is a ~2887 bit number
 714   ;; should be large enough to never ever be a native integer (fixnum)
 715   ;; oh, in case someone already bought a 3072-bit processor,
 716   ;; please phone me
 717   (Check-Error range-error (^ (factorial 400) (factorial 400)))
 718   ;; unless we try a unit or a zero as base
 719   (Assert (= (^ 1 (factorial 400)) 1))
 720   (Assert (= (^ -1 (factorial 400)) 1))
 721   (Assert (= (^ -1 (1+ (factorial 400))) -1))
 722   (Assert (= (^ 0 (factorial 400)) 0))
 723
 724   ;;; maxima and minima
 725   (let ((sets '(((1 2 3 -44) :max 3 :min -44)
 726                 ((1 1 1 1 1) :max 1 :min 1)
 727                 ((-100 -2000 -4000) :max -100 :min -4000)
 728                 ((+infinity 5000 -6000 -8000 -infinity)
 729                  :max +infinity :min -infinity))))
 730     (mapc #'(lambda (set)
 731               (let ((max (plist-get (cdr set) :max))
 732                     (min (plist-get (cdr set) :min)))
 733                 (eval `(Assert (= ,max (max ,@(car set)))))
 734                 (eval `(Assert (= ,min (min ,@(car set)))))))
 735           sets))
 736
 737   ;;; % remainder
 738   ;; we cannot use eq for big integers
 739   ;; also, (mod (coerce -1 'bigz) 17) => 16 and not -1, therefore
 740   ;; the result differs by 17 when we have negative x
 741   (Assert (= 16 (% (coerce -1 'bigz) 17)))
 742   (dotimes (j 30)
 743     (let ((x (random))
 744           (y (- (random))))
 745       (eval `(Assert (= ,x (+ (% ,x 17) (* (/ ,x 17) 17)))))
 746       (eval `(Assert (= (- ,x) (+ (% (- ,x) 17) (* (/ (- ,x) 17) 17)))))
 747       (let ((z (+ (% y 17) (* (/ y 17) 17))))
 748         (if (bigzp y)
 749             (eval `(Assert (= ,y (- ,z 17))))
 750           (eval `(Assert (= ,y z)))))
 751       ))
 752
 753   ;;; remove-factor
 754   (mapc #'(lambda (i)
 755             (dotimes (j 10)
 756               (let* ((r (abs (random)))
 757                      (-r (- r))
 758                      (rf `(remove-factor ,i ,r))
 759                      (-rf `(remove-factor ,i ,-r))
 760                      (rf! (remove-factor i r))
 761                      (-rf! (remove-factor i -r)))
 762                 ;; first, test a positive number
 763                 (eval `(Assert (consp ,rf)))
 764                 (eval `(Assert (nonnegativep (cdr ,rf))))
 765                 (eval `(Assert (or (< (car ,rf) ,r)
 766                                    (zerop (cdr ,rf)))))
 767                 ;; then a negative number
 768                 (eval `(Assert (consp ,-rf)))
 769                 (eval `(Assert (nonnegativep (cdr ,-rf))))
 770                 (eval `(Assert (or (< ,-r (car ,-rf))
 771                                    (zerop (cdr ,-rf)))))
 772                 ;; then test if reduced number is coprime to factor
 773                 (eval `(Assert (= (car (remove-factor ,i ,(car rf!)))
 774                                   ,(car rf!))))
 775                 (eval `(Assert (zerop (cdr (remove-factor ,i ,(car rf!))))))
 776                 (eval `(Assert (= (car (remove-factor ,i ,(car -rf!)))
 777                                   ,(car -rf!))))
 778                 (eval `(Assert (zerop (cdr (remove-factor ,i ,(car -rf!)))))))))
 779             '(2 3 4 10 20 50 100 200))
 780
 781   ;; check the consistency of the result values
 782   (mapc #'(lambda (i)
 783             (dotimes (j 20)
 784               (let* ((r (random))
 785                      (rf `(remove-factor ,i ,r))
 786                      (rf! (remove-factor i r)))
 787                 ;; check if  car*factor^cdr  is the original number
 788                 (eval `(Assert (= (* ,(car rf!) (^ ,i ,(cdr rf!))) ,r)))
 789                 (if (primep i)
 790                     (eval `(Assert (coprimep ,i ,(car rf!))))))))
 791         '(-29 -19 -17 -13 -11 -7 -5 -3 -2 -1 0
 792               1 2 3 5 7 11 13 17 19 29))
 793   ;; check coercion
 794   (mapc #'(lambda (i)
 795             (dotimes (j 10)
 796               ;; test real args
 797               (let* ((r (sqrt (abs (random))))
 798                      (rf `(remove-factor ,i ,r))
 799                      (rf! (remove-factor i r)))
 800                 (eval `(Assert (consp ,rf)))
 801                 (eval `(Assert (nonnegativep (cdr ,rf))))
 802                 (eval `(Assert (or (< (car ,rf) ,r)
 803                                    (zerop (cdr ,rf))))))
 804               ;; test quotient args
 805               (let* ((r (// (random) (random)))
 806                      (rf `(remove-factor ,i ,r))
 807                      (rf! (remove-factor i r)))
 808                 (eval `(Assert (consp ,rf)))
 809                 (eval `(Assert (nonnegativep (cdr ,rf))))
 810                 (eval `(Assert (or (/= (car ,rf) ,r)
 811                                    (zerop (cdr ,rf))))))))
 812         '(-29 -29/3 -19 -19/2 -17 -17.25 -13 -13.2
 813               -11 -11/4 -11.7 -7/3
 814               7/3 11 11/3 13 13.4 17 17/2 19 19.25 29 29.3))
 815
 816   ;;; test primep, coprimep, next prime, etc.
 817   (mapc #'(lambda (i)
 818             (eval `(Assert (primep ,i)))
 819             (dotimes (j 100)
 820               (let ((r (car (remove-factor i (random)))))
 821                 (eval `(Assert (coprimep ,i ,r)))))
 822             (eval `(Assert (< ,i (next-prime ,i))))
 823             (eval `(Assert (primep ,(next-prime i))))
 824             (eval `(Assert (coprimep ,i ,(next-prime i)))))
 825         '(-521 -101 -61 -29 2 3 5 7 11 13 17 19 29 101))
 826   ;; test some Mersenne primes (this may take some time)
 827   (mapc #'(lambda (i)
 828             (let ((Mi (1- (2^ i))))
 829               (eval `(Assert (primep ,Mi)))
 830               (eval `(Assert (oddp ,Mi)))))
 831         '(2 3 5 7 13 17 19 31 61 89 107 127 521 607))
 832
 833   ;;; test factorial
 834   (mapc #'(lambda (i)
 835             (let* ((r 1)
 836                    (r (loop for j from 2 to i
 837                         do
 838                         (setq r (* r j))
 839                         finally return r))
 840                    (rf `(factorial ,i))
 841                    (rf-1 `(factorial ,(1- i))))
 842                 ;; check if  (factorial i) == 1*2*...*i
 843                 (eval `(Assert (= ,r ,rf)))
 844                 (eval `(Assert (evenp ,rf)))
 845                 (eval `(Assert (not (primep ,rf))))
 846                 (eval `(Assert (= (car (remove-factor ,rf-1 ,rf)) ,i)))
 847                 (eval `(Assert (= (cdr (remove-factor ,rf-1 ,rf)) 1)))))
 848         '(3 4 5 6 7 8 9 10 11 20 30))
 849   ;; further tests with inductive Assert
 850   (mapc #'(lambda (i)
 851             (let* ((rf `(factorial ,i))
 852                    (rf-1 `(factorial ,(1- i))))
 853                 ;; check if  (factorial i) == 1*2*...*i
 854                 (eval `(Assert (= ,rf (* ,i ,rf-1))))
 855                 (if (featurep 'mpfr)
 856                     (eval `(Assert (> (log ,rf) (- (* ,i (log ,i)) ,i))))
 857                   (eval `(Assert (or (> (log ,rf) (- (* ,i (log ,i)) ,i))
 858                                      (eq +infinity (log ,rf))))))))
 859         '(60 100 120 150 200 300 500 1000))
 860   (mapc #'(lambda (i)
 861             (eval `(Check-Error wrong-type-argument (factorial ,i))))
 862         '(-1 -2 3/2 -3/2 1.5 -10.5 10.0))
 863
 864   ;; test congruency and divisibility
 865   (let ((divis
 866          '((16 . 4) (16 . 2)
 867            (17 . 1) (17 . 17)
 868            (22 . 2) (22 . 11)
 869            (39 . 3) (39 . 13)))
 870         (ndivis
 871          '((16 . 5) (16 . 3)
 872            (17 . 2) (17 . 3) (17 . 4) (17 . 5) (17 . 7) (17 . 11)
 873            (22 . 3) (22 . 13) (22 . 21) (22 . 23)
 874            (39 . 17)))
 875         (cong
 876          '((5 (16 . 1) (16 . 11) (17 . 2) (-17 . 3) (5 . 0))
 877            (7 (16 . 2) (16 . 51) (51 . 16) (2 . 16) (-1 . 6))
 878            (16 (4 . 20) (32 . 0) (-32 . 16) (16 . -32))))
 879         (ncong
 880          '((5 (16 . -1) (16 . 2) (17 . 16) (16 . 17) (2 . -2))
 881            (21 (7 . 21) (21 . 7) (3 . 23) (-3 . 19)))))
 882     ;; divisibility
 883     (mapc #'(lambda (val)
 884               (eval `(Assert (divisiblep ,(car val) ,(cdr val)))))
 885           divis)
 886     (mapc #'(lambda (val)
 887               (eval `(Assert (not (divisiblep ,(car val) ,(cdr val))))))
 888           ndivis)
 889     ;; congruency
 890     (mapc #'(lambda (val)
 891               (let ((module (car val))
 892                     (congs (cdr val)))
 893                 (mapc #'(lambda (cong)
 894                           (eval `(Assert
 895                                   (congruentp ,(car cong) ,(cdr cong)
 896                                               ,module))))
 897                       congs)))
 898           cong)
 899     (mapc #'(lambda (val)
 900               (let ((module (car val))
 901                     (congs (cdr val)))
 902                 (mapc #'(lambda (cong)
 903                           (eval `(Assert
 904                                   (not (congruentp ,(car cong) ,(cdr cong)
 905                                                    ,module)))))
 906                       congs)))
 907           ncong)))
 908
 909 (when (featurep 'bigq)
 910   ;;; addition
 911   (let ((sums '((1/2 2/3 7/6)
 912                 (1233211/2344321 10000/125897 25528682181/42163282991)
 913                 (12332112344321/2 1 12332112344323/2)
 914                 (1/3 12332112344321 36996337032964/3)
 915                 (10101/10101 101589/101589 2/1)
 916                 (-100/99 -50/51 -3350/1683)))
 917         (prods '((2/3 3/4 1/2)
 918                  (1002004/2001 5/2 2505010/2001)
 919                  (-1002004/2001 5/2 -2505010/2001)))
 920         (pows '((2/3 2 4/9)
 921                 (-4/10 4 256/10000)
 922                 (7/3 -16 43046721/33232930569601))))
 923     (mapc #'(lambda (sum)
 924               (eval `(Assert (= (+ ,(car sum) ,(cadr sum)) ,(caddr sum))))
 925               (eval `(Assert (= (- ,(caddr sum) ,(cadr sum)) ,(car sum))))
 926               (unless (bigqp (caddr sum))
 927                 (eval `(Assert (= (bigq (+ (bigq ,(car sum))
 928                                            (bigq ,(cadr sum))))
 929                                   (bigq ,(caddr sum)))))
 930                 (eval `(Assert (= (bigq (- (bigq ,(caddr sum))
 931                                            (bigq ,(cadr sum))))
 932                                   (bigq ,(car sum)))))
 933                 ;; testing triangle inequality
 934                 ;; | a + b | <= |a| + |b|
 935                 (eval `(Assert (<= (abs (+ ,(car sum) ,(cadr sum)))
 936                                    (+ (abs ,(car sum)) (abs ,(cadr sum))))))))
 937           sums)
 938     (mapc #'(lambda (prod)
 939               (eval `(Assert (= (* ,(car prod) ,(cadr prod)) ,(caddr prod))))
 940               (eval `(Assert (= (/ ,(caddr prod) ,(cadr prod)) ,(car prod))))
 941               (unless (bigqp (caddr prod))
 942                 (eval `(Assert (= (bigq (* (bigq ,(car prod))
 943                                            (bigq ,(cadr prod))))
 944                                   (bigq ,(caddr prod)))))
 945                 (eval `(Assert (= (bigq (/ (bigq ,(caddr prod))
 946                                            (bigq ,(cadr prod))))
 947                                   (bigq ,(car prod)))))
 948                 ;; testing multiplicativiy of abs
 949                 ;; | a b | = |a| |b|
 950                 (eval `(Assert (= (abs (* ,(car prod) ,(cadr prod)))
 951                                   (* (abs ,(car prod)) (abs ,(cadr prod))))))))
 952           prods)
 953     (mapc #'(lambda (pow)
 954               (eval `(Assert (= (^ ,(car pow) ,(cadr pow)) ,(caddr pow))))
 955               (eval `(Assert (= (bigq (^ (bigq ,(car pow))
 956                                          ,(cadr pow)))
 957                                 (bigq ,(caddr pow))))))
 958           pows)))
 959
 960
 961 ;; ceil/floor stuff
 962 (let ((one-arg-floor-list `((0 0)
 963                             (1 1)
 964                             (-1 -1)
 965                             (7.4 7)
 966                             (-7.4 -8))))
 967   (when (featurep 'bigz)
 968     (setq one-arg-floor-list
 969           (append one-arg-floor-list
 970                   `((,(factorial 20) ,(factorial 20))
 971                     (,(- (factorial 20)) ,(- (factorial 20)))))))
 972   (when (featurep 'bigq)
 973     (setq one-arg-floor-list
 974           (append one-arg-floor-list
 975                   `((1/2 0)
 976                     (-1/2 -1)
 977                     (40/3 13)
 978                     (-40/3 -14)))))
 979   (when (featurep 'bigf)
 980     (setq one-arg-floor-list
 981           (append one-arg-floor-list
 982                   `((,(bigf 7.4) 7)
 983                     (,(bigf -7.4) -8)))))
 984   (when (featurep 'bigfr)
 985     (setq one-arg-floor-list
 986           (append one-arg-floor-list
 987                   `((,(bigfr 7.4) 7)
 988                     (,(bigfr -7.4) -8)
 989                     (,(sqrt 2) 1)
 990                     (,(log 2) 0)
 991                     (,(log 0.1) -3)))))
 992   (mapc #'(lambda (arg-list)
 993             (eval `(Assert (= (floor ,(car arg-list))
 994                               ,(cadr arg-list)))))
 995         one-arg-floor-list))
 996
 997 (let ((two-arg-floor-list `((0 1 0)
 998                             (1 2 0)
 999                             (-1 2 -1)
1000                             (7.4 2 3)
1001                             (-7.4 2 -4))))
1002   (when (featurep 'bigz)
1003     (setq two-arg-floor-list
1004           (append two-arg-floor-list
1005                   `((,(factorial 20) 100001 24328776793998)
1006                     (,(- (factorial 20)) 100001 -24328776793999)))))
1007   (when (featurep 'bigq)
1008     (setq two-arg-floor-list
1009           (append two-arg-floor-list
1010                   `((1/2 2 0)
1011                     (1/2 1/2 1)
1012                     (2 -1/2 -4)
1013                     (3/2 -1/3 -5)
1014                     (40/3 1/5 66)
1015                     (40/3 -1/5 -67)))))
1016   (when (featurep 'bigf)
1017     (setq two-arg-floor-list
1018           (append two-arg-floor-list
1019                   `((,(bigf 1) 2 0)
1020                     (2 ,(bigf 0.5) 4)
1021                     (,(bigf 3880.5) 2 1940)
1022                     (,(bigf -3880.5) 2 -1941)))))
1023   (when (featurep 'bigfr)
1024     (setq two-arg-floor-list
1025           (append two-arg-floor-list
1026                   `((,(bigfr 1) 2 0)
1027                     (2 ,(bigfr 0.5) 4)
1028                     (,(sqrt 12) 2 1)
1029                     (1 (log 1.2) 5)
1030                     (,(exp 37) 37 316733577643313)))))
1031
1032   (mapc #'(lambda (arg-list)
1033             (eval `(Assert (= (floor ,(car arg-list) ,(cadr arg-list))
1034                               ,(caddr arg-list)))))
1035         two-arg-floor-list))
1036
1037
1038 ;;-----------------------------------------------------
1039 ;; Testing relations
1040 ;;-----------------------------------------------------
1041 (when (featurep 'ent)
1042   (let ((ones)
1043         (twos))
1044     (and (featurep 'bigz)
1045          (add-to-list 'ones (coerce 1 'bigz))
1046          (add-to-list 'twos (coerce 2 'bigz)))
1047     (and (featurep 'bigq)
1048          (add-to-list 'ones 101/100)
1049          (add-to-list 'twos 202/100))
1050     (and (featurep 'bigf)
1051          (add-to-list 'ones (coerce 1.01 'bigf))
1052          (add-to-list 'twos (coerce 2.02 'bigf)))
1053     (and (featurep 'bigfr)
1054          (add-to-list 'ones (coerce 1.01 'bigfr))
1055          (add-to-list 'twos (coerce 2.02 'bigfr)))
1056     (dolist (one ones)
1057       (dolist (two twos)
1058         (eval `(Assert (< ,one ,two)))
1059         (eval `(Assert (<= ,one ,two)))
1060         (eval `(Assert (<= ,two ,two)))
1061         (eval `(Assert (>  ,two ,one)))
1062         (eval `(Assert (>= ,two ,one)))
1063         (eval `(Assert (>= ,two ,two)))
1064         (eval `(Assert (/= ,one ,two)))
1065         (eval `(Assert (not (/= ,two ,two))))
1066         (eval `(Assert (not (< ,one ,one))))
1067         (eval `(Assert (not (> ,one ,one))))
1068         (eval `(Assert (<= ,one ,one ,two ,two)))
1069         (eval `(Assert (not (< ,one ,one ,two ,two))))
1070         (eval `(Assert (>= ,two ,two ,one ,one)))
1071         (eval `(Assert (not (> ,two ,two ,one ,one))))
1072         (eval `(Assert (= ,one ,one ,one)))
1073         (eval `(Assert (not (= ,one ,one ,one ,two))))
1074         (eval `(Assert (not (/= ,one ,two ,one))))
1075         ))
1076     (when (featurep 'bigc)
1077       ;; now check complexes, these are not comparable
1078       (dolist (one ones)
1079         (eval `(Check-Error relation-error (< ,one 1+i)))
1080         (eval `(Check-Error relation-error (<= ,one 1+i)))
1081         (eval `(Check-Error relation-error (<= 1+i 1+i)))
1082         (eval `(Check-Error relation-error (> ,one 1+i)))
1083         (eval `(Check-Error relation-error (>= ,one 1+i)))
1084         (eval `(Check-Error relation-error (>= 1+i 1+i)))
1085         (eval `(Check-Error relation-error (not (/= ,one 1+i))))
1086         (eval `(Check-Error relation-error (= ,one 1+i)))
1087         ))))
1088
1089 ;;-----------------------------------------------------
1090 ;; Testing infinities
1091 ;;-----------------------------------------------------
1092 (Assert (boundp '+infinity))
1093 (Assert (boundp '-infinity))
1094 (Assert (boundp 'complex-infinity))
1095 (Assert (boundp 'not-a-number))
1096
1097 (Assert (infinityp +infinity))
1098 (Assert (infinityp -infinity))
1099 (Assert (infinityp complex-infinity))
1100 (Assert (indefinitep +infinity))
1101 (Assert (indefinitep -infinity))
1102 (Assert (indefinitep complex-infinity))
1103 (Assert (indefinitep not-a-number))
1104
1105 ;;; testing arithmetics with infinity symbols
1106 (let* ((ASSERT-EQUAL
1107         #'(lambda (form result)
1108             (eval `(Assert-Equal ,form ,result))))
1109        (ASSERT-=
1110         #'(lambda (form result)
1111             (eval `(Assert (= ,form ,result)))))
1112        (ASSERT-EQUAL-nc
1113         #'(lambda (form result)
1114             (eval `(Check-Error wrong-type-argument (equal ,form ,result)))))
1115        (ASSERT-=-nc
1116         #'(lambda (form result)
1117             (eval `(Check-Error relation-error (= ,form ,result)))))
1118        (ASSERT-EQUAL+=
1119         #'(lambda (form result)
1120             (funcall ASSERT-EQUAL form result)
1121             (funcall ASSERT-= form result)))
1122        (ASSERT-EQUAL+=-nc
1123         #'(lambda (form result)
1124             (funcall ASSERT-EQUAL form result)
1125             (funcall ASSERT-=-nc form result)))
1126        (ASSERT-EQUAL-nc+=-nc
1127         #'(lambda (form result)
1128             (funcall ASSERT-EQUAL-nc form result)
1129             (funcall ASSERT-=-nc form result))))
1130
1131   ;; addition
1132   (funcall ASSERT-EQUAL+= '(+ 0 +infinity) '+infinity)
1133   (funcall ASSERT-EQUAL+= '(+ 1 +infinity) '+infinity)
1134   (funcall ASSERT-EQUAL+= '(+ -1 +infinity) '+infinity)
1135   (funcall ASSERT-EQUAL+= '(+ +infinity 0) '+infinity)
1136   (funcall ASSERT-EQUAL+= '(+ +infinity 1) '+infinity)
1137   (funcall ASSERT-EQUAL+= '(+ +infinity -1) '+infinity)
1138   (funcall ASSERT-EQUAL+= '(+ +infinity) '+infinity)
1139   (funcall ASSERT-EQUAL+= '(1+ +infinity) '+infinity)
1140   (funcall ASSERT-EQUAL+= '(+ +infinity +infinity) '+infinity)
1141   (funcall ASSERT-EQUAL+=-nc '(+ complex-infinity +infinity) 'not-a-number)
1142   (funcall ASSERT-EQUAL+=-nc '(+ -infinity +infinity) 'not-a-number)
1143
1144   (funcall ASSERT-EQUAL+= '(+ 0 -infinity) '-infinity)
1145   (funcall ASSERT-EQUAL+= '(+ 1 -infinity) '-infinity)
1146   (funcall ASSERT-EQUAL+= '(+ -1 -infinity) '-infinity)
1147   (funcall ASSERT-EQUAL+= '(+ -infinity 0) '-infinity)
1148   (funcall ASSERT-EQUAL+= '(+ -infinity 1) '-infinity)
1149   (funcall ASSERT-EQUAL+= '(+ -infinity -1) '-infinity)
1150   (funcall ASSERT-EQUAL+=-nc '(+ -infinity +infinity) 'not-a-number)
1151   (funcall ASSERT-EQUAL+= '(+ -infinity) '-infinity)
1152   (funcall ASSERT-EQUAL+= '(1+ -infinity) '-infinity)
1153   (funcall ASSERT-EQUAL+=-nc '(+ +infinity -infinity) 'not-a-number)
1154   (funcall ASSERT-EQUAL+= '(+ -infinity -infinity) '-infinity)
1155   (funcall ASSERT-EQUAL+=-nc '(+ complex-infinity -infinity) 'not-a-number)
1156
1157   (funcall ASSERT-EQUAL+= '(+ 0 complex-infinity) 'complex-infinity)
1158   (funcall ASSERT-EQUAL+= '(+ 1 complex-infinity) 'complex-infinity)
1159   (funcall ASSERT-EQUAL+= '(+ -1 complex-infinity) 'complex-infinity)
1160   (funcall ASSERT-EQUAL+= '(+ complex-infinity 0) 'complex-infinity)
1161   (funcall ASSERT-EQUAL+= '(+ complex-infinity 1) 'complex-infinity)
1162   (funcall ASSERT-EQUAL+= '(+ complex-infinity -1) 'complex-infinity)
1163   (funcall ASSERT-EQUAL+= '(+ complex-infinity) 'complex-infinity)
1164   (funcall ASSERT-EQUAL+= '(1+ complex-infinity) 'complex-infinity)
1165   (funcall ASSERT-EQUAL+=-nc '(+ +infinity complex-infinity) 'not-a-number)
1166   (funcall ASSERT-EQUAL+=-nc '(+ -infinity complex-infinity) 'not-a-number)
1167   (funcall ASSERT-EQUAL+=
1168            '(+ complex-infinity complex-infinity) complex-infinity)
1169
1170   (funcall ASSERT-EQUAL+=-nc '(+ 0 not-a-number) 'not-a-number)
1171   (funcall ASSERT-EQUAL+=-nc '(+ 1 not-a-number) 'not-a-number)
1172   (funcall ASSERT-EQUAL+=-nc '(+ -1 not-a-number) 'not-a-number)
1173   (funcall ASSERT-EQUAL+=-nc '(+ not-a-number 0) 'not-a-number)
1174   (funcall ASSERT-EQUAL+=-nc '(+ not-a-number 1) 'not-a-number)
1175   (funcall ASSERT-EQUAL+=-nc '(+ not-a-number -1) 'not-a-number)
1176   (funcall ASSERT-EQUAL+=-nc '(+ not-a-number) 'not-a-number)
1177   (funcall ASSERT-EQUAL+=-nc '(1+ not-a-number) 'not-a-number)
1178   (funcall ASSERT-EQUAL+=-nc '(+ not-a-number +infinity) 'not-a-number)
1179   (funcall ASSERT-EQUAL+=-nc '(+ +infinity not-a-number) 'not-a-number)
1180   (funcall ASSERT-EQUAL+=-nc '(+ not-a-number -infinity) 'not-a-number)
1181   (funcall ASSERT-EQUAL+=-nc '(+ -infinity not-a-number) 'not-a-number)
1182   (funcall ASSERT-EQUAL+=-nc
1183            '(+ not-a-number complex-infinity) 'not-a-number)
1184   (funcall ASSERT-EQUAL+=-nc
1185            '(+ complex-infinity not-a-number) 'not-a-number)
1186
1187   ;; subtraction
1188   (funcall ASSERT-EQUAL+= '(- 0 +infinity) '-infinity)
1189   (funcall ASSERT-EQUAL+= '(- 1 +infinity) '-infinity)
1190   (funcall ASSERT-EQUAL+= '(- -1 +infinity) '-infinity)
1191   (funcall ASSERT-EQUAL+= '(- +infinity 0) '+infinity)
1192   (funcall ASSERT-EQUAL+= '(- +infinity 1) '+infinity)
1193   (funcall ASSERT-EQUAL+= '(- +infinity -1) '+infinity)
1194   (funcall ASSERT-EQUAL+= '(- +infinity) '-infinity)
1195   (funcall ASSERT-EQUAL+= '(1- +infinity) '+infinity)
1196   (funcall ASSERT-EQUAL+=-nc '(- +infinity +infinity) 'not-a-number)
1197   (funcall ASSERT-EQUAL+= '(- -infinity +infinity) '-infinity)
1198   (funcall ASSERT-EQUAL+=-nc '(- complex-infinity +infinity) 'not-a-number)
1199
1200   (funcall ASSERT-EQUAL+= '(- 0 -infinity) '+infinity)
1201   (funcall ASSERT-EQUAL+= '(- 1 -infinity) '+infinity)
1202   (funcall ASSERT-EQUAL+= '(- -1 -infinity) '+infinity)
1203   (funcall ASSERT-EQUAL+= '(- -infinity 0) '-infinity)
1204   (funcall ASSERT-EQUAL+= '(- -infinity 1) '-infinity)
1205   (funcall ASSERT-EQUAL+= '(- -infinity -1) '-infinity)
1206   (funcall ASSERT-EQUAL+= '(- -infinity +infinity) '-infinity)
1207   (funcall ASSERT-EQUAL+= '(- -infinity) '+infinity)
1208   (funcall ASSERT-EQUAL+= '(1- -infinity) '-infinity)
1209   (funcall ASSERT-EQUAL+= '(- +infinity -infinity) '+infinity)
1210   (funcall ASSERT-EQUAL+=-nc '(- -infinity -infinity) 'not-a-number)
1211   (funcall ASSERT-EQUAL+=-nc '(- complex-infinity -infinity) 'not-a-number)
1212
1213   (funcall ASSERT-EQUAL+= '(- 0 complex-infinity) 'complex-infinity)
1214   (funcall ASSERT-EQUAL+= '(- 1 complex-infinity) 'complex-infinity)
1215   (funcall ASSERT-EQUAL+= '(- -1 complex-infinity) 'complex-infinity)
1216   (funcall ASSERT-EQUAL+= '(- complex-infinity 0) 'complex-infinity)
1217   (funcall ASSERT-EQUAL+= '(- complex-infinity 1) 'complex-infinity)
1218   (funcall ASSERT-EQUAL+= '(- complex-infinity -1) 'complex-infinity)
1219   (funcall ASSERT-EQUAL+= '(- complex-infinity) 'complex-infinity)
1220   (funcall ASSERT-EQUAL+= '(1- complex-infinity) 'complex-infinity)
1221   (funcall ASSERT-EQUAL+=-nc '(- +infinity complex-infinity) 'not-a-number)
1222   (funcall ASSERT-EQUAL+=-nc '(- -infinity complex-infinity) 'not-a-number)
1223   (funcall ASSERT-EQUAL+=
1224            '(- complex-infinity complex-infinity) complex-infinity)
1225
1226   (funcall ASSERT-EQUAL+=-nc '(- 0 not-a-number) 'not-a-number)
1227   (funcall ASSERT-EQUAL+=-nc '(- 1 not-a-number) 'not-a-number)
1228   (funcall ASSERT-EQUAL+=-nc '(- -1 not-a-number) 'not-a-number)
1229   (funcall ASSERT-EQUAL+=-nc '(- not-a-number 0) 'not-a-number)
1230   (funcall ASSERT-EQUAL+=-nc '(- not-a-number 1) 'not-a-number)
1231   (funcall ASSERT-EQUAL+=-nc '(- not-a-number -1) 'not-a-number)
1232   (funcall ASSERT-EQUAL+=-nc '(- not-a-number) 'not-a-number)
1233   (funcall ASSERT-EQUAL+=-nc '(1- not-a-number) 'not-a-number)
1234   (funcall ASSERT-EQUAL+=-nc '(- not-a-number +infinity) 'not-a-number)
1235   (funcall ASSERT-EQUAL+=-nc '(- +infinity not-a-number) 'not-a-number)
1236   (funcall ASSERT-EQUAL+=-nc '(- not-a-number -infinity) 'not-a-number)
1237   (funcall ASSERT-EQUAL+=-nc '(- -infinity not-a-number) 'not-a-number)
1238   (funcall ASSERT-EQUAL+=-nc
1239            '(- not-a-number complex-infinity) 'not-a-number)
1240   (funcall ASSERT-EQUAL+=-nc
1241            '(- complex-infinity not-a-number) 'not-a-number)
1242
1243   ;; multiplication
1244   (funcall ASSERT-EQUAL+=-nc '(* 0 +infinity) 'not-a-number)
1245   (funcall ASSERT-EQUAL+= '(* 1 +infinity) '+infinity)
1246   (funcall ASSERT-EQUAL+= '(* -1 +infinity) '-infinity)
1247   (funcall ASSERT-EQUAL+=-nc '(* +infinity 0) 'not-a-number)
1248   (funcall ASSERT-EQUAL+= '(* +infinity 1) '+infinity)
1249   (funcall ASSERT-EQUAL+= '(* +infinity -1) '-infinity)
1250   (funcall ASSERT-EQUAL+= '(* +infinity) '+infinity)
1251   (funcall ASSERT-EQUAL+= '(* +infinity +infinity) '+infinity)
1252   (funcall ASSERT-EQUAL+= '(* -infinity +infinity) '-infinity)
1253   (funcall ASSERT-EQUAL+= '(* complex-infinity +infinity) 'complex-infinity)
1254
1255   (funcall ASSERT-EQUAL+=-nc '(* 0 -infinity) 'not-a-number)
1256   (funcall ASSERT-EQUAL+= '(* 1 -infinity) '-infinity)
1257   (funcall ASSERT-EQUAL+= '(* -1 -infinity) '+infinity)
1258   (funcall ASSERT-EQUAL+=-nc '(* -infinity 0) 'not-a-number)
1259   (funcall ASSERT-EQUAL+= '(* -infinity 1) '-infinity)
1260   (funcall ASSERT-EQUAL+= '(* -infinity -1) '+infinity)
1261   (funcall ASSERT-EQUAL+= '(* -infinity +infinity) '-infinity)
1262   (funcall ASSERT-EQUAL+= '(* -infinity) '-infinity)
1263   (funcall ASSERT-EQUAL+= '(* +infinity -infinity) '-infinity)
1264   (funcall ASSERT-EQUAL+= '(* -infinity -infinity) '+infinity)
1265   (funcall ASSERT-EQUAL+= '(* complex-infinity -infinity) 'complex-infinity)
1266
1267   (funcall ASSERT-EQUAL+=-nc '(* 0 complex-infinity) 'not-a-number)
1268   (funcall ASSERT-EQUAL+= '(* 1 complex-infinity) 'complex-infinity)
1269   (funcall ASSERT-EQUAL+= '(* -1 complex-infinity) 'complex-infinity)
1270   (funcall ASSERT-EQUAL+=-nc '(* complex-infinity 0) 'not-a-number)
1271   (funcall ASSERT-EQUAL+= '(* complex-infinity 1) 'complex-infinity)
1272   (funcall ASSERT-EQUAL+= '(* complex-infinity -1) 'complex-infinity)
1273   (funcall ASSERT-EQUAL+= '(* complex-infinity +infinity) 'complex-infinity)
1274   (funcall ASSERT-EQUAL+= '(* complex-infinity) 'complex-infinity)
1275   (funcall ASSERT-EQUAL+= '(* +infinity complex-infinity) 'complex-infinity)
1276   (funcall ASSERT-EQUAL+= '(* -infinity complex-infinity) 'complex-infinity)
1277   (funcall ASSERT-EQUAL+=
1278            '(* complex-infinity complex-infinity) complex-infinity)
1279
1280   (funcall ASSERT-EQUAL+=-nc '(* 0 not-a-number) 'not-a-number)
1281   (funcall ASSERT-EQUAL+=-nc '(* 1 not-a-number) 'not-a-number)
1282   (funcall ASSERT-EQUAL+=-nc '(* -1 not-a-number) 'not-a-number)
1283   (funcall ASSERT-EQUAL+=-nc '(* not-a-number 0) 'not-a-number)
1284   (funcall ASSERT-EQUAL+=-nc '(* not-a-number 1) 'not-a-number)
1285   (funcall ASSERT-EQUAL+=-nc '(* not-a-number -1) 'not-a-number)
1286   (funcall ASSERT-EQUAL+=-nc '(* not-a-number) 'not-a-number)
1287   (funcall ASSERT-EQUAL+=-nc '(* not-a-number +infinity) 'not-a-number)
1288   (funcall ASSERT-EQUAL+=-nc '(* +infinity not-a-number) 'not-a-number)
1289   (funcall ASSERT-EQUAL+=-nc '(* not-a-number -infinity) 'not-a-number)
1290   (funcall ASSERT-EQUAL+=-nc '(* -infinity not-a-number) 'not-a-number)
1291   (funcall ASSERT-EQUAL+=-nc
1292            '(* not-a-number complex-infinity) 'not-a-number)
1293   (funcall ASSERT-EQUAL+=-nc
1294            '(* complex-infinity not-a-number) 'not-a-number)
1295
1296   ;; division
1297   (funcall ASSERT-EQUAL+= '(/ 0 +infinity) 0)
1298   (funcall ASSERT-EQUAL+= '(/ 1 +infinity) 0)
1299   (funcall ASSERT-EQUAL+= '(/ -1 +infinity) 0)
1300   (funcall ASSERT-EQUAL+=-nc '(/ +infinity 0) 'not-a-number)
1301   (funcall ASSERT-EQUAL+= '(/ +infinity 1) '+infinity)
1302   (funcall ASSERT-EQUAL+= '(/ +infinity -1) '-infinity)
1303   (funcall ASSERT-EQUAL+= '(/ +infinity) 0)
1304   (funcall ASSERT-EQUAL+=-nc '(/ +infinity +infinity) 'not-a-number)
1305   (funcall ASSERT-EQUAL+=-nc '(/ -infinity +infinity) 'not-a-number)
1306   (funcall ASSERT-EQUAL+= '(/ complex-infinity +infinity) 'complex-infinity)
1307
1308   (funcall ASSERT-EQUAL+= '(/ 0 -infinity) 0)
1309   (funcall ASSERT-EQUAL+= '(/ 1 -infinity) 0)
1310   (funcall ASSERT-EQUAL+= '(/ -1 -infinity) 0)
1311   (funcall ASSERT-EQUAL+=-nc '(/ -infinity 0) 'not-a-number)
1312   (funcall ASSERT-EQUAL+= '(/ -infinity 1) '-infinity)
1313   (funcall ASSERT-EQUAL+= '(/ -infinity -1) '+infinity)
1314   (funcall ASSERT-EQUAL+=-nc '(/ -infinity +infinity) 'not-a-number)
1315   (funcall ASSERT-EQUAL+= '(/ -infinity) 0)
1316   (funcall ASSERT-EQUAL+=-nc '(/ +infinity -infinity) 'not-a-number)
1317   (funcall ASSERT-EQUAL+=-nc '(/ -infinity -infinity) 'not-a-number)
1318   (funcall ASSERT-EQUAL+= '(/ complex-infinity -infinity) 'complex-infinity)
1319
1320   (funcall ASSERT-EQUAL+= '(/ 0 complex-infinity) 'complex-infinity)
1321   (funcall ASSERT-EQUAL+= '(/ 1 complex-infinity) 'complex-infinity)
1322   (funcall ASSERT-EQUAL+= '(/ -1 complex-infinity) 'complex-infinity)
1323   (funcall ASSERT-EQUAL+=-nc '(/ complex-infinity 0) 'not-a-number)
1324   (funcall ASSERT-EQUAL+= '(/ complex-infinity 1) 'complex-infinity)
1325   (funcall ASSERT-EQUAL+= '(/ complex-infinity -1) 'complex-infinity)
1326   (funcall ASSERT-EQUAL+= '(/ complex-infinity +infinity) 'complex-infinity)
1327   (funcall ASSERT-EQUAL+= '(/ complex-infinity) 'complex-infinity)
1328   (funcall ASSERT-EQUAL+= '(/ +infinity complex-infinity) 'complex-infinity)
1329   (funcall ASSERT-EQUAL+= '(/ -infinity complex-infinity) 'complex-infinity)
1330   (funcall ASSERT-EQUAL+=
1331            '(/ complex-infinity complex-infinity) complex-infinity)
1332
1333   (funcall ASSERT-EQUAL+=-nc '(/ 0 not-a-number) 'not-a-number)
1334   (funcall ASSERT-EQUAL+=-nc '(/ 1 not-a-number) 'not-a-number)
1335   (funcall ASSERT-EQUAL+=-nc '(/ -1 not-a-number) 'not-a-number)
1336   (funcall ASSERT-EQUAL+=-nc '(/ not-a-number 0) 'not-a-number)
1337   (funcall ASSERT-EQUAL+=-nc '(/ not-a-number 1) 'not-a-number)
1338   (funcall ASSERT-EQUAL+=-nc '(/ not-a-number -1) 'not-a-number)
1339   (funcall ASSERT-EQUAL+=-nc '(/ not-a-number) 'not-a-number)
1340   (funcall ASSERT-EQUAL+=-nc '(/ not-a-number +infinity) 'not-a-number)
1341   (funcall ASSERT-EQUAL+=-nc '(/ +infinity not-a-number) 'not-a-number)
1342   (funcall ASSERT-EQUAL+=-nc '(/ not-a-number -infinity) 'not-a-number)
1343   (funcall ASSERT-EQUAL+=-nc '(/ -infinity not-a-number) 'not-a-number)
1344   (funcall ASSERT-EQUAL+=-nc
1345            '(/ not-a-number complex-infinity) 'not-a-number)
1346   (funcall ASSERT-EQUAL+=-nc
1347            '(/ complex-infinity not-a-number) 'not-a-number)
1348
1349   ;; division part 2
1350   (funcall ASSERT-EQUAL+= '(// 0 +infinity) 0)
1351   (funcall ASSERT-EQUAL+= '(// 1 +infinity) 0)
1352   (funcall ASSERT-EQUAL+= '(// -1 +infinity) 0)
1353   (funcall ASSERT-EQUAL+=-nc '(// +infinity 0) 'not-a-number)
1354   (funcall ASSERT-EQUAL+= '(// +infinity 1) '+infinity)
1355   (funcall ASSERT-EQUAL+= '(// +infinity -1) '-infinity)
1356   (funcall ASSERT-EQUAL+= '(// +infinity) 0)
1357   (funcall ASSERT-EQUAL+=-nc '(// +infinity +infinity) 'not-a-number)
1358   (funcall ASSERT-EQUAL+=-nc '(// -infinity +infinity) 'not-a-number)
1359   (funcall ASSERT-EQUAL+= '(// complex-infinity +infinity) 'complex-infinity)
1360
1361   (funcall ASSERT-EQUAL+= '(// 0 -infinity) 0)
1362   (funcall ASSERT-EQUAL+= '(// 1 -infinity) 0)
1363   (funcall ASSERT-EQUAL+= '(// -1 -infinity) 0)
1364   (funcall ASSERT-EQUAL+=-nc '(// -infinity 0) 'not-a-number)
1365   (funcall ASSERT-EQUAL+= '(// -infinity 1) '-infinity)
1366   (funcall ASSERT-EQUAL+= '(// -infinity -1) '+infinity)
1367   (funcall ASSERT-EQUAL+=-nc '(// -infinity +infinity) 'not-a-number)
1368   (funcall ASSERT-EQUAL+= '(// -infinity) 0)
1369   (funcall ASSERT-EQUAL+=-nc '(// +infinity -infinity) 'not-a-number)
1370   (funcall ASSERT-EQUAL+=-nc '(// -infinity -infinity) 'not-a-number)
1371   (funcall ASSERT-EQUAL+= '(// complex-infinity -infinity) 'complex-infinity)
1372
1373   (funcall ASSERT-EQUAL+= '(// 0 complex-infinity) 'complex-infinity)
1374   (funcall ASSERT-EQUAL+= '(// 1 complex-infinity) 'complex-infinity)
1375   (funcall ASSERT-EQUAL+= '(// -1 complex-infinity) 'complex-infinity)
1376   (funcall ASSERT-EQUAL+=-nc '(// complex-infinity 0) 'not-a-number)
1377   (funcall ASSERT-EQUAL+= '(// complex-infinity 1) 'complex-infinity)
1378   (funcall ASSERT-EQUAL+= '(// complex-infinity -1) 'complex-infinity)
1379   (funcall ASSERT-EQUAL+= '(// complex-infinity +infinity) 'complex-infinity)
1380   (funcall ASSERT-EQUAL+= '(// complex-infinity) 'complex-infinity)
1381   (funcall ASSERT-EQUAL+= '(// +infinity complex-infinity) 'complex-infinity)
1382   (funcall ASSERT-EQUAL+= '(// -infinity complex-infinity) 'complex-infinity)
1383   (funcall ASSERT-EQUAL+=
1384            '(// complex-infinity complex-infinity) complex-infinity)
1385
1386   (funcall ASSERT-EQUAL+=-nc '(// 0 not-a-number) 'not-a-number)
1387   (funcall ASSERT-EQUAL+=-nc '(// 1 not-a-number) 'not-a-number)
1388   (funcall ASSERT-EQUAL+=-nc '(// -1 not-a-number) 'not-a-number)
1389   (funcall ASSERT-EQUAL+=-nc '(// not-a-number 0) 'not-a-number)
1390   (funcall ASSERT-EQUAL+=-nc '(// not-a-number 1) 'not-a-number)
1391   (funcall ASSERT-EQUAL+=-nc '(// not-a-number -1) 'not-a-number)
1392   (funcall ASSERT-EQUAL+=-nc '(// not-a-number) 'not-a-number)
1393   (funcall ASSERT-EQUAL+=-nc '(// not-a-number +infinity) 'not-a-number)
1394   (funcall ASSERT-EQUAL+=-nc '(// +infinity not-a-number) 'not-a-number)
1395   (funcall ASSERT-EQUAL+=-nc '(// not-a-number -infinity) 'not-a-number)
1396   (funcall ASSERT-EQUAL+=-nc '(// -infinity not-a-number) 'not-a-number)
1397   (funcall ASSERT-EQUAL+=-nc
1398            '(// not-a-number complex-infinity) 'not-a-number)
1399   (funcall ASSERT-EQUAL+=-nc
1400            '(// complex-infinity not-a-number) 'not-a-number)
1401
1402   ;; reduction modulo number
1403   (funcall ASSERT-EQUAL+= '(% 0 +infinity) 0)
1404   (funcall ASSERT-EQUAL+= '(% 1 +infinity) 1)
1405   (funcall ASSERT-EQUAL+= '(% -1 +infinity) -1)
1406   (funcall ASSERT-EQUAL+=-nc '(% +infinity 0) 'not-a-number)
1407   (funcall ASSERT-EQUAL+=-nc '(% +infinity 1) 'not-a-number)
1408   (funcall ASSERT-EQUAL+=-nc '(% +infinity -1) 'not-a-number)
1409   (funcall ASSERT-EQUAL+= '(% +infinity +infinity) '+infinity)
1410   (funcall ASSERT-EQUAL+= '(% -infinity +infinity) '-infinity)
1411   (funcall ASSERT-EQUAL+= '(% complex-infinity +infinity) 'complex-infinity)
1412
1413   (funcall ASSERT-EQUAL+= '(% 0 -infinity) '0)
1414   (funcall ASSERT-EQUAL+= '(% 1 -infinity) '1)
1415   (funcall ASSERT-EQUAL+= '(% -1 -infinity) '-1)
1416   (funcall ASSERT-EQUAL+=-nc '(% -infinity 0) 'not-a-number)
1417   (funcall ASSERT-EQUAL+=-nc '(% -infinity 1) 'not-a-number)
1418   (funcall ASSERT-EQUAL+=-nc '(% -infinity -1) 'not-a-number)
1419   (funcall ASSERT-EQUAL+= '(% -infinity +infinity) '-infinity)
1420   (funcall ASSERT-EQUAL+= '(% +infinity -infinity) '-infinity)
1421   (funcall ASSERT-EQUAL+= '(% -infinity -infinity) '+infinity)
1422   (funcall ASSERT-EQUAL+= '(% complex-infinity -infinity) 'complex-infinity)
1423
1424   (funcall ASSERT-EQUAL+= '(% 0 complex-infinity) '0)
1425   (funcall ASSERT-EQUAL+= '(% 1 complex-infinity) '1)
1426   (funcall ASSERT-EQUAL+= '(% -1 complex-infinity) '-1)
1427   (funcall ASSERT-EQUAL+=-nc '(% complex-infinity 0) 'not-a-number)
1428   (funcall ASSERT-EQUAL+=-nc '(% complex-infinity 1) 'not-a-number)
1429   (funcall ASSERT-EQUAL+=-nc '(% complex-infinity -1) 'not-a-number)
1430   (funcall ASSERT-EQUAL+= '(% complex-infinity +infinity) 'complex-infinity)
1431   (funcall ASSERT-EQUAL+= '(% +infinity complex-infinity) 'complex-infinity)
1432   (funcall ASSERT-EQUAL+= '(% -infinity complex-infinity) 'complex-infinity)
1433   (funcall ASSERT-EQUAL+=
1434            '(% complex-infinity complex-infinity) complex-infinity)
1435
1436   (funcall ASSERT-EQUAL+=-nc '(% 0 not-a-number) 'not-a-number)
1437   (funcall ASSERT-EQUAL+=-nc '(% 1 not-a-number) 'not-a-number)
1438   (funcall ASSERT-EQUAL+=-nc '(% -1 not-a-number) 'not-a-number)
1439   (funcall ASSERT-EQUAL+=-nc '(% not-a-number 0) 'not-a-number)
1440   (funcall ASSERT-EQUAL+=-nc '(% not-a-number 1) 'not-a-number)
1441   (funcall ASSERT-EQUAL+=-nc '(% not-a-number -1) 'not-a-number)
1442   (funcall ASSERT-EQUAL+=-nc '(% not-a-number +infinity) 'not-a-number)
1443   (funcall ASSERT-EQUAL+=-nc '(% +infinity not-a-number) 'not-a-number)
1444   (funcall ASSERT-EQUAL+=-nc '(% not-a-number -infinity) 'not-a-number)
1445   (funcall ASSERT-EQUAL+=-nc '(% -infinity not-a-number) 'not-a-number)
1446   (funcall ASSERT-EQUAL+=-nc
1447            '(% not-a-number complex-infinity) 'not-a-number)
1448   (funcall ASSERT-EQUAL+=-nc
1449            '(% complex-infinity not-a-number) 'not-a-number)
1450
1451   ;; exponentiation
1452   (funcall ASSERT-EQUAL+= '(^ 0 +infinity) 0)
1453   (funcall ASSERT-EQUAL+= '(^ 1 +infinity) 1)
1454   (funcall ASSERT-EQUAL+= '(^ 2 +infinity) +infinity)
1455   (funcall ASSERT-EQUAL+= '(2^ +infinity) +infinity)
1456   (funcall ASSERT-EQUAL+= '(^ 10 +infinity) +infinity)
1457   (funcall ASSERT-EQUAL+= '(10^ +infinity) +infinity)
1458   (funcall ASSERT-EQUAL+=-nc '(^ -1 +infinity) 'not-a-number)
1459   (funcall ASSERT-EQUAL+=-nc '(^ +infinity 0) 'not-a-number)
1460   (funcall ASSERT-EQUAL+= '(^ +infinity 1) '+infinity)
1461   (funcall ASSERT-EQUAL+= '(^ +infinity 2) '+infinity)
1462   (funcall ASSERT-EQUAL+= '(^ +infinity -1) 0)
1463   (funcall ASSERT-EQUAL+= '(^-1 +infinity) 0)
1464   (funcall ASSERT-EQUAL+= '(^ +infinity -2) 0)
1465   (funcall ASSERT-EQUAL+=-nc '(^ +infinity +infinity) 'not-a-number)
1466   (funcall ASSERT-EQUAL+=-nc '(^ -infinity +infinity) 'not-a-number)
1467   (funcall ASSERT-EQUAL+= '(^ complex-infinity +infinity) 'complex-infinity)
1468
1469   (funcall ASSERT-EQUAL+= '(^ 0 -infinity) 0)
1470   (funcall ASSERT-EQUAL+= '(^ 1 -infinity) 1)
1471   (funcall ASSERT-EQUAL+= '(^ 2 -infinity) 0)
1472   (funcall ASSERT-EQUAL+= '(2^ -infinity) 0)
1473   (funcall ASSERT-EQUAL+= '(^ 10 -infinity) 0)
1474   (funcall ASSERT-EQUAL+= '(10^ -infinity) 0)
1475   (funcall ASSERT-EQUAL+=-nc '(^ -1 -infinity) 'not-a-number)
1476   (funcall ASSERT-EQUAL+=-nc '(^ -infinity 0) 'not-a-number)
1477   (funcall ASSERT-EQUAL+= '(^ -infinity 1) '-infinity)
1478   (funcall ASSERT-EQUAL+= '(^ -infinity 2) '+infinity)
1479   (funcall ASSERT-EQUAL+= '(^ -infinity -1) 0)
1480   (funcall ASSERT-EQUAL+= '(^-1 -infinity) 0)
1481   (funcall ASSERT-EQUAL+= '(^ -infinity -2) 0)
1482   (funcall ASSERT-EQUAL+=-nc '(^ +infinity -infinity) 'not-a-number)
1483   (funcall ASSERT-EQUAL+=-nc '(^ -infinity -infinity) 'not-a-number)
1484   (funcall ASSERT-EQUAL+= '(^ complex-infinity -infinity) 'complex-infinity)
1485
1486   (funcall ASSERT-EQUAL+= '(^ 0 complex-infinity) 'complex-infinity)
1487   (funcall ASSERT-EQUAL+= '(^ 1 complex-infinity) 'complex-infinity)
1488   (funcall ASSERT-EQUAL+= '(^ -1 complex-infinity) 'complex-infinity)
1489   (funcall ASSERT-EQUAL+=-nc '(^ complex-infinity 0) 'not-a-number)
1490   (funcall ASSERT-EQUAL+= '(^ complex-infinity 1) 'complex-infinity)
1491   (funcall ASSERT-EQUAL+= '(^ complex-infinity -1) 'complex-infinity)
1492   (funcall ASSERT-EQUAL+= '(^ complex-infinity +infinity) 'complex-infinity)
1493   (funcall ASSERT-EQUAL+= '(^ +infinity complex-infinity) 'complex-infinity)
1494   (funcall ASSERT-EQUAL+= '(^ -infinity complex-infinity) 'complex-infinity)
1495   (funcall ASSERT-EQUAL+=
1496            '(^ complex-infinity complex-infinity) complex-infinity)
1497
1498   (funcall ASSERT-EQUAL+=-nc '(^ 0 not-a-number) 'not-a-number)
1499   (funcall ASSERT-EQUAL+=-nc '(^ 1 not-a-number) 'not-a-number)
1500   (funcall ASSERT-EQUAL+=-nc '(^ -1 not-a-number) 'not-a-number)
1501   (funcall ASSERT-EQUAL+=-nc '(^ not-a-number 0) 'not-a-number)
1502   (funcall ASSERT-EQUAL+=-nc '(^ not-a-number 1) 'not-a-number)
1503   (funcall ASSERT-EQUAL+=-nc '(^ not-a-number -1) 'not-a-number)
1504   (funcall ASSERT-EQUAL+=-nc '(^ not-a-number +infinity) 'not-a-number)
1505   (funcall ASSERT-EQUAL+=-nc '(^ +infinity not-a-number) 'not-a-number)
1506   (funcall ASSERT-EQUAL+=-nc '(^ not-a-number -infinity) 'not-a-number)
1507   (funcall ASSERT-EQUAL+=-nc '(^ -infinity not-a-number) 'not-a-number)
1508   (funcall ASSERT-EQUAL+=-nc
1509            '(^ not-a-number complex-infinity) 'not-a-number)
1510   (funcall ASSERT-EQUAL+=-nc
1511            '(^ complex-infinity not-a-number) 'not-a-number)
1512   )
1513
1514 ;; testing order of numbers and infinities
1515 (Assert (/= -1 +infinity))
1516 (Assert (not (= -1 +infinity)))
1517 (Assert (< -1 +infinity))
1518 (Assert (not (> -1 +infinity)))
1519 (Assert (<= -1 +infinity))
1520 (Assert (not (>= -1 +infinity)))
1521 (Assert (/= +infinity -1))
1522 (Assert (not (= +infinity -1)))
1523 (Assert (not (< +infinity -1)))
1524 (Assert (> +infinity -1))
1525 (Assert (not (<= +infinity -1)))
1526 (Assert (>= +infinity -1))
1527 (Assert (< +infinity +infinity))
1528 (Assert (> +infinity +infinity))
1529 (Assert (= +infinity +infinity))
1530 (Assert (<= +infinity +infinity))
1531 (Assert (>= +infinity +infinity))
1532
1533 (Assert (/= -1 -infinity))
1534 (Assert (not (= -1 -infinity)))
1535 (Assert (not (< -1 -infinity)))
1536 (Assert (> -1 -infinity))
1537 (Assert (not (<= -1 -infinity)))
1538 (Assert (>= -1 -infinity))
1539 (Assert (/= -infinity -1))
1540 (Assert (not (= -infinity -1)))
1541 (Assert (< -infinity -1))
1542 (Assert (not (> -infinity -1)))
1543 (Assert (<= -infinity -1))
1544 (Assert (not (>= -infinity -1)))
1545 (Assert (< -infinity -infinity))
1546 (Assert (> -infinity -infinity))
1547 (Assert (= -infinity -infinity))
1548 (Assert (<= -infinity -infinity))
1549 (Assert (>= -infinity -infinity))
1550
1551 (Assert (/= -infinity +infinity))
1552 (Assert (not (= -infinity +infinity)))
1553 (Assert (< -infinity -1 +infinity))
1554 (Assert (not (> -infinity -1 +infinity)))
1555 (Assert (not (> -1 -infinity +infinity)))
1556 (Assert (<= -infinity -1 +infinity))
1557 (Assert (not (>= -infinity -1 +infinity)))
1558 (Assert (not (< +infinity -1 -infinity)))
1559 (Assert (> +infinity -1 -infinity))
1560 (Assert (not (<= +infinity -1 -infinity)))
1561 (Assert (>= +infinity -1 -infinity))
1562 (Assert (< -infinity -infinity -2 -1 0 +infinity +infinity))
1563 (Assert (> +infinity +infinity 2 1 0 -infinity -infinity))
1564 (Assert (<= -infinity -infinity -2 -1 0 +infinity +infinity))
1565 (Assert (>= +infinity +infinity 2 1 0 -infinity -infinity))
1566
1567 (Check-Error relation-error (< 0 complex-infinity))
1568 (Check-Error relation-error (= 0 complex-infinity))
1569 (Check-Error relation-error (/= 0 complex-infinity))
1570 (Check-Error relation-error (> 0 complex-infinity))
1571 (Check-Error relation-error (<= 0 complex-infinity))
1572 (Check-Error relation-error (>= 0 complex-infinity))
1573 (Check-Error relation-error (< complex-infinity 0))
1574 (Check-Error relation-error (= complex-infinity 0))
1575 (Check-Error relation-error (/= complex-infinity 0))
1576 (Check-Error relation-error (> complex-infinity 0))
1577 (Check-Error relation-error (<= complex-infinity 0))
1578 (Check-Error relation-error (>= complex-infinity 0))
1579
1580 (Check-Error relation-error (< 0 not-a-number))
1581 (Check-Error relation-error (< +infinity not-a-number))
1582 (Check-Error relation-error (< not-a-number not-a-number))
1583 (Check-Error relation-error (< complex-infinity not-a-number))
1584 (Check-Error relation-error (= 0 not-a-number))
1585 (Check-Error relation-error (= +infinity not-a-number))
1586 (Check-Error relation-error (= complex-infinity not-a-number))
1587 (Check-Error relation-error (= not-a-number not-a-number))
1588 (Check-Error relation-error (/= 0 not-a-number))
1589 (Check-Error relation-error (/= +infinity not-a-number))
1590 (Check-Error relation-error (/= complex-infinity not-a-number))
1591 (Check-Error relation-error (/= not-a-number not-a-number))
1592 (Check-Error relation-error (> 0 not-a-number))
1593 (Check-Error relation-error (> +infinity not-a-number))
1594 (Check-Error relation-error (> complex-infinity not-a-number))
1595 (Check-Error relation-error (> not-a-number not-a-number))
1596 (Check-Error relation-error (<= 0 not-a-number))
1597 (Check-Error relation-error (<= +infinity not-a-number))
1598 (Check-Error relation-error (<= complex-infinity not-a-number))
1599 (Check-Error relation-error (<= not-a-number not-a-number))
1600 (Check-Error relation-error (>= 0 not-a-number))
1601 (Check-Error relation-error (>= +infinity not-a-number))
1602 (Check-Error relation-error (>= complex-infinity not-a-number))
1603 (Check-Error relation-error (>= not-a-number not-a-number))
1604 (Check-Error relation-error (< not-a-number 0))
1605 (Check-Error relation-error (< not-a-number +infinity))
1606 (Check-Error relation-error (< not-a-number complex-infinity))
1607 (Check-Error relation-error (< not-a-number 0 not-a-number))
1608 (Check-Error relation-error (= not-a-number 0))
1609 (Check-Error relation-error (= not-a-number +infinity))
1610 (Check-Error relation-error (= not-a-number complex-infinity))
1611 (Check-Error relation-error (= not-a-number 0 not-a-number))
1612 (Check-Error relation-error (/= not-a-number 0))
1613 (Check-Error relation-error (/= not-a-number +infinity))
1614 (Check-Error relation-error (/= not-a-number complex-infinity))
1615 (Check-Error relation-error (/= not-a-number 0 not-a-number))
1616 (Check-Error relation-error (> not-a-number 0))
1617 (Check-Error relation-error (> not-a-number +infinity))
1618 (Check-Error relation-error (> not-a-number complex-infinity))
1619 (Check-Error relation-error (> not-a-number 0 not-a-number))
1620 (Check-Error relation-error (<= not-a-number 0))
1621 (Check-Error relation-error (<= not-a-number +infinity))
1622 (Check-Error relation-error (<= not-a-number complex-infinity))
1623 (Check-Error relation-error (<= not-a-number 0 not-a-number))
1624 (Check-Error relation-error (>= not-a-number 0))
1625 (Check-Error relation-error (>= not-a-number +infinity))
1626 (Check-Error relation-error (>= not-a-number complex-infinity))
1627 (Check-Error relation-error (>= not-a-number 0 not-a-number))
1628
1629
1630 ;; testing predicates on infinities
1631 (let ((npreds '(zerop intp bigzp integerp bigqp rationalp floatp
1632                       bigfp bigfrp realp biggp bigcp
1633                       consp stringp arrayp evenp oddp primep))
1634       (comp-inf-preds '(comparablep))
1635       (inf-preds '(atom numberp infinityp archimedeanp))
1636       ;; values
1637       (nvals '(+infinity -infinity complex-infinity not-a-number))
1638       (comp-inf-vals '(+infinity -infinity))
1639       (inf-vals '(+infinity -infinity complex-infinity)))
1640   (mapc #'(lambda (pred)
1641             (and (fboundp pred)
1642                  (mapc #'(lambda (val)
1643                            (eval `(Assert (not (,pred ,val)))))
1644                        nvals)))
1645         npreds)
1646   (mapc #'(lambda (pred)
1647             (mapc #'(lambda (val)
1648                       (eval `(Assert (,pred ,val))))
1649                   comp-inf-vals))
1650         comp-inf-preds)
1651   (mapc #'(lambda (pred)
1652             (mapc #'(lambda (val)
1653                       (eval `(Assert (,pred ,val))))
1654                   inf-vals))
1655         inf-preds))
1656
1657 ;; testing lifts
1658 (let ((lift-types
1659        (remove-if-not
1660         #'(lambda (type)
1661             (condition-case nil
1662                 (coerce-number 0 type)
1663               (error nil)))
1664         '(int bigz integer bigq rational bigf bigfr float real
1665               bigc quatern))))
1666   (mapc-internal
1667    #'(lambda (type)
1668        (eval `(Assert (zerop (coerce-number 0 ',type))))
1669        (eval `(Assert (onep (coerce-number 1 ',type))))
1670        (eval `(Assert (zerop (coerce-number 0.0 ',type))))
1671        (eval `(Assert (onep (coerce-number 1.0 ',type))))
1672
1673        ;; lifts are idempotent
1674        (eval `(Assert-Equal
1675                        (coerce-number 0 ',type)
1676                        (coerce-number (coerce-number 0 ',type) ',type)))
1677        (eval `(Assert-Equal
1678                        (coerce-number 1 ',type)
1679                        (coerce-number (coerce-number 1 ',type) ',type)))
1680        (eval `(Assert (= (coerce-number 0 ',type)
1681                          (coerce-number (coerce-number 0 ',type) ',type))))
1682        (eval `(Assert (= (coerce-number 1 ',type)
1683                          (coerce-number (coerce-number 1 ',type) ',type))))
1684        ;; lifts are homomorphic wrt negation (equal'ity needs not hold)
1685        (eval `(Assert (= (coerce-number -1 ',type)
1686                          (- (coerce-number 1 ',type)))))
1687
1688        ;; infinity lifts
1689        (eval `(Assert (indefinitep (coerce-number +infinity ',type))))
1690        (eval `(Assert (indefinitep (coerce-number -infinity ',type))))
1691        (eval `(Assert (infinityp (coerce-number +infinity ',type))))
1692        (eval `(Assert (infinityp (coerce-number -infinity ',type))))
1693        (eval `(Assert (= +infinity (coerce-number +infinity ',type))))
1694        (eval `(Assert (= -infinity (coerce-number -infinity ',type))))
1695        (if (comparablep (coerce-number 0 type))
1696            (eval `(Check-Error domain-error
1697                                (coerce-number complex-infinity ',type)))
1698          (eval `(Assert (infinityp
1699                          (coerce-number complex-infinity ',type))))
1700          (eval `(Assert (= complex-infinity
1701                            (coerce-number complex-infinity ',type)))))
1702        (eval `(Check-Error domain-error
1703                            (coerce-number not-a-number ',type))))
1704    lift-types))
1705
1706 ;; testing string conversion
1707 (Assert (string= (number-to-string +infinity) "+infinity"))
1708 (Assert (string= (number-to-string -infinity) "-infinity"))
1709 (Assert (string= (number-to-string complex-infinity) "complex-infinity"))
1710 (Check-Error wrong-type-argument (number-to-string not-a-number))
1711
1712 (when (featurep 'bigfr)
1713   ;; test computations which throw out an indefinite
1714   (Assert (indefinitep (log 0)))
1715   (Assert (infinityp (log 0)))
1716   (Assert (indefinitep (log -1)))
1717   (Assert (indefinitep (log10 0)))
1718   (Assert (infinityp (log10 0)))
1719   (Assert (indefinitep (log10 -1)))
1720   (Assert (indefinitep (log2 0)))
1721   (Assert (infinityp (log2 0)))
1722   (Assert (indefinitep (log2 -1)))
1723   (Assert (or (indefinitep (sqrt -2))
1724               (complexp (sqrt -2))))
1725   ;; especially assert that these throws are not bigfr
1726   (Assert (not (bigfrp (log 0))))
1727   (Assert (not (bigfrp (log -1))))
1728   (Assert (not (bigfrp (log10 0))))
1729   (Assert (not (bigfrp (log10 -1))))
1730   (Assert (not (bigfrp (log2 0))))
1731   (Assert (not (bigfrp (log2 -1))))
1732   (Assert (not (bigfrp (sqrt -2)))))
1733
1734 ;; stress test for trig functions
1735 (let ((nan-funs '(acos asin atan cos sin tan sec csc cot
1736                        cosh sinh tanh sech csch coth
1737                        acosh asinh atanh
1738                        erf erfc log-gamma))
1739       (more-funs '(abs sqrt cbrt log log10 log2
1740                        ceiling truncate round
1741                        ffloor fceiling ftruncate fround
1742                        next-prime
1743                        canonical-norm conjugate real-part))
1744       (vals '(+infinity -infinity complex-infinity not-a-number)))
1745   (mapc #'(lambda (fun)
1746             (when (fboundp fun)
1747               (mapc #'(lambda (val)
1748                         (eval `(Assert-Equal (,fun ,val) not-a-number)))
1749                     vals)))
1750         nan-funs)
1751   (mapc #'(lambda (fun)
1752             (when (fboundp fun)
1753               (mapc #'(lambda (val)
1754                         (eval `(Assert (indefinitep (,fun ,val)))))
1755                     vals)))
1756         more-funs)
1757
1758   ;; some more checks
1759   (when (or (featurep 'bigg)
1760             (featurep 'bigc))
1761     (Assert (zerop (imaginary-part +infinity)))
1762     (Assert (zerop (imaginary-part -infinity)))
1763     (Assert (infinityp (imaginary-part complex-infinity))))
1764   (Assert (zerop (exp -infinity)))
1765   ;; logb cannot handle infinity, this might change in the future
1766   ;; same for logand, logior, logxor and lognot
1767   (mapc #'(lambda (fun)
1768             (mapc #'(lambda (val)
1769                       (eval `(Check-Error wrong-type-argument (,fun ,val))))
1770                   vals))
1771         '(;;logb
1772           logand logior logxor lognot)))
1773
1774
1775 (when (featurep 'bigz)
1776   ;; test remove-factor with infinities
1777   (mapc #'(lambda (i)
1778             (eval `(Assert (consp (remove-factor +infinity ,i))))
1779             (if (infinityp (eval i))
1780                 (eval `(Assert (infinityp (cdr (remove-factor +infinity ,i)))))
1781               (eval `(Assert (zerop (cdr (remove-factor +infinity ,i))))))
1782             (eval `(Assert (= (car (remove-factor +infinity ,i)) ,i)))
1783             (eval `(Check-Error wrong-type-argument
1784                                 (remove-factor -infinity ,i))))
1785         '(0 1 2 3 4 10 20 50 100 200 -200 -100 -50 -20 -10 -4 -1 +infinity))
1786   (mapc #'(lambda (i)
1787             (eval `(Assert (consp (remove-factor ,i +infinity))))
1788             (eval `(Assert (infinityp (cdr (remove-factor ,i +infinity)))))
1789             (eval `(Assert (infinityp (car (remove-factor ,i +infinity)))))
1790             (eval `(Assert (consp (remove-factor ,i -infinity))))
1791             (eval `(Assert (infinityp (cdr (remove-factor ,i -infinity)))))
1792             (eval `(Assert (infinityp (car (remove-factor ,i -infinity))))))
1793         '(2 3 4 10 20 50 100 200 +infinity)))
1794
1795 ;; rounding
1796 (when (featurep 'bigq)
1797   (Assert (integerp (round 10/3)))
1798   (Assert (integerp (round 11/3)))
1799   (Assert (integerp (round -10/3)))
1800   (Assert (integerp (round -11/3)))
1801   (Assert (= (round 9/3) 3))
1802   (Assert (= (round 10/3) 3))
1803   (Assert (= (round 11/3) 4))
1804   (Assert (= (round 12/3) 4))
1805   (Assert (= (round -9/3) -3))
1806   (Assert (= (round -10/3) -3))
1807   (Assert (= (round -11/3) -4))
1808   (Assert (= (round -12/3) -4)))
1809
1810
1811 ;;-----------------------------------------------------
1812 ;; Test zeroes and ones
1813 ;;-----------------------------------------------------
1814 (let ((zero 0)
1815       (zerof 0.0)
1816       (one 1)
1817       (onef 1.0))
1818   (Assert (zerop zero))
1819   (Assert (zerop zerof))
1820   (Assert (onep one))
1821   (Assert (onep onef))
1822   ;; these tests are useful because there are rings where one is zero
1823   (Assert (not (zerop one)))
1824   (Assert (not (zerop onef)))
1825   (Assert (not (onep zero)))
1826   (Assert (not (onep zerof)))
1827   (Assert (onep (1+ zero)))
1828   (Assert (onep (1+ zerof)))
1829   (Assert (zerop (1- one)))
1830   (Assert (zerop (1- onef)))
1831   ;; check coercions
1832   (mapc #'(lambda (cat)
1833             (when (featurep cat)
1834               (eval `(Assert (zerop (coerce-number ,zero ',cat))))
1835               (eval `(Assert (zerop (coerce-number ,zerof ',cat))))
1836               (eval `(Assert (onep (coerce-number ,one ',cat))))
1837               (eval `(Assert (onep (coerce-number ,onef ',cat))))
1838               ;; again we test the null-ring property
1839               (eval `(Assert (not (zerop (coerce-number ,one ',cat)))))
1840               (eval `(Assert (not (zerop (coerce-number ,onef ',cat)))))
1841               (eval `(Assert (not (onep (coerce-number ,zero ',cat)))))
1842               (eval `(Assert (not (onep (coerce-number ,zerof ',cat)))))))
1843         '(bigz bigq bigf bigfr bigg bigc)))
1844
1845 (let ((ints (list 1 4 -23 0))
1846       (bigzs (when (featurep 'bigz)
1847                (list (factorial 23) (bigz 40) -892893489238924308234 (bigz 0))))
1848       (bigqs (when (featurep 'bigq)
1849                (list 3/4 (// (factorial 42) 101) -82759873478/1231 (bigq 0))))
1850       (floats (list 1.4 22.44 -494.2 (float 0)))
1851       (bigfs (when (featurep 'bigf)
1852                (list (bigf 1.44) (bigf (factorial 20)) (bigf 0))))
1853       (bigfrs (when (featurep 'bigfr)
1854                 (list (exp 1) (atan 1) (exp 0) (bigfr 0))))
1855       (biggs (when (featurep 'bigg)
1856                (list 2+3i (make-bigg (factorial 20) 213) (bigg 0))))
1857       (bigcs (when (featurep 'bigc)
1858                (list 2.3+1.22i (make-bigc (exp 1) (exp 1)) (bigc 0)))))
1859   (mapc #'(lambda (cat)
1860             (mapc #'(lambda (num)
1861                       ;; zeroes
1862                       (eval `(Assert (zerop (zero ,num))))
1863                       (when (comparablep num)
1864                         (eval `(Assert (= (+ (zero ,num) ,num) ,num)))
1865                         (eval `(Assert (= (* (zero ,num) ,num) (zero ,num)))))
1866                       (unless (comparablep num)
1867                         (eval `(Assert-Equal (+ (zero ,num) ,num) ,num))
1868                         (eval `(Assert
1869                                 (equal (* (zero ,num) ,num) (zero ,num)))))
1870                       ;; ones
1871                       (eval `(Assert (onep (one ,num))))
1872                       (eval `(Assert (zerop (1- (one ,num)))))
1873                       (eval `(Assert (onep (1+ (zero ,num)))))
1874                       (when (comparablep num)
1875                         (eval `(Assert (= (* (one ,num) ,num) ,num)))
1876                         (eval `(Assert (= (zero ,num) (1- (one ,num))))))
1877                       (unless (comparablep num)
1878                         (eval `(Assert-Equal (* (one ,num) ,num) ,num))
1879                         (eval `(Assert-Equal (zero ,num) (1- (one ,num))))))
1880                   (symbol-value cat)))
1881         '(ints bigzs bigqs floats bigfs bigfrs biggs bigcs)))
1882
1883
1884 ;;-----------------------------------------------------
1885 ;; Test units
1886 ;;-----------------------------------------------------
1887 (Assert (unitp 1))
1888 (Assert (unitp -1))
1889 (Assert (not (unitp 0)))
1890 (Assert (not (unitp 2)))
1891
1892 (when (featurep 'fpfloat)
1893   (Assert (unitp 0.0))
1894   (Assert (unitp 1.0))
1895   (Assert (unitp -1.0))
1896   (Assert (unitp -2.2)))
1897
1898 (when (featurep 'bigz)
1899   (Assert (unitp (bigz 1)))
1900   (Assert (unitp (bigz -1)))
1901   (Assert (not (unitp (bigz 0))))
1902   (Assert (not (unitp (bigz -3)))))
1903
1904 (when (featurep 'bigq)
1905   (Assert (unitp (bigq 1)))
1906   (Assert (unitp (bigq -1)))
1907   (Assert (unitp (bigq 0)))
1908   (Assert (unitp 1/2))
1909   (Assert (unitp -2/3)))
1910
1911 (when (featurep 'bigf)
1912   (Assert (unitp (bigf 1)))
1913   (Assert (unitp (bigf 1.2)))
1914   (Assert (unitp (bigf 0)))
1915   (Assert (unitp (bigf -1.3333))))
1916
1917 (when (featurep 'bigfr)
1918   (Assert (unitp (bigfr 0)))
1919   (Assert (unitp (bigfr 1)))
1920   (Assert (unitp (bigfr -1)))
1921   (Assert (unitp (bigfr -0.2)))
1922   (Assert (unitp (bigfr 0.2 4096))))
1923
1924 (when (featurep 'gaussian)
1925   (Assert (unitp 1+0i))
1926   (Assert (unitp 0+i))
1927   (Assert (not (unitp 0+0i)))
1928   (Assert (unitp 1+i))
1929   (Assert (unitp -1+0i))
1930   (Assert (unitp -1-i))
1931   (Assert (unitp 0-i))
1932   (Assert (not (unitp -2+i)))
1933   (Assert (not (unitp 1+2i)))
1934   (Assert (not (unitp 1-3i))))
1935
1936 (when (featurep 'bigc)
1937   (Assert (unitp (bigc 0)))
1938   (Assert (unitp (bigc 1)))
1939   (Assert (unitp (bigc -1)))
1940   (Assert (unitp 0.5-0.5i))
1941   (Assert (unitp -0.25+i))
1942   (Assert (unitp 0.0+2.0i))
1943   (Assert (unitp -0.1-22.1i)))
1944
1945 (when (featurep 'quatern)
1946   (Assert (unitp 1+0i+0j+0k))
1947   (Assert (unitp 0+i+0j+0k))
1948   (Assert (unitp 0+0i+j+0k))
1949   (Assert (unitp 0+0i+0j+k))
1950   (Assert (not (unitp 0+0i+0j+0k)))
1951   (Assert (unitp 1+i+0j+0k))
1952   (Assert (unitp 1+0i+j+0k))
1953   (Assert (unitp 1+0i+0j+k))
1954   (Assert (unitp 0+i+j+0k))
1955   (Assert (unitp 0+i+0j+k))
1956   (Assert (unitp 0+0i+j+k))
1957   (Assert (unitp 0+i+j+k))
1958   (Assert (unitp 1+0i+j+k))
1959   (Assert (unitp 1+i+0j+k))
1960   (Assert (unitp 1+i+j+0k))
1961   (Assert (unitp 1+i+j+k))
1962   (Assert (unitp -1-i-j-k))
1963   (Assert (unitp 0-i-j+k))
1964   (Assert (unitp 0+i-j-k))
1965   (Assert (unitp 1+0i+j-k))
1966   (Assert (not (unitp 2+i+j+k)))
1967   (Assert (not (unitp -2+2i-j+2k))))
1968
1969
1970 ;;-----------------------------------------------------
1971 ;; Test miscellaneous functions
1972 ;;-----------------------------------------------------
1973
1974 (Check-Error wrong-type-argument (random 0))
1975 (when (featurep 'bigz)
1976   (Check-Error wrong-type-argument (random (bigz 0)))
1977
1978   (dotimes (i 1000)
1979     (Assert (intp (random)))
1980
1981     ;; test random function with limit
1982     (let ((limit (bigz (random))))
1983       (cond ((positivep limit)
1984              (Assert (nonnegativep (random limit))))
1985             ((zerop limit)
1986              (Check-Error wrong-type-argument (random limit)))
1987             (t
1988              (Check-Error wrong-type-argument (random limit)))))
1989
1990     ;; random with limit of 1 should always return zero
1991     (Assert (zerop (random 1)))
1992     (Assert (zerop (random (bigz 1)))))
1993
1994   ;; expect at least one bigz random number in 1000 trials
1995   (Assert (let ((some nil))
1996             (dotimes (i 1000 some)
1997               (setq some
1998                     (or some (bigzp (random (factorial 20)))))))))
1999