(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated "10-Mar-88 10:02:26" {eris}sun>test>do-test.\;3 22922 |changes| |to:| (functions xcl-user::do-all-tests) (vars do-testcoms) (variables xcl-user::*test-mode* xcl-user::*test-batch-results* xcl-user::*test-file-pattern*) |previous| |date:| " 2-Mar-88 15:47:17" {eris}sun>test>do-test.\;1) ; Copyright (c) 1986, 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint do-testcoms) (rpaqq do-testcoms ((variables xcl-user::*any-errors* xcl-user::*test-cleanup-forms* xcl-user::*test-compile* xcl-user::*test-mode* xcl-user::*test-batch-results* xcl-user::*test-file-pattern* xcl-user::*test-file-name*) (p (defpackage "XCL-TEST" (:use "LISP" "XCL") (:import xcl-user::do-test-file xcl-user::do-all-tests xcl-user::do-test xcl-user::do-test-group xcl-user::cl-readfile xcl-user::expect-errors xcl-user::test-defun xcl-user::test-defmacro xcl-user::test-setq xcl-user::*test-mode* xcl-user::*test-compile* xcl-user::*test-batch-results* xcl-user::*test-file-pattern* xcl-user::*test-file-name*))) (functions xcl-user::do-test xcl-user::do-test-group xcl-user::test-defmacro xcl-user::test-defun xcl-user::test-setq xcl-user::without-batch-mode-errors xcl-user::expect-errors xcl-user::do-all-tests xcl-user::current-file-name xcl-user::cl-readfile xcl-user::do-test-file xcl-user::do-test-list) (prop (makefile-environment filetype) do-test))) (cl:defvar xcl-user::*any-errors* nil) (cl:defvar xcl-user::*test-cleanup-forms* nil) (cl:defvar xcl-user::*test-compile* nil) (cl:defvar xcl-user::*test-mode* :interactive) (cl:defvar xcl-user::*test-batch-results* "{dsk}test-results" ) (cl:defvar xcl-user::*test-file-pattern* '("{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" "{dsk}*.TEST" ) ) (cl:defvar xcl-user::*test-file-name* "unknown" ) (defpackage "XCL-TEST" (:use "LISP" "XCL") (:import xcl-user::do-test-file xcl-user::do-all-tests xcl-user::do-test xcl-user::do-test-group xcl-user::cl-readfile xcl-user::expect-errors xcl-user::test-defun xcl-user::test-defmacro xcl-user::test-setq xcl-user::*test-mode* xcl-user::*test-compile* xcl-user::*test-batch-results* xcl-user::*test-file-pattern* xcl-user::*test-file-name*)) (defmacro xcl-user::do-test (name-and-options &body body) (let ((name nil) (options nil)) (cond ((cl:consp name-and-options) (cl:setq name (car name-and-options)) (cl:setq options (cdr name-and-options))) (t (cl:setq name name-and-options))) (cl:if (or (eq xcl-user::*test-mode* :interactive) (eq xcl-user::*test-mode* :batch-verbose)) (cl:format *error-output* "Testing... ~S~%" name)) `(not (cl:when (null (xcl-user::without-batch-mode-errors ,@body)) (cl:format *error-output* "Test \"~A\" failed in file \"~A\"~%" ',name (xcl-user::current-file-name)) (setq xcl-user::*any-errors* t))))) (defmacro xcl-user::do-test-group (name-and-options &body body) (let ((name nil) (options nil)) (cond ((cl:consp name-and-options) (cl:setq name (car name-and-options)) (cl:setq options (cdr name-and-options))) (t (cl:setq name name-and-options))) (* |;;| "Hack: find :BEFORE and :AFTER clauses in the body and move them out") (cl:loop (cl:if (and (cl:symbolp (car body)) (or (eq (car body) :before) (eq (car body) :after))) (progn (setq options (append options (list (car body) (cadr body)))) (setq body (cddr body))) (return nil))) `(let ((xcl-user::*test-cleanup-forms* nil)) (cl:block ,name ,(cl:if (or (eq xcl-user::*test-mode* :interactive) (eq xcl-user::*test-mode* :batch-verbose)) (cl:format *error-output* "Testing... ~S~%" name)) ,(let ((before (ignore-errors (cl:getf options :before)))) (cl:if before `(cl:when (null (xcl-user::without-batch-mode-errors ,before t)) (cl:format *error-output* ":BEFORE forms for test \"~A\" in file ~S failed." ',name (xcl-user::current-file-name)) (setq xcl-user::*any-errors* t) (cl:return-from ,name)))) ,@(|for| b |in| body |join| (|if| (and (cl:consp b) (eq (car b) 'xcl-user::do-test)) |then| (list b) |else| (cl:format *error-output* "Non DO-TEST form in ~S in ~S~%~S~%" name (xcl-user::current-file-name) b))) ,(let ((after (ignore-errors (cl:getf options :after)))) (cl:if after `(cl:when (null (xcl-user::without-batch-mode-errors ,after t)) (cl:format *error-output* ":AFTER forms for test \"~A\" in file ~S failed." ',name (xcl-user::current-file-name)) (cl:setq xcl-user::*any-errors* t))))) (cl:eval (cons 'progn xcl-user::*test-cleanup-forms*)) nil))) (defmacro xcl-user::test-defmacro (name &rest stuff) `(progn (cl:if (cl:fboundp ',name) (cl:if (cl:macro-function ',name) (cl:push (list 'cl:setf (list 'cl:symbol-function (list 'cl:macro-function '',name)) (list 'quote (cl:symbol-function (cl:macro-function ',name)))) xcl-user::*test-cleanup-forms*) (cl:error "Please don't redefine ~A in a test form" ',name)) (cl:push (list 'remprop '',name ''macro-fn) xcl-user::*test-cleanup-forms*)) (defmacro (\\\, name) ,@stuff ) )) (defmacro xcl-user::test-defun (name &rest stuff) `(progn (cl:if (cl:fboundp ',name) (cl:if (or (cl:macro-function ',name) (cl:special-form-p ',name)) (cl:error "Please don't redefine ~A in a test form" ',name) (cl:push (list 'cl:setf (list 'cl:symbol-function '',name) (list 'quote (cl:symbol-function ',name))) xcl-user::*test-cleanup-forms*)) (cl:push (list 'cl:fmakunbound '',name) xcl-user::*test-cleanup-forms*)) (cl:defun (\\\, name) ,@stuff ) )) (defmacro xcl-user::test-setq (&rest xcl-user::stuff) (let (xcl-user::unbindlist) (cl:do ((xcl-user::x xcl-user::stuff (cddr xcl-user::x))) ((null xcl-user::x)) (cl:push `(cl:if (boundp ',(car xcl-user::x)) (cl:push (list 'cl:setq ',(car xcl-user::x) (list 'quote (cl:symbol-value ',(car xcl-user::x)))) xcl-user::*test-cleanup-forms*) (cl:push (list 'cl:makunbound '',(car xcl-user::x)) xcl-user::*test-cleanup-forms*)) xcl-user::unbindlist)) `(progn ,@xcl-user::unbindlist (cl:setq ,@xcl-user::stuff)))) (defmacro xcl-user::without-batch-mode-errors (&body body) (cond ((eq xcl-user::*test-mode* :interactive ) `(progn ,@body)) (t `(ignore-errors ,@body)))) (defmacro xcl-user::expect-errors (error-types &rest forms) `(condition-case (progn ,@forms nil) (,error-types (condition) (cl:values t condition)))) (cl:defun xcl-user::do-all-tests (&key (xcl-user::results xcl-user::*test-batch-results*) (xcl-user::patterns (cl:if (cl:consp xcl-user::*test-file-pattern* ) xcl-user::*test-file-pattern* (list xcl-user::*test-file-pattern* ))) (xcl-user::sysout-type nil) (xcl-user::resume nil)) (let ((no-problems t) (*default-pathname-defaults* (pathname "{dsk}")) (*error-output* (cl:if (eq xcl-user::results t) *error-output* (open xcl-user::results :direction :output :if-exists (cl:if xcl-user::resume :append :new-version))))) (cl:unwind-protect (progn (cl:if (not xcl-user::resume) (progn (cl:format *error-output* ";;; Test results for sysout of ~A~%" makesysdate) (cl:if xcl-user::sysout-type (cl:format *error-output* ";;; Sysout type is ~A~%" xcl-user::sysout-type )) (cl:if xcl-user::*test-compile* (cl:format *error-output* ";;; Tests are being compiled~%" )) (cl:format *error-output* ";;; Tests run on ~A~%" (date)) (cl:format *error-output* ";;; Running tests from ~A~2%" xcl-user::patterns) (cl:setq xcl-user::*all-files-remaining* (for xcl-user::dp in xcl-user::patterns join (directory xcl-user::dp)))) (cl:format *error-output* ";;;Resuming after dying on file ~S~%" (cl:pop xcl-user::*all-files-remaining* ))) (|while| xcl-user::*all-files-remaining* |do| (cl:format *standard-output* "Testing ~s..." (car xcl-user::*all-files-remaining* )) (cl:setq no-problems (and (xcl-user::do-test-file (car xcl-user::*all-files-remaining* )) no-problems)) (cl:format *standard-output* "done~%") (cl:pop xcl-user::*all-files-remaining*)) (cl:format *error-output* "(END-OF-TESTS)")) (cl:unless (eq xcl-user::results t) (cl:close *error-output*))) no-problems)) (cl:defun xcl-user::current-file-name nil xcl-user::*test-file-name*) (cl:defun xcl-user::cl-readfile (test-file &optional (*readtable* cmlrdtbl) (endtoken "STOP")) (let ((xcl-user::true-name (cl:probe-file test-file))) (cl:if xcl-user::true-name (let (tem (*package* (cl:find-package 'xcl-user::xcl-test)) (*features* (cons :no-stack-overflow *features*))) (cl:setq xcl-user::*test-file-name* (cl:namestring xcl-user::true-name)) (cl:with-open-file (test-file test-file :direction :input) (until (or (null (ignore-errors (cl:setq tem (cl:read test-file)))) (and (cl:symbolp tem) (cl:string= tem endtoken))) collect tem))) (progn (cl:format *error-output* "~%Couldn't find file ~A~%" test-file) nil)))) (cl:defun xcl-user::do-test-file (filename) (let* ((*package* (cl:find-package 'xcl-user::xcl-test)) (xcl-user::*test-file-name* nil) (test-forms (xcl-user::cl-readfile filename cmlrdtbl)) (xcl-user::*any-errors* nil)) (xcl-user::do-test-list test-forms) (|if| xcl-user::*any-errors* |then| (cl:terpri *error-output*)) (not xcl-user::*any-errors*))) (cl:defun xcl-user::do-test-list (xcl-user::test-forms &optional xcl-user::options xcl-user::name) (let ((dfnflg nil)) (declare (cl:special dfnflg)) (|if| (null xcl-user::test-forms) |then| (cl:format *error-output* "~%(Trouble reading ~A)~%" (xcl-user::current-file-name)) (cl:setq xcl-user::*any-errors* t) |else| (|for| xcl-user::form |in| xcl-user::test-forms |do| (block 0) (cl:if (and (cl:consp xcl-user::form) (or (eq (car xcl-user::form) 'xcl-user::do-test) (eq (car xcl-user::form) 'xcl-user::do-test-group))) (cl:if xcl-user::*test-compile* (cl:block xcl-user::compiler-punt (let ((xcl-user::compiled-form (cl:if (eq xcl-user::*test-mode* :interactive) (cl:compile nil `(cl:lambda nil ,xcl-user::form)) (ignore-errors (cl:compile nil `(cl:lambda nil ,xcl-user::form))))) ) (cl:if (null (cl:compiled-function-p xcl-user::compiled-form) ) (let ((*print-level* 3) (*print-length* 3)) (cl:format *error-output* "Compilation of this form in file ~S failed:~% ~S~%" (xcl-user::current-file-name) xcl-user::form) (cl:return-from xcl-user::compiler-punt)) (cl:if (null (cl:if (eq xcl-user::*test-mode* :interactive) (progn (cl:funcall xcl-user::compiled-form ) t) (ignore-errors (progn (cl:funcall xcl-user::compiled-form ) t)))) (let ((*print-level* 3) (*print-length* 3)) (cl:format *error-output* "Compiled code failed for this form in file ~S :~%~S~%" (xcl-user::current-file-name) xcl-user::form)))))) (cl:eval xcl-user::form)) (cl:format *error-output* "Non DO-TEST form at top level in ~S~%~S~%" ( xcl-user::current-file-name ) xcl-user::form)))))) (putprops do-test filetype :compile-file) (putprops do-test copyright ("Xerox Corporation" 1986 1987 1988)) (declare\: dontcopy (filemap (nil))) stop