tests/assertoid.lisp

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