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:in-package :cl-user)
  16
  17 (defmacro grab-condition (&body body)
  18   `(nth-value 1
  19      (ignore-errors ,@body)))
  20
  21 (defmacro raises-error? (&body body)
  22   `(typep (nth-value 1 (ignore-errors ,@body)) 'error))
  23
  24 ;;; EXPR is an expression to evaluate (both with EVAL and with
  25 ;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
  26 ;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the
  27 ;;; expression to be tested in other than the default optimization
  28 ;;; level(s).
  29 ;;;
  30 ;;; The messiness with the various flavors of EXPECTED stuff is
  31 ;;; to handle various issues:
  32 ;;;   * Some things are expected to signal errors instead of returning
  33 ;;;     ordinary values.
  34 ;;;   * Some things are expected to return multiple values.
  35 ;;;   * Some things can return any of several values (e.g. generalized
  36 ;;;     booleans).
  37 ;;; The default is to expect a generalized boolean true.
  38 ;;;
  39 ;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given
  40 ;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
  41 ;;; shorthand for special cases of EXPECTED-LAMBDA.
  42 ;;;
  43 ;;; Use EXPECTED-ERROR to require an error to be thrown. Use
  44 ;;; EXPECTED-ERROR-LAMBDA to require that an error be thrown and
  45 ;;; that further it satisfies the given lambda.
  46 (defmacro assertoid (expr
  47                      &key
  48                      extra-optimizations
  49                      (expected-eql nil expected-eql-p)
  50                      (expected-equal nil expected-equal-p)
  51                      (expected-equalp nil expected-equalp-p)
  52                      (expected-lambda (cond
  53                                        (expected-eql-p
  54                                         (lambda (x)
  55                                           (eql x (eval expected-eql))))
  56                                        (expected-equal-p
  57                                         (lambda (x)
  58                                           (equal x (eval expected-equal))))
  59                                        (expected-equalp-p
  60                                         (lambda (x)
  61                                           (equalp x (eval expected-equalp))))
  62                                        (t
  63                                         (lambda (x)
  64                                           x)))
  65                                       expected-lambda-p)
  66                      (expected-error-type nil expected-error-type-p)
  67                      (expected-error-lambda (if expected-error-type
  68                                                 (lambda (condition)
  69                                                   (typep condition
  70                                                          expected-error-type))
  71                                                 nil)
  72                                             expected-error-lambda-p))
  73   (when (> (count-if #'identity
  74                      (vector expected-eql-p
  75                              expected-equal-p
  76                              expected-equalp-p
  77                              expected-lambda-p
  78                              expected-error-type-p
  79                              expected-error-lambda-p))
  80            1)
  81     (error "multiple EXPECTED-FOO arguments"))
  82   (when expected-error-lambda
  83     (error "stub: expected-error functionality not supported yet"))
  84   (let ((eval-expected-lambda (eval expected-lambda)))
  85     (flet ((frob (evaloid)
  86                  (let ((result (funcall evaloid expr)))
  87                    (unless (funcall eval-expected-lambda result)
  88                      (error "failed assertoid" expr))))
  89            (compile-as-evaloid (optimizations)
  90              (lambda (expr)
  91                (funcall (compile nil
  92                                  `(lambda ()
  93                                     (declare (optimize ,@optimizations))
  94                                     ,expr))))))
  95       (frob #'eval)
  96       (frob (compile-as-evaloid ()))
  97       (dolist (i extra-optimizations)
  98         (frob (compile-as-evaloid i))))))
  99
 100 ;;; examples
 101 (assertoid (= 2 (length (list 1 2))))
 102 (assertoid (= 2 (length (list 1 2)))
 103            :extra-optimizations (((speed 2) (space 3))
 104                                  ((speed 1) (space 3))))
 105 (assertoid (cons 1 2)
 106            :expected-lambda (lambda (x) (equal x '(1 . 2))))
 107 (assertoid (cons (list 1 2) (list 1 2))
 108            :expected-equal '((1 2) 1 2))
 109 ;;; not implemented yet:
 110 #+nil (assertoid (length (eval (find-package :cl)))
 111                  :expected-error-type 'type-error)