0.7.7.38:
[sbcl.git] / 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
16 (defmacro define-compiled-fun (fun name)
17   `(progn
18     (declaim (notinline ,name))
19     (defun ,name (&rest args)
20      (declare (optimize safety))
21      (case (length args)
22        (0 (,fun))
23        (1 (,fun (car args)))
24        (2 (,fun (car args) (cadr args)))
25        (t (apply #',fun args))))))
26
27 (define-compiled-fun min compiled-min)
28 (define-compiled-fun max compiled-max)
29 (define-compiled-fun + compiled-+)
30 (define-compiled-fun * compiled-*)
31 (define-compiled-fun logand compiled-logand)
32 (define-compiled-fun logior compiled-logior)
33 (define-compiled-fun logxor compiled-logxor)
34
35 (assert (null (ignore-errors (compiled-min '(1 2 3)))))
36 (assert (= (compiled-min -1) -1))
37 (assert (null (ignore-errors (compiled-min 1 #(1 2 3)))))
38 (assert (= (compiled-min 10 11) 10))
39 (assert (null (ignore-errors (compiled-min (find-package "CL") -5.0))))
40 (assert (= (compiled-min 5.0 -3) -3))
41 (assert (null (ignore-errors (compiled-max #c(4 3)))))
42 (assert (= (compiled-max 0) 0))
43 (assert (null (ignore-errors (compiled-max "MIX" 3))))
44 (assert (= (compiled-max -1 10.0) 10.0))
45 (assert (null (ignore-errors (compiled-max 3 #'max))))
46 (assert (= (compiled-max -3 0) 0))
47
48 (assert (null (ignore-errors (compiled-+ "foo"))))
49 (assert (= (compiled-+ 3f0) 3f0))
50 (assert (null (ignore-errors (compiled-+ 1 #p"tmp"))))
51 (assert (= (compiled-+ 1 2) 3))
52 (assert (null (ignore-errors (compiled-+ '(1 2 3) 3))))
53 (assert (= (compiled-+ 3f0 4f0) 7f0))
54 (assert (null (ignore-errors (compiled-* "foo"))))
55 (assert (= (compiled-* 3f0) 3f0))
56 (assert (null (ignore-errors (compiled-* 1 #p"tmp"))))
57 (assert (= (compiled-* 1 2) 2))
58 (assert (null (ignore-errors (compiled-* '(1 2 3) 3))))
59 (assert (= (compiled-* 3f0 4f0) 12f0))
60
61 (assert (null (ignore-errors (compiled-logand #(1)))))
62 (assert (= (compiled-logand 1) 1))
63 (assert (null (ignore-errors (compiled-logior 3f0))))
64 (assert (= (compiled-logior 4) 4))
65 (assert (null (ignore-errors (compiled-logxor #c(2 3)))))
66 (assert (= (compiled-logxor -6) -6))
67
68 (assert (raises-error? (coerce (expt 10 1000) 'single-float) type-error))
69
70 (sb-ext:quit :unix-status 104)