tests/arith.impure.lisp

   1 ;;;; arithmetic tests with side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (load "assertoid.lisp")
  15 (use-package "ASSERTOID")
  16
  17 (defmacro define-compiled-fun (fun name)
  18   `(progn
  19     (declaim (notinline ,name))
  20     (defun ,name (&rest args)
  21      (declare (optimize safety))
  22      (case (length args)
  23        (0 (,fun))
  24        (1 (,fun (car args)))
  25        (2 (,fun (car args) (cadr args)))
  26        (t (apply #',fun args))))))
  27
  28 (define-compiled-fun min compiled-min)
  29 (define-compiled-fun max compiled-max)
  30 (define-compiled-fun + compiled-+)
  31 (define-compiled-fun * compiled-*)
  32 (define-compiled-fun logand compiled-logand)
  33 (define-compiled-fun logior compiled-logior)
  34 (define-compiled-fun logxor compiled-logxor)
  35
  36 (assert (null (ignore-errors (compiled-min '(1 2 3)))))
  37 (assert (= (compiled-min -1) -1))
  38 (assert (null (ignore-errors (compiled-min 1 #(1 2 3)))))
  39 (assert (= (compiled-min 10 11) 10))
  40 (assert (null (ignore-errors (compiled-min (find-package "CL") -5.0))))
  41 (assert (= (compiled-min 5.0 -3) -3))
  42 (assert (null (ignore-errors (compiled-max #c(4 3)))))
  43 (assert (= (compiled-max 0) 0))
  44 (assert (null (ignore-errors (compiled-max "MIX" 3))))
  45 (assert (= (compiled-max -1 10.0) 10.0))
  46 (assert (null (ignore-errors (compiled-max 3 #'max))))
  47 (assert (= (compiled-max -3 0) 0))
  48
  49 (assert (null (ignore-errors (compiled-+ "foo"))))
  50 (assert (= (compiled-+ 3f0) 3f0))
  51 (assert (null (ignore-errors (compiled-+ 1 #p"tmp"))))
  52 (assert (= (compiled-+ 1 2) 3))
  53 (assert (null (ignore-errors (compiled-+ '(1 2 3) 3))))
  54 (assert (= (compiled-+ 3f0 4f0) 7f0))
  55 (assert (null (ignore-errors (compiled-* "foo"))))
  56 (assert (= (compiled-* 3f0) 3f0))
  57 (assert (null (ignore-errors (compiled-* 1 #p"tmp"))))
  58 (assert (= (compiled-* 1 2) 2))
  59 (assert (null (ignore-errors (compiled-* '(1 2 3) 3))))
  60 (assert (= (compiled-* 3f0 4f0) 12f0))
  61
  62 (assert (null (ignore-errors (compiled-logand #(1)))))
  63 (assert (= (compiled-logand 1) 1))
  64 (assert (null (ignore-errors (compiled-logior 3f0))))
  65 (assert (= (compiled-logior 4) 4))
  66 (assert (null (ignore-errors (compiled-logxor #c(2 3)))))
  67 (assert (= (compiled-logxor -6) -6))
  68
  69 (assert (raises-error? (coerce (expt 10 1000) 'single-float) type-error))
  70
  71 (sb-ext:quit :unix-status 104)