tester.lisp

   1 ;; tester.cl
   2 ;; A test harness for Allegro CL.
   3 ;;
   4 ;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
   5 ;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved.
   6 ;;
   7 ;; This code is free software; you can redistribute it and/or
   8 ;; modify it under the terms of the version 2.1 of
   9 ;; the GNU Lesser General Public License as published by
  10 ;; the Free Software Foundation, as clarified by the Franz
  11 ;; preamble to the LGPL found in
  12 ;; http://opensource.franz.com/preamble.html.
  13 ;;
  14 ;; This code is distributed in the hope that it will be useful,
  15 ;; but without any warranty; without even the implied warranty of
  16 ;; merchantability or fitness for a particular purpose.  See the GNU
  17 ;; Lesser General Public License for more details.
  18 ;;
  19 ;; Version 2.1 of the GNU Lesser General Public License can be
  20 ;; found at http://opensource.franz.com/license.html.
  21 ;; If it is not present, you can access it from
  22 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
  23 ;; version) or write to the Free Software Foundation, Inc., 59 Temple
  24 ;; Place, Suite 330, Boston, MA  02111-1307  USA
  25 ;;
  26 ;;;; from the original ACL 6.1 sources:
  27 ;; Id: tester.cl,v 2.2.12.1 2001/06/05 18:45:10 layer Exp
  28
  29 ;; $Id: tester.lisp,v 1.3 2003/07/18 19:47:07 kevin Exp $
  30
  31 (defpackage :util.test
  32   (:use :common-lisp)
  33   (:shadow #:test)
  34   (:export
  35 ;;;; Control variables:
  36    #:*break-on-test-failures*
  37    #:*error-protect-tests*
  38    #:*test-errors*
  39    #:*test-successes*
  40    #:*test-unexpected-failures*
  41
  42 ;;;; The test macros:
  43    #:test
  44    #:test-error
  45    #:test-no-error
  46    #:test-warning
  47    #:test-no-warning
  48
  49    #:with-tests
  50    ))
  51
  52 (in-package :util.test)
  53
  54 ;; Added by Kevin Rosenberg
  55
  56 (define-condition simple-break (error simple-condition) ())
  57
  58 #+cmu
  59 (unless (find-class 'break nil)
  60   (define-condition break (simple-condition) ()))
  61
  62 ;; the if* macro used in Allegro:
  63 ;;
  64 ;; This is in the public domain... please feel free to put this definition
  65 ;; in your code or distribute it with your version of lisp.
  66
  67 (eval-when (:compile-toplevel :load-toplevel :execute)
  68   (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
  69
  70 (defmacro if* (&rest args)
  71    (do ((xx (reverse args) (cdr xx))
  72         (state :init)
  73         (elseseen nil)
  74         (totalcol nil)
  75         (lookat nil nil)
  76         (col nil))
  77        ((null xx)
  78         (cond ((eq state :compl)
  79                `(cond ,@totalcol))
  80               (t (error "if*: illegal form ~s" args))))
  81        (cond ((and (symbolp (car xx))
  82                    (member (symbol-name (car xx))
  83                            if*-keyword-list
  84                            :test #'string-equal))
  85               (setq lookat (symbol-name (car xx)))))
  86
  87        (cond ((eq state :init)
  88               (cond (lookat (cond ((string-equal lookat "thenret")
  89                                    (setq col nil
  90                                          state :then))
  91                                   (t (error
  92                                       "if*: bad keyword ~a" lookat))))
  93                     (t (setq state :col
  94                              col nil)
  95                        (push (car xx) col))))
  96              ((eq state :col)
  97               (cond (lookat
  98                      (cond ((string-equal lookat "else")
  99                             (cond (elseseen
 100                                    (error
 101                                     "if*: multiples elses")))
 102                             (setq elseseen t)
 103                             (setq state :init)
 104                             (push `(t ,@col) totalcol))
 105                            ((string-equal lookat "then")
 106                             (setq state :then))
 107                            (t (error "if*: bad keyword ~s"
 108                                               lookat))))
 109                     (t (push (car xx) col))))
 110              ((eq state :then)
 111               (cond (lookat
 112                      (error
 113                       "if*: keyword ~s at the wrong place " (car xx)))
 114                     (t (setq state :compl)
 115                        (push `(,(car xx) ,@col) totalcol))))
 116              ((eq state :compl)
 117               (cond ((not (string-equal lookat "elseif"))
 118                      (error "if*: missing elseif clause ")))
 119               (setq state :init)))))
 120
 121
 122 (defvar *break-on-test-failures* nil
 123   "When a test failure occurs, common-lisp:break is called, allowing
 124 interactive debugging of the failure.")
 125
 126 (defvar *test-errors* 0
 127   "The value is the number of test errors which have occurred.")
 128 (defvar *test-successes* 0
 129   "The value is the number of test successes which have occurred.")
 130 (defvar *test-unexpected-failures* 0
 131   "The value is the number of unexpected test failures which have occurred.")
 132
 133 (defvar *error-protect-tests* nil
 134   "Protect each test from errors.  If an error occurs, then that will be
 135 taken as a test failure unless test-error is being used.")
 136
 137 (defmacro test-values-errorset (form &optional announce catch-breaks)
 138   ;; internal macro
 139   (let ((g-announce (gensym))
 140         (g-catch-breaks (gensym)))
 141     `(let* ((,g-announce ,announce)
 142             (,g-catch-breaks ,catch-breaks))
 143        (handler-case (cons t (multiple-value-list ,form))
 144          (condition (condition)
 145            (if* (and (null ,g-catch-breaks)
 146                      (typep condition 'simple-break))
 147               then (break condition)
 148             elseif ,g-announce
 149               then (format *error-output* "~&Condition type: ~a~%"
 150                            (class-of condition))
 151                    (format *error-output* "~&Message: ~a~%" condition))
 152            condition)))))
 153
 154 (defmacro test-values (form &optional announce catch-breaks)
 155   ;; internal macro
 156   (if* *error-protect-tests*
 157      then `(test-values-errorset ,form ,announce ,catch-breaks)
 158      else `(cons t (multiple-value-list ,form))))
 159
 160 (defmacro test (expected-value test-form
 161                 &key (test #'eql test-given)
 162                      (multiple-values nil multiple-values-given)
 163                      (fail-info nil fail-info-given)
 164                      (known-failure nil known-failure-given)
 165
 166 ;;;;;;;;;; internal, undocumented keywords:
 167 ;;;; Note about these keywords: if they were documented, we'd have a
 168 ;;;; problem, since they break the left-to-right order of evaluation.
 169 ;;;; Specifically, errorset breaks it, and I don't see any way around
 170 ;;;; that.  `errorset' is used by the old test.cl module (eg,
 171 ;;;; test-equal-errorset).
 172                      errorset
 173                      reported-form
 174                      (wanted-message nil wanted-message-given)
 175                      (got-message nil got-message-given))
 176   "Perform a single test.  `expected-value' is the reference value for the
 177 test.  `test-form' is a form that will produce the value to be compared to
 178 the expected-value.  If the values are not the same, then an error is
 179 logged, otherwise a success is logged.
 180
 181 Normally the comparison of values is done with `eql'.  The `test' keyword
 182 argument can be used to specify other comparison functions, such as eq,
 183 equal,equalp, string=, string-equal, etc.
 184
 185 Normally, only the first return value from the test-form is considered,
 186 however if `multiple-values' is t, then all values returned from test-form
 187 are considered.
 188
 189 `fail-info' allows more information to be printed with a test failure.
 190
 191 `known-failure' marks the test as a known failure.  This allows for
 192 programs that do regression analysis on the output from a test run to
 193 discriminate on new versus known failures."
 194   `(test-check
 195     :expected-result ,expected-value
 196     :test-results
 197     (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
 198     ,@(when test-given `(:predicate ,test))
 199     ,@(when multiple-values-given `(:multiple-values ,multiple-values))
 200     ,@(when fail-info-given `(:fail-info ,fail-info))
 201     ,@(when known-failure-given `(:known-failure ,known-failure))
 202     :test-form ',(if reported-form reported-form test-form)
 203     ,@(when wanted-message-given `(:wanted-message ,wanted-message))
 204     ,@(when got-message-given `(:got-message ,got-message))))
 205
 206 (defmethod conditionp ((thing condition)) t)
 207 (defmethod conditionp ((thing t)) nil)
 208
 209 (defmacro test-error (form &key announce
 210                                 catch-breaks
 211                                 (fail-info nil fail-info-given)
 212                                 (known-failure nil known-failure-given)
 213                                 (condition-type ''simple-error)
 214                                 (include-subtypes nil include-subtypes-given)
 215                                 (format-control nil format-control-given)
 216                                 (format-arguments nil format-arguments-given))
 217   "Test that `form' signals an error. The order of evaluation of the
 218 arguments is keywords first, then test form.
 219
 220 If `announce' is non-nil, then cause the error message to be printed.
 221
 222 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
 223 `error'.
 224
 225 `fail-info' allows more information to be printed with a test failure.
 226
 227 `known-failure' marks the test as a known failure.  This allows for
 228 programs that do regression analysis on the output from a test run to
 229 discriminate on new versus known failures.
 230
 231 If `condition-type' is non-nil, it should be a symbol naming a condition
 232 type, which is used to check against the signalled condition type.  The
 233 test will fail if they do not match.
 234
 235 `include-subtypes', used with `condition-type', can be used to match a
 236 condition to an entire subclass of the condition type hierarchy.
 237
 238 `format-control' and `format-arguments' can be used to check the error
 239 message itself."
 240   (let ((g-announce (gensym))
 241         (g-catch-breaks (gensym))
 242         (g-fail-info (gensym))
 243         (g-known-failure (gensym))
 244         (g-condition-type (gensym))
 245         (g-include-subtypes (gensym))
 246         (g-format-control (gensym))
 247         (g-format-arguments (gensym))
 248         (g-c (gensym)))
 249     `(let* ((,g-announce ,announce)
 250             (,g-catch-breaks ,catch-breaks)
 251             ,@(when fail-info-given `((,g-fail-info ,fail-info)))
 252             ,@(when known-failure-given `((,g-known-failure ,known-failure)))
 253             (,g-condition-type ,condition-type)
 254             ,@(when include-subtypes-given
 255                 `((,g-include-subtypes ,include-subtypes)))
 256             ,@(when format-control-given
 257                 `((,g-format-control ,format-control)))
 258             ,@(when format-arguments-given
 259                 `((,g-format-arguments ,format-arguments)))
 260             (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
 261        (test-check
 262         :predicate #'eq
 263         :expected-result t
 264         :test-results
 265         (test-values (and (conditionp ,g-c)
 266                           ,@(if* include-subtypes-given
 267                                then `((if* ,g-include-subtypes
 268                                          then (typep ,g-c ,g-condition-type)
 269                                          else (eq (class-of ,g-c)
 270                                                   (find-class
 271                                                    ,g-condition-type))))
 272                                else `((eq (class-of ,g-c)
 273                                           (find-class ,g-condition-type))))
 274                           ,@(when format-control-given
 275                               `((or
 276                                  (null ,g-format-control)
 277                                  (string=
 278                                   (concatenate 'simple-string
 279                                     "~1@<" ,g-format-control "~:@>")
 280                                   (simple-condition-format-control ,g-c)))))
 281                           ,@(when format-arguments-given
 282                               `((or
 283                                  (null ,g-format-arguments)
 284                                  (equal
 285                                   ,g-format-arguments
 286                                   (simple-condition-format-arguments ,g-c))))))
 287                      t)
 288         :test-form ',form
 289         ,@(when fail-info-given `(:fail-info ,g-fail-info))
 290         ,@(when known-failure-given `(:known-failure ,g-known-failure))
 291         :condition-type ,g-condition-type
 292         :condition ,g-c
 293         ,@(when include-subtypes-given
 294             `(:include-subtypes ,g-include-subtypes))
 295         ,@(when format-control-given
 296             `(:format-control ,g-format-control))
 297         ,@(when format-arguments-given
 298             `(:format-arguments ,g-format-arguments))))))
 299
 300 (defmacro test-no-error (form &key announce
 301                                    catch-breaks
 302                                    (fail-info nil fail-info-given)
 303                                    (known-failure nil known-failure-given))
 304   "Test that `form' does not signal an error.  The order of evaluation of
 305 the arguments is keywords first, then test form.
 306
 307 If `announce' is non-nil, then cause the error message to be printed.
 308
 309 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
 310 `error'.
 311
 312 `fail-info' allows more information to be printed with a test failure.
 313
 314 `known-failure' marks the test as a known failure.  This allows for
 315 programs that do regression analysis on the output from a test run to
 316 discriminate on new versus known failures."
 317   (let ((g-announce (gensym))
 318         (g-catch-breaks (gensym))
 319         (g-fail-info (gensym))
 320         (g-known-failure (gensym))
 321         (g-c (gensym)))
 322     `(let* ((,g-announce ,announce)
 323             (,g-catch-breaks ,catch-breaks)
 324             ,@(when fail-info-given `((,g-fail-info ,fail-info)))
 325             ,@(when known-failure-given `((,g-known-failure ,known-failure)))
 326             (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
 327        (test-check
 328         :predicate #'eq
 329         :expected-result t
 330         :test-results (test-values (not (conditionp ,g-c)))
 331         :test-form ',form
 332         :condition ,g-c
 333         ,@(when fail-info-given `(:fail-info ,g-fail-info))
 334         ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
 335
 336 (defvar *warn-cookie* (cons nil nil))
 337
 338 (defmacro test-warning (form &key fail-info known-failure)
 339   "Test that `form' signals a warning.  The order of evaluation of
 340 the arguments is keywords first, then test form.
 341
 342 `fail-info' allows more information to be printed with a test failure.
 343
 344 `known-failure' marks the test as a known failure.  This allows for
 345 programs that do regression analysis on the output from a test run to
 346 discriminate on new versus known failures."
 347   (let ((g-fail-info (gensym))
 348         (g-known-failure (gensym))
 349         (g-value (gensym)))
 350     `(let* ((,g-fail-info ,fail-info)
 351             (,g-known-failure ,known-failure)
 352             (,g-value (test-values-errorset ,form nil t)))
 353        (test
 354         *warn-cookie*
 355         (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
 356            then *warn-cookie*
 357            else ;; test produced no warning
 358                 nil)
 359         :test #'eq
 360         :reported-form ,form ;; quoted by test macro
 361         :wanted-message "a warning"
 362         :got-message "no warning"
 363         :fail-info ,g-fail-info
 364         :known-failure ,g-known-failure))))
 365
 366 (defmacro test-no-warning (form &key fail-info known-failure)
 367   "Test that `form' does not signal a warning.  The order of evaluation of
 368 the arguments is keywords first, then test form.
 369
 370 `fail-info' allows more information to be printed with a test failure.
 371
 372 `known-failure' marks the test as a known failure.  This allows for
 373 programs that do regression analysis on the output from a test run to
 374 discriminate on new versus known failures."
 375   (let ((g-fail-info (gensym))
 376         (g-known-failure (gensym))
 377         (g-value (gensym)))
 378     `(let* ((,g-fail-info ,fail-info)
 379             (,g-known-failure ,known-failure)
 380             (,g-value (test-values-errorset ,form nil t)))
 381        (test
 382         *warn-cookie*
 383         (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
 384            then nil ;; test produced warning
 385            else *warn-cookie*)
 386         :test #'eq
 387         :reported-form ',form
 388         :wanted-message "no warning"
 389         :got-message "a warning"
 390         :fail-info ,g-fail-info
 391         :known-failure ,g-known-failure))))
 392
 393 (defvar *announce-test* nil) ;; if true announce each test that was done
 394
 395 (defmacro errorset (form) ;subset of test-values-errorset
 396   `(handler-case
 397     (values-list (cons t (multiple-value-list ,form)))
 398     (error (cond)
 399      (format *error-output* "~&An error occurred: ~a~%" cond)
 400      nil)))
 401
 402
 403 (defun test-check (&key (predicate #'eql)
 404                         expected-result test-results test-form
 405                         multiple-values fail-info known-failure
 406                         wanted-message got-message condition-type condition
 407                         include-subtypes format-control format-arguments
 408                    &aux fail predicate-failed got wanted)
 409   ;; for debugging large/complex test sets:
 410   (when *announce-test*
 411     (format t "Just did test ~s~%" test-form)
 412     (force-output))
 413
 414   ;; this is an internal function
 415   (flet ((check (expected-result result)
 416            (let* ((results
 417                    (multiple-value-list
 418                     (errorset (funcall predicate expected-result result))))
 419                   (failed (null (car results))))
 420              (if failed
 421                  (progn
 422                    (setq predicate-failed t)
 423                    nil)
 424                  (cadr results)))))
 425     (when (conditionp test-results)
 426       (setq condition test-results)
 427       (setq test-results nil))
 428     (when (null (car test-results))
 429       (setq fail t))
 430     (if* (and (not fail) (not multiple-values))
 431        then ;; should be a single result
 432             ;; expected-result is the single result wanted
 433             (when (not (and (cdr test-results)
 434                             (check expected-result (cadr test-results))))
 435               (setq fail t))
 436             (when (and (not fail) (cddr test-results))
 437               (setq fail 'single-got-multiple))
 438        else ;; multiple results wanted
 439             ;; expected-result is a list of results, each of which
 440             ;; should be checked against the corresponding test-results
 441             ;; using the predicate
 442             (do ((got (cdr test-results) (cdr got))
 443                  (want expected-result (cdr want)))
 444                 ((or (null got) (null want))
 445                  (when (not (and (null want) (null got)))
 446                    (setq fail t)))
 447               (when (not (check (car got) (car want)))
 448                 (return (setq fail t)))))
 449     (if* fail
 450        then (when (not known-failure)
 451               (format *error-output*
 452                       "~& * * * UNEXPECTED TEST FAILURE * * *~%")
 453               (incf *test-unexpected-failures*))
 454             (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
 455                     known-failure test-form)
 456             (if* (eq 'single-got-multiple fail)
 457                then (format
 458                      *error-output*
 459                      "~
 460 Reason: additional value were returned from test form.~%")
 461              elseif predicate-failed
 462                then (format *error-output* "Reason: predicate error.~%")
 463              elseif (null (car test-results))
 464                then (format *error-output* "~
 465 Reason: an error~@[ (of type `~s')~] was detected.~%"
 466                             (when condition (class-of condition)))
 467              elseif condition
 468                then (if* (not (conditionp condition))
 469                        then (format *error-output* "~
 470 Reason: expected but did not detect an error of type `~s'.~%"
 471                                     condition-type)
 472                      elseif (null condition-type)
 473                        then (format *error-output* "~
 474 Reason: detected an unexpected error of type `~s':
 475         ~a.~%"
 476                                     (class-of condition)
 477                                     condition)
 478                      elseif (not (if* include-subtypes
 479                                     then (typep condition condition-type)
 480                                     else (eq (class-of condition)
 481                                              (find-class condition-type))))
 482                        then (format *error-output* "~
 483 Reason: detected an incorrect condition type.~%")
 484                             (format *error-output*
 485                                     "  wanted: ~s~%" condition-type)
 486                             (format *error-output*
 487                                     "     got: ~s~%" (class-of condition))
 488                      elseif (and format-control
 489                                  (not (string=
 490                                        (setq got
 491                                          (concatenate 'simple-string
 492                                            "~1@<" format-control "~:@>"))
 493                                        (setq wanted
 494                                          (simple-condition-format-control
 495                                           condition)))))
 496                        then ;; format control doesn't match
 497                             (format *error-output* "~
 498 Reason: the format-control was incorrect.~%")
 499                             (format *error-output* "  wanted: ~s~%" wanted)
 500                             (format *error-output* "     got: ~s~%" got)
 501                      elseif (and format-arguments
 502                                  (not (equal
 503                                        (setq got format-arguments)
 504                                        (setq wanted
 505                                          (simple-condition-format-arguments
 506                                           condition)))))
 507                        then (format *error-output* "~
 508 Reason: the format-arguments were incorrect.~%")
 509                             (format *error-output* "  wanted: ~s~%" wanted)
 510                             (format *error-output* "     got: ~s~%" got)
 511                        else ;; what else????
 512                             (error "internal-error"))
 513                else (let ((*print-length* 50)
 514                           (*print-level* 10))
 515                       (if* wanted-message
 516                          then (format *error-output*
 517                                       "  wanted: ~a~%" wanted-message)
 518                          else (if* (not multiple-values)
 519                                  then (format *error-output*
 520                                               "  wanted: ~s~%"
 521                                               expected-result)
 522                                  else (format
 523                                        *error-output*
 524                                        "  wanted values: ~{~s~^, ~}~%"
 525                                        expected-result)))
 526                       (if* got-message
 527                          then (format *error-output*
 528                                       "     got: ~a~%" got-message)
 529                          else (if* (not multiple-values)
 530                                  then (format *error-output* "     got: ~s~%"
 531                                        (second test-results))
 532                                  else (format
 533                                        *error-output*
 534                                        "     got values: ~{~s~^, ~}~%"
 535                                        (cdr test-results))))))
 536             (when fail-info
 537               (format *error-output* "Additional info: ~a~%" fail-info))
 538             (incf *test-errors*)
 539             (when *break-on-test-failures*
 540               (break "~a is non-nil." '*break-on-test-failures*))
 541        else (when known-failure
 542               (format *error-output*
 543                       "~&Expected test failure for ~s did not occur.~%"
 544                       test-form)
 545               (when fail-info
 546                 (format *error-output* "Additional info: ~a~%" fail-info))
 547               (setq fail t))
 548             (incf *test-successes*))
 549     (not fail)))
 550
 551 (defmacro with-tests ((&key (name "unnamed")) &body body)
 552   (let ((g-name (gensym)))
 553     `(flet ((doit () ,@body))
 554        (let ((,g-name ,name)
 555              (*test-errors* 0)
 556              (*test-successes* 0)
 557              (*test-unexpected-failures* 0))
 558          (format *error-output* "Begin ~a test~%" ,g-name)
 559          (if* *break-on-test-failures*
 560               then (doit)
 561               else (handler-case (doit)
 562                      (error (c)
 563                        (format
 564                         *error-output*
 565                         "~
 566 ~&Test ~a aborted by signalling an uncaught error:~%~a~%"
 567                         ,g-name c))))
 568          #+allegro
 569          (let ((state (sys:gsgc-switch :print)))
 570            (setf (sys:gsgc-switch :print) nil)
 571            (format t "~&**********************************~%" ,g-name)
 572            (format t "End ~a test~%" ,g-name)
 573            (format t "Errors detected in this test: ~s " *test-errors*)
 574            (unless (zerop *test-unexpected-failures*)
 575              (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
 576            (format t "~%Successes this test:~s~%" *test-successes*)
 577            (setf (sys:gsgc-switch :print) state))
 578          #-allegro
 579          (progn
 580            (format t "~&**********************************~%" ,g-name)
 581            (format t "End ~a test~%" ,g-name)
 582            (format t "Errors detected in this test: ~D " *test-errors*)
 583            (unless (zerop *test-unexpected-failures*)
 584              (format t "UNEXPECTED: ~D" *test-unexpected-failures*))
 585            (format t "~%Successes this test:~D~%" *test-successes*))))))
 586
 587 (provide :tester #+module-versions 1.1)