Commit 66d3fa5a authored by pfdietz's avatar pfdietz

Rewrote rt-package.lsp to avoid possible copyright problem.

Added *print-circle-on-failure*, which when true causes the
failure report of do-test(s) to be printed with *print-circle*
bound to true.  This is disabled normally, however, since
*print-circle* is very slow on gcl (and caused at least one
mysterious stack overflow).
parent 80db50c0
;-*- Mode: Lisp -*-
;;;; Copyright 1998 Motorola, Inc. All right reserved.
;;;; Motorola Internal Use Only.
;;;;
;;;; Author: Paul Dietz
;;;; Created: Sat Mar 7 10:32:13 1998
;;;; Contains: Package definition for RT system (new form)
;;;; Created: Tue Dec 17 21:10:53 2002
;;;; Contains: Package definition for RT
(eval-when
;;(:execute :compile-toplevel :load-toplevel)
(load eval compile)
(defpackage :rt
(:nicknames)
(:use :cl)
(:export
"DEFTEST" "GET-TEST" "DO-TEST" "REM-TEST"
"REM-ALL-TESTS" "DO-TESTS" "PENDING-TESTS"
"CONTINUE-TESTING" "*TEST*" "*DO-TESTS-WHEN-DEFINED*")))
"*DO-TESTS-WHEN-DEFINED*"
"*TEST*"
"CONTINUE-TESTING"
"DEFTEST"
"DO-TEST"
"DO-TESTS"
"GET-TEST"
"PENDING-TESTS"
"REM-ALL-TESTS"
"REM-TEST"
)))
(in-package :rt)
......@@ -31,6 +31,8 @@
(defvar *in-test* nil "Used by TEST")
(defvar *debug* nil "For debugging")
(defvar *catch-errors* t "When true, causes errors in a test to be caught.")
(defvar *print-circle-on-failure* nil
"Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
(defstruct (entry (:conc-name nil)
(:type list))
......@@ -136,17 +138,18 @@
(or aborted
(not (equalp-with-case r (vals entry)))))
(when (pend entry)
(format s "~&Test ~:@(~S~) failed~
(let ((*print-circle* *print-circle-on-failure*))
(format s "~&Test ~:@(~S~) failed~
~%Form: ~S~
~%Expected value~P: ~
~{~S~^~%~17t~}~%"
*test* (form entry)
(length (vals entry))
(vals entry))
(format s "Actual value~P: ~
*test* (form entry)
(length (vals entry))
(vals entry))
(format s "Actual value~P: ~
~{~S~^~%~15t~}.~%"
(length r) r))))
(when (not (pend entry)) *test*))
(length r) r)))))
(when (not (pend entry)) *test*))
(defun continue-testing ()
(if *in-test*
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment