tester.cl

   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.cl,v 1.2 2002/09/20 07:55:56 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 (defun test-check (&key (predicate #'eql)
 396                         expected-result test-results test-form
 397                         multiple-values fail-info known-failure
 398                         wanted-message got-message condition-type condition
 399                         include-subtypes format-control format-arguments
 400                    &aux fail predicate-failed got wanted)
 401   ;; for debugging large/complex test sets:
 402   (when *announce-test*
 403     (format t "Just did test ~s~%" test-form)
 404     (force-output))
 405
 406   ;; this is an internal function
 407   (flet ((check (expected-result result)
 408            (let* ((results
 409                    (multiple-value-list
 410                     (errorset (funcall predicate expected-result result) t)))
 411                   (failed (null (car results))))
 412              (if* failed
 413                 then (setq predicate-failed t)
 414                      nil
 415                 else (cadr results)))))
 416     (when (conditionp test-results)
 417       (setq condition test-results)
 418       (setq test-results nil))
 419     (when (null (car test-results))
 420       (setq fail t))
 421     (if* (and (not fail) (not multiple-values))
 422        then ;; should be a single result
 423             ;; expected-result is the single result wanted
 424             (when (not (and (cdr test-results)
 425                             (check expected-result (cadr test-results))))
 426               (setq fail t))
 427             (when (and (not fail) (cddr test-results))
 428               (setq fail 'single-got-multiple))
 429        else ;; multiple results wanted
 430             ;; expected-result is a list of results, each of which
 431             ;; should be checked against the corresponding test-results
 432             ;; using the predicate
 433             (do ((got (cdr test-results) (cdr got))
 434                  (want expected-result (cdr want)))
 435                 ((or (null got) (null want))
 436                  (when (not (and (null want) (null got)))
 437                    (setq fail t)))
 438               (when (not (check (car got) (car want)))
 439                 (return (setq fail t)))))
 440     (if* fail
 441        then (when (not known-failure)
 442               (format *error-output*
 443                       "~& * * * UNEXPECTED TEST FAILURE * * *~%")
 444               (incf *test-unexpected-failures*))
 445             (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
 446                     known-failure test-form)
 447             (if* (eq 'single-got-multiple fail)
 448                then (format
 449                      *error-output*
 450                      "~
 451 Reason: additional value were returned from test form.~%")
 452              elseif predicate-failed
 453                then (format *error-output* "Reason: predicate error.~%")
 454              elseif (null (car test-results))
 455                then (format *error-output* "~
 456 Reason: an error~@[ (of type `~s')~] was detected.~%"
 457                             (when condition (class-of condition)))
 458              elseif condition
 459                then (if* (not (conditionp condition))
 460                        then (format *error-output* "~
 461 Reason: expected but did not detect an error of type `~s'.~%"
 462                                     condition-type)
 463                      elseif (null condition-type)
 464                        then (format *error-output* "~
 465 Reason: detected an unexpected error of type `~s':
 466         ~a.~%"
 467                                     (class-of condition)
 468                                     condition)
 469                      elseif (not (if* include-subtypes
 470                                     then (typep condition condition-type)
 471                                     else (eq (class-of condition)
 472                                              (find-class condition-type))))
 473                        then (format *error-output* "~
 474 Reason: detected an incorrect condition type.~%")
 475                             (format *error-output*
 476                                     "  wanted: ~s~%" condition-type)
 477                             (format *error-output*
 478                                     "     got: ~s~%" (class-of condition))
 479                      elseif (and format-control
 480                                  (not (string=
 481                                        (setq got
 482                                          (concatenate 'simple-string
 483                                            "~1@<" format-control "~:@>"))
 484                                        (setq wanted
 485                                          (simple-condition-format-control
 486                                           condition)))))
 487                        then ;; format control doesn't match
 488                             (format *error-output* "~
 489 Reason: the format-control was incorrect.~%")
 490                             (format *error-output* "  wanted: ~s~%" wanted)
 491                             (format *error-output* "     got: ~s~%" got)
 492                      elseif (and format-arguments
 493                                  (not (equal
 494                                        (setq got format-arguments)
 495                                        (setq wanted
 496                                          (simple-condition-format-arguments
 497                                           condition)))))
 498                        then (format *error-output* "~
 499 Reason: the format-arguments were incorrect.~%")
 500                             (format *error-output* "  wanted: ~s~%" wanted)
 501                             (format *error-output* "     got: ~s~%" got)
 502                        else ;; what else????
 503                             (error "internal-error"))
 504                else (let ((*print-length* 50)
 505                           (*print-level* 10))
 506                       (if* wanted-message
 507                          then (format *error-output*
 508                                       "  wanted: ~a~%" wanted-message)
 509                          else (if* (not multiple-values)
 510                                  then (format *error-output*
 511                                               "  wanted: ~s~%"
 512                                               expected-result)
 513                                  else (format
 514                                        *error-output*
 515                                        "  wanted values: ~{~s~^, ~}~%"
 516                                        expected-result)))
 517                       (if* got-message
 518                          then (format *error-output*
 519                                       "     got: ~a~%" got-message)
 520                          else (if* (not multiple-values)
 521                                  then (format *error-output* "     got: ~s~%"
 522                                        (second test-results))
 523                                  else (format
 524                                        *error-output*
 525                                        "     got values: ~{~s~^, ~}~%"
 526                                        (cdr test-results))))))
 527             (when fail-info
 528               (format *error-output* "Additional info: ~a~%" fail-info))
 529             (incf *test-errors*)
 530             (when *break-on-test-failures*
 531               (break "~a is non-nil." '*break-on-test-failures*))
 532        else (when known-failure
 533               (format *error-output*
 534                       "~&Expected test failure for ~s did not occur.~%"
 535                       test-form)
 536               (when fail-info
 537                 (format *error-output* "Additional info: ~a~%" fail-info))
 538               (setq fail t))
 539             (incf *test-successes*))
 540     (not fail)))
 541
 542 (defmacro with-tests ((&key (name "unnamed")) &body body)
 543   (let ((g-name (gensym)))
 544     `(flet ((doit () ,@body))
 545        (let ((,g-name ,name)
 546              (*test-errors* 0)
 547              (*test-successes* 0)
 548              (*test-unexpected-failures* 0))
 549          (format *error-output* "Begin ~a test~%" ,g-name)
 550          (if* *break-on-test-failures*
 551             then (doit)
 552             else (handler-case (doit)
 553                    (error (c)
 554                      (format
 555                       *error-output*
 556                       "~
 557 ~&Test ~a aborted by signalling an uncaught error:~%~a~%"
 558                       ,g-name c))))
 559          #+allegro
 560          (let ((state (sys:gsgc-switch :print)))
 561            (setf (sys:gsgc-switch :print) nil)
 562            (format t "~&**********************************~%" ,g-name)
 563            (format t "End ~a test~%" ,g-name)
 564            (format t "Errors detected in this test: ~s " *test-errors*)
 565            (unless (zerop *test-unexpected-failures*)
 566              (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
 567            (format t "~%Successes this test:~s~%" *test-successes*)
 568            (setf (sys:gsgc-switch :print) state))
 569          #-allegro
 570          (progn
 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
 578 (provide :tester #+module-versions 1.1)