(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER")

(il:filecreated "17-Jun-88 15:44:57" il:{qv}<pedersen>lisp>tester.\;5
 6908   

      il:|changes| il:|to:|  (il:vars il:testercoms) (il:functions test-equal define-verified-test make-test-defun type-number get-forms verified-test-to-do-test comment-p)
 (il:commands "COPY-TEST" "E-TEST") (file-environments "TESTER")

      il:|previous| il:|date:| "14-Jun-88 14:56:12" il:{qv}<pedersen>lisp>tester.\;4)


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

(il:prettycomprint il:testercoms)

(il:rpaqq il:testercoms ((il:declare\: il:dontcopy il:donteval@load il:doeval@compile (il:files il:cmlarray-support)) (il:functions test-equal) (il:coms (il:* il:|;;| "tester definition ") (il:define-types verified-tests) (il:functions define-verified-test make-test-defun)) (il:functions verified-test-to-do-test get-forms comment-p) (il:functions type-number make-test-defun) (il:commands "COPY-TEST" "E-TEST") (file-environments "TESTER")))
(il:declare\: il:dontcopy il:donteval@load il:doeval@compile 

(il:filesload il:cmlarray-support)
)

(defun test-equal (x y) (equal x y))



(il:* il:|;;| "tester definition ")



(def-define-type verified-tests "verified regression test")

(defdefiner define-verified-test verified-tests (name message &body body) (il:* il:|;;| "Assumes the body is a form that returns a value or a list of values (comparable by equal) that may be computed at definition/compile time. NAME is a symbol and MESSAGE is a string to printed at success/failure") (let ((values (compile-form (il:bquote (progn (il:\\\,@ body)))))) (il:bquote (eval-when (load) (format *error-output* "~&Test: ~a, " (il:\\\, message)) (if (test-equal (quote (il:\\\, values)) (progn (il:\\\,@ body))) (format *error-output* "succeeded.~%") (format *error-output* "failed. ***********~%"))))))

(defmacro make-test-defun (test-name) (il:bquote (defun (il:\\\, test-name) nil (il:\\\,@ (nthcdr 3 (il:getdef test-name (quote verified-tests)))))))

(defun verified-test-to-do-test (filename pathname &optional (linelength 60)) (let* ((root-name (intern (string filename) (find-package "INTERLISP"))) (makefile-environment (get root-name (quote il:makefile-environment)))) (let ((*package* (find-package (or (second (member :package makefile-environment :test (function eq))) "INTERLISP"))) (*readtable* (il:find-readtable (or (second (member :readtable makefile-environment :test (function eq))) "INTERLISP"))) (*print-base* (or (second (member :base makefile-environment :test (function eq))) 10)) (*print-case* :downcase) (*print-array* t) (*print-level* nil) (*print-length* nil) (*print-structure* t) (il:* il:|;;| "Interlisp gorp that controls pretty printing") (il:*print-semicolon-comments* t) (il:fontchangeflg nil) (il:\#rpars nil) (il:**comment**flg nil)) (declare (global il:filelinelength il:prettyflg)) (declare (special il:fontchangeflg il:\#rpars il:**comment**flg il:*print-semicolon-comments*)) (with-open-file (stream (make-pathname :type "TEST" :version :newest :defaults pathname) :direction :output) (il:resetvars (il:* il:|;;| "Interlisp gorp that controls pretty printing") ((il:filelinelength linelength) (il:prettyflg t)) (il:* il:|;;| "Identifier") (format stream "~&;;; File converted on ~A from source ~A" (il:date) root-name) (let ((dates (get root-name (quote il:filedates)))) (when dates (format stream "~&;;; Original source ~A created ~A" (cdar dates) (caar dates)))) (terpri stream) (terpri stream) (il:* il:|;;| "Copyright notice") (let ((owner (get root-name (quote il:copyright)))) (when (and owner (consp owner)) (format stream ";;; Copyright (c) ") (do ((tail (cdr owner) (cdr tail))) ((null tail)) (format stream "~4d" (car tail)) (if (cdr tail) (princ ", " stream))) (format stream " by ~a~%" (car owner)))) (terpri stream) (dolist (com (symbol-value (il:filecoms root-name))) (dolist (form (get-forms com)) (pprint form stream) (terpri stream) (il:block)))) (namestring stream)))))

(defun get-forms (command) (let ((unsupported-types (quote (il:fns il:specvars il:globalvars il:localvars il:initvars il:alists il:defs il:initrecords il:lispxmacros il:macros il:props il:records il:sysrecords il:usermacros il:vars il:constants export il:resources il:initresources il:globalresources il:i.s.oprs il:horriblevars il:uglyvars il:bitmaps il:cursors il:advice il:advise il:courierprograms il:templates il:prop il:files il:declare\:))) (filepkgtype (car command))) (if (member filepkgtype unsupported-types :test (function eq)) (progn (warn "Filepkg type ~s not supported: ~s" filepkgtype command) nil) (case filepkgtype (il:p (cdr command)) (il:coms (il:* il:|;;| "Recurse") (mapcan (function (lambda (x) (get-forms x))) (cdr command))) ((eval-when il:eval-when) (il:bquote ((eval-when (il:\\\, (mapcar (function (lambda (sym) (intern (string sym) (find-package "LISP")))) (second command))) (il:\\\,@ (get-forms (third command))))))) ((il:*) (il:* il:|;;| "Comment ") (list command)) (t (il:* il:|;;| "Should the filepkgtype of a definer") (let ((ignored-definers (quote (file-environments il:define-types optimizers il:sedit-formats advised-functions il:commands il:special-forms profiles xcl::walker-templates))) (definer-type (il:getfilepkgtype filepkgtype (quote il:commands) t))) (if (member definer-type ignored-definers :test (function eq)) (unless (eq definer-type (quote file-environments)) (progn (warn "Ignoring definer coms: ~s" command) nil)) (let* ((get-def-method (and definer-type (get definer-type :defined-by) (get definer-type (quote il:getdef)))) (defs (and get-def-method (mapcar (function (lambda (name) (if (comment-p name) name (funcall get-def-method name definer-type)))) (cdr command))))) (case definer-type (verified-tests (setq defs (mapcar (function (lambda (def) (destructuring-bind (tag name message &body body) def (let ((values (compile-form (remove-comments (il:bquote (progn (il:\\\,@ body))))))) (il:bquote (do-test (il:\\\, message) (equal (quote (il:\\\, values)) (il:\\\,@ (if (eq 1 (length body)) body (il:bquote ((progn (il:\\\,@ body))))))))))))) defs)))) (or defs (progn (warn "Can't parse: ~s" command) nil))))))))))

(defun comment-p (form) (and (consp form) (eq (car form) (quote il:*)) (consp (cdr form)) (member (cadr form) (quote (il:\; il:|;;| il:|;;;|)) :test (function eq)) t))

(defun type-number (type) (il:%cml-type-to-typenumber-expander type))

(defmacro make-test-defun (test-name) (il:bquote (defun (il:\\\, test-name) nil (il:\\\,@ (nthcdr 3 (il:getdef test-name (quote verified-tests)))))))

(defcommand "COPY-TEST" (from to) (il:copydef from to (quote verified-tests)))

(defcommand "E-TEST" (name) (ed name (quote (:dontwait verified-tests))))

(define-file-environment "TESTER" :package "XCL-USER" :readtable "XCL" :compiler :compile-file)
(il:putprops il:tester il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop