home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / trace.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  14.7 KB  |  406 lines
  1. ;;; -*- Log: code.log; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: trace.lisp,v 1.8.1.1 92/05/26 23:39:40 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Old TRACE based on EXT:ENCAPSULATE.
  15. ;;;
  16. ;;; NOTE: This only works for functions named with symbols which is not the
  17. ;;; fault of EXT:ENCAPSULATE.  Common Lisp changed out from under the code
  18. ;;; Jim wrote a long long time ago.
  19. ;;;
  20. ;;; Written by Jim Large.
  21. ;;;
  22. ;;; **********************************************************************
  23. ;;;
  24.  
  25. (in-package "EXTENSIONS")
  26.  
  27. (export '(*trace-print-level* *trace-print-length*
  28.       *traced-function-list* *max-trace-indentation*))
  29.  
  30.  
  31.  
  32. ;;;; Support stuff.
  33.  
  34. (proclaim '(special
  35.         *trace-output*  ;The stream where all traced output goes.
  36.         trace-in-trouble-p  ;used to detect infinite recursion due to tracing
  37.         trace-went-deeper   ;decides whether ok to print result on same line.
  38.         *print-level*       ;so we can twiddle it.
  39.         *print-length*      ;ditto.
  40.         ))
  41.  
  42. (defvar trace-level ())          ;Gad, I seem to have to bind this.
  43.  
  44. (defvar *traced-function-list* ()
  45.   "A list of the names of all functions which are being traced.")
  46.  
  47. (defvar *Max-trace-indentation* 40
  48.   "The maximum number of spaces for trace to indent.")
  49.  
  50. (defvar *trace-print-length* ()
  51.   "*Print-length* will be bound to this value when trace is printing.")
  52.  
  53. (defvar *trace-print-level* ()
  54.   "*Print-level* will be bound to this value when trace is printing.")
  55.  
  56. ;;; MARKED-FUNCTION-CALLER -- Internal.
  57. ;;;
  58. ;;; This is like apply, but it takes a third parameter, a variable to increment
  59. ;;; before the call, and decrement after the call.  Marked-function-caller is
  60. ;;; used to encapsulate functions which have been marked by Trace-function-mark
  61. ;;;
  62. (defun marked-function-caller (function variable args)
  63.   (set variable (1+ (symbol-value variable)))
  64.   (unwind-protect (apply function args)
  65.           (set variable (1- (symbol-value variable)))))
  66.  
  67. ;;; TRACE-FUNCTION-MARK -- Internal.
  68. ;;;
  69. ;;; This returns an uninterned symbol which will be incremented every time the
  70. ;;; marked function is entered, and decremented every time the function exits.
  71. ;;; The symbol and the number of times the function has been "marked" are
  72. ;;; stored as a cons (symbol . times) on the function- name's
  73. ;;; trace-recursion-counter property.
  74. ;;;
  75. (defun trace-function-mark (function-name)
  76.   "Returns a symbol which the function will 1+ on entry and 1- on exit."
  77.   ;;If the symbol already has the encapsulation,
  78.   (cond ((encapsulated-p function-name 'trace-recursion-counter)
  79.      ;;update the number of times marked,
  80.       (setf (get function-name 'trace-recursion-counter) 
  81.            (cons (car (get function-name 'trace-recursion-counter))
  82.              (1+ (cdr (get function-name 'trace-recursion-counter)))))
  83.      ;;and return the symbol which is already in the property list.
  84.      (car (get function-name 'trace-recursion-counter)))
  85.     ;;Otherwise, Make a new uninterned symbol,
  86.     (T (let ((uninterned-symbol (make-symbol (symbol-name function-name))))
  87.          ;;encapsulate the function with the marked-function-caller,
  88.          (encapsulate function-name 'trace-recursion-counter
  89.           `(marked-function-caller basic-definition
  90.                        ',uninterned-symbol
  91.                        argument-list))
  92.          ;;put (uninterned-symbol . 1) on function-name's plist,
  93.          (setf (get function-name 'Trace-recursion-counter) 
  94.            (cons uninterned-symbol 1))
  95.          ;;and initialize the counter to 0.
  96.          (set uninterned-symbol 0)
  97.          uninterned-symbol))))
  98.  
  99. ;;; TRACE-FUNCTION-UNMARK -- Internal.
  100. ;;;
  101. ;;; This informs the function that we are no longer using the counter provided
  102. ;;; by trace-function-mark.  It does not necessarily turn the feature, because
  103. ;;; other functions may be looking at the same symbol.
  104. ;;;
  105. (defun trace-function-unmark (function-name)
  106.   "Informs function that caller is no longer using trace-function-mark feature."
  107.   ;;Get the trace-recursion-counter (symbol . times-marked)
  108.   (let ((trc (get function-name 'trace-recursion-counter)))
  109.     ;;if the number of times marked is < 2,
  110.     (cond ((< (cdr trc) 2)
  111.        ;;unencapsulate the function and remove the nasty property
  112.        (unencapsulate function-name 'trace-recursion-counter)
  113.        (remprop function-name 'trace-recursion-counter))
  114.       ;;otherwise decrement the number of times marked.
  115.       (T (setf (get function-name 'trace-recursion-counter) 
  116.            (cons (car trc) (1- (cdr trc))))))
  117.     ()))
  118.  
  119.  
  120. ;;; TRACE-INDENT -- Internal.
  121. ;;;
  122. ;;; Takes a level and prints out useful looking indentation text on a fresh
  123. ;;; line.
  124. ;;;
  125. (defun trace-indent (level)
  126.   (write-string "
  127.                                                                                 "
  128.         *trace-output*
  129.         :start 0
  130.         :end (+ 2 (min (* level 2) *max-trace-indentation*)))
  131.   (princ level *trace-output*))
  132.  
  133. ;;; TRACE-AUX-PRINT -- Internal.
  134. ;;;
  135. ;;; takes a list of forms, and prints the value of each one after calling
  136. ;;; trace-indent to indent a fresh line.
  137. ;;;
  138. (defun trace-aux-print (forms level)
  139.   (do ((flist forms (cdr flist)))
  140.       ((null flist) ())
  141.     (trace-indent level)
  142.     (princ "* " *trace-output*)
  143.     (prin1 (eval (car flist)) *trace-output*)))
  144.  
  145.  
  146.  
  147.  
  148. ;;; TRACE-CALL -- Internal.
  149. ;;;
  150. ;;; is similar to apply except that it prints out debugging info on function
  151. ;;; entry & exit.  On entry, it prints NAME and ARGS and the value of each of
  152. ;;; the forms in the list PRINT, iff the form CONDITION evals to non-nil.  On
  153. ;;; exit it prints the result (or results if multiple values) of the function
  154. ;;; call and the result of evaluating each of the forms in the list
  155. ;;; PRINT-AFTER, iff CONDITION evaled to non- nil before the call.
  156. ;;;
  157. (defun trace-call (function name condition break break-after
  158.                 print print-after args)
  159.   ;;If trace-in-trouble-p, just do the function.
  160.   (when (and (boundp 'trace-in-trouble-p) trace-in-trouble-p)
  161.     (return-from trace-call (apply function args)))
  162.   ;;So that our caller will know we have been printing stuff.
  163.   (setq trace-went-deeper T)
  164.   ;;Some local variables bound for rest of this function
  165.   (let* ((trace-in-trouble-p T)
  166.      (trace-went-deeper ())
  167.      (print-p (if condition (eval condition) 'T))
  168.      (trace-level
  169.       (if print-p                    ;level gets incremented
  170.           (if (and (boundp 'trace-level)        ; iff we are printing
  171.                (numberp trace-level))
  172.           (1+ trace-level)
  173.           0)
  174.           trace-level)))
  175.     ;;if printing, print the args while binding *print-level* & *print-length*.
  176.     (if print-p
  177.     (let ((*print-level* *trace-print-level*)
  178.           (*print-length* *trace-print-length*))
  179.       (trace-indent trace-level)
  180.       (princ ": " *trace-output*)
  181.       (prin1 (cons name args) *trace-output*)
  182.       (if print (trace-aux-print print trace-level))
  183.       (force-output *trace-output*)))
  184.     ;;Turn off trace-in-trouble-p temporarily while we call the original funct,
  185.     ;;  and optionaly while we are in the break loop.
  186.     ;;  Function may return multiple values.
  187.     (setq trace-in-trouble-p ())
  188.     (if (eval break) (break "Trace entry"))
  189.     (let ((result (multiple-value-list (apply function args))))
  190.       (if (eval break-after) (break "Trace exit"))
  191.       (setq trace-in-trouble-p T)
  192.       ;;if printing, bind *print-level* & *print-length*, & do hairy print.
  193.       (if print-p
  194.       (let ((*print-level* *trace-print-level*)
  195.         (*print-length* *trace-print-length*))
  196.         (trace-indent trace-level)
  197.         (princ ": returned" *trace-output*)
  198.         (do ((res result (cdr res)))        ;do loop prints all the
  199.         ((null res) ())                ;values separated by
  200.           (princ " " *trace-output*)            ;spaces
  201.           (prin1 (car res) *trace-output*))
  202.         (if print-after (trace-aux-print print-after trace-level))
  203.         (force-output *trace-output*)))
  204.       ;;return multiple values or single value according to result.
  205.       (if (cdr result)
  206.       (values-list result)
  207.       (car result)))))
  208.  
  209.  
  210. ;;; TRACE-1 -- Internal.
  211. ;;;
  212. ;;; Puts a trace encapsulation around the specified function.  If the function
  213. ;;; is already traced, all of the old options will be canceled.
  214. ;;;
  215. ;;;  FUNCTION-NAME is the name of the function to trace.
  216. ;;; If an option is () then it is ignored.
  217. ;;;  CONDITION form to eval at each entry  Controls printing of trace info.
  218. ;;;  BREAK -- a form to eval at each entry.  If T, call break loop.
  219. ;;;  BREAK-AFTER -- same, but happens afterward.
  220. ;;;  WHEREIN list of function names.  Trace only when inside call to one.
  221. ;;;  PRINT is a list of forms to eval & print at start of each call.
  222. ;;;  PRINT-AFTER  forms to eval & print at end of each call.
  223. ;;;
  224. (defun trace-1 (function-name condition break break-after
  225.                   wherein print print-after)
  226.   "Called by TRACE to put a trace encapsulation around a function."
  227.   (untrace-1 function-name)                ;cancel any existing trace options.
  228.   ;;make form which returns non-() iff evaled inside any of the wherein funs.
  229.   ;;Trace-function-mark returns a variable which is plusp iff inside function
  230.   (let ((wherein-form
  231.      (case (length wherein)
  232.        ((0) ())                    ;trivial case always false.
  233.        ;;one function.  form tests variable for plusp
  234.        ((1) `(plusp ,(trace-function-mark (car wherein))))
  235.        ;;more than one, form or's one function cases
  236.        (T `
  237.         (or ,@(do ((names wherein (cdr names))
  238.                (result () (cons
  239.                    `(plusp ,(trace-function-mark (car names)))
  240.                    result)))
  241.                ((null names) result)))))))
  242.     ;;If wherein was provided, save wherein list on plist for untrace,
  243.     (cond (wherein
  244.         (setf (get function-name 'trace-only-within) wherein)
  245.  
  246.         ;;and make a new condition form combining old one with wherein.
  247.         (setq condition (if condition
  248.                 `(and ,condition ,wherein-form)
  249.                 wherein-form)))
  250.       (T ()))
  251.     ;;Encapsulate the function with a trace-call.
  252.     (encapsulate function-name 'trace
  253.      `(trace-call basic-definition             ;defined by encapsulate.
  254.           ',function-name
  255.           ',condition
  256.           ',break
  257.           ',break-after
  258.           ',print
  259.           ',print-after
  260.           argument-list)))             ;defined by encapsulate.
  261.   ;;save the name of the function for untrace-all, and return name.
  262.   (push function-name *traced-function-list*)
  263.   function-name)
  264.  
  265.  
  266. ;;; UNTRACE-1 -- Internal.
  267. ;;;
  268. ;;; will untrace the specified function.  If the function was not already
  269. ;;; traced, nothing special will happen.  Because untrace-1 can be called due
  270. ;;; to trace-in-trouble-p, we must ALWAYS unencapsulate first, and clean up
  271. ;;; later.
  272. ;;;
  273. (defun untrace-1 (function-name)
  274.   "Turns off tracing for the specified function."
  275.   (unencapsulate function-name 'trace)
  276.   ;;Be polite, and unmark all of the functions which we are traced wherein.
  277.   (let ((wherein (get function-name 'trace-only-within)))
  278.     (cond (wherein
  279.        (do ((funct wherein (cdr funct)))
  280.            ((null funct) ())
  281.          (trace-function-unmark (car funct)))
  282.        (remprop function-name 'trace-only-within))
  283.       (T ())))
  284.   ;;Remove function-name from who's who.
  285.   (setq *Traced-function-list*
  286.     (remove function-name *traced-function-list*))
  287.   ;;And return function-name.
  288.   function-name)
  289.  
  290.  
  291.  
  292. ;;;; TRACE.
  293.  
  294. (eval-when (compile eval load)
  295.  
  296. (defmacro with-keywords (option-list key-list &rest body)
  297.   `(let ,(mapcar #'(lambda (kl)
  298.             `(,(cadr kl)        ;var
  299.               (let ((rest-options (memq ',(car kl) ,option-list)))
  300.                 (if rest-options
  301.                 (cadr rest-options)    ;may return NIL
  302.                 ,(caddr kl)))) )    ;default
  303.         key-list)
  304.     . ,body ))
  305.  
  306. ) ;EVAL-WHEN
  307.  
  308.  
  309. ;;; TRACE -- Public.
  310. ;;;
  311. ;;; parses a list of specs, and if they survive some type checking, it returns
  312. ;;; a progn which will call trace-1 once for each spec.  If anything fails, No
  313. ;;; tracing will be done.
  314. ;;;
  315. ;;; A spec is either a function name, or a list of a function name followed by
  316. ;;; keywords and arguments.
  317. ;;;
  318. (defmacro trace (&rest specs)
  319.   "For simple use, specs are function names.  Undo with Untrace."
  320.   (if
  321.    specs
  322.    (do ((name ())               ;name of function this iteration
  323.     (options ())               ;list of keywords & options for name
  324.     (trace-1-forms ())           ;list of calls to trace-1
  325.     (name-list ())               ;list of names so we can fboundp
  326.     (spec-list specs (cdr spec-list)))
  327.        ;;return a form which trace-1's all the functions iff all are fboundp.
  328.        ((null spec-list)
  329.     `(progn
  330.        ,@(mapcar #'(lambda (x) `#',x) name-list)
  331.        ,@trace-1-forms))
  332.      ;;LOOP BODY stuffs one form into Trace-1-forms on each pass.
  333.      ;;first, separate the name & the list of options
  334.      (typecase (car spec-list)
  335.        (symbol (setq name (car spec-list))
  336.            (setq options ()))
  337.        (list
  338.     (if (not (symbolp (caar spec-list)))
  339.         (error "Illegal function name:  ~s." (caar spec-list)))
  340.     (if (eq (caar spec-list) 'quote)
  341.         (error "I bet you don't want to trace QUOTE."))
  342.     (setq options (cdar spec-list))
  343.     (setq name (caar spec-list)))
  344.        (T (error "Illegal trace spec:  ~s." (car spec-list))))
  345.      ;;parse the options list.
  346.      (with-keywords options
  347.        ((:condition condition ())
  348.     (:break break ())
  349.     (:break-after break-after ())
  350.     (:break-all break-all ())
  351.         (:wherein wherein ())
  352.         (:print print ())
  353.         (:print-after print-after ())
  354.     (:print-all print-all ()))
  355.       (when break-all (setq break (setq break-after break-all)))
  356.       (when print-all (setq print (setq print-after print-all)))
  357.       ;;Make sure wherein spec is a list of symbols or ()
  358.       (setq wherein
  359.     (typecase wherein
  360.      (null ())
  361.      (symbol (list wherein))
  362.      (list (do ((funs wherein (cdr funs)))
  363.            ((null funs) wherein)
  364.          (if (not (symbolp (car funs)))
  365.              (error
  366.                  "Illegal function name, ~s, in :wherein."
  367.                  (car funs)))))
  368.      (T (error "Illegal :wherein option:  ~s." wherein))))
  369.       ;;make sure print and print-after are lists.
  370.       (if (not (listp print))
  371.       (error "Illegal form list, ~s, for :print."
  372.           print))
  373.       (if (not (listp print-after))
  374.       (error "Illegal form list, ~s, for :print-after."
  375.           print-after))
  376.       (push `(trace-1 ',name ',condition ',break ',break-after
  377.               ',wherein ',print ',print-after)
  378.         trace-1-forms)
  379.       (push name name-list)))
  380.    ;; if (not specs)
  381.    '*traced-function-list*))
  382.  
  383.  
  384.  
  385. ;;;; UNTRACE.
  386.  
  387. ;;; UNTRACE -- Public.
  388. ;;;
  389. ;;; checks to see that its args are all symbols.  If they are, it returns a
  390. ;;; form which will untrace each one.  Otherwise, it signals an error, and none
  391. ;;; of the forms are untraced.
  392. ;;;
  393. ;;; with no args, untraces all traced functions.
  394. ;;;
  395. (defmacro untrace (&rest names)
  396.   "Removes tracing from the functions named.  With no args, untraces all
  397.    functions."
  398.   (if (null names) (setq names *traced-function-list*))
  399.   (do ((untrace-1-forms ())
  400.        (name-list names (cdr name-list)))
  401.       ((null name-list)
  402.        `(progn ,@untrace-1-forms))
  403.     (if (symbolp (car name-list))
  404.     (push `(untrace-1 ',(car name-list)) untrace-1-forms)
  405.     (error "Illegal function name:  ~s." (car name-list)))))
  406.