;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     The data in this file contains enhancments.                    ;;;;;
;;;                                                                    ;;;;;
;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
;;;     All rights reserved                                            ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "MAXIMA")
(macsyma-module mtrace)

(declare-top(*lexpr trace-mprint) ;; forward references
	 (genprefix mtrace-)
	 (special $functions $transrun trace-allp))

;;; a reasonable trace capability for macsyma users.
;;; 8:10pm  Saturday, 10 January 1981 -GJC.

;; TRACE(F1,F2,...)   /* traces the functions */
;; TRACE()            /* returns a list of functions under trace */
;; UNTRACE(F1,F2,...) /* untraces the functions */
;; UNTRACE()          /* untraces all functions. */
;; TRACE_MAX_INDENT   /* The maximum indentation of trace printing. */
;;
;; TRACE_OPTIONS(F,option1,option2,...)  /* gives F options */
;;
;; TRACE_BREAK_ARG    /* Bound to list of argument during BREAK ENTER,
;;                      and the return value during BREAK EXIT.
;;                      This lets you change the arguments to a function,
;;                      or make a function return a different value,
;;                      which are both usefull debugging hacks.
;;
;;                      You probably want to give this a short alias
;;                      for typing convenience. 
;;                    */
;;
;; An option is either a keyword, FOO.
;; or an expression  FOO(PREDICATE_FUNCTION);
;;
;; A keyword means that the option is in effect, an keyword
;; expression means to apply the predicate function to some arguments
;; to determine if the option is in effect. The argument list is always
;; [LEVEL,DIRECTION, FUNCTION, ITEM] where
;; LEVEL      is the recursion level for the function.
;; DIRECTION  is either ENTER or EXIT.
;; FUNCTION   is the name of the function.
;; ITEM       is either the argument list or the return value.
;;
;; ----------------------------------------------
;; | Keyword    | Meaning of return value       |
;; ----------------------------------------------
;; | NOPRINT    | If TRUE do no printing.       |
;; | BREAK      | If TRUE give a breakpoint.    |
;; | LISP_PRINT | If TRUE use lisp printing.    |
;; | INFO       | Extra info to print           |
;; | ERRORCATCH | If TRUE errors are caught.    |
;; ----------------------------------------------
;;
;; General interface functions. These would be called by user debugging utilities.
;;
;; TRACE_IT('F)             /* Trace the function named F */
;; TRACE                    /* list of functions presently traced. */
;; UNTRACE_IT('F)           /* Untrace the function named F */
;; GET('F,'TRACE_OPTIONS)  /* Access the trace options of F */
;;
;; Sophisticated feature:
;; TRACE_SAFETY a variable with default value TRUE.
;; Example: F(X):=X; BREAKP([L]):=(PRINT("Hi!",L),FALSE),
;; TRACE(F,BREAKP); TRACE_OPTIONS(F,BREAK(BREAKP));
;; F(X); Note that even though BREAKP is traced, and it is called,
;; it does not print out as if it were traced. If you set
;; TRACE_SAFETY:FALSE; then F(X); will cause a normal trace-printing
;; for BREAKP. However, then consider TRACE_OPTIONS(BREAKP,BREAK(BREAKP));
;; When TRACE_SAFETY:FALSE; F(X); will give an infinite recursion,
;; which it would not if safety were turned on.
;; [Just thinking about this gives me a headache.]

;; Internal notes on this package:				-jkf
;; Trace works by storing away the real definition of a function and
;; replacing it by a 'shadow' function.  The shadow function prints a
;; message, calls the real function, and then prints a message as it
;; leaves.  The type of the shadow function may differ from the
;; function being shadowed.  The chart below shows what type of shadow
;; function is needed for each type of Macsyma function.
;;
;; Macsyma function	shadow type	hook type	mget
;; ____________________________________________________________
;;	subr		 expr		  expr
;;	expr		 expr		  expr
;;	lsubr		 expr		  expr
;;	fsubr		 fexpr		  fexpr
;;	fexpr		 fexpr		  fexpr
;;	mexpr		 expr		  expr		t
;;	mfexpr*		 mfexpr*	  macro
;;	mfexpr*s	 mfexpr*	  macro
;;
;; The 'hook type' refers to the form of the shadow function.  'expr' types
;; are really lexprs, they expect any number of evaluated arguments.
;; 'fexpr' types expect one unevaluated argument which is the list of
;; arguments.  'macro' types expect one argument, the caar of which is the
;; name of the function, and the cdr of which is a list of arguments.
;;
;; For systems which store all function properties on the property list,
;; it is easy to shadow a function.  For systems with function cells,
;; the situation is a bit more difficult since the standard types of
;; functions are stored in the function cell (expr,fexpr,lexpr), whereas
;; the macsyma functions (mfexpr*,...) are stored on the property list.
;;

;;; Structures.

(eval-when (compile load eval)
(defmacro trace-p (x) `(mget ,x 'trace))
(defmacro trace-type (x) `(mget ,x 'trace-type))
(defmacro trace-level (x) `(mget ,x 'trace-level))
(defmacro trace-options (x) `($get ,x '$trace_options))
#+(or Franz Cl)
(defmacro trace-oldfun (x) `(mget ,x 'trace-oldfun))
)



;;; User interface functions.

(defmvar $trace (list '(mlist)) "List of functions actively traced")
#-cl
(putprop '$trace #'read-only-assign 'assign)

(defun mlistcan-$all (fun llist default)
  "totally random utility function"
  (let (trace-allp)
    (if (null llist) default
        `((mlist) ,@(mapcan fun
			    (if (memq (car llist) '($all $functions))
			        (prog2 (setq trace-allp t)
				       (mapcar #'caar (cdr $functions)))
			        llist))))))

(defmspec $trace (form)
  (mlistcan-$all #'macsyma-trace (cdr form) $trace))
  
(defmfun $trace_it (function) `((mlist),@(macsyma-trace function)))


(defmspec $untrace (form)
  `((mlist) ,@(mapcan #'macsyma-untrace (or (cdr form)
					    (cdr $trace)))))

(defmfun $untrace_it (function) `((mlist) ,@(macsyma-untrace function)))

(defmspec $trace_options (form)
  (setf (trace-options (cadr form))
	`((mlist) ,@(cddr form))))



;;; System interface functions.

(defvar hard-to-trace '(trace-handler listify args setplist
				     trace-apply
				     *apply mapply))


;; A list of functions called by the TRACE-HANDLEr at times when
;; it cannot possibly shield itself from a continuation which would
;; cause infinite recursion. We are assuming the best-case of
;; compile code.

(defun macsyma-trace (fun) (macsyma-trace-sub fun 'trace-handler $trace))

(defun macsyma-trace-sub (fun handler ilist &aux temp)
  (cond ((not (symbolp fun))
	 (mtell "~%Bad arg to TRACE: ~M" fun)
	 nil)
	((trace-p fun)
	 ;; Things which redefine should be expected to reset this
	 ;; to NIL.
	 (if (not trace-allp) (mtell "~%~@:M is already traced." fun))
	 nil)
	((memq fun hard-to-trace)
	 (mtell
	  "~%The function ~:@M cannot be traced because: ASK GJC~%"
	  fun)
	 nil)
	((null (setq temp (macsyma-fsymeval fun)))
	 (mtell "~%~@:M has no functional properties." fun)
	 nil)
	((memq (car temp) '(mmacro translated-mmacro))
	 (mtell "~%~@:M is a macro, won't trace well, so use ~
		     the MACROEXPAND function to debug it." fun)
	 nil)
	((get (car temp) 'shadow)
	 (put-trace-info fun (car temp) ilist)
	 (trace-fshadow fun (car temp)
			(make-trace-hook fun (car temp) handler))
	 (list fun))
	(t
	 (mtell "~%~@:M has functional properties not understood by TRACE"
		fun)
	 nil)))

(defvar trace-handling-stack ())

(defun macsyma-untrace (fun) (macsyma-untrace-sub fun 'trace-handler $trace))

(defun macsyma-untrace-sub (fun handler ilist)
  (prog1
   (cond ((not (symbolp fun))
	  (mtell "~%Bad arg to UNTRACE: ~M" fun)
	  nil)
	 ((not (trace-p fun))
	  (mtell "~%~:@M is not traced." fun)
	  nil)
	 (t
	  (trace-unfshadow fun (trace-type fun))
	  (rem-trace-info fun ilist)
	  (list fun)))
   (if (memq fun trace-handling-stack)
       ;; yes, he has re-defined or untraced the function
       ;; during the trace-handling application.
       ;; This is not strange, in fact it happens all the
       ;; time when the user is using the $ERRORCATCH option!
       (macsyma-trace-sub fun handler ilist))))

(defun put-trace-info (fun type ilist)
       (setf (trace-p fun) fun) ; needed for MEVAL at this time also.
       (setf (trace-type fun) type)
#+Franz(setf (trace-oldfun fun) (getd fun))
#+cl(setf (trace-oldfun fun) (and (fboundp fun) (symbol-function fun)))
       (LET ((SYM (GENSYM)))
	    (SET SYM 0)
	    (setf (trace-level fun) SYM))
       (push fun (cdr ilist))
       (list fun))

(defun rem-trace-info (fun ilist)
       (setf (trace-p fun) nil)
       (or (memq fun trace-handling-stack)
	   (setf (trace-level fun) nil))
       (setf (trace-type fun) nil)
       (delq fun ilist)
       (list fun))


;; Placing the TRACE functional hook.
;; Because the function properties in macsyma are used by the EDITOR, SAVE,
;; and GRIND commands it is not possible to simply replace the function
;; being traced with a hook and to store the old definition someplace.
;; [We do know how to cons up machine-code hooks on the fly, so that
;;  is not stopping us].


;; This data should be formalized somehow at the time of
;; definition of the DEFining form.

(defprop subr expr shadow)
(defprop lsubr expr shadow)
(defprop expr expr shadow)
(defprop mfexpr*s mfexpr* shadow)
(defprop mfexpr* mfexpr* shadow)
(defprop fsubr fexpr shadow)
(defprop fexpr fexpr shadow)

#-Multics
(progn
;; too slow to snap links on multics.
(defprop subr t uuolinks)
(defprop lsubr t uuolinks)
(defprop fsubr t uuolinks) ; believe it or not. 
)

(defprop mexpr t mget)
(defprop mexpr expr shadow)

(defun get! (x y)
       (or (get x y)
	   (get! (MAXIMA-ERROR (list "Undefined" y "property") x 'wrng-type-arg)
		 y)))

#+Maclisp
(defun trace-fshadow (fun type value)
       ;; the value is defined to be a lisp functional object, which
       ;; might have to be compiled to be placed in certain locations.
       (if (get type 'uuolinks)
	   (sstatus uuolinks))
       (let ((shadow (get! type 'shadow)))
	    (setplist fun (list* shadow value (symbol-plist fun)))))

#+Franz
(defun trace-fshadow (fun type value)
   (cond ((and (get type 'uuolinks)
	       (status translink))
	  (sstatus translink nil)))
   (let ((shadow (get! type 'shadow)))
      (cond ((memq shadow '(expr subr))
	     (setf (trace-oldfun fun) (getd fun))
	     (putd fun value))
	    ((memq shadow '(fexpr fsubr))
	     (setf (trace-oldfun fun) (getd fun))
	     (putd fun (cons 'nlambda (cdr value))))
	    (t (setplist fun
			 `(,shadow ,value ,@(symbol-plist fun)))))))

#+cl
(defun trace-fshadow (fun type value)
   (let ((shadow (get! type 'shadow)))
      (cond ((memq shadow '(expr subr))
	     (setf (trace-oldfun fun) (and (fboundp fun) (symbol-function fun)))
	     (setf (symbol-function  fun)  value))
	    ((memq shadow '(fexpr fsubr))
	     (setf (trace-oldfun fun) (symbol-function fun))
	     (setf (symbol-function  fun)  (cons 'nlambda (cdr value))))
	    (t (setplist fun
			 `(,shadow ,value ,@(symbol-plist fun)))))))

#+Maclisp
(defun trace-unfshadow (fun type)
       ;; what a hack.
       (remprop fun (get! type 'shadow)))

#+Franz
(defun trace-unfshadow (fun type)
   (cond ((memq type '(expr subr fexpr fsubr))
	  (let ((oldf (trace-oldfun fun)))
	    (if (not (null oldf))
		(putd fun oldf)
		(putd fun nil))))
	 (t (remprop fun (get! type 'shadow))
	    (putd fun nil))))

#+cl
(defun trace-unfshadow (fun type &aux new-fun)
  (cond ((and (fboundp fun)
	      (consp (setq new-fun (symbol-function fun)))
	      (consp (second new-fun))
	      (among 'trace-args (second new-fun)))
  (cond ((memq type '(expr subr fexpr fsubr))
	 (let ((oldf (trace-oldfun fun)))
	   (if (not (null oldf))
	     (setf (symbol-function  fun)  oldf)
	     (fmakunbound fun))))
	 (t (remprop fun (get! type 'shadow))
	    (fmakunbound fun))))
	(t  (format t "~%This function was no longer defined as an interpreted-trace"))))

;--- trace-fsymeval :: find original function
;  fun : a function which is being traced.  The original defintion may
;	 be hidden on the property list behind the shadow function.
;
(defun trace-fsymeval (fun)
   (or
      (let ((type-of (trace-type fun)))
	 (cond ((get type-of 'mget)
		(if (eq (get! type-of 'shadow) type-of)
		    (mget (cdr (mgetl fun (list type-of))) type-of)
		    (mget fun type-of)))
	       #+(or Franz Cl)
	       ((memq (get! type-of 'shadow) '(expr fexpr))
		(trace-oldfun fun))
	       (t (if (eq (get! type-of 'shadow) type-of)
		      (get (cdr (getl fun (list type-of))) type-of)
		      (get fun type-of)))))
      (trace-fsymeval
	 (merror "Macsyma BUG: Trace property for ~:@M went away without hook."
		 fun))))

;;; The handling of a traced call.

(defvar trace-indent-level -1)

(defmacro bind-sym (symbol value . body)
	  #-Multics
	   ;; is by far the best dynamic binding generally available.
	  `(progv (list ,symbol)
		  (list ,value)
		  ,@body)
	  #+Multics ; PROGV is wedged on multics.
	  `(let ((the-symbol ,symbol)
		 (the-value ,value))
		(let ((old-value (symbol-value the-symbol)))
		     (unwind-protect
		      (progn (set the-symbol the-value)
			     ,@body)
		      (set the-symbol old-value)))))

;; We really want to (BINDF (TRACE-LEVEL FUN) (f1+ (TRACE-LEVEL FUN)) ...)
;; (Think about PROGV and SETF and BINDF. If the trace object where
;; a closure, then we want to fluid bind instance variables.)

;; From JPG;SUPRV
;;(DEFMFUN $ERRCATCH FEXPR (L)
;; (LET ((ERRCATCH (CONS BINDLIST LOCLIST)) RET)
;;      (IF (NULL (SETQ RET (ERRSET (MEVALN L) LISPERRPRINT)))
;;	  (ERRLFUN1 ERRCATCH))
;;      (CONS '(MLIST) RET)))
;; ERRLFUN1 does the UNBINDING.
;; As soon as error handlers are written and signalling is
;; implemented, use the correct thing and get rid of this macro.

(declare-top(special errcatch lisperrprint bindlist loclist)
	 (*expr errlfun1))

(defmacro macsyma-errset (form &aux (ret (gensym)))
	  `(let ((errcatch (cons bindlist loclist)) ,ret)
		(setq ,ret (errset ,form lisperrprint))
		(or ,ret (errlfun1 errcatch))
		,ret))

(defvar predicate-arglist nil)

(defvar return-to-trace-handle nil)

(defun trace-handler (fun largs)
       (If return-to-trace-handle
	   ;; we were called by the trace-handler.
	   (trace-apply fun largs)
	   (let ((trace-indent-level (f1+ trace-indent-level))
		 (return-to-trace-handle t)
		 (trace-handling-stack (cons fun trace-handling-stack))
		 (LEVEL-SYM (TRACE-LEVEL fun))(LEVEL))
		(SETQ LEVEL (f1+ (SYMBOL-VALUE LEVEL-SYM)))
		(BIND-SYM
		 LEVEL-SYM
		 LEVEL
		 (do ((ret-val)(continuation)(predicate-arglist))(nil)
		     (setq predicate-arglist `(,level $enter ,fun ((mlist) ,@largs)))
		     (setq largs (trace-enter-break fun level largs))
		     (trace-enter-print fun level largs)
		     (cond ((trace-option-p fun '$errorcatch)
			    (setq ret-val (macsyma-errset (trace-apply fun largs)))
			    (cond ((null ret-val)
				   (setq ret-val (trace-error-break fun level largs))
				   (setq continuation (car ret-val)
					 ret-val (cdr ret-val)))
				  (t
				   (setq continuation 'exit
					 ret-val (car ret-val)))))
			   (t
			    (setq continuation 'exit
				  ret-val (trace-apply fun largs))))
		     (case continuation
			    ((exit)
			     (setq predicate-arglist `(,level $exit ,fun ,ret-val))
			     (setq ret-val (trace-exit-break fun level ret-val))
			     (trace-exit-print fun level ret-val)
			     (return ret-val))
			    ((retry)
			     (setq largs ret-val)
			     (MTELL "~%Re applying the function ~:@M~%" fun))
			    ((MAXIMA-ERROR)
			     (MERROR "~%Signaling MAXIMA-ERROR for function ~:@M~%" fun))))))))


;; The (Trace-options function) access is not optimized to take place
;; only once per trace-handle call. This is so that the user may change
;; options during his break loops.
;; Question: Should we bind return-to-trace-handle to NIL when we
;; call the user's predicate? He has control over his own lossage.

(defmvar $trace_safety t "This is subtle")

(defun trace-option-p (function KEYWORD)
  (do ((options					
	(LET ((OPTIONS (TRACE-OPTIONS FUNCTION)))
	  (COND ((NULL OPTIONS) NIL)
		(($LISTP OPTIONS) (CDR OPTIONS))
		(T
		 (mtell "Trace options for ~:@M not a list, so ignored."
			function)
		 NIL)))
	(CDR OPTIONS))
       (OPTION))
      ((null options) nil)
    (setq OPTION (CAR OPTIONS))
    (cond ((atom option)
	   (if (eq option keyword) (return t)))
	  ((eq (caar option) keyword)
	   (let ((return-to-trace-handle $trace_safety))
	     (return (mapply (cadr option) predicate-arglist
			     "&A trace option predicate")))))))
			

(defun trace-enter-print (fun lev largs &aux (mlargs `((mlist) ,@largs)))
  (if (not (trace-option-p fun '$noprint))
      (let ((info (trace-option-p fun '$info)))
	(cond ((trace-option-p fun '$lisp_print)
	       (trace-print `(,lev enter ,fun ,largs ,@info)))
	      (t
	       (trace-mprint lev " Enter " (mopstringnam fun) " " mlargs
			     (if info " -> " "")
			     (if info info "")))))))

(defun mopstringnam (x) (maknam (mstring (getop x))))

(defun trace-exit-print (fun lev ret-val)
       (if (not (trace-option-p fun '$noprint))
	   (let ((info (trace-option-p fun '$info)))
		(cond ((trace-option-p fun '$lisp_print)
		       (trace-print `(,lev exit ,fun ,ret-val ,@info)))
		      (t
		       (trace-mprint lev " Exit  " (mopstringnam fun) " " ret-val
				     (if info " -> " "")
				     (if info info "")))))))

(defmvar $trace_break_arg '$TRACE_BREAK_ARG 
	 "During trace Breakpoints bound to the argument list or return value")

(defun trace-enter-break (fun lev largs)
       (if (trace-option-p fun '$break)
	   (do ((return-to-trace-handle nil)
		($trace_break_arg `((mlist) ,@largs)))(nil)
	       ($break '|&Trace entering| fun '|&level| lev)
	       (cond (($listp $trace_break_arg)
		      (return (cdr $trace_break_arg)))
		     (t
		       (mtell "~%Trace_break_arg set to nonlist, ~
			      please try again"))))
	   largs))

(defun trace-exit-break (fun lev ret-val)
       (if (trace-option-p fun '$break)
	   (let (($trace_break_arg ret-val)
		 (return-to-trace-handle nil))
		($break '|&Trace exiting| fun '|&level| lev)
		$trace_break_arg)
	   ret-val))

(defun pred-$read (predicate argl bad-message)
       (do ((ans))(nil)
	   (setq ans (apply #'$read argl))
	   (if (funcall predicate ans) (return ans))
	   (mtell "~%Unacceptable input, ~A~%" bad-message)))

(declare-top(special upper))

(defun ask-choicep (llist &rest header-message)
       (do ((j 0 (f1+ j))
	    (dlist nil
		   (list* "M" `((marrow) ,j ,(car ilist)) dlist))
	    (ilist llist (cdr ilist)))
	   ((null ilist)
	    (setq dlist (nconc header-message (cons "M" (nreverse dlist))))
	    (let ((upper (f1- j)))
		 (pred-$read #'(lambda (val)
				      (and (integerp val)
					   (>= val 0)
					   (<= val upper)))
			    dlist
			    "please reply with an integer from the menue.")))))

(declare-top (unspecial upper))

(defun trace-error-break (fun level largs)
       (case (ask-choicep '("Signal an MAXIMA-ERROR, i.e. PUNT?"
			     "Retry with same arguments?"
			     "Retry with new arguments?"
			     "Exit with user supplied value")
			   "Error during application of" (mopstringnam fun)
			   "at level" level
			   "M" "Do you want to:")
	      ((0)
	       '(MAXIMA-ERROR))
	      ((1)
	       (cons 'retry largs))
	      ((2)
	       (cons 'retry (let (($trace_break_arg `((mlist) ,largs)))
				 (cdr (pred-$read '$listp
						 (list
						  "Enter new argument list for"
						  (mopstringnam fun))
						 "please enter a list.")))))
					   
	      ((3)
	       (cons 'exit ($read "Enter value to return")))))


;;; application dispatch, and the consing up of the trace hook.

(defun macsyma-fsymeval (fun)
       (let ((try (macsyma-fsymeval-sub fun)))
	    (cond (try try)
		  ((get fun 'autoload)
		   (load-and-tell (get fun 'autoload))
		   (setq try (macsyma-fsymeval-sub fun))
		   (or try
		       (mtell "~%~:@M has no functional~
			      properties after autoloading.~%"
			      fun))
		   try)
		  (t try))))

(defun macsyma-fsymeval-sub (fun)
       ;; The semantics of $TRANSRUN are herein taken from DESCRIBE,
       ;; a carefull reading of MEVAL1 reveals, well... I've promised to watch
       ;; my language in these comments.

       (let ((mprops (mgetl fun '(mexpr mmacro)))
	     (lprops (getl  fun '(translated-mmacro mfexpr* mfexpr*s)))
	     (fcell-props (getl-fun fun '(subr lsubr expr fexpr macro fsubr))))
	    (cond ($TRANSRUN
		   ;; the default, so its really a waste to have looked for
		   ;; those mprops. Its better to fix the crock than to
		   ;; optimize this though!
		   (or lprops fcell-props mprops))
		  (t
		   (or mprops lprops fcell-props)))))

(Defprop EXPR EXPR HOOK-TYPE)
(DEFPROP MEXPR EXPR HOOK-TYPE)
(Defprop SUBR EXPR HOOK-TYPE)
(Defprop LSUBR EXPR HOOK-TYPE)
(Defprop FEXPR FEXPR HOOK-TYPE)
(Defprop FSUBR FEXPR HOOK-TYPE)
(Defprop MFEXPR* MACRO HOOK-TYPE)
(Defprop MFEXPR*S MACRO HOOK-TYPE)

#+Maclisp
(defun make-trace-hook (fun type handler)
  (CASE (GET! TYPE 'HOOK-TYPE)
    ((EXPR)
     `(lambda trace-nargs
	(,handler ',fun (listify trace-nargs))))
    ((FEXPR)
     `(LAMBDA (TRACE-ARGL)
	(,HANDLER ',FUN TRACE-ARGL)))
    ((MACRO)
     `(lambda (TRACE-FORM)
	(,HANDLER (CAAR TRACE-FORM) (LIST TRACE-FORM))))))

#+Franz
(defun make-trace-hook (fun type handler)
  (CASE (GET! TYPE 'HOOK-TYPE)
    ((EXPR)
     `(lexpr (trace-nargs)
	     (,handler ',fun (listify trace-nargs))))
    ((FEXPR)
     `(LAMBDA (TRACE-ARGL)
	(,HANDLER ',FUN TRACE-ARGL)))
    ((MACRO)
     `(lambda (TRACE-FORM)
	(,HANDLER (CAAR TRACE-FORM) (LIST TRACE-FORM))))))

#+cl
(defun make-trace-hook (fun type handler)
  (CASE (GET! TYPE 'HOOK-TYPE)
    ((EXPR)
     `(lambda (&rest trace-args)
	(,handler ',fun (copy-list trace-args))))
    ((FEXPR)
     `(LAMBDA (&quote &rest TRACE-ARGL)
	(,HANDLER ',FUN (copy-list TRACE-ARGL))))
;;;???
    ((MACRO)
     `(lambda (&quote &rest TRACE-FORM)
	(,HANDLER (CAAR TRACE-FORM) (copy-list TRACE-FORM))))))
       
#+Maclisp
(defmacro trace-setup-call (prop fun type)  
  `(args 'the-trace-apply-hack (args ,fun))
  `(setplist 'the-trace-apply-hack (list ,type ,prop)))

#+Franz
(defmacro trace-setup-call (prop fun type)
  `(putd 'the-trace-apply-hack ,prop))

#+cl
(defmacro trace-setup-call (prop fun type) fun type
  `(setf (symbol-function  'the-trace-apply-hack)  ,prop))

(defun trace-apply (fun largs)
       (let ((prop (trace-fsymeval fun))
	     (type (trace-type fun))
	     (return-to-trace-handle nil))
	    (case type
		   ((mexpr)
		    (mapply prop largs "&A traced function"))
		   ((expr)
		    (apply prop largs))
		   ((subr lsubr)
		    ;; no need to be fast here.
		    (args 'the-trace-apply-hack (args fun))
		    (setplist 'the-trace-apply-hack (list type prop))
		    #-cl (apply 'the-trace-apply-hack largs)
		    #+cl (apply (second (getl 'the-trace-apply-hack '(subr lsubr))) largs)
		    )
		   ((MFEXPR*)
		    (FUNCALL PROP (CAR LARGS)))
		   ((MFEXPR*S)
		    (SUBRCALL NIL PROP (CAR LARGS)))
		   ((FEXPR)
		    (FUNCALL PROP LARGS))
		   ((FSUBR)
		    (SUBRCALL NIL PROP LARGS)))))

;;; I/O cruft

(defmvar $trace_max_indent 15. "max number of spaces it will go right"
	 FIXNUM)
(putprop '$trace_max_indent 'assign-mode-check 'assign)
(putprop '$trace_max_indent '$fixnum 'mode)

(defun-prop (spaceout dimension) (form result)
       (dimension-string (*make-list (cadr form) #\Space) result))

(defun trace-mprint (&rest l)
       (mtell-open "~M"
		   `((mtext)
		     ((spaceout) ,(min $trace_max_indent trace-indent-level))
		     ,@ (copy-rest-arg l))))

(defun trace-print (form)
       (terpri)
       (do ((j (min $trace_max_indent trace-indent-level)
	       (f1- j)))
	   ((not (> j 0)))
	   (tyo #\Space))
       (if prin1 (funcall prin1 form)
	   (prin1 form))
       (tyo #\Space))


;; 9:02pm  Monday, 18 May 1981 -GJC
;; A function benchmark facility using trace utilities.
;; This provides medium accuracy, enough for most user needs.

(DEFMVAR $TIMER '((MLIST)) "List of functions under active timetrace")
#-cl
(PUTPROP '$TIMER #'READ-ONLY-ASSIGN 'ASSIGN)

(DEFMSPEC $TIMER (FORM)
  (MLISTCAN-$ALL #'macsyma-timer (cdr form) $timer))

(DEFMSPEC $UNTIMER (FORM)
  `((MLIST) ,@(MAPCAN #'MACSYMA-UNTIMER (OR (CDR FORM)
					    (CDR $TIMER)))))

(DEFUN MICRO-TO-SEC (RUNTIME)
  (MUL RUNTIME 1.0E-6 '$SEC))
(DEFUN MICRO-PER-CALL-TO-SEC (RUNTIME CALLS)
  (DIV (MICRO-TO-SEC RUNTIME)
       (IF (ZEROP CALLS) 1 CALLS)))

(DEFUN TIMER-MLIST (FUNCTION CALLS RUNTIME GCTIME)
  `((MLIST SIMP) ,FUNCTION
		 ,(MICRO-PER-CALL-TO-SEC (PLUS RUNTIME GCTIME) CALLS)
		 ,CALLS
		 ,(MICRO-TO-SEC RUNTIME)
		 ,(MICRO-TO-SEC GCTIME)))

(DEFMSPEC $TIMER_INFO (FORM)
  (DO ((L (OR (CDR FORM) (CDR $TIMER))
	  (CDR L))
       (V NIL)
       (TOTAL-RUNTIME 0)
       (TOTAL-GCTIME 0)
       (TOTAL-CALLS 0))
      ((NULL L)
       `(($matrix simp)
	 ((MLIST SIMP) $FUNCTION $TIME//CALL $CALLS $RUNTIME $GCTIME)
	 ,.(NREVERSE V)
	 ,(TIMER-MLIST '$TOTAL TOTAL-CALLS TOTAL-RUNTIME TOTAL-GCTIME)))
      (LET ((RUNTIME ($GET (CAR L) '$RUNTIME))
	    (GCTIME  ($GET (CAR L) '$GCTIME))
	    (CALLS   ($GET (CAR L) '$CALLS)))
	(WHEN RUNTIME
	      (SETQ TOTAL-CALLS (PLUS CALLS TOTAL-CALLS))
	      (SETQ TOTAL-RUNTIME (PLUS RUNTIME TOTAL-RUNTIME))
	      (SETQ TOTAL-GCTIME (PLUS GCTIME TOTAL-GCTIME))
	      (PUSH (TIMER-MLIST (CAR L) CALLS RUNTIME GCTIME) V)))))

(DEFUN macsyma-timer (fun)
  (PROG1 (macsyma-trace-sub fun 'timer-handler $timer)
	 ($PUT FUN 0 '$RUNTIME)
	 ($PUT FUN 0 '$GCTIME)
	 ($PUT FUN 0 '$CALLS)
	 ))

(defun macsyma-untimer (fun) (macsyma-untrace-sub fun 'timer-handler $timer))

(DEFVAR RUNTIME-DEVALUE 0)
(DEFVAR GCTIME-DEVALUE 0)

(DEFMVAR $TIMER_DEVALUE NIL
  "If true, then time spent inside calls to other timed functions is
  subtracted from the timing figure for a function.")

(DEFUN TIMER-HANDLER (FUN LARGS)
  ;; N.B. Doesn't even try to account for use of DYNAMIC CONTROL
  ;; such as ERRSET ERROR and CATCH and THROW, as these are
  ;; rare and the overhead for the unwind-protect is high.
  (LET ((RUNTIME (RUNTIME))
	(GCTIME (STATUS GCTIME))
	(OLD-RUNTIME-DEVALUE RUNTIME-DEVALUE)
	(OLD-GCTIME-DEVALUE GCTIME-DEVALUE))
    (PROG1 (TRACE-APPLY FUN LARGS)
	   (SETQ OLD-RUNTIME-DEVALUE (- RUNTIME-DEVALUE OLD-RUNTIME-DEVALUE))
	   (SETQ OLD-GCTIME-DEVALUE (- GCTIME-DEVALUE OLD-GCTIME-DEVALUE))
	   (SETQ RUNTIME (- (RUNTIME) RUNTIME OLD-RUNTIME-DEVALUE))
	   (SETQ GCTIME (- (STATUS GCTIME) GCTIME OLD-GCTIME-DEVALUE))
	   (WHEN $TIMER_DEVALUE
		 (SETQ RUNTIME-DEVALUE (f+ RUNTIME-DEVALUE RUNTIME))
		 (SETQ GCTIME-DEVALUE (f+ GCTIME-DEVALUE GCTIME)))
	   ($PUT FUN (f+ ($GET FUN '$RUNTIME) RUNTIME) '$RUNTIME)
	   ($PUT FUN (f+ ($GET FUN '$GCTIME) GCTIME) '$GCTIME)
	   ($PUT FUN (f1+ ($GET FUN '$CALLS)) '$CALLS))))