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