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