-;; -*- lisp -*-
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
-(in-package :it.bese.FiveAM)
+(in-package :it.bese.fiveam)
;;;; * Checks
;;;; ** Types of test results
-;;;; Every check produces a result object.
+;;;; Every check produces a result object.
(defclass test-result ()
((reason :accessor reason :initarg :reason :initform "no reason given")
(defmacro process-failure (&rest args)
`(progn
- (with-simple-restart (ignore-failure "Continue the test run.")
- (error 'check-failure ,@args))
- (add-result 'test-failure ,@args)))
+ (with-simple-restart (ignore-failure "Continue the test run.")
+ (error 'check-failure ,@args))
+ (add-result 'test-failure ,@args)))
(defclass test-failure (test-result)
()
(let ((result (apply #'make-instance result-type
(append make-instance-args (list :test-case current-test)))))
(etypecase result
- (test-passed (format *test-dribble* "."))
+ (test-passed (format *test-dribble* "."))
(unexpected-test-failure (format *test-dribble* "X"))
- (test-failure (format *test-dribble* "f"))
- (test-skipped (format *test-dribble* "s")))
+ (test-failure (format *test-dribble* "f"))
+ (test-skipped (format *test-dribble* "s")))
(push result result-list))))
;;;; ** The check operators
(predicate value) - Means that we want to ensure that VALUE
satisfies PREDICATE.
- Wrapping the TEST form in a NOT simply preducse a negated reason
+ Wrapping the TEST form in a NOT simply produces a negated reason
string."
(assert (listp test)
(test)
"Argument to IS must be a list, not ~S" test)
(let (bindings effective-test default-reason-args)
- (with-unique-names (e a v)
+ (with-gensyms (e a v)
(flet ((process-entry (predicate expected actual &optional negatedp)
;; make sure EXPECTED is holding the entry that starts with 'values
(when (and (consp actual)
(assert (not (and (consp expected)
(eq (car expected) 'values))) ()
"Both the expected and actual part is a values expression.")
- (let ((tmp expected))
- (setf expected actual
- actual tmp)))
+ (rotatef expected actual))
(let ((setf-forms))
(if (and (consp expected)
(eq (car expected) 'values))
(setf bindings (list (list e expected)
(list a actual))))
(setf effective-test `(progn
- ,@setf-forms
- ,(if negatedp
- `(not (,predicate ,e ,a))
- `(,predicate ,e ,a)))))))
+ ,@setf-forms
+ ,(if negatedp
+ `(not (,predicate ,e ,a))
+ `(,predicate ,e ,a)))))))
(list-match-case test
((not (?predicate ?expected ?actual))
(process-entry ?predicate ?expected ?actual t)
"The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list."
`(progn
- ,@(if (every #'consp clauses)
- (loop for (expected actual . reason) in clauses
- collect `(is (,predicate ,expected ,actual) ,@reason))
- (progn
- (assert (evenp (list-length clauses)))
- (loop for (expr value) on clauses by #'cddr
- collect `(is (,predicate ,expr ,value)))))))
+ ,@(if (every #'consp clauses)
+ (loop for (expected actual . reason) in clauses
+ collect `(is (,predicate ,expected ,actual) ,@reason))
+ (progn
+ (assert (evenp (list-length clauses)))
+ (loop for (expr value) on clauses by #'cddr
+ collect `(is (,predicate ,expr ,value)))))))
(defmacro is-true (condition &rest reason-args)
"Like IS this check generates a pass if CONDITION returns true
does not inspect CONDITION to determine how to report the
failure."
`(if ,condition
- (add-result 'test-passed :test-expr ',condition)
- (process-failure
- :reason ,(if reason-args
- `(format nil ,@reason-args)
- `(format nil "~S did not return a true value" ',condition))
- :test-expr ',condition)))
+ (add-result 'test-passed :test-expr ',condition)
+ (process-failure
+ :reason ,(if reason-args
+ `(format nil ,@reason-args)
+ `(format nil "~S did not return a true value" ',condition))
+ :test-expr ',condition)))
(defmacro is-false (condition &rest reason-args)
"Generates a pass if CONDITION returns false, generates a
failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
not inspect CONDITION to determine what reason to give it case
of test failure"
-
- (with-unique-names (value)
+
+ (with-gensyms (value)
`(let ((,value ,condition))
(if ,value
(process-failure
(handler-bind ((,condition (lambda (c)
(declare (ignore c))
;; ok, body threw condition
- (add-result 'test-passed
+ (add-result 'test-passed
:test-expr ',condition)
(return-from ,block-name t))))
(block nil
fails."
`(let ((ok nil))
(unwind-protect
- (progn
- ,@body
- (setf ok t))
+ (progn
+ ,@body
+ (setf ok t))
(if ok
- (add-result 'test-passed :test-expr ',body)
+ (add-result 'test-passed :test-expr ',body)
(process-failure
:reason (format nil "Test didn't finish")
:test-expr ',body)))))
(defmacro pass (&rest message-args)
"Simply generate a PASS."
- `(add-result 'test-passed
+ `(add-result 'test-passed
:test-expr ',message-args
,@(when message-args
`(:reason (format nil ,@message-args)))))
`(:reason (format nil ,@message-args)))))
;; Copyright (c) 2002-2003, Edward Marco Baringer
-;; All rights reserved.
-;;
+;; All rights reserved.
+;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
-;;
+;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
-;;
+;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;; of its contributors may be used to endorse or promote products
;; derived from this software without specific prior written permission.
-;;
+;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR