mirror of
https://github.com/PDP-10/its.git
synced 2026-01-27 04:32:08 +00:00
Update macsyma sources with newer versions of some files.
Resolves #1059.
This commit is contained in:
Eric Swenson
789
src/maxsrc/mtrace.46
Normal file
789
src/maxsrc/mtrace.46
Normal file
@@ -0,0 +1,789 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1981, 1983 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module mtrace)
|
||||
|
||||
(declare (*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.
|
||||
|
||||
(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 LispM)
|
||||
(defmacro trace-oldfun (x) `(mget ,x 'trace-oldfun))
|
||||
|
||||
;;; User interface functions.
|
||||
|
||||
(defmvar $trace (list '(mlist)) "List of functions actively traced")
|
||||
(putprop '$trace #'read-only-assign 'assign)
|
||||
|
||||
(defun mlistcan-$all (fun list default)
|
||||
"totally random utility function"
|
||||
(let (trace-allp)
|
||||
(if (null list) default
|
||||
`((mlist) ,@(mapcan fun
|
||||
(if (memq (car list) '($all $functions))
|
||||
(prog2 (setq trace-allp t)
|
||||
(mapcar #'caar (cdr $functions)))
|
||||
list))))))
|
||||
|
||||
(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))
|
||||
#+LispM(setf (trace-oldfun fun) (and (fboundp fun) (fsymeval 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! (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 (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 ,@(plist fun)))))))
|
||||
|
||||
#+LispM
|
||||
(defun trace-fshadow (fun type value)
|
||||
(let ((shadow (get! type 'shadow)))
|
||||
(cond ((memq shadow '(expr subr))
|
||||
(setf (trace-oldfun fun) (and (fboundp fun) (fsymeval fun)))
|
||||
(fset fun value))
|
||||
((memq shadow '(fexpr fsubr))
|
||||
(setf (trace-oldfun fun) (fsymeval fun))
|
||||
(fset fun (cons 'nlambda (cdr value))))
|
||||
(t (setplist fun
|
||||
`(,shadow ,value ,@(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))))
|
||||
|
||||
#+LispM
|
||||
(defun trace-unfshadow (fun type)
|
||||
(cond ((memq type '(expr subr fexpr fsubr))
|
||||
(let ((oldf (trace-oldfun fun)))
|
||||
(if (not (null oldf))
|
||||
(fset fun oldf)
|
||||
(fmakunbound fun))))
|
||||
(t (remprop fun (get! type 'shadow))
|
||||
(fmakunbound fun))))
|
||||
|
||||
;--- 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 LispM)
|
||||
((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 (symeval the-symbol)))
|
||||
(unwind-protect
|
||||
(progn (set the-symbol the-value)
|
||||
,@body)
|
||||
(set the-symbol old-value)))))
|
||||
|
||||
;; We really want to (BINDF (TRACE-LEVEL FUN) (1+ (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 (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 (1+ trace-indent-level))
|
||||
(return-to-trace-handle t)
|
||||
(trace-handling-stack (cons fun trace-handling-stack))
|
||||
(LEVEL-SYM (TRACE-LEVEL fun))(LEVEL))
|
||||
(SETQ LEVEL (1+ (SYMEVAL 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))))
|
||||
(caseq 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))
|
||||
((error)
|
||||
(MERROR "~%Signaling 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 (special upper))
|
||||
|
||||
(defun ask-choicep (list &rest header-message)
|
||||
(do ((j 0 (1+ j))
|
||||
(dlist nil
|
||||
(list* "M" `((marrow) ,j ,(car ilist)) dlist))
|
||||
(ilist list (cdr ilist)))
|
||||
((null ilist)
|
||||
(setq dlist (nconc header-message (cons "M" (nreverse dlist))))
|
||||
(let ((upper (1- j)))
|
||||
(pred-$read #'(lambda (val)
|
||||
(and (fixp val)
|
||||
(>= val 0)
|
||||
(<= val upper)))
|
||||
dlist
|
||||
"please reply with an integer from the menue.")))))
|
||||
|
||||
(declare (unspecial upper))
|
||||
|
||||
(defun trace-error-break (fun level largs)
|
||||
(caseq (ask-choicep '("Signal an 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)
|
||||
'(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)
|
||||
(CASEQ (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)
|
||||
(CASEQ (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))))))
|
||||
|
||||
#+LispM
|
||||
(defun make-trace-hook (fun type handler)
|
||||
(CASEQ (GET! TYPE 'HOOK-TYPE)
|
||||
((EXPR)
|
||||
`(lambda (&rest trace-args)
|
||||
(,handler ',fun (copylist trace-args))))
|
||||
((FEXPR)
|
||||
`(LAMBDA ("e &rest TRACE-ARGL)
|
||||
(,HANDLER ',FUN (copylist TRACE-ARGL))))
|
||||
;;;???
|
||||
((MACRO)
|
||||
`(lambda ("e &rest TRACE-FORM)
|
||||
(,HANDLER (CAAR TRACE-FORM) (copyLIST 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))
|
||||
|
||||
#+Lispm
|
||||
(defmacro trace-setup-call (prop fun type)
|
||||
`(fset 'the-trace-apply-hack ,prop))
|
||||
|
||||
(defun trace-apply (fun largs)
|
||||
(let ((prop (trace-fsymeval fun))
|
||||
(type (trace-type fun))
|
||||
(return-to-trace-handle nil))
|
||||
(caseq type
|
||||
((mexpr)
|
||||
(mapply prop largs "&A traced function"))
|
||||
((expr)
|
||||
(apply prop largs))
|
||||
((subr lsubr)
|
||||
;; no need to be fast here.
|
||||
(trace-setup-call prop fun type)
|
||||
(apply 'the-trace-apply-hack 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 (spaceout dimension) (form result)
|
||||
(dimension-string (*make-list (cadr form) #\sp) result))
|
||||
|
||||
(defun trace-mprint (&rest l)
|
||||
(mtell-open "~M"
|
||||
`((mtext)
|
||||
((spaceout) ,(min $trace_max_indent trace-indent-level))
|
||||
,@l)))
|
||||
|
||||
(defun trace-print (form)
|
||||
(terpri)
|
||||
(do ((j (min $trace_max_indent trace-indent-level)
|
||||
(1- j)))
|
||||
((not (> j 0)))
|
||||
(tyo #\sp))
|
||||
(if prin1 (funcall prin1 form)
|
||||
(prin1 form))
|
||||
(tyo #\sp))
|
||||
|
||||
|
||||
;; 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")
|
||||
(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 TIME-TO-SEC (RUNTIME)
|
||||
(MUL RUNTIME #+Maclisp 1.0E-6 #+Franz 0.01666666666666667 #+LispM .01 '$SEC))
|
||||
|
||||
(DEFUN TIME-PER-CALL-TO-SEC (RUNTIME CALLS)
|
||||
(DIV (TIME-TO-SEC RUNTIME)
|
||||
(IF (ZEROP CALLS) 1 CALLS)))
|
||||
|
||||
(DEFUN TIMER-MLIST (FUNCTION CALLS RUNTIME GCTIME)
|
||||
`((MLIST SIMP) ,FUNCTION
|
||||
,(TIME-PER-CALL-TO-SEC (PLUS RUNTIME GCTIME) CALLS)
|
||||
,CALLS
|
||||
,(TIME-TO-SEC RUNTIME)
|
||||
,(TIME-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 (SYS-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 (- (SYS-GCTIME) GCTIME OLD-GCTIME-DEVALUE))
|
||||
(WHEN $TIMER_DEVALUE
|
||||
(SETQ RUNTIME-DEVALUE (+ RUNTIME-DEVALUE RUNTIME))
|
||||
(SETQ GCTIME-DEVALUE (+ GCTIME-DEVALUE GCTIME)))
|
||||
($PUT FUN (+ ($GET FUN '$RUNTIME) RUNTIME) '$RUNTIME)
|
||||
($PUT FUN (+ ($GET FUN '$GCTIME) GCTIME) '$GCTIME)
|
||||
($PUT FUN (1+ ($GET FUN '$CALLS)) '$CALLS))))
|
||||
|
||||
Reference in New Issue
Block a user