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" "ASSERT-ERROR"
  18            "HAS-ERROR?" "IS" "ASSERTOID"
  19            "ASSERT-SIGNAL" "ASSERT-NO-SIGNAL"))
  20
  21 (cl:in-package "ASSERTOID")
  22
  23 (defmacro grab-condition (&body body)
  24   `(nth-value 1
  25      (ignore-errors ,@body)))
  26
  27 (defmacro has-error? (form &optional (error-subtype-spec 'error))
  28   `(typep (nth-value 1 (ignore-errors ,form)) ',error-subtype-spec))
  29
  30 (defmacro assert-error (form &optional (error-subtype-spec 'error))
  31   `(assert (typep (nth-value 1 (ignore-errors ,form)) ',error-subtype-spec)))
  32
  33 (defmacro assert-signal (form &optional (signal-type 'condition))
  34   (let ((signal (gensym)))
  35     `(let (,signal)
  36        (handler-bind ((,signal-type (lambda (c)
  37                                       (setf ,signal c))))
  38          ,form)
  39        (assert ,signal))))
  40
  41 (defmacro assert-no-signal (form &optional (signal-type 'condition))
  42   (let ((signal (gensym)))
  43     `(let (,signal)
  44        (handler-bind ((,signal-type (lambda (c)
  45                                       (setf ,signal c))))
  46          ,form)
  47        (assert (not ,signal)))))
  48
  49 ;;; EXPR is an expression to evaluate (both with EVAL and with
  50 ;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
  51 ;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the
  52 ;;; expression to be tested in other than the default optimization
  53 ;;; level(s).
  54 ;;;
  55 ;;; The messiness with the various flavors of EXPECTED stuff is
  56 ;;; to handle various issues:
  57 ;;;   * Some things are expected to signal errors instead of returning
  58 ;;;     ordinary values.
  59 ;;;   * Some things are expected to return multiple values.
  60 ;;;   * Some things can return any of several values (e.g. generalized
  61 ;;;     booleans).
  62 ;;; The default is to expect a generalized boolean true.
  63 ;;;
  64 ;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given
  65 ;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
  66 ;;; shorthand for special cases of EXPECTED-LAMBDA.
  67 ;;;
  68 ;;; Use EXPECTED-ERROR to require an error to be signalled. Use
  69 ;;; EXPECTED-ERROR-LAMBDA to require that an error be signalled and
  70 ;;; that further it satisfies the given lambda.
  71 (defmacro assertoid (expr
  72                      &key
  73                      extra-optimizations
  74                      (expected-eql nil expected-eql-p)
  75                      (expected-equal nil expected-equal-p)
  76                      (expected-equalp nil expected-equalp-p)
  77                      (expected-lambda (cond
  78                                        (expected-eql-p
  79                                         (lambda (x)
  80                                           (eql x (eval expected-eql))))
  81                                        (expected-equal-p
  82                                         (lambda (x)
  83                                           (equal x (eval expected-equal))))
  84                                        (expected-equalp-p
  85                                         (lambda (x)
  86                                           (equalp x (eval expected-equalp))))
  87                                        (t
  88                                         (lambda (x)
  89                                           x)))
  90                                       expected-lambda-p)
  91                      (expected-error-type nil expected-error-type-p)
  92                      (expected-error-lambda (if expected-error-type
  93                                                 (lambda (condition)
  94                                                   (typep condition
  95                                                          expected-error-type))
  96                                                 nil)
  97                                             expected-error-lambda-p))
  98   (when (> (count-if #'identity
  99                      (vector expected-eql-p
 100                              expected-equal-p
 101                              expected-equalp-p
 102                              expected-lambda-p
 103                              expected-error-type-p
 104                              expected-error-lambda-p))
 105            1)
 106     (error "multiple EXPECTED-FOO arguments"))
 107   (when expected-error-lambda
 108     (error "stub: expected-error functionality not supported yet"))
 109   (let ((eval-expected-lambda (eval expected-lambda)))
 110     (flet ((frob (evaloid)
 111                  (let ((result (funcall evaloid expr)))
 112                    (unless (funcall eval-expected-lambda result)
 113                      (error "failed assertoid ~S" expr))))
 114            (compile-as-evaloid (optimizations)
 115              (lambda (expr)
 116                (funcall (compile nil
 117                                  `(lambda ()
 118                                     (declare (optimize ,@optimizations))
 119                                     ,expr))))))
 120       (frob #'eval)
 121       (frob (compile-as-evaloid ()))
 122       (dolist (i extra-optimizations)
 123         (frob (compile-as-evaloid i))))))
 124
 125 ;;; examples
 126 (assertoid (= 2 (length (list 1 2))))
 127 (assertoid (= 2 (length (list 1 2)))
 128            :extra-optimizations (((speed 2) (space 3))
 129                                  ((speed 1) (space 3))))
 130 (assertoid (cons 1 2)
 131            :expected-lambda (lambda (x) (equal x '(1 . 2))))
 132 (assertoid (cons (list 1 2) (list 1 2))
 133            :expected-equal '((1 2) 1 2))
 134 ;;; not implemented yet:
 135 #+nil (assertoid (length (eval (find-package :cl)))
 136                  :expected-error-type 'type-error)
 137
 138 (defmacro is (form)
 139   (if (consp form)
 140       (destructuring-bind (op expected real) form
 141         `(let ((expected-value ,expected)
 142                (real-value ,real))
 143            (unless (,op expected-value real-value)
 144              (error "Wanted ~S, got ~S:~% ~S"
 145                     expected-value real-value ',form))))
 146       `(unless ,form
 147          (error "~S evaluated to NIL" ',form))))