;;;-*-lisp-*-

(herald timepn)

(defun (timeprogn macro) (form)
       (displace form
		 `(unwind-protect
			 (progn  (time-origin 'push)
				 ,@(cdr form))
			 (time-origin 'pop))))


(defvar last-gctime nil)
(defvar last-runtime nil)
(defvar last-realtime nil)


(defun time-origin (&optional (updatep nil)
			      (printp (not (eq updatep 'push))))
       (let ((realtime (time))
	     (runtime (runtime))
	     (gctime (status gctime)))
	    (if
	     printp
	     (let ((rel-realtime (-$ realtime (car last-realtime)))
		   (rel-runtime (- runtime (car last-runtime)))
		   (rel-gctime  (- gctime (car last-gctime))))
		  (format
		   msgfiles
		   "~&;~D.~3,'0D cpu sec. ~D% gc ~D.~D realtime (~D%)~:[ so far~]"
		   (// rel-runtime 1000000.)
		   (\ (// rel-runtime 1000.) 1000.)
		   (quotient (times 100. rel-gctime)
			     rel-runtime)
		   (ifix rel-realtime)
		   (\ (ifix (*$ 10.0 rel-realtime)) 10.)
		   (ifix (//$ (*$ 1.0e-4 (float rel-runtime))
			      rel-realtime))
		   updatep)))
		    
	    (caseq updatep
		   (set
		    (setf (car last-realtime) realtime)
		    (setf (car last-gctime) gctime)
		    (setf (car last-runtime) runtime))
		   (push
		    (push realtime last-realtime)
		    (push gctime last-gctime)
		    (push runtime last-runtime))
		   (pop
		    (pop last-realtime)
		    (pop last-gctime)
		    (pop last-runtime)))))

(time-origin 'push)

(sstatus ttyint #^] #'(lambda (stream char)
			      (if (= char (tyipeek -1 stream))
				  (tyi stream))
			      (time-origin)))