Remove some code duplication in TRANSLATE-PREDICATE
[maxima.git] / src / mtrace.lisp
blob16eac505467a64b49de905cbed42e27667b5c34c
1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancments. ;;;;;
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 $functions $transrun 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 #+gcl (compile load eval)
175 #-gcl (:compile-toplevel :load-toplevel :execute)
176 (defmacro trace-p (x)
177 `(mget ,x 'trace))
178 (defmacro trace-type (x)
179 `(mget ,x 'trace-type))
180 (defmacro trace-level (x)
181 `(mget ,x 'trace-level))
182 (defmacro trace-options (x)
183 `($get ,x '$trace_options))
184 (defmacro trace-oldfun (x)
185 `(mget ,x 'trace-oldfun)))
187 ;;; User interface functions.
189 (defmvar $trace (list '(mlist)) "List of functions actively traced")
191 (defun mlistcan-$all (fun llist default)
192 "totally random utility function"
193 (let (trace-allp)
194 (if (null llist)
195 default
196 `((mlist) ,@(mapcan fun
197 (if (member (car llist) '($all $functions) :test #'eq)
198 (prog2
199 (setq trace-allp t)
200 (mapcar #'caar (cdr $functions)))
201 llist))))))
203 (defmspec $trace (form)
204 (mlistcan-$all #'macsyma-trace (cdr form) $trace))
206 (defmfun $trace_it (function)
207 `((mlist) ,@(macsyma-trace function)))
209 (defmspec $untrace (form)
210 `((mlist) ,@(mapcan #'macsyma-untrace (or (cdr form) (cdr $trace)))))
212 (defmfun $untrace_it (function)
213 `((mlist) ,@(macsyma-untrace function)))
215 (defmspec $trace_options (form)
216 (setf (trace-options (cadr form))
217 `((mlist) ,@(cddr form))))
219 ;;; System interface functions.
221 (defvar hard-to-trace '(trace-handler listify args trace-apply *apply mapply))
223 ;; A list of functions called by the TRACE-HANDLEr at times when
224 ;; it cannot possibly shield itself from a continuation which would
225 ;; cause infinite recursion. We are assuming the best-case of
226 ;; compile code.
228 (defun macsyma-trace (fun)
229 (macsyma-trace-sub fun 'trace-handler $trace))
231 (defun macsyma-trace-sub (fun handler ilist &aux temp)
232 (cond ((not (symbolp (setq fun (getopr fun))))
233 (mtell (intl:gettext "trace: argument is apparently not a function or operator: ~M~%") fun)
234 nil)
235 ((trace-p fun)
236 ;; Things which redefine should be expected to reset this
237 ;; to NIL.
238 (if (not trace-allp) (mtell (intl:gettext "trace: function ~@:M is already traced.~%") fun))
239 nil)
240 ((member fun hard-to-trace :test #'eq)
241 (mtell (intl:gettext "trace: ~@:M cannot be traced.~%") fun)
242 nil)
243 ((not (setq temp (car (macsyma-fsymeval fun))))
244 (mtell (intl:gettext "trace: ~@:M has no functional properties.~%") fun)
245 nil)
246 ((member temp '(mmacro translated-mmacro) :test #'eq)
247 (mtell (intl:gettext "trace: ~@:M is a macro, so it won't trace well; try 'macroexpand' to debug it.~%") fun)
248 nil)
249 ((get temp 'shadow)
250 (put-trace-info fun temp ilist)
251 (trace-fshadow fun temp (make-trace-hook fun temp handler))
252 (list fun))
254 (mtell (intl:gettext "trace: ~@:M is an unknown type of function.~%") fun)
255 nil)))
257 (defvar trace-handling-stack ())
259 (defun macsyma-untrace (fun)
260 (macsyma-untrace-sub fun 'trace-handler $trace))
262 (defun macsyma-untrace-sub (fun handler ilist)
263 (prog1
264 (cond ((not (symbolp (setq fun (getopr fun))))
265 (mtell (intl:gettext "untrace: argument is apparently not a function or operator: ~M~%") fun)
266 nil)
267 ((not (trace-p fun))
268 (mtell (intl:gettext "untrace: ~@:M is not traced.~%") fun)
269 nil)
271 (trace-unfshadow fun (trace-type fun))
272 (rem-trace-info fun ilist)
273 (list fun)))
274 (if (member fun trace-handling-stack :test #'eq)
275 ;; yes, he has re-defined or untraced the function
276 ;; during the trace-handling application.
277 ;; This is not strange, in fact it happens all the
278 ;; time when the user is using the $ERRORCATCH option!
279 (macsyma-trace-sub fun handler ilist))))
281 (defun put-trace-info (fun type ilist)
282 (setf (trace-p fun) fun) ; needed for MEVAL at this time also.
283 (setf (trace-type fun) type)
284 (setf (trace-oldfun fun) (and (fboundp fun) (symbol-function fun)))
285 (let ((sym (gensym)))
286 (setf (symbol-value sym) 0)
287 (setf (trace-level fun) sym))
288 (push fun (cdr ilist))
289 (list fun))
291 (defun rem-trace-info (fun ilist)
292 (setf (trace-p fun) nil)
293 (or (member fun trace-handling-stack :test #'eq)
294 (setf (trace-level fun) nil))
295 (setf (trace-type fun) nil)
296 (setq ilist (delete fun ilist :test #'eq))
297 (list fun))
299 ;; Placing the TRACE functional hook.
300 ;; Because the function properties in macsyma are used by the EDITOR, SAVE,
301 ;; and GRIND commands it is not possible to simply replace the function
302 ;; being traced with a hook and to store the old definition someplace.
303 ;; [We do know how to cons up machine-code hooks on the fly, so that
304 ;; is not stopping us].
307 ;; This data should be formalized somehow at the time of
308 ;; definition of the DEFining form.
310 (defprop subr expr shadow)
311 (defprop lsubr expr shadow)
312 (defprop expr expr shadow)
313 (defprop mfexpr*s mfexpr* shadow)
314 (defprop mfexpr* mfexpr* shadow)
316 (defprop mexpr t mget)
317 (defprop mexpr expr shadow)
319 (defun get! (x y)
320 (or (get x y)
321 (maxima-error (intl:gettext "GET!: property ~a of symbol ~a undefined.") y x)))
323 (defun trace-fshadow (fun type value)
324 (let ((shadow (get! type 'shadow)))
325 (cond ((and (eq type 'mexpr)
326 (mget fun 'mfexprp))
327 ; We're tracing an mexpr with special evaluation rules (mfexpr).
328 ; Let's put a Maxima lambda expression on the plist that calls
329 ; the trace hook. Then in the evaluator we can just have mlambda
330 ; do the work for us.
332 ; If there is not a rest argument in the mexpr's lambda list
333 ; then this newly-constructed lambda expression just does a
334 ; funcall. If there is a rest argument then it requires a
335 ; little more work.
336 (putprop fun
337 (let* ((lambda-list (cadr (mget fun 'mexpr)))
338 (params (mparams lambda-list)))
339 `((lambda) ,lambda-list
340 ,(if (mget fun 'mlexprp)
341 (flet ((call-hook (restarg &rest nonrestargs)
342 (apply value (append nonrestargs
343 (cdr restarg)))))
344 ; This is the mfexpr+mlexpr case (we have at
345 ; least one quoted arg and a rest arg).
347 ; The use of call-hook here is basically like
349 ; `(($apply) ,value
350 ; (($append)
351 ; ((mlist) ,@(butlast params))
352 ; ,(car (last params))))
354 ; but faster. We just have to construct
355 ; things so simplifya doesn't barf on any
356 ; intermediate expressions.
357 `((funcall) ,#'call-hook
358 ,(car (last params))
359 ,@(butlast params)))
360 `((funcall) ,value ,@params))))
361 'mfexpr))
362 ((member shadow '(expr subr) :test #'eq)
363 (setf (trace-oldfun fun) (and (fboundp fun) (symbol-function fun)))
364 (setf (symbol-function fun) value))
366 (setf (symbol-plist fun) `(,shadow ,value ,@(symbol-plist fun)))))))
368 (defun trace-unfshadow (fun type)
369 ;; At this point, we know that FUN is traced.
370 (cond ((and (eq type 'mexpr)
371 (safe-get fun 'mfexpr))
372 (remprop fun 'mfexpr))
373 ((member type '(expr subr) :test #'eq)
374 (let ((oldf (trace-oldfun fun)))
375 (if (not (null oldf))
376 (setf (symbol-function fun) oldf)
377 (fmakunbound fun))))
378 (t (remprop fun (get! type 'shadow))
379 (fmakunbound fun))))
381 ;;--- trace-fsymeval :: find original function
382 ;; fun : a function which is being traced. The original definition may
383 ;; be hidden on the property list behind the shadow function.
385 (defun trace-fsymeval (fun)
387 (let ((type-of (trace-type fun)))
388 (cond ((get type-of 'mget)
389 (if (eq (get! type-of 'shadow) type-of)
390 (mget (cdr (mgetl fun (list type-of))) type-of)
391 (mget fun type-of)))
392 ((eq (get! type-of 'shadow) 'expr)
393 (trace-oldfun fun))
394 (t (if (eq (get! type-of 'shadow) type-of)
395 (cadr (getl (cdr (getl fun `(,type-of))) `(,type-of)))
396 (get fun type-of)))))
397 (trace-fsymeval
398 (merror "internal error: trace property for ~:@M went away without hook." fun))))
400 ;;; The handling of a traced call.
402 (defvar trace-indent-level -1)
404 (defmacro bind-sym (symbol value . body)
405 ;; is by far the best dynamic binding generally available.
406 `(progv (list ,symbol)
407 (list ,value)
408 ,@body))
410 ;; We really want to (BINDF (TRACE-LEVEL FUN) (1+ (TRACE-LEVEL FUN)) ...)
411 ;; (Think about PROGV and SETF and BINDF. If the trace object where
412 ;; a closure, then we want to fluid bind instance variables.)
414 (declare-top (special errcatch bindlist loclist))
416 (defmacro macsyma-errset (form &aux (ret (gensym)))
417 `(let ((errcatch (cons bindlist loclist)) ,ret)
418 (setq ,ret (errset ,form))
419 (or ,ret (errlfun1 errcatch))
420 ,ret))
422 (defvar predicate-arglist nil)
424 (defvar return-to-trace-handle nil)
426 (defun trace-handler (fun largs)
427 (if (or return-to-trace-handle
428 (and (not (atom (car largs)))
429 (not (atom (caar largs)))
430 (eq (caaar largs) '$untrace)
431 (eq (cadar largs) fun)))
432 ;; We were called by the trace-handler or by $untrace and the function
433 ;; fun is to be untraced.
434 (trace-apply fun largs)
435 (let ((trace-indent-level (1+ trace-indent-level))
436 (return-to-trace-handle t)
437 (trace-handling-stack (cons fun trace-handling-stack))
438 (level-sym (trace-level fun))
439 (level))
440 (setq level (1+ (symbol-value level-sym)))
441 (bind-sym level-sym level
442 (do ((ret-vals)
443 (continuation)
444 (predicate-arglist))
445 (nil)
446 (setq predicate-arglist `(,level $enter ,fun ((mlist) ,@largs)))
447 (setq largs (trace-enter-break fun level largs))
448 (trace-enter-print fun level largs)
449 (cond ((trace-option-p fun '$errorcatch)
450 (setq ret-vals (macsyma-errset (trace-apply fun largs)))
451 (cond ((null ret-vals)
452 (setq ret-vals (trace-error-break fun level largs))
453 (setq continuation (car ret-vals)
454 ret-vals (cdr ret-vals)))
456 (setq continuation 'exit))))
458 (setq continuation 'exit
459 ret-vals (multiple-value-list (trace-apply fun largs)))))
460 (case continuation
461 ((exit)
462 (setq predicate-arglist `(,level $exit ,fun ,(car ret-vals)))
463 (setq ret-vals (trace-exit-break fun level ret-vals))
464 (trace-exit-print fun level (car ret-vals))
465 (return (values-list ret-vals)))
466 ((retry)
467 (setq largs ret-vals)
468 (mtell "TRACE-HANDLER: reapplying the function ~:@M~%" fun))
469 ((maxima-error)
470 (merror "~%TRACE-HANDLER: signaling 'maxima-error' for function ~:@M~%" fun))))))))
473 ;; The (Trace-options function) access is not optimized to take place
474 ;; only once per trace-handle call. This is so that the user may change
475 ;; options during his break loops.
476 ;; Question: Should we bind return-to-trace-handle to NIL when we
477 ;; call the user's predicate? He has control over his own lossage.
479 (defmvar $trace_safety t "This is subtle")
481 (defun trace-option-p (function keyword)
482 (do ((options
483 (let ((options (trace-options function)))
484 (cond ((null options) nil)
485 (($listp options) (cdr options))
487 (mtell "TRACE-OPTION-P: trace options for ~:@M not a list, so ignored.~%" function)
488 nil)))
489 (cdr options))
490 (option))
491 ((null options) nil)
492 (setq option (car options))
493 (cond ((atom option)
494 (if (eq option keyword) (return t)))
495 ((eq (caar option) keyword)
496 (let ((return-to-trace-handle $trace_safety))
497 (return (mapply (cadr option) predicate-arglist
498 "A trace option predicate")))))))
501 (defun trace-enter-print (fun lev largs)
502 (let ((args (if (eq (trace-type fun) 'mfexpr*)
503 (margs (car largs))
504 largs)))
505 (if (not (trace-option-p fun '$noprint))
506 (let ((info (trace-option-p fun '$info)))
507 (cond ((trace-option-p fun '$lisp_print)
508 (trace-print `(,lev enter ,fun ,args ,@info)))
510 (trace-mprint lev
511 (intl:gettext " Enter ")
512 (mopstringnam fun)
514 `((mlist) ,@args)
515 (if info " -> " "")
516 (if info info ""))))))))
518 (defun mopstringnam (x)
519 (maknam (mstring (getop x))))
521 (defun trace-exit-print (fun lev ret-val)
522 (if (not (trace-option-p fun '$noprint))
523 (let ((info (trace-option-p fun '$info)))
524 (cond ((trace-option-p fun '$lisp_print)
525 (trace-print `(,lev exit ,fun ,ret-val ,@info)))
527 (trace-mprint lev (intl:gettext " Exit ") (mopstringnam fun) " " ret-val
528 (if info " -> " "")
529 (if info info "")))))))
531 (defmvar $trace_break_arg '$trace_break_arg
532 "During trace Breakpoints bound to the argument list or return value")
534 (defun trace-enter-break (fun lev largs)
535 (if (trace-option-p fun '$break)
536 (do ((return-to-trace-handle nil)
537 ($trace_break_arg `((mlist) ,@largs)))(nil)
538 ($break "Trace entering" fun "level" lev)
539 (cond (($listp $trace_break_arg)
540 (return (cdr $trace_break_arg)))
542 (mtell "TRACE-ENTER-BREAK: 'trace_break_arg' must be a list.~%"))))
543 largs))
545 (defun trace-exit-break (fun lev ret-vals)
546 (if (trace-option-p fun '$break)
547 (let (($trace_break_arg (car ret-vals))
548 (return-to-trace-handle nil))
549 ($break "Trace exiting" fun "level" lev)
550 ; If trace_break_arg is the same (in the sense of eq) now
551 ; as when we started the breakpoint, then return all of the
552 ; original return values from the function. This means if
553 ; the user sets trace_break_arg but its value is eq to its
554 ; original value (which is only the primary return value
555 ; from the original function) then we still return the extra
556 ; values (if there are any). I (kjak) don't think this is
557 ; strictly correct, but we can try to fix it up later if
558 ; anyone ever really cares about this corner case involving
559 ; multiple return values, exit breakpoints and setting
560 ; trace_break_arg to the same value it started with.
561 (if (eq $trace_break_arg (car ret-vals))
562 ret-vals
563 (list $trace_break_arg)))
564 ret-vals))
566 (defun pred-$read (predicate argl bad-message)
567 (do ((ans))(nil)
568 (setq ans (apply #'$read argl))
569 (if (funcall predicate ans) (return ans))
570 (mtell "PRED-$READ: unacceptable input: ~A~%" bad-message)))
572 (defun ask-choicep (llist &rest header-message)
573 (do ((j 0 (1+ j))
574 (dlist nil (list* #\newline `((marrow) ,j ,(car ilist)) dlist))
575 (ilist llist (cdr ilist)))
576 ((null ilist)
577 (setq dlist (nconc header-message (cons #\newline (nreverse dlist))))
578 (let ((upper (1- j)))
579 (pred-$read #'(lambda (val)
580 (and (integerp val)
581 (>= val 0)
582 (<= val upper)))
583 dlist
584 "please reply with an integer from the menue.")))))
586 ;; I GUESS ALL OF THE STRINGS IN THIS FUNCTION NEED TO BE GETTEXT'D TOO
587 ;; JUST CAN'T BRING MYSELF TO DO IT
589 (defun trace-error-break (fun level largs)
590 (case (ask-choicep '("Signal an `maxima-error', i.e. punt?"
591 "Retry with same arguments?"
592 "Retry with new arguments?"
593 "Exit with user supplied value")
594 "Error during application of" (mopstringnam fun)
595 "at level" level
596 #\newline "Do you want to:")
597 ((0)
598 '(maxima-error))
599 ((1)
600 (cons 'retry largs))
601 ((2)
602 (cons 'retry (let (($trace_break_arg `((mlist) ,@largs)))
603 (cdr (pred-$read '$listp
604 (list
605 "Enter new argument list for"
606 (mopstringnam fun))
607 "please enter a list.")))))
609 ((3)
610 (cons 'exit (list ($read "Enter value to return"))))))
612 ;;; application dispatch, and the consing up of the trace hook.
614 (defun macsyma-fsymeval (fun)
615 (let ((try (macsyma-fsymeval-sub fun)))
616 (cond (try try)
617 ((get fun 'autoload)
618 (load-and-tell (get fun 'autoload))
619 (setq try (macsyma-fsymeval-sub fun))
620 (or try
621 (mtell (intl:gettext "trace: ~@:M has no functional properties after autoloading.~%")
622 fun))
623 try)
624 (t try))))
626 (defun macsyma-fsymeval-sub (fun)
627 ;; The semantics of $TRANSRUN are herein taken from DESCRIBE,
628 ;; a careful reading of MEVAL1 reveals, well... I've promised to watch
629 ;; my language in these comments.
631 (let ((mprops (mgetl fun '(mexpr mmacro)))
632 (lprops (getl fun '(translated-mmacro mfexpr* mfexpr*s)))
633 (fcell-props (getl-lm-fcn-prop fun '(subr lsubr expr macro))))
634 (cond ($transrun
635 ;; the default, so its really a waste to have looked for
636 ;; those mprops. Its better to fix the crock than to
637 ;; optimize this though!
638 (or lprops fcell-props mprops))
640 (or mprops lprops fcell-props)))))
642 (defprop expr expr hook-type)
643 (defprop mexpr expr hook-type)
644 (defprop subr expr hook-type)
645 (defprop lsubr expr hook-type)
646 (defprop mfexpr* macro hook-type)
647 (defprop mfexpr*s macro hook-type)
649 (defun make-trace-hook (fun type handler)
650 ;; Argument handling according to FUN's TYPE is already done
651 ;; elsewhere: HANDLER, meval...
652 (declare (ignore type))
653 #'(lambda (&rest trace-args)
654 (funcall handler fun trace-args)))
656 (defmacro trace-setup-call (prop fun type)
657 (declare (ignore fun type))
658 `(setf (symbol-function 'the-trace-apply-hack) ,prop))
660 (defun trace-apply (fun largs)
661 (let ((prop (trace-fsymeval fun))
662 (type (trace-type fun))
663 (return-to-trace-handle nil))
664 (case type
665 ((mexpr)
666 (mapply prop largs "A traced function"))
667 ((expr)
668 (apply prop largs))
669 ((subr lsubr)
670 (setf (symbol-plist 'the-trace-apply-hack) (list type prop))
671 (apply (second (getl 'the-trace-apply-hack '(subr lsubr))) largs))
672 ((mfexpr* mfexpr*s)
673 (funcall prop (car largs))))))
675 ;;; I/O cruft
677 (defmvar $trace_max_indent 15. "max number of spaces it will go right" fixnum)
679 (putprop '$trace_max_indent 'assign-mode-check 'assign)
680 (putprop '$trace_max_indent '$fixnum 'mode)
682 (defun-prop (spaceout dimension) (form result)
683 (dimension-string (make-list (cadr form) :initial-element #\space) result))
685 (defun trace-mprint (&rest l)
686 (mtell-open "~M" `((mtext) ((spaceout) ,(min $trace_max_indent trace-indent-level)) ,@l)))
688 (defun trace-print (form)
689 (do ((j (min $trace_max_indent trace-indent-level) (1- j)))
690 ((not (> j 0)))
691 (write-char #\space))
692 (prin1 form)
693 (terpri)
694 (finish-output))
696 ;; 9:02pm Monday, 18 May 1981 -GJC
697 ;; A function benchmark facility using trace utilities.
698 ;; This provides medium accuracy, enough for most user needs.
700 (defmvar $timer '((mlist)) "List of functions under active timetrace")
702 (defmspec $timer (form)
703 (mlistcan-$all #'macsyma-timer (cdr form) $timer))
705 (defmspec $untimer (form)
706 `((mlist) ,@(mapcan #'macsyma-untimer (or (cdr form) (cdr $timer)))))
708 (defun micro-to-sec (runtime)
709 (mul runtime (float (/ internal-time-units-per-second)) '$sec))
711 (defun micro-per-call-to-sec (runtime calls)
712 (div (micro-to-sec runtime)
713 (if (zerop calls) 1 calls)))
715 (defun timer-mlist (function calls runtime gctime)
716 `((mlist simp) ,function
717 ,(micro-per-call-to-sec (+ runtime gctime) calls)
718 ,calls
719 ,(micro-to-sec runtime)
720 ,(micro-to-sec gctime)))
722 (defmspec $timer_info (form)
723 (do ((l (or (cdr form) (cdr $timer))
724 (cdr l))
725 (v nil)
726 (total-runtime 0)
727 (total-gctime 0)
728 (total-calls 0))
729 ((null l)
730 `(($matrix simp)
731 ((mlist simp) $function $time//call $calls $runtime $gctime)
732 ,.(nreverse v)
733 ,(timer-mlist '$total total-calls total-runtime total-gctime)))
734 (let*
735 ((fun-opr (getopr (car l)))
736 (runtime ($get fun-opr '$runtime))
737 (gctime ($get fun-opr '$gctime))
738 (calls ($get fun-opr '$calls)))
739 (when runtime
740 (incf total-calls calls)
741 (incf total-runtime runtime)
742 (incf total-gctime gctime)
743 (push (timer-mlist (car l) calls runtime gctime) v)))))
745 (defun macsyma-timer (fun)
746 (prog1
747 (macsyma-trace-sub fun 'timer-handler $timer)
748 (let ((fun-opr (getopr fun)))
749 ($put fun-opr 0 '$runtime)
750 ($put fun-opr 0 '$gctime)
751 ($put fun-opr 0 '$calls))))
753 (defun macsyma-untimer (fun) (macsyma-untrace-sub fun 'timer-handler $timer))
755 (defvar runtime-devalue 0)
756 (defvar gctime-devalue 0)
758 (defmvar $timer_devalue nil
759 "If true, then time spent inside calls to other timed functions is
760 subtracted from the timing figure for a function.")
762 (defun timer-handler (fun largs)
763 ;; N.B. Doesn't even try to account for use of DYNAMIC CONTROL
764 ;; such as ERRSET ERROR and CATCH and THROW, as these are
765 ;; rare and the overhead for the unwind-protect is high.
766 (let ((runtime (get-internal-run-time))
767 (gctime (status gctime))
768 (old-runtime-devalue runtime-devalue)
769 (old-gctime-devalue gctime-devalue))
770 (multiple-value-prog1 (trace-apply fun largs)
771 (setq old-runtime-devalue (- runtime-devalue old-runtime-devalue))
772 (setq old-gctime-devalue (- gctime-devalue old-gctime-devalue))
773 (setq runtime (- (get-internal-run-time) runtime old-runtime-devalue))
774 (setq gctime (- (status gctime) gctime old-gctime-devalue))
775 (when $timer_devalue
776 (incf runtime-devalue runtime)
777 (incf gctime-devalue gctime))
778 ($put fun (+ ($get fun '$runtime) runtime) '$runtime)
779 ($put fun (+ ($get fun '$gctime) gctime) '$gctime)
780 ($put fun (1+ ($get fun '$calls)) '$calls))))