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