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))))