(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")

(filecreated "30-Oct-86 18:07:27" {eris}<lispcore>library>do-test.\;41
 13987  

      |changes| |to:|  (functions xcl-test::do-test-list)

      |previous| |date:| "28-Oct-86 16:36:44" {eris}<lispcore>library>do-test.\;40)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(prettycomprint do-testcoms)

(rpaqq do-testcoms
 
       ((functions xcl-test:do-test xcl-test:do-test-group xcl-test:test-defmacro xcl-test:test-defun 
               xcl-test:test-setq xcl-test::without-batch-mode-errors xcl-test:expect-errors 
               xcl-test:do-all-tests xcl-test::current-file-name xcl-test:cl-readfile 
               xcl-test:do-test-file xcl-test::do-test-list)
        (variables xcl-test::*any-errors* xcl-test::*test-cleanup-forms* xcl-test:*test-compile* 
               xcl-test:*test-mode* xcl-test:*test-batch-results* xcl-test:*test-file-pattern* 
               xcl-test::*test-file-name*)
        (p (defpackage "XCL-TEST"
                  (:export xcl-test:do-test xcl-test:do-test-group xcl-test:expect-errors 
                         xcl-test:test-defun xcl-test:test-defmacro xcl-test:test-setq 
                         xcl-test:do-all-tests xcl-test:cl-readfile xcl-test:do-test-file 
                         xcl-test:*test-mode* xcl-test:*test-batch-results* xcl-test:*test-compile* 
                         xcl-test:*test-file-pattern*)))
        (prop (makefile-environment filetype)
              xcl-test:do-test)))
(defmacro xcl-test: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 (eq xcl-test:*test-mode* :interactive)
               (cl:format *error-output* "Testing... ~S~%" name))
        `(not (cl:when (null (xcl-test::without-batch-mode-errors ,@body))
                     (cl:format *error-output* "Test \"~A\" failed in file \"~A\"~%"
                            ',name
                            (xcl-test::current-file-name))
                     (setq xcl-test::*any-errors* t)))))

(defmacro xcl-test: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-test::*test-cleanup-forms* nil))
              (cl:block ,name ,(cl:if (eq xcl-test:*test-mode* :interactive)
                                      (cl:format *error-output* "Testing... ~S~%" name))
                     ,(let ((before (cl:getf options :before)))
                           (cl:if before `(cl:when (null (xcl-test::without-batch-mode-errors
                                                          ,before t))
                                                 (cl:format *error-output* 
                                                   ":BEFORE forms for test \"~A\" in file ~S failed."
                                                        ',name
                                                        (xcl-test::current-file-name))
                                                 (setq xcl-test::*any-errors* t)
                                                 (cl:return-from ,name))))
                     ,@(|for|
 b |in|
 body |join|
 (|if|
 (and (cl:consp b)
                                                            (eq (car b)
                                                                'xcl-test:do-test))
                                                     |then|
 (list b)
                                                   |else|
 (cl:format *error-output* 
                                                                 "Non DO-TEST form in ~S in ~S~%~S~%" 
                                                                 name (xcl-test::current-file-name)
                                                                 b)))
                     ,(let ((after (cl:getf options :after)))
                           (cl:if after `(cl:when (null (xcl-test::without-batch-mode-errors
                                                         ,after t))
                                                (cl:format *error-output* 
                                                    ":AFTER forms for test \"~A\" in file ~S failed."
                                                       ',name
                                                       (xcl-test::current-file-name))
                                                (setq xcl-test::*any-errors* t)))))
              (eval (cons 'progn xcl-test::*test-cleanup-forms*))
              nil)))

(defmacro xcl-test:test-defmacro
 (name &rest stuff)
   (cl:if (cl:fboundp name)
          (cl:if (cl:macro-function name)
                 (cl:push `(cl:setf (cl:symbol-function (cl:macro-function ',name))
                                  ',(cl:symbol-function (cl:macro-function name))) 
                        xcl-test::*test-cleanup-forms*)
                 (cl:error "Please don't redefine ~A in a test form" name))
          (cl:push `(remprop ',name 'macro-fn) xcl-test::*test-cleanup-forms*))
   `(defmacro (\\\,
 name) ,@stuff )
)

(defmacro xcl-test:test-defun
 (name &rest stuff)
   (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 `(cl:setf (cl:symbol-function ',name)
                                  ',(cl:symbol-function name)) xcl-test::*test-cleanup-forms*))
          (cl:push `(cl:fmakunbound ',name) xcl-test::*test-cleanup-forms*))
   `(cl:defun (\\\,
 name) ,@stuff )
)

(defmacro xcl-test:test-setq
 (x y &rest stuff) (cl:if (boundp x)
                                                      (cl:push
                                                       `(cl:setq ,x ',(cl:symbol-value x)) 
                                                       xcl-test::*test-cleanup-forms*)
                                                      (cl:push `(cl:makunbound ',x) 
                                                             xcl-test::*test-cleanup-forms*))
                                               (cl:if stuff `(progn (cl:setq ,x ,y)
                                                                    (xcl-test:test-setq ,@stuff))
                                                      `(cl:setq ,x ,y)))

(defmacro xcl-test::without-batch-mode-errors
 (&body body) (cond
                                                              ((eq xcl-test:*test-mode* :interactive)
                                                               `(progn ,@body))
                                                              (t `(ignore-errors ,@body))))

(defmacro xcl-test:expect-errors
 (error-types &rest forms) `(condition-case (progn ,@forms nil)
                                                                   (,error-types (condition)
                                                                          (cl:values t condition))))

(cl:defun xcl-test:do-all-tests
 (&key (results xcl-test:*test-batch-results*)
                                      (pattern xcl-test:*test-file-pattern*)
                                      (sysout-type nil)) (cl:with-open-file (*error-output* 
                                                                        xcl-test:*test-batch-results* 
                                                                                   :direction :output 
                                                                                   :if-exists 
                                                                                   :new-version)
                                                                (cl:format *error-output* 
                                                                ";;; Test results for sysout of ~A~%" 
                                                                       makesysdate)
                                                                (cl:if sysout-type
                                                                       (format *error-output* 
                                                                            ";;; Sysout type is ~A~%" 
                                                                              sysout-type))
                                                                (cl:format *error-output* 
                                                                       ";;; Tests run on ~A~2%"
                                                                       (date))
                                                                (for
 fn in
 (directory pattern)
                                                                   do
 (xcl-test:do-test-file fn))
                                                                (cl:format *error-output* 
                                                                       "(END-OF-TESTS)")))

(cl:defun xcl-test::current-file-name
 nil xcl-test::*test-file-name*)

(cl:defun xcl-test:cl-readfile
 (test-file &optional (*readtable* cmlrdtbl)
                                      (endtoken "STOP")) 
    (* |Pavel| "23-Sep-86 12:40")

   (|if|
 (cl:probe-file test-file)
       |then|
 (let (forms-list tem (*package* (cl:find-package "XCL-TEST")))
                   (cl:with-open-stream (test-file (opentextstream (mkatom test-file)))
                          (|until|
 (or (null (ignore-errors (cl:setq tem (cl:read test-file))))
                                       (and (cl:symbolp tem)
                                            (cl:string= tem endtoken))) |do|
 (cl:push tem forms-list)
                                 )
                          (cl:nreverse forms-list)))
     |else|
 (progn (cl:format *error-output* "~%Couldn't find file ~A~%" test-file)
                   nil)))

(cl:defun xcl-test:do-test-file
 (filename) 
                  (* |Pavel| "23-Sep-86 12:19")

   (let* ((*package* (cl:find-package "user"))
          (test-forms (xcl-test:cl-readfile filename cmlrdtbl))
          (xcl-test::*test-file-name* (let ((pf (pathname filename)))
                                           (cl:format nil "~A.~A;~A" (cl:pathname-name pf)
                                                  (cl:pathname-type pf)
                                                  (cl:pathname-version pf))))
          (xcl-test::*any-errors* nil))
         (xcl-test::do-test-list test-forms)
         (|if|
 xcl-test::*any-errors*
             |then|
 (cl:terpri *error-output*))))

(cl:defun xcl-test::do-test-list
 (test-forms &optional options name)
   (let ((dfnflg nil))
        (|if|
 (null test-forms)
            |then|
 (cl:format *error-output* "~%(Trouble reading ~A)~%" (xcl-test::current-file-name)
                          )
                  (cl:setq xcl-test::*any-errors* t)
          |else|
 (|for|
 form |in|
 test-forms
                    |do|
 (cl:if (and (cl:consp form)
                                     (or (eq (car form)
                                             'xcl-test:do-test)
                                         (eq (car form)
                                             'xcl-test:do-test-group)))
                                (cl:if xcl-test:*test-compile*
                                       (cl:funcall (compiler::xcl-compile nil
                                                          `(cl:lambda nil ,form)))
                                       (cl:eval form))
                                (cl:format *error-output* "Non DO-TEST form at top level in ~S~%~S~%"
                                       (xcl-test::current-file-name)
                                       form))))))

(cl:defvar xcl-test::*any-errors*
 nil)

(cl:defvar xcl-test::*test-cleanup-forms*
 nil)

(cl:defvar xcl-test:*test-compile*
 nil)

(cl:defvar xcl-test:*test-mode*
 :batch)

(cl:defvar xcl-test:*test-batch-results*
 "{eris}<lispcore>cml>test>test-results" )

(cl:defvar xcl-test:*test-file-pattern*
 "{ERIS}<LISPCORE>CML>TEST>*.TEST;" )

(cl:defvar xcl-test::*test-file-name*
 "unknown" )

(defpackage "XCL-TEST" (:export xcl-test:do-test xcl-test:do-test-group xcl-test:expect-errors 
                              xcl-test:test-defun xcl-test:test-defmacro xcl-test:test-setq 
                              xcl-test:do-all-tests xcl-test:cl-readfile xcl-test:do-test-file 
                              xcl-test:*test-mode* xcl-test:*test-batch-results* 
                              xcl-test:*test-compile* xcl-test:*test-file-pattern*))

(putprops xcl-test:do-test makefile-environment
 (:readtable "xcl" :package (defpackage "XCL-TEST"
                                                                                  (:use "LISP"))))

(putprops xcl-test:do-test filetype
 cl:compile-file)
(putprops do-test copyright ("Xerox Corporation" 1986))
(declare\: dontcopy
  (filemap (nil)))
stop