Merge branch 'master' into gcl_cleanup
[maxima/cygwin.git] / src / mtrace.lisp
blobbfb1ca1542c93ec5dbfa4ae8a533dd7403e5d927
1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancements. ;;;;;
4 ;;; ;;;;;
5 ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
6 ;;; All rights reserved ;;;;;
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package :maxima)
13 (macsyma-module mtrace)
15 (declare-top (special trace-allp))
17 ;;; a reasonable trace capability for macsyma users.
18 ;;; 8:10pm Saturday, 10 January 1981 -GJC.
20 ;; TRACE(F1,F2,...) /* traces the functions */
21 ;; TRACE() /* returns a list of functions under trace */
22 ;; UNTRACE(F1,F2,...) /* untraces the functions */
23 ;; UNTRACE() /* untraces all functions. */
24 ;; TRACE_MAX_INDENT /* The maximum indentation of trace printing. */
26 ;; TRACE_OPTIONS(F,option1,option2,...) /* gives F options */
28 ;; TRACE_BREAK_ARG /* Bound to list of argument during BREAK ENTER,
29 ;; and the return value during BREAK EXIT.
30 ;; This lets you change the arguments to a function,
31 ;; or make a function return a different value,
32 ;; which are both useful debugging hacks.
34 ;; You probably want to give this a short alias
35 ;; for typing convenience.
36 ;; */
38 ;; An option is either a keyword, FOO.
39 ;; or an expression FOO(PREDICATE_FUNCTION);
41 ;; A keyword means that the option is in effect, an keyword
42 ;; expression means to apply the predicate function to some arguments
43 ;; to determine if the option is in effect. The argument list is always
44 ;; [LEVEL,DIRECTION, FUNCTION, ITEM] where
45 ;; LEVEL is the recursion level for the function.
46 ;; DIRECTION is either ENTER or EXIT.
47 ;; FUNCTION is the name of the function.
48 ;; ITEM is either the argument list or the return value.
50 ;; ----------------------------------------------
51 ;; | Keyword | Meaning of return value |
52 ;; ----------------------------------------------
53 ;; | NOPRINT | If TRUE do no printing. |
54 ;; | BREAK | If TRUE give a breakpoint. |
55 ;; | LISP_PRINT | If TRUE use lisp printing. |
56 ;; | INFO | Extra info to print |
57 ;; | ERRORCATCH | If TRUE errors are caught. |
58 ;; ----------------------------------------------
60 ;; General interface functions. These would be called by user debugging utilities.
62 ;; TRACE_IT('F) /* Trace the function named F */
63 ;; TRACE /* list of functions presently traced. */
64 ;; UNTRACE_IT('F) /* Untrace the function named F */
65 ;; GET('F,'TRACE_OPTIONS) /* Access the trace options of F */
67 ;; Sophisticated feature:
68 ;; TRACE_SAFETY a variable with default value TRUE.
69 ;; Example: F(X):=X; BREAKP([L]):=(PRINT("Hi!",L),FALSE),
70 ;; TRACE(F,BREAKP); TRACE_OPTIONS(F,BREAK(BREAKP));
71 ;; F(X); Note that even though BREAKP is traced, and it is called,
72 ;; it does not print out as if it were traced. If you set
73 ;; TRACE_SAFETY:FALSE; then F(X); will cause a normal trace-printing
74 ;; for BREAKP. However, then consider TRACE_OPTIONS(BREAKP,BREAK(BREAKP));
75 ;; When TRACE_SAFETY:FALSE; F(X); will give an infinite recursion,
76 ;; which it would not if safety were turned on.
77 ;; [Just thinking about this gives me a headache.]
79 ;; Internal notes on this package: -jkf
80 ;; Trace works by storing away the real definition of a function and
81 ;; replacing it by a 'shadow' function. The shadow function prints a
82 ;; message, calls the real function, and then prints a message as it
83 ;; leaves. The type of the shadow function may differ from the
84 ;; function being shadowed. The chart below shows what type of shadow
85 ;; function is needed for each type of Macsyma function.
87 ;; Macsyma function shadow type hook type mget
88 ;; ____________________________________________________________
89 ;; subr expr expr
90 ;; expr expr expr
91 ;; lsubr expr expr
92 ;; fsubr fexpr fexpr
93 ;; fexpr fexpr fexpr
94 ;; mexpr expr expr t
95 ;; mfexpr* mfexpr* macro
96 ;; mfexpr*s mfexpr* macro
98 ;; The 'hook type' refers to the form of the shadow function. 'expr' types
99 ;; are really lexprs, they expect any number of evaluated arguments.
100 ;; 'fexpr' types expect one unevaluated argument which is the list of
101 ;; arguments. 'macro' types expect one argument, the caar of which is the
102 ;; name of the function, and the cdr of which is a list of arguments.
104 ;; For systems which store all function properties on the property list,
105 ;; it is easy to shadow a function. For systems with function cells,
106 ;; the situation is a bit more difficult since the standard types of
107 ;; functions are stored in the function cell (expr,fexpr,lexpr), whereas
108 ;; the macsyma functions (mfexpr*,...) are stored on the property list.
111 ;; 1) The variety of maxima functions is much more restricted than
112 ;; what the table above shows. I think the following table gives
113 ;; the correct picture (like its counterpart, it ignores maxima
114 ;; macros or functional arrays).
117 ;; Maxima function shadow type hook type mget
118 ;; ____________________________________________________________
119 ;; expr expr expr
120 ;; mexpr expr expr t
121 ;; mfexpr* mfexpr* expr
123 ;; These types have the following meaning: Suppose MFUN evaluates to some
124 ;; symbol in the MAXIMA package. That this symbol is of type
126 ;; - EXPR (or SUBR) implies that it has a lisp function definition
127 ;; (SYMBOL-FUNCTION MFUN).
129 ;; - MEXPR implies that it has a (parsed) maxima language definition
130 ;; (MGET MFUN 'MEXPR) and all arguments are evaluated by MEVAL.
132 ;; - MFEXPR* implies that it has a lisp function definition
133 ;; (GET MFUN 'MFEXPR*) and its arguments are not automatically
134 ;; evaluated by MEVAL.
136 ;; Note that the shadow type has to agree with the original function's
137 ;; type in the way arguments are evaluated. On the other hand, I think
138 ;; we are left with EXPR as the only hook type; as a matter of fact, this
139 ;; is equivalent to the next point:
141 ;; 2) There is no need for MAKE-TRACE-HOOK to dispatch with respect to
142 ;; HOOK-TYPE since, roughly speaking, proper handling of the traced
143 ;; function's arguments is done by the trace handler in concert with
144 ;; MEVAL*.
146 ;; Note that I also removed the COPY-LIST used to pass the traced
147 ;; function's argument list to the trace handler.
149 ;; There remains an annoying problem with translated functions: tracing
150 ;; some function of type MEXPR and then loading its translated version
151 ;; (which is of type EXPR) will not cleanly untrace it (i.e., it is
152 ;; effectively no longer traced but it remains on the list of traced
153 ;; functions). I think that this has to be fixed somewhere in the
154 ;; translation package. -wj
156 ;; Maxima offers no user-level mechanism for manipulating multiple
157 ;; return values; however, multiple (lisp) return values need to be
158 ;; handled and returned correctly in traced or timed functions.
159 ;; For example, if a user traces or times a rule created by defrule
160 ;; then the second return value must be propagated so apply1 and
161 ;; friends know when the rule hits (the documentation states that
162 ;; these rules can be treated as functions, so it seems reasonable
163 ;; to want to trace or time them).
165 ;; We still pretend like there is only one return value when we
166 ;; print the trace, pass the value to a trace option predicate or
167 ;; allow the user to set a new return value at a breakpoint. This
168 ;; is both for backward-compatibility (particularly in predicates)
169 ;; and because Maxima doesn't actually support multiple values anyway.
171 ;;; Structures.
173 (eval-when
174 (:compile-toplevel :load-toplevel :execute)
175 (defmacro trace-p (x)
176 `(mget ,x 'trace))
177 (defmacro trace-type (x)
178 `(mget ,x 'trace-type))
179 (defmacro trace-level (x)
180 `(mget ,x 'trace-level))
181 (defmacro trace-options (x)
182 `($get ,x '$trace_options))
183 (defmacro trace-oldfun (x)
184 `(mget ,x 'trace-oldfun)))
186 ;;; User interface functions.
188 (defmvar $trace (list '(mlist))
189 "List of functions actively traced"
190 :properties ((assign 'neverset)))
192 (defun mlistcan-$all (fun llist default)
193 "totally random utility function"
194 (let (trace-allp)
195 (if (null llist)
196 default
197 `((mlist) ,@(mapcan fun
198 (if (member (car llist) '($all $functions) :test #'eq)
199 (prog2
200 (setq trace-allp t)
201 (mapcar #'caar (cdr $functions)))
202 llist))))))
204 (defmspec $trace (form)
205 (mlistcan-$all #'macsyma-trace (cdr form) $trace))
207 (defmfun $trace_it (function)
208 `((mlist) ,@(macsyma-trace function)))
210 (defmspec $untrace (form)
211 `((mlist) ,@(mapcan #'macsyma-untrace (or (cdr form) (cdr $trace)))))
213 (defmfun $untrace_it (function)
214 `((mlist) ,@(macsyma-untrace function)))
216 (defmspec $trace_options (form)
217 (setf (trace-options (cadr form))
218 `((mlist) ,@(cddr form))))
220 ;;; System interface functions.
222 (defvar hard-to-trace '(trace-handler listify args trace-apply *apply mapply))
224 ;; A list of functions called by the TRACE-HANDLEr at times when
225 ;; it cannot possibly shield itself from a continuation which would
226 ;; cause infinite recursion. We are assuming the best-case of
227 ;; compile code.
229 (defun macsyma-trace (fun)
230 (macsyma-trace-sub fun 'trace-handler $trace))
232 (defun macsyma-trace-sub (fun handler ilist &aux temp)
233 (cond ((not (symbolp (setq fun (getopr fun))))
234 (mtell (intl:gettext "trace: argument is apparently not a function or operator: ~M~%") fun)
235 nil)
236 ((trace-p fun)
237 ;; Things which redefine should be expected to reset this
238 ;; to NIL.
239 (if (not trace-allp) (mtell (intl:gettext "trace: function ~@:M is already traced.~%") fun))
240 nil)
241 ((member fun hard-to-trace :test #'eq)
242 (mtell (intl:gettext "trace: ~@:M cannot be traced.~%") fun)
243 nil)
244 ((not (setq temp (car (macsyma-fsymeval fun))))
245 (mtell (intl:gettext "trace: ~@:M has no functional properties.~%") fun)
246 nil)
247 ((member temp '(mmacro translated-mmacro) :test #'eq)
248 (mtell (intl:gettext "trace: ~@:M is a macro, so it won't trace well; try 'macroexpand' to debug it.~%") fun)
249 nil)
250 ((get temp 'shadow)
251 (put-trace-info fun temp ilist)
252 (trace-fshadow fun temp (make-trace-hook fun temp handler))
253 (list fun))
255 (mtell (intl:gettext "trace: ~@:M is an unknown type of function.~%") fun)
256 nil)))
258 (defvar trace-handling-stack ())
260 (defun macsyma-untrace (fun)
261 (macsyma-untrace-sub fun 'trace-handler $trace))
263 (defun macsyma-untrace-sub (fun handler ilist)
264 (prog1
265 (cond ((not (symbolp (setq fun (getopr fun))))
266 (mtell (intl:gettext "untrace: argument is apparently not a function or operator: ~M~%") fun)
267 nil)
268 ((not (trace-p fun))
269 (mtell (intl:gettext "untrace: ~@:M is not traced.~%") fun)
270 nil)
272 (trace-unfshadow fun (trace-type fun))
273 (rem-trace-info fun ilist)
274 (list fun)))
275 (if (member fun trace-handling-stack :test #'eq)
276 ;; yes, he has re-defined or untraced the function
277 ;; during the trace-handling application.
278 ;; This is not strange, in fact it happens all the
279 ;; time when the user is using the $ERRORCATCH option!
280 (macsyma-trace-sub fun handler ilist))))
282 (defun put-trace-info (fun type ilist)
283 (setf (trace-p fun) fun) ; needed for MEVAL at this time also.
284 (setf (trace-type fun) type)
285 ;; Pretty sure this next property assignment is clobbered by TRACE-FSHADOW,
286 ;; however, the assignment is conditional there, so I don't know 100%.
287 (setf (trace-oldfun fun) (and (fboundp fun) (symbol-function (or (get fun 'impl-name) fun))))
288 (let ((sym (gensym)))
289 (setf (symbol-value sym) 0)
290 (setf (trace-level fun) sym))
291 (push fun (cdr ilist))
292 (list fun))
294 (defun rem-trace-info (fun ilist)
295 (setf (trace-p fun) nil)
296 (or (member fun trace-handling-stack :test #'eq)
297 (setf (trace-level fun) nil))
298 (setf (trace-type fun) nil)
299 (setq ilist (delete fun ilist :test #'eq))
300 (list fun))
302 ;; Placing the TRACE functional hook.
303 ;; Because the function properties in macsyma are used by the EDITOR, SAVE,
304 ;; and GRIND commands it is not possible to simply replace the function
305 ;; being traced with a hook and to store the old definition someplace.
306 ;; [We do know how to cons up machine-code hooks on the fly, so that
307 ;; is not stopping us].
310 ;; This data should be formalized somehow at the time of
311 ;; definition of the DEFining form.
313 (defprop subr expr shadow)
314 (defprop lsubr expr shadow)
315 (defprop expr expr shadow)
316 (defprop mfexpr*s mfexpr* shadow)
317 (defprop mfexpr* mfexpr* shadow)
319 (defprop mexpr t mget)
320 (defprop mexpr expr shadow)
322 (defun get! (x y)
323 (or (get x y)
324 (maxima-error (intl:gettext "GET!: property ~a of symbol ~a undefined.") y x)))
326 (defun trace-fshadow (fun type value)
327 (let ((shadow (get! type 'shadow)))
328 (cond ((and (eq type 'mexpr)
329 (mget fun 'mfexprp))
330 ; We're tracing an mexpr with special evaluation rules (mfexpr).
331 ; Let's put a Maxima lambda expression on the plist that calls
332 ; the trace hook. Then in the evaluator we can just have mlambda
333 ; do the work for us.
335 ; If there is not a rest argument in the mexpr's lambda list
336 ; then this newly-constructed lambda expression just does a
337 ; funcall. If there is a rest argument then it requires a
338 ; little more work.
339 (putprop fun
340 (let* ((lambda-list (cadr (mget fun 'mexpr)))
341 (params (mparams lambda-list)))
342 `((lambda) ,lambda-list
343 ,(if (mget fun 'mlexprp)
344 (flet ((call-hook (restarg &rest nonrestargs)
345 (apply value (append nonrestargs
346 (cdr restarg)))))
347 ; This is the mfexpr+mlexpr case (we have at
348 ; least one quoted arg and a rest arg).
350 ; The use of call-hook here is basically like
352 ; `(($apply) ,value
353 ; (($append)
354 ; ((mlist) ,@(butlast params))
355 ; ,(car (last params))))
357 ; but faster. We just have to construct
358 ; things so simplifya doesn't barf on any
359 ; intermediate expressions.
360 `((funcall) ,#'call-hook
361 ,(car (last params))
362 ,@(butlast params)))
363 `((funcall) ,value ,@params))))
364 'mfexpr))
365 ((member shadow '(expr subr) :test #'eq)
366 (setf (trace-oldfun fun) (and (fboundp fun) (symbol-function (or (get fun 'impl-name) fun))))
367 (setf (symbol-function (or (get fun 'impl-name) fun)) value))
369 (setf (symbol-plist fun) `(,shadow ,value ,@(symbol-plist fun)))))))
371 (defun trace-unfshadow (fun type)
372 ;; At this point, we know that FUN is traced.
373 (cond ((and (eq type 'mexpr)
374 (safe-get fun 'mfexpr))
375 (remprop fun 'mfexpr))
376 ((member type '(expr subr) :test #'eq)
377 (let ((oldf (trace-oldfun fun)))
378 (if (not (null oldf))
379 (setf (symbol-function (or (get fun 'impl-name) fun)) oldf)
380 (fmakunbound fun))))
381 (t (remprop fun (get! type 'shadow))
382 (fmakunbound fun))))
384 ;;--- trace-fsymeval :: find original function
385 ;; fun : a function which is being traced. The original definition may
386 ;; be hidden on the property list behind the shadow function.
388 (defun trace-fsymeval (fun)
390 (let ((type-of (trace-type fun)))
391 (cond ((get type-of 'mget)
392 (if (eq (get! type-of 'shadow) type-of)
393 (mget (cdr (mgetl fun (list type-of))) type-of)
394 (mget fun type-of)))
395 ((eq (get! type-of 'shadow) 'expr)
396 (trace-oldfun fun))
397 (t (if (eq (get! type-of 'shadow) type-of)
398 (cadr (getl (cdr (getl fun `(,type-of))) `(,type-of)))
399 (get fun type-of)))))
400 (trace-fsymeval
401 (merror "internal error: trace property for ~:@M went away without hook." fun))))
403 ;;; The handling of a traced call.
405 (defvar trace-indent-level -1)
407 (defmacro bind-sym (symbol value . body)
408 ;; is by far the best dynamic binding generally available.
409 `(progv (list ,symbol)
410 (list ,value)
411 ,@body))
413 ;; We really want to (BINDF (TRACE-LEVEL FUN) (1+ (TRACE-LEVEL FUN)) ...)
414 ;; (Think about PROGV and SETF and BINDF. If the trace object where
415 ;; a closure, then we want to fluid bind instance variables.)
417 (defmacro macsyma-errset (form &aux (ret (gensym)))
418 `(let ((errcatch (cons bindlist loclist)) ,ret)
419 (setq ,ret (errset ,form))
420 (or ,ret (errlfun1 errcatch))
421 ,ret))
423 (defvar predicate-arglist nil)
425 (defvar return-to-trace-handle nil)
427 (defun trace-handler (fun largs)
428 (if (or return-to-trace-handle
429 (and (not (atom (car largs)))
430 (not (atom (caar largs)))
431 (eq (caaar largs) '$untrace)
432 (eq (cadar largs) fun)))
433 ;; We were called by the trace-handler or by $untrace and the function
434 ;; fun is to be untraced.
435 (trace-apply fun largs)
436 (let ((trace-indent-level (1+ trace-indent-level))
437 (return-to-trace-handle t)
438 (trace-handling-stack (cons fun trace-handling-stack))
439 (level-sym (trace-level fun))
440 (level))
441 (setq level (1+ (symbol-value level-sym)))
442 (bind-sym level-sym level
443 (do ((ret-vals)
444 (continuation)
445 (predicate-arglist))
446 (nil)
447 (setq predicate-arglist `(,level $enter ,fun ((mlist) ,@largs)))
448 (setq largs (trace-enter-break fun level largs))
449 (trace-enter-print fun level largs)
450 (cond ((trace-option-p fun '$errorcatch)
451 (setq ret-vals (macsyma-errset (trace-apply fun largs)))
452 (cond ((null ret-vals)
453 (setq ret-vals (trace-error-break fun level largs))
454 (setq continuation (car ret-vals)
455 ret-vals (cdr ret-vals)))
457 (setq continuation 'exit))))
459 (setq continuation 'exit
460 ret-vals (multiple-value-list (trace-apply fun largs)))))
461 (case continuation
462 ((exit)
463 (setq predicate-arglist `(,level $exit ,fun ,(car ret-vals)))
464 (setq ret-vals (trace-exit-break fun level ret-vals))
465 (trace-exit-print fun level (car ret-vals))
466 (return (values-list ret-vals)))
467 ((retry)
468 (setq largs ret-vals)
469 (mtell "TRACE-HANDLER: reapplying the function ~:@M~%" fun))
470 ((maxima-error)
471 (merror "~%TRACE-HANDLER: signaling 'maxima-error' for function ~:@M~%" fun))))))))
474 ;; The (Trace-options function) access is not optimized to take place
475 ;; only once per trace-handle call. This is so that the user may change
476 ;; options during his break loops.
477 ;; Question: Should we bind return-to-trace-handle to NIL when we
478 ;; call the user's predicate? He has control over his own lossage.
480 (defmvar $trace_safety t "This is subtle")
482 (defun trace-option-p (function keyword)
483 (do ((options
484 (let ((options (trace-options function)))
485 (cond ((null options) nil)
486 (($listp options) (cdr options))
488 (mtell "TRACE-OPTION-P: trace options for ~:@M not a list, so ignored.~%" function)
489 nil)))
490 (cdr options))
491 (option))
492 ((null options) nil)
493 (setq option (car options))
494 (cond ((atom option)
495 (if (eq option keyword) (return t)))
496 ((eq (caar option) keyword)
497 (let ((return-to-trace-handle $trace_safety))
498 (return (mapply (cadr option) predicate-arglist
499 "A trace option predicate")))))))
502 (defun trace-enter-print (fun lev largs)
503 (let ((args (if (eq (trace-type fun) 'mfexpr*)
504 (margs (car largs))
505 largs)))
506 (if (not (trace-option-p fun '$noprint))
507 (let ((info (trace-option-p fun '$info)))
508 (cond ((trace-option-p fun '$lisp_print)
509 (trace-print `(,lev enter ,fun ,args ,@info)))
511 (trace-mprint lev
512 (intl:gettext " Enter ")
513 (mopstringnam fun)
515 `((mlist) ,@args)
516 (if info " -> " "")
517 (if info info ""))))))))
519 (defun mopstringnam (x)
520 (maknam (mstring (getop x))))
522 (defun trace-exit-print (fun lev ret-val)
523 (if (not (trace-option-p fun '$noprint))
524 (let ((info (trace-option-p fun '$info)))
525 (cond ((trace-option-p fun '$lisp_print)
526 (trace-print `(,lev exit ,fun ,ret-val ,@info)))
528 (trace-mprint lev (intl:gettext " Exit ") (mopstringnam fun) " " ret-val
529 (if info " -> " "")
530 (if info info "")))))))
532 (defmvar $trace_break_arg '$trace_break_arg
533 "During trace Breakpoints bound to the argument list or return value")
535 (defun trace-enter-break (fun lev largs)
536 (if (trace-option-p fun '$break)
537 (do ((return-to-trace-handle nil)
538 ($trace_break_arg `((mlist) ,@largs)))(nil)
539 ($break "Trace entering" fun "level" lev)
540 (cond (($listp $trace_break_arg)
541 (return (cdr $trace_break_arg)))
543 (mtell "TRACE-ENTER-BREAK: 'trace_break_arg' must be a list.~%"))))
544 largs))
546 (defun trace-exit-break (fun lev ret-vals)
547 (if (trace-option-p fun '$break)
548 (let (($trace_break_arg (car ret-vals))
549 (return-to-trace-handle nil))
550 ($break "Trace exiting" fun "level" lev)
551 ; If trace_break_arg is the same (in the sense of eq) now
552 ; as when we started the breakpoint, then return all of the
553 ; original return values from the function. This means if
554 ; the user sets trace_break_arg but its value is eq to its
555 ; original value (which is only the primary return value
556 ; from the original function) then we still return the extra
557 ; values (if there are any). I (kjak) don't think this is
558 ; strictly correct, but we can try to fix it up later if
559 ; anyone ever really cares about this corner case involving
560 ; multiple return values, exit breakpoints and setting
561 ; trace_break_arg to the same value it started with.
562 (if (eq $trace_break_arg (car ret-vals))
563 ret-vals
564 (list $trace_break_arg)))
565 ret-vals))
567 (defun pred-$read (predicate argl bad-message)
568 (do ((ans))(nil)
569 (setq ans (apply #'$read argl))
570 (if (funcall predicate ans) (return ans))
571 (mtell "PRED-$READ: unacceptable input: ~A~%" bad-message)))
573 (defun ask-choicep (llist &rest header-message)
574 (do ((j 0 (1+ j))
575 (dlist nil (list* #\newline `((marrow) ,j ,(car ilist)) dlist))
576 (ilist llist (cdr ilist)))
577 ((null ilist)
578 (setq dlist (nconc header-message (cons #\newline (nreverse dlist))))
579 (let ((upper (1- j)))
580 (pred-$read #'(lambda (val)
581 (and (integerp val)
582 (>= val 0)
583 (<= val upper)))
584 dlist
585 "please reply with an integer from the menue.")))))
587 ;; I GUESS ALL OF THE STRINGS IN THIS FUNCTION NEED TO BE GETTEXT'D TOO
588 ;; JUST CAN'T BRING MYSELF TO DO IT
590 (defun trace-error-break (fun level largs)
591 (case (ask-choicep '("Signal an `maxima-error', i.e. punt?"
592 "Retry with same arguments?"
593 "Retry with new arguments?"
594 "Exit with user supplied value")
595 "Error during application of" (mopstringnam fun)
596 "at level" level
597 #\newline "Do you want to:")
598 ((0)
599 '(maxima-error))
600 ((1)
601 (cons 'retry largs))
602 ((2)
603 (cons 'retry (let (($trace_break_arg `((mlist) ,@largs)))
604 (cdr (pred-$read '$listp
605 (list
606 "Enter new argument list for"
607 (mopstringnam fun))
608 "please enter a list.")))))
610 ((3)
611 (cons 'exit (list ($read "Enter value to return"))))))
613 ;;; application dispatch, and the consing up of the trace hook.
615 (defun macsyma-fsymeval (fun)
616 (let ((try (macsyma-fsymeval-sub fun)))
617 (cond (try try)
618 ((get fun 'autoload)
619 (load-and-tell (get fun 'autoload))
620 (setq try (macsyma-fsymeval-sub fun))
621 (or try
622 (mtell (intl:gettext "trace: ~@:M has no functional properties after autoloading.~%")
623 fun))
624 try)
625 (t try))))
627 (defun macsyma-fsymeval-sub (fun)
628 ;; The semantics of $TRANSRUN are herein taken from DESCRIBE,
629 ;; a careful reading of MEVAL1 reveals, well... I've promised to watch
630 ;; my language in these comments.
632 (let ((mprops (mgetl fun '(mexpr mmacro)))
633 (lprops (getl fun '(translated-mmacro mfexpr* mfexpr*s)))
634 (fcell-props (getl-lm-fcn-prop fun '(subr lsubr expr macro))))
635 (cond ($transrun
636 ;; the default, so its really a waste to have looked for
637 ;; those mprops. Its better to fix the crock than to
638 ;; optimize this though!
639 (or lprops fcell-props mprops))
641 (or mprops lprops fcell-props)))))
643 (defprop expr expr hook-type)
644 (defprop mexpr expr hook-type)
645 (defprop subr expr hook-type)
646 (defprop lsubr expr hook-type)
647 (defprop mfexpr* macro hook-type)
648 (defprop mfexpr*s macro hook-type)
650 (defun make-trace-hook (fun type handler)
651 ;; Argument handling according to FUN's TYPE is already done
652 ;; elsewhere: HANDLER, meval...
653 (declare (ignore type))
654 #'(lambda (&rest trace-args)
655 (funcall handler fun trace-args)))
657 (defun trace-apply (fun largs)
658 (let ((prop (trace-fsymeval fun))
659 (type (trace-type fun))
660 (return-to-trace-handle nil))
661 (case type
662 ((mexpr)
663 (mapply prop largs "A traced function"))
664 ((expr)
665 (apply prop largs))
666 ((subr lsubr)
667 (apply prop largs))
668 ((mfexpr* mfexpr*s)
669 (funcall prop (car largs))))))
671 ;;; I/O cruft
673 (defmvar $trace_max_indent 15.
674 "max number of spaces it will go right"
675 fixnum
676 :properties ((assign 'assign-mode-check)
677 (mode '$fixnum)))
679 (defun-prop (spaceout dimension) (form result)
680 (dimension-string (make-list (cadr form) :initial-element #\space) result))
682 (defun trace-mprint (&rest l)
683 (mtell-open "~M" `((mtext) ((spaceout) ,(min $trace_max_indent trace-indent-level)) ,@l)))
685 (defun trace-print (form)
686 (do ((j (min $trace_max_indent trace-indent-level) (1- j)))
687 ((not (> j 0)))
688 (write-char #\space))
689 (prin1 form)
690 (terpri)
691 (finish-output))
693 ;; 9:02pm Monday, 18 May 1981 -GJC
694 ;; A function benchmark facility using trace utilities.
695 ;; This provides medium accuracy, enough for most user needs.
697 (defmvar $timer '((mlist)) "List of functions under active timetrace")
699 (defmspec $timer (form)
700 (mlistcan-$all #'macsyma-timer (cdr form) $timer))
702 (defmspec $untimer (form)
703 `((mlist) ,@(mapcan #'macsyma-untimer (or (cdr form) (cdr $timer)))))
705 (defun micro-to-sec (runtime)
706 (mul runtime (float (/ internal-time-units-per-second)) '$sec))
708 (defun micro-per-call-to-sec (runtime calls)
709 (div (micro-to-sec runtime)
710 (if (zerop calls) 1 calls)))
712 (defun timer-mlist (function calls runtime gctime)
713 `((mlist simp) ,function
714 ,(micro-per-call-to-sec (+ runtime gctime) calls)
715 ,calls
716 ,(micro-to-sec runtime)
717 ,(micro-to-sec gctime)))
719 (defmspec $timer_info (form)
720 (do ((l (or (cdr form) (cdr $timer))
721 (cdr l))
722 (v nil)
723 (total-runtime 0)
724 (total-gctime 0)
725 (total-calls 0))
726 ((null l)
727 `(($matrix simp)
728 ((mlist simp) $function $time//call $calls $runtime $gctime)
729 ,.(nreverse v)
730 ,(timer-mlist '$total total-calls total-runtime total-gctime)))
731 (let*
732 ((fun-opr (getopr (car l)))
733 (runtime ($get fun-opr '$runtime))
734 (gctime ($get fun-opr '$gctime))
735 (calls ($get fun-opr '$calls)))
736 (when runtime
737 (incf total-calls calls)
738 (incf total-runtime runtime)
739 (incf total-gctime gctime)
740 (push (timer-mlist (car l) calls runtime gctime) v)))))
742 (defun macsyma-timer (fun)
743 (prog1
744 (macsyma-trace-sub fun 'timer-handler $timer)
745 (let ((fun-opr (getopr fun)))
746 ($put fun-opr 0 '$runtime)
747 ($put fun-opr 0 '$gctime)
748 ($put fun-opr 0 '$calls))))
750 (defun macsyma-untimer (fun) (macsyma-untrace-sub fun 'timer-handler $timer))
752 (defvar runtime-devalue 0)
753 (defvar gctime-devalue 0)
755 (defmvar $timer_devalue nil
756 "If true, then time spent inside calls to other timed functions is
757 subtracted from the timing figure for a function.")
759 (defun timer-handler (fun largs)
760 ;; N.B. Doesn't even try to account for use of DYNAMIC CONTROL
761 ;; such as ERRSET ERROR and CATCH and THROW, as these are
762 ;; rare and the overhead for the unwind-protect is high.
763 (let ((runtime (get-internal-run-time))
764 (gctime (status gctime))
765 (old-runtime-devalue runtime-devalue)
766 (old-gctime-devalue gctime-devalue))
767 (multiple-value-prog1 (trace-apply fun largs)
768 (setq old-runtime-devalue (- runtime-devalue old-runtime-devalue))
769 (setq old-gctime-devalue (- gctime-devalue old-gctime-devalue))
770 (setq runtime (- (get-internal-run-time) runtime old-runtime-devalue))
771 (setq gctime (- (status gctime) gctime old-gctime-devalue))
772 (when $timer_devalue
773 (incf runtime-devalue runtime)
774 (incf gctime-devalue gctime))
775 ($put fun (+ ($get fun '$runtime) runtime) '$runtime)
776 ($put fun (+ ($get fun '$gctime) gctime) '$gctime)
777 ($put fun (1+ ($get fun '$calls)) '$calls))))