;; Function To Be Tested: TIME  (Programmer's Assistant Command)
;;
;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release)
;;		CLtL, Section 20.2
;; Section: The EXEC
;; Page: 29
;;
;; Created By:   John Park
;;
;; Creation Date: Feb 23, 1987
;;
;; Last Update:  March 24, 1987  
;;
;; Filed As:      {ERIS}<lispcore>exec>time.u
;;
;;
;; Syntax:        TIME FORM &key REPEAT &environment ENV
;;
;; Function Description: Time the evaluation of FORM in the lexical environment
;; ENV, repeating REPEAT number of times.  Information is displayed in the exec
;; window.
;; 
;; Argument(s):  FORM 
;;			  REPEAT (number)
;;			  ENV (environment)
;;			  
;; Returns:     See function description
;;
;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands,
;; testing them will not be totally automatic.  Comments are incorporated within 
;; each command file, which will be run by using the function bksysbuf.  
;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command 
;; string. The do-test form within the command file will return T or "test 
;; failed" This test file requires TEDIT package.
;;
;; Messages will be printed before each command in the command files is executed
;; for user monitoring. This test will determine whether the correct results for
;; TIME are returned "elapsed time","net compute time, etc".  Test result is 
;; logged on {eris}<lispcore>test>exec>test.report.

(DO-TEST "TIME-TEST-SETUP"
	(PROGN 
		(SETQ MESS0 "Printing time statistics for compilation of the function palindromep...") 
		(SETQ MESS1 "Various time statics have been saved in {core}testfor analysis...")
		(SETQ MESS2 "Do-test will determine if various statics have been printed.....")
		(IF (FBOUNDP 'PALINDROMEP) (FMAKUNBOUND 'PALINDROMEP))
		;; palindrome reads the same forwards and backwards
		(setf (symbol-function 'palindromep) 
		           '(lambda (string &optional
								(start 0)
								(end (length string)))
					(dotimes (k (floor (- end start) 2) t)
						(unless (char-equal (char string (+ start k))
										(char string (- end k 1)))
						(return nil)))))
		(SETQ {CORE}TEST "{CORE}TIME") ; this is where the results are stored
		(SETQ TIME-CATEGORIES 
			'("Elapsed time    " "SWAP time       " "reclaim time    " 
				"net compute time"))
		(SETQ TEST-RESULT "{ERIS}<LISPCORE>TEST>EXECUTIVE>TEST.REPORT")
		(DEFUN T-FORMAT (STATUS)
				(FORMAT *OUTPUT* "~%COMMAND: TIME~%STATUS:  ~A  DATE:  ~A  TESTER:  ~A~%" STATUS (IL:DATE) IL:USERNAME))

(SETQ TIME-COMMAND-STRING 
"(FORMAT NIL MESS0)
(DRIBBLE '{CORE}TIME)
TIME (COMPILE 'PALINDROMEP)
(DRIBBLE)
(FORMAT NIL MESS1)
(FORMAT NIL MESS2)
(FMAKUNBOUND 'PALINDROMEP)
(DO-TEST 'TIME-TEST-RESULT
   	(PROGN (SETQ TIME-PRINTOUT-FLG NIL TIME-UNIT-FLG NIL)
			(SETQ *TIME-STREAM* (OPEN {CORE}TEST :DIRECTION :INPUT))
			(DEFUN MOVE-PTR (NO) (DO ((CNT 1 (1+ CNT)))
								((= CNT (1+ NO)) T)
								(READ *TIME-STREAM*)))
			(MOVE-PTR 4)
			(READ-LINE *TIME-STREAM*)
			;; Checking for various time statistics
 			(DOLIST  (Y TIME-CATEGORIES)
				(IF (STRING-EQUAL Y (READ-LINE *TIME-STREAM*):END2 16) 
						(PUSH T TIME-PRINTOUT-FLG)
						(PUSH NIL TIME-PRINTOUT-FLG)
				)
			)
			(CLOSE *TIME-STREAM*)
			(SETQ *TIME-STREAM* (OPEN {CORE}TEST :DIRECTION :INPUT))
			(MOVE-PTR 8)
			;; Checking to see if time is indicated in floating-point number
			 
			(DO ((CNT 1 (1+ CNT)))
				((= CNT 4) T) 
				(IF  (FLOATP (PROG1 (READ *TIME-STREAM*)(MOVE-PTR 4)))
 						(PUSH T TIME-UNIT-FLG)
						(PUSH NIL TIME-UNIT-FLG)
				)
			)
			(READ *TIME-STREAM*)
			(IF  (FLOATP (READ *TIME-STREAM*)(MOVE-PTR 4))
 						(PUSH T TIME-UNIT-FLG)
						(PUSH NIL TIME-UNIT-FLG)
				)
			(CLOSE *TIME-STREAM*)
			(MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE}))
			(LET ((*OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT
		 		:IF-EXISTS  :APPEND)))
            		(PROGN 
					(IF(AND (NOTANY #'NULL TIME-PRINTOUT-FLG)
					  	  (NOTANY #'NULL TIME-UNIT-FLG))
					 	(T-FORMAT 'SUCCESS)
						(T-FORMAT 'FAILED))
                     	(CLOSE *OUTPUT*)))
			)
	)

")
		(IL:BKSYSBUF TIME-COMMAND-STRING)
	)
)

STOP