;;-*- Mode:LISP; Package:VERIFICATION-INTERNALS; Base:8 -*- ;; (C) Copyright 1983 Lisp Machines Inc. ;; 10/26/83 12:41:02 -George Carrette ;; Two kinds of testing will be done. The first kind will test the instructions of the ;; machine and the basic lisp functions. Sets of these tests will be compiled, ;; loaded into the environment, and run with the RUN-TEST or RUN-TEST-SET functions. ;; Loading and running will also been done with the VERIFY function, which is a ;; read-eval-print loop augmented with timing statistic maintainence, which takes ;; input from a file and prints output to a file. These output files can be ;; kept as a permanent record of machine performance over time. Especially ;; useful functions to test in this manner are the arithmetic functions, ;; with emphasis on floating-point and bignum correctness and speed. ;; The second kind of test is interactive-simulation which is ;; difficult to make and maintain as a thorough testing of all the functional ;; units of the machine. Irreproducability of timing makes it impossible to ;; keep a stream of meaningfull mouse-and-keyboard-input to feed into at any presently ;; possible level of the software or hardware. ;; syntax for use in test :inputs to reference test :outputs from ;; other tests. (defmacro tvar (var-name test-name) "(tvar X FOO-INIT) references the output variable X from the deftest FOO-INIT" `(*tvar-reference ',var-name ',test-name)) (defmacro tvar? (var-name test-name) `(*tvar-reference? ',var-name ',test-name)) (defprop tvar ((tvar var-name test-name) set-tvar var-name test-name si:val) setf) (defun *tvar-reference (var-name test-name) (get! (get! test-name 'test-variables) var-name)) (defun *tvar-reference? (var-name test-name) (get-restl (get! test-name 'test-variables) var-name)) (defmacro set-tvar (var-name test-name val) `(*tvar-set ',var-name ',test-name ,val)) (defun *tvar-set (var-name test-name value) (putprop (get! test-name 'test-variables) value var-name)) ;; (defvar *tests* ()) (defun add-test (plist) (or (get plist ':unaccounted) (or (memq (plist-name plist) *tests*) (setq *tests* (nconc *tests* (list (plist-name plist)))))) (record-source-file-name (plist-name plist) 'deftest) (putprop (plist-name plist) (list 'test-variables) 'test-variables) (putprop (plist-name plist) (copylist plist) 'deftest)) (defun tests-in-file (pathname) (subset #'(lambda (x) (eq (si:get-source-file-name x 'deftest) pathname)) *tests*)) (defprop deftest "Test" si:definition-type-name) (defmacro deftest (&rest plist) "Defines a test with options :inputs, :outputs, :verification, :code, :loop-count, :measure The :inputs are variable value pairs as in LET, the :outputs are variables, the :verification is an expression which gets evaluated to return true or false, the :code is evaluated using the :inputs and setting the :outputs, :loop-count defaults to 1, :measure to :realtime and :disk-wait. Run-Test thens runs the test." (let ((name (plist-name plist)) (inputs (getprop plist ':inputs ())) (outputs (getprop plist ':outputs ())) (verify (getpropd plist ':verification t)) (compilation-options (getpropd plist ':compilation-options '((normal)))) (code (getprop plist ':code ())) (loop-count (getpropd plist ':loop-count 1)) (measure (getpropd plist ':measure '(:realtime :disk-wait)))) (let ((vars (union (mapcar #'car inputs) outputs))) `(progn 'compile (add-test ',plist) (defun (:property ,name run-test) (option) (let (,@inputs ,@(mapkan #'(lambda (o) (and (not (assq o inputs)) (list o))) outputs)) (let ,(mapcar #'(lambda (m) `(,(get! m 'state-var) ,(get! m 'measure))) measure) (let ((loop-count (funcall (get! ',name option) ,@vars))) (let ,(mapcar #'(lambda (m) `(,(get! m 'state-var-after) ,(get! m 'measure))) measure) ,@(mapcar #'(lambda (m) `(setq ,(get! m 'state-var) (,(get! m 'measure-difference) ,(get! m 'state-var-after) ,(get! m 'state-var)))) measure) ,@(mapcar #'(lambda (o) `(setq ,o (tvar ,o ,name))) outputs) (report-measurements ',name option loop-count ,verify ,@(mapkan #'(lambda (m) `(',m ,(get! m 'state-var))) measure))))))) ,@(mapcar #'(lambda (option) `(defun (:property ,name ,(car option)) ,vars (compiler-let ,(do ((l (cdr option) (cddr l)) (v () (cons (list (car l) (cadr l)) v))) ((null l) (nreverse v))) (do ((loop-count ,loop-count) (j 0 (1+ j))) ((= j loop-count) (prog1 loop-count ,@(mapcar #'(lambda (o) `(*tvar-set ',o ',name ,o)) outputs))) ,code)))) compilation-options))))) (defun report-measurements (name option loop-count passed? &rest l) (format standard-output "~&; ~A ~A looping ~D time~p ~:[**FAILED THE TEST***.~;is ok.~]~%" name option loop-count loop-count passed?) (push (list* option ':loop-count loop-count (copylist l)) (get (get! name 'deftest) ':report)) (do ((l l (cddr l)) (st)(val)(unit)(per)) ((null l)) (setq st (get! (car l) 'measure-convert-print) val (funcall (get! (car l) 'measure-convert) (cadr l)) unit (get! (car l) 'measure-convert-unit) per (and (not (= 1 loop-count)) (funcall (getprop (car l) 'measure-per-loop #'(lambda (ignore ignore) ())) val loop-count))) (format standard-output "; ~A of ~S ~A~:[~; ~S per loop~]~%" st val unit per per)) passed?) (defun test-defined? (name) (get name 'deftest)) (defun run-test (&optional (name () name-p) (option () option-p)) "Runs a test(s) NAME defined by Deftest, with compilation option." (cond ((null name-p) (mapcar #'run-test *tests*)) ((not (atom name)) (mapcar #'(lambda (name) (if option-p (run-test name option) (run-test name))) name)) ((not (test-defined? name)) "not a known test") ('else (let ((p (get! name 'deftest))) (if option-p (run-deftest p (list option)) (run-deftest p)))))) (defun run-deftest (p &optional (options (mapcar #'car (get p ':compilation-options)))) (run-first-tests p) (mapcar #'(lambda (option) (run-one-deftest-option p option)) options)) (defun run-first-tests (p) (mapc #'(lambda (test-name) (get! (get! test-name 'deftest) ':report #'(lambda (p ignored) (run-deftest p)))) (get p ':run-first))) (defconst *clean-dirty-pages? t) (defun run-one-deftest-option (p option) (when (and *clean-dirty-pages? (fboundp 'si:clean-dirty-pages)) (format t "~&;Cleaning dirty pages...") (format t " done, got ~D of 'em.~%" (si:clean-dirty-pages))) (list (plist-name p) (if (get (plist-name p) option) (if (funcall (get (plist-name p) 'run-test) option) ':passed ':failed) ':unknown) option)) (defun describe-test (&optional (name () name-p)) (cond ((null name-p) (mapc #'describe-test *tests*)) ('else (let ((p (Get! name 'deftest))) (format standard-output "~&~%; The purpose of the ~A test is ~A.~%" name (getprop p ':purpose "unknown")) (let ((l (cdr (get name 'test-variables)))) (cond (l (format standard-output "; Its output variables are:~%") (do ((l l (cddr l))) ((null l)) (format standard-output "; ~S value: ~S~%" (car l) (cadr l))))))))) "done") ;; blecherous hacks used by tests or verification files which defined and run tests. ;; CALLING THE COMPILER (defvar *forms-list*) (defvar *forms-list-tyi-hack*) (defun list-of-forms-closure-function (operation &optional arg1 &Rest args) (selectq operation (:which-operations '(:read :tyi :untyi)) (:tyi (if (null *forms-list-tyi-hack*) (setq *forms-list-tyi-hack* #/() (error "only one tyi hack allowed"))) (:untyi (setq *forms-list-tyi-hack* ())) (:read (cond ((null *forms-list*) (setq *forms-list* 'eof) arg1) ((eq *forms-list* 'eof) (error "read past end of file")) ('else (pop *forms-list*)))) (:otherwise (stream-default-handler #'list-of-forms-closure-function operation arg1 args)))) (defun make-list-of-forms-stream (*forms-list* &aux *forms-list-tyi-hack*) (closure '(*forms-list* *forms-list-tyi-hack*) #'list-of-forms-closure-function)) (defprop compile-list-of-forms t si:may-surround-defun) (defun compile-list-of-forms (l) (let ((compiler:qc-file-check-indentation ()) (zwei:COMPILE-PROCESSING-MODE 'COMPILER:MACRO-COMPILE)) (declare (special zwei:COMPILE-PROCESSING-MODE)) (compiler:compile-stream (make-list-of-forms-stream l) (fs:make-dummy-pathname 'compile-list-of-forms ) () #'(lambda (form) (COMPILER:LOCKING-RESOURCES (COMPILER:COMPILE-DRIVER FORM #'ZWEI:COMPILE-BUFFER-FORM NIL))) t () package))) ;; CALLING THE ERROR SYSTEM. ;; We would like to be able to use the output from sending the ;; :BUG-REPORT-DESCRIPTION message as used by the C-M command in ;; the error handler. However, we were not able to easily construct the ;; correct environment of special variables and process context ;; to do that. In the interest of not duplicating a lot of code ;; we give a simple version of this instead. We don't really want ;; to have to switch stack groups anyway. In any case, I am using here ;; the "CHAR-PUNTING-STREAM" way of making finite output instead of the ;; PRINLEVEL/PRINLENGTH method. ;; Due to continued non deterministic behavior, we switch our strategy ;; back to using our own stack group for error message printing. ;; Foo, the reason things are screwy should be obvious, it is the ;; stack-cache that is screwing us. AREF on the SG-REGULAR-PDL must be meaningless ;; while the stack group is running. This is not a VAX, so Live and learn. -GJC ;; (it does seem unfortunate that the behavior of user-level functions is ;; not deterministic on some datum). ;; Not much code from the error handler must be duplicated. (DEFMACRO-DISPLACE VERBOSE-CATCH-ERROR (BODY &REST OPTIONS) "verbose form of catch-error, with output like the C-M command in the debugger. options are :NUMBER-OF-FRAMES, :USE-MAIL-STYLE? [NIL], :SKIP-SOME-FRAMES? [T], :ACTIVE-FRAMES-ONLY [T]." (LET ((TAG (GENSYM))) `(CATCH-CONTINUATION ',TAG #'(LAMBDA () (VALUES NIL T)) NIL (CONDITION-BIND ((ERROR 'VERBOSE-ERRSET-HANDLER ',TAG ,@OPTIONS)) (A-FRAME-to-STOP-ON ,BODY))))) (defresource fake-second-level-error-handler () :constructor (make-stack-group 'fake-second-level-error-handler)) (DEFCONST fake-second-level-error-handler-INHERITED-VARIABLES '(PACKAGE READTABLE BASE IBASE *NOPOINT SI:PRINT-READABLY PRINLEVEL PRINLENGTH TERMINAL-IO STANDARD-INPUT STANDARD-OUTPUT QUERY-IO DEBUG-IO ERROR-OUTPUT)) (DEFUN VERBOSE-ERRSET-HANDLER (CONDITION TAG &OPTIONAL &KEY (NUMBER-OF-FRAMES NIL) (USE-MAIL-STYLE? NIL) (skip-some-frames? t) (active-frames-only? nil)) (COND (ERRSET (format error-output "~&; ERRSET is non-nil~%")) ((SEND CONDITION ':DANGEROUS-CONDITION-P) (format error-output "~&; Condition is ~S true: ~S~%" ':DANGEROUS-CONDITION-P condition)) ('else (cond ((not (or (null number-of-frames) (and (fixp number-of-frames) (>= number-of-frames 0)))) ;; otherwise we can get a hard-to-extricate-from error. (format error-output "~&; bad value for number-of-frames-to-print, assuming NIL") (setq number-of-frames nil))) (format error-output "~&; Error in ~A system:~%" (SEND condition ':BUG-REPORT-RECIPIENT-SYSTEM)) (or use-mail-style? (SEND CONDITION ':PRINT-ERROR-MESSAGE CURRENT-STACK-GROUP T ERROR-OUTPUT)) (using-resource (sg fake-second-level-error-handler) (STACK-GROUP-PRESET SG (closure fake-second-level-error-handler-INHERITED-VARIABLES 'fake-SECOND-LEVEL-ERROR-HANDLER) current-stack-group condition number-of-frames use-mail-style? skip-some-frames? active-frames-only?) (funcall sg)) (*THROW TAG CONDITION)))) (defprop VERBOSE-ERRSET-HANDLER t :error-reporter) (defprop eh:invoke-handlers t :error-reporter) (defvar *number-of-frames* nil) (defvar *use-mail-style? nil) (defvar *map-n-frames-active-only? ()) (defun fake-SECOND-LEVEL-ERROR-HANDLER (SG eh:EH-ERROR *number-of-frames* *use-mail-style? skip-some-frames? *map-n-frames-active-only? &AUX eh:CURRENT-FRAME eh:ERROR-LOCUS-FRAME eh:INNERMOST-VISIBLE-FRAME eh:INNERMOST-FRAME-IS-INTERESTING) ;; [some code from EH:SECOND-LEVEL-ERROR-HANDLER] (SETQ eh:INNERMOST-VISIBLE-FRAME (sys:SG-AP SG)) (setq eh:current-frame eh:innermost-visible-frame) (when skip-some-frames? ;; the :FIND-CURRENT-FRAME message as defined for CONDITION ;; doesn't work here because it assumes something about ;; what is on the stack which isn't, namely the call to the current-stack-group ;; group, which the real second-level-error-handler gets rid of first. (DO ((RP (sys:SG-REGULAR-PDL SG)) (FN)(fnn)) ((NOT (OR (EQ (setq fn (sys:RP-FUNCTION-WORD RP eh:current-frame)) current-stack-group) (and (symbolp (setq fnn (function-name fn))) (get fnn ':error-reporter))))) (setq eh:current-frame (eh:SG-NEXT-ACTIVE SG eh:current-frame)))) (setq eh:ERROR-LOCUS-FRAME (eh:SG-OUT-TO-INTERESTING-ACTIVE sg eh:current-frame)) (FAKE-DEBUGGER-COMMAND-LOOP SG) (stack-group-return ())) (defun FAKE-DEBUGGER-COMMAND-LOOP (eh:error-sg) ;; now we could send messages such as :BUG-REPORT-DESCRIPTION ;; (this-is-not-defined) ;; test robustness. ok. (if *use-mail-style? (send eh:eh-error ':bug-report-description error-output *number-of-frames*) (print-n-frames eh:error-sg eh:current-frame *number-of-frames*))) (defun a-frame-to-stop-on (value) ;; like it says, a frame to stop on, looked for by the verbose-errset-handler ;; stack walker. value) (defun next-frame (stack-group frame) (if *map-n-frames-active-only? (eh:sg-next-active stack-group frame) (eh:sg-next-open stack-group frame))) (defun map-n-frames (f stack-group start-frame n &rest l) (do ((j 0 (1+ j)) ;; using EH:SG-NEXT-OPEN gives an error on about the last frame. ;; but in use, the FRAME-to-STOP-ON might save us. (frame start-frame (next-frame stack-group frame))) ((or (null frame) (and n (> j n)))) (lexpr-funcall f j stack-group frame l))) (defun print-n-frames (stack-group start-frame n) (*catch 'print-n-frames (map-n-frames #'print-a-frame stack-group start-frame n (make-char-punting-stream error-output)))) (defun print-a-frame (number sg frame stream &aux fn) (setq fn (si:rp-function-word (si:sg-regular-pdl sg) frame)) (if (or (eq fn #'a-frame-to-stop-on) ;; a compiled call to verbose-error-catch (and (eq fn #'si:eval1) (= 1 (eh:sg-frame-number-of-spread-args sg frame)) (let ((arg-to-*eval (AREF (eh:SG-REGULAR-PDL SG) (+ FRAME 1)))) (and (not (atom arg-to-*eval)) ;; an interpreted call. (eq (car arg-to-*eval) 'a-frame-to-stop-on))))) (*throw 'print-n-frames ())) (format-puntable stream "~%Frame number ~D is an ~:[open-frame to call~;active call to~] ~S" number (eh:sg-frame-active-p sg frame) fn) (terpri-puntable stream) (let ((l (and (functionp fn t) (arglist fn)))) (cond (l (format-puntable stream "Arglist: ~S" l) (terpri-puntable stream)))) (cond ((eh:sg-frame-active-p sg frame) (do ((j 0 (1+ j)) (n (eh:sg-frame-number-of-spread-args sg frame)) (l (eh:sg-frame-rest-arg-value sg frame))) ((and (>= j n) (atom l))) (format-puntable stream "Arg[~D]= ~S" j (if (>= j n) (pop l) ;; the eh:sg-frame-arg-value goes to ;; a lot more trouble than this to ;; print the present value of a ;; argument which also gets specbound. (AREF (eh:SG-REGULAR-PDL SG) (+ FRAME j 1)))) (terpri-puntable stream))))) (or (fboundp 'eh:sg-frame-rest-arg-value) (fset 'eh:sg-frame-rest-arg-value (fsymeval 'eh:sg-rest-arg-value))) ;; (defun apropos-list (x l) "e.g. (apropos-list 'WIDTH (send terminal-io :which-operations))" (subset (let-closed ((yow x)) #'(lambda (v) (string-search yow v))) l)) (defvar *char-punting-limit*) (defvar *char-punting-count*) (defvar *char-punting-output*) (defun char-punting-stream-closure-function (operation &optional arg1 &Rest args) (selectq operation (:which-operations '(:tyo :reset :count)) ((:tyo) (cond ((> (setq *char-punting-count* (1+ *char-punting-count*)) *char-punting-limit*) (princ " etc ..." *char-punting-output*) (*throw 'char-punt *char-punting-limit*)) ('else (send *char-punting-output* operation arg1)))) ((:reset) (setq *char-punting-count* (or arg1 0))) ((:count) *char-punting-count*) (:otherwise (stream-default-handler #'char-punting-stream-closure-function operation arg1 args)))) (defun make-char-punting-stream (*char-punting-output* &optional (*char-punting-limit* 80.) &aux (*char-punting-count* 0)) (closure '(*char-punting-output* *char-punting-limit* *char-punting-count*) #'char-punting-stream-closure-function)) (defun call-on-char-punting-stream (sofar stream f &rest l) (send stream ':reset sofar) (*catch 'char-punt (lexpr-funcall f l)) (send stream ':count)) (defun prin1-puntable (sofar object stream) (call-on-char-punting-stream sofar stream #'prin1 object stream)) (defun princ-puntable (sofar object stream) (call-on-char-punting-stream sofar stream #'princ object stream)) (defun terpri-puntable (stream) (call-on-char-punting-stream 0 stream #'terpri stream)) (defun format-puntable (stream string &rest l) ;; this doesn't work, probably having to do with the funarg problem or something. ;; No, was a bug in the microcode for apply, change to lexpr-funcall and it works. (lexpr-funcall #'call-on-char-punting-stream 0 stream #'format stream string l))