1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / tests / assertoid.lisp
1 ;;;; the ASSERTOID macro, asserting something with added generality
2 ;;;; to help in regression tests
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
9 ;;;; from CMU CL.
10 ;;;;
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
14
15 (cl:defpackage "ASSERTOID"
16   (:use "CL")
17   (:export "GRAB-CONDITION" "RAISES-ERROR?" "IS" "ASSERTOID"))
18
19 (cl:in-package "ASSERTOID")
20
21 (defmacro grab-condition (&body body)
22   `(nth-value 1
23      (ignore-errors ,@body)))
24
25 (defmacro raises-error? (form &optional (error-subtype-spec 'error))
26   `(typep (nth-value 1 (ignore-errors ,form)) ',error-subtype-spec))
27
28 ;;; EXPR is an expression to evaluate (both with EVAL and with
29 ;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
30 ;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the
31 ;;; expression to be tested in other than the default optimization
32 ;;; level(s).
33 ;;;
34 ;;; The messiness with the various flavors of EXPECTED stuff is
35 ;;; to handle various issues:
36 ;;;   * Some things are expected to signal errors instead of returning
37 ;;;     ordinary values.
38 ;;;   * Some things are expected to return multiple values.
39 ;;;   * Some things can return any of several values (e.g. generalized
40 ;;;     booleans).
41 ;;; The default is to expect a generalized boolean true.
42 ;;;
43 ;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given
44 ;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
45 ;;; shorthand for special cases of EXPECTED-LAMBDA.
46 ;;;
47 ;;; Use EXPECTED-ERROR to require an error to be signalled. Use
48 ;;; EXPECTED-ERROR-LAMBDA to require that an error be signalled and
49 ;;; that further it satisfies the given lambda.
50 (defmacro assertoid (expr
51                      &key
52                      extra-optimizations
53                      (expected-eql nil expected-eql-p)
54                      (expected-equal nil expected-equal-p)
55                      (expected-equalp nil expected-equalp-p)
56                      (expected-lambda (cond
57                                        (expected-eql-p
58                                         (lambda (x)
59                                           (eql x (eval expected-eql))))
60                                        (expected-equal-p
61                                         (lambda (x)
62                                           (equal x (eval expected-equal))))
63                                        (expected-equalp-p
64                                         (lambda (x)
65                                           (equalp x (eval expected-equalp))))
66                                        (t
67                                         (lambda (x)
68                                           x)))
69                                       expected-lambda-p)
70                      (expected-error-type nil expected-error-type-p)
71                      (expected-error-lambda (if expected-error-type
72                                                 (lambda (condition)
73                                                   (typep condition
74                                                          expected-error-type))
75                                                 nil)
76                                             expected-error-lambda-p))
77   (when (> (count-if #'identity
78                      (vector expected-eql-p
79                              expected-equal-p
80                              expected-equalp-p
81                              expected-lambda-p
82                              expected-error-type-p
83                              expected-error-lambda-p))
84            1)
85     (error "multiple EXPECTED-FOO arguments"))
86   (when expected-error-lambda
87     (error "stub: expected-error functionality not supported yet"))
88   (let ((eval-expected-lambda (eval expected-lambda)))
89     (flet ((frob (evaloid)
90                  (let ((result (funcall evaloid expr)))
91                    (unless (funcall eval-expected-lambda result)
92                      (error "failed assertoid ~S" expr))))
93            (compile-as-evaloid (optimizations)
94              (lambda (expr)
95                (funcall (compile nil
96                                  `(lambda ()
97                                     (declare (optimize ,@optimizations))
98                                     ,expr))))))
99       (frob #'eval)
100       (frob (compile-as-evaloid ()))
101       (dolist (i extra-optimizations)
102         (frob (compile-as-evaloid i))))))
103
104 ;;; examples
105 (assertoid (= 2 (length (list 1 2))))
106 (assertoid (= 2 (length (list 1 2)))
107            :extra-optimizations (((speed 2) (space 3))
108                                  ((speed 1) (space 3))))
109 (assertoid (cons 1 2)
110            :expected-lambda (lambda (x) (equal x '(1 . 2))))
111 (assertoid (cons (list 1 2) (list 1 2))
112            :expected-equal '((1 2) 1 2))
113 ;;; not implemented yet:
114 #+nil (assertoid (length (eval (find-package :cl)))
115                  :expected-error-type 'type-error)
116
117 (defmacro is (form)
118   (if (consp form)
119       (destructuring-bind (op expected real) form
120         `(let ((expected-value ,expected)
121                (real-value ,real))
122            (unless (,op expected-value real-value)
123              (error "Wanted ~S, got ~S:~% ~S"
124                     expected-value real-value ',form))))
125       `(unless ,form
126          (error "~S evaluated to NIL" ',form))))