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