(DEFINE-FILE-INFO §READTABLE "xcl" §PACKAGE (DEFPACKAGE "XCL-TEST" (§USE "LISP")))

(il:filecreated "30-Oct-86 18:10:00" il:{eris}<lispcore>library>do-test.\;42
 12743  

      il:|changes| il:|to:|  (il:vars il:do-testcoms)
                             (il:props (il:do-test il:makefile-environment))
                             (il:functions do-test-list)

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


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

(il:prettycomprint il:do-testcoms)

(il:rpaqq il:do-testcoms
 
          ((il:functions do-test do-test-group test-defmacro test-defun test-setq 
                  without-batch-mode-errors expect-errors do-all-tests current-file-name cl-readfile 
                  do-test-file do-test-list)
           (il:variables *any-errors* *test-cleanup-forms* *test-compile* *test-mode* 
                  *test-batch-results* *test-file-pattern* *test-file-name*)
           (il:p (il:defpackage "XCL-TEST"
                        (:export do-test do-test-group expect-errors test-defun test-defmacro 
                               test-setq do-all-tests cl-readfile do-test-file *test-mode* 
                               *test-batch-results* *test-compile* *test-file-pattern*)))
           (il:prop (il:makefile-environment il:filetype)
                  il:do-test)))
(defmacro do-test
 (il:name-and-options &body il:body)
   (let ((il:name nil)
         (il:options nil))
        (cond
           ((consp il:name-and-options)
            (setq il:name (car il:name-and-options))
            (setq il:options (cdr il:name-and-options)))
           (t (setq il:name il:name-and-options)))
        (if (eq *test-mode* :interactive)
            (format *error-output* "Testing... ~S~%" il:name))
        `(not (when (null (without-batch-mode-errors ,@il:body))
                    (format *error-output* "Test \"~A\" failed in file \"~A\"~%" ',il:name (
                                                                                    current-file-name
                                                                                            ))
                    (il:setq *any-errors* t)))))

(defmacro do-test-group
 (il:name-and-options &body il:body)
   (let ((il:name nil)
         (il:options nil))
        (cond
           ((consp il:name-and-options)
            (setq il:name (car il:name-and-options))
            (setq il:options (cdr il:name-and-options)))
           (t (setq il:name il:name-and-options)))           (il:* 

                                "Hack: find :BEFORE and :AFTER clauses in the body and move them out")

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

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

(defmacro test-defun
 (il:name &rest il:stuff)
   (if (fboundp il:name)
       (if (or (macro-function il:name)
               (special-form-p il:name))
           (error "Please don't redefine ~A in a test form" il:name)
           (push `(setf (symbol-function ',il:name)
                        ',(symbol-function il:name)) *test-cleanup-forms*))
       (push `(fmakunbound ',il:name) *test-cleanup-forms*))
   `(defun (il:\\\,
 il:name) ,@il:stuff )
)

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

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

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

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

(defun current-file-name
 nil *test-file-name*)

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

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

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

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

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

(defvar *any-errors*
 nil)

(defvar *test-cleanup-forms*
 nil)

(defvar *test-compile*
 nil)

(defvar *test-mode*
 :batch)

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

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

(defvar *test-file-name*
 "unknown" )

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

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

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