home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / LISP / PDLISP.ZIP / DEBUG.L < prev    next >
Encoding:
Text File  |  1986-05-04  |  6.4 KB  |  252 lines
  1. ; debug.l - Copyright (c) 1984 by David Morein.
  2. ;
  3. ; this file contains miscellaneous debugger support routines.
  4. ;
  5. ; note - this is an initialization file, see the manual for more info.
  6. ;
  7. (pdq /sys/cmd)
  8. ;
  9. ;global functions:
  10. ;
  11. (global
  12. 'debugq
  13. 'debug
  14. 'debugset
  15. 'baktrace
  16. 'showstack
  17. 'trace
  18. 'untrace
  19. 'reset)
  20. ;
  21. ;
  22. ; local variables:
  23. (setq *tracelevel* 0)
  24. ;
  25. ; debugq - same as debug except that it quotes its argument.
  26. ;
  27. (def debugq (nlambda (e)
  28.     (debug e)))
  29. ;
  30. ; debug - evaluates an argument in a debugging environment
  31. ;
  32. (defun debug (e &aux olderrlbl result)
  33.     (progn
  34.     (setq olderrlbl (status error_label))    ;save entry value ierrlbl
  35.     (status error_label nil)        ;disable internal error label
  36.     (setq result (eval e))            ;evaluate e
  37.     (status error_label olderrlbl)        ;restore internal error label
  38.     result))                ;return the result
  39. ;
  40. ; debugset - sets up a debugging environment.
  41. ;
  42. (def debugset (nlambda (x)
  43.     (cond
  44.     (x 
  45.         (progn                ;x non-NIL => disable debugging
  46.         (status error_label nil)        ;reset error label
  47.         (status smash_hook  t)        ;turn on macro displacement
  48.         t))                    ;return t
  49.     (t
  50.         (progn                ;x NIL => enable debugging 
  51.         (status error_label 'errset)    ;set error label
  52.         (status smash_hook  nil)        ;turn off macro displacement
  53.         t)))))                ;return t
  54. ;
  55. ;
  56. ; baktrace - outputs an abbreviated back-trace of the stack,
  57. ; showing only function names.
  58. ;
  59. (defun baktrace (&optional n)
  60.     (cond    
  61.     (n (bt_print_list (firstn n (cdddr (cdddr (cdddr (baktrce 0)))))))
  62.     (t (bt_print_list (cdddr (cdddr (cdddr (baktrce 0))))))))
  63. ;
  64. ;
  65. ; bt_print_list - outputs a list for baktrace
  66. ;
  67. (defun bt_print_list (l)
  68.     (cond
  69.         ((null l) t)
  70.     (t
  71.         (progn
  72.         (cond
  73.             ((atom (car l)) (print (car l)))
  74.         (t (print (caar l))))
  75.         (terpri)
  76.         (bt_print_list (cdr l))))))
  77. ;
  78. ;
  79. ; showstack - outputs a complete back trace.
  80. ; if n is specified, then only n frames
  81. ; are printed; otherwise, the entire
  82. ; stack is printed.
  83. ;
  84. (defun showstack (&optional n)
  85.     (cond 
  86.         (n (shstk_print_list (firstn n (cdddr (cdddr (cdddr (baktrce 0)))))))
  87.     (t (shstk_print_list (cdddr (cdddr (cdddr (baktrce 0))))))))
  88. ;
  89. ;
  90. (def trace (nlambda (&rest fnlist)
  91.     (mapcar '*trace1 fnlist)))
  92. ;
  93. ;
  94. (defun *trace1 (tfn &aux lambda-exp)
  95.     (cond            ;check that tfn is not already being traced
  96.     ((get 'trace tfn) nil)    ;if tfn being traced, return NIL    
  97.     (t            ;otherwise ...
  98.         (cond        ;check that tfn is bound as a function
  99.         ((not (fboundp tfn)) nil)    ;if not, return NIL
  100.         (t                ;otherwise ...
  101.             (progn
  102. ;
  103. ; save tfn's old definition on TRACE's property list, and alter
  104. ; tnf's function definition cell.
  105. ;
  106.             (setq lambda-exp (symbol-function tfn))
  107.             (putprop 'trace lambda-exp tfn)
  108. ;
  109. ; if no error is generated during the call to trace-alter,
  110. ; return T; otherwise, return NIL:
  111. ;
  112.             (cond
  113.             ((errset (putd tfn (trace-alter tfn)))    t)
  114.             (t  nil)))))) ))
  115. ;
  116. ;
  117. ; trace-alter - produces a new function definition for traced symbols
  118. ;
  119. ; for some function foo, we want trace-alter to expand it to:
  120. ;
  121. ; (progn
  122. ;    (princ "entering ")
  123. ;    (unprint 'foo)
  124. ;    (unprinc " ")
  125. ;    (unprint actuals)
  126. ;    (terpri)
  127. ;    (setq *trace_result (funcall (get 'trace 'traced_function) actuals))
  128. ;    (princ "exiting ")
  129. ;    (unprint 'foo)
  130. ;    (unprinc " ")
  131. ;    (unprint *trace_result)
  132. ;    (terpri)
  133. ;    *trace_result)
  134. ;
  135. (defun trace-alter (tfn &aux *trace_result l-exp discipline parameters)
  136.     (progn
  137.     (setq l-exp (symbol-function tfn))
  138.     (setq discipline (car l-exp))
  139.     (setq parameters
  140.     (cond
  141.         ((or
  142.         (eql discipline 'lambda)
  143.         (eql discipline 'nlambda))
  144.         (cadr l-exp))
  145.     (t
  146.         (err "***> TRACE-ALTER: untraceable function discipline."))))
  147.     (list discipline parameters
  148.       (list 'progn
  149. ;
  150. ; output "entering <fn-name> <actual parameter list>"
  151. ;
  152.             (list 'indent_princ '*tracelevel* (list "entering "))
  153.         (list 'unprint (list quote tfn))
  154.         (list 'unprinc " ")
  155.         (list
  156.             'unprint
  157.         (cond
  158.             ((or (eql discipline 'lambda) (eql discipline 'nlambda))
  159.             (list 'tr-evlist (list 'quote parameters)))
  160.             (t
  161.             (err "***> TRACE: bad discipline."))))
  162.         (list 'terpri)
  163.         (list 'setq '*tracelevel* (list '+ '*tracelevel* 1))
  164.         (list
  165.            'setq '*trace_result
  166.            (list 'apply
  167.             (list
  168.                 'get
  169.                 (list quote 'trace)
  170.                 (list quote tfn))
  171.             (list 'evlist (list 'quote parameters))))
  172.         (list 'setq '*tracelevel* (list '- '*tracelevel* 1))
  173.         (list 'indent_princ '*tracelevel* (list "exiting "))
  174.         (list 'unprint (list quote tfn))
  175.         (list 'unprinc " ")
  176.         (list 'unprint '*trace_result)
  177.         (list 'terpri)
  178.         '*trace_result))))
  179. ;
  180. ; untrace - untraces a list of functions
  181. ;
  182. (def untrace (nlambda (&rest fnlist)
  183.     (mapcar '*untrace1 fnlist)))
  184. ;
  185. ; *untrace1 - untraces a single function
  186. ;
  187. (defun *untrace1 (fn)
  188.     (cond                ;check that fn is being traced.
  189.     ((get 'trace fn)
  190.         (progn            ;fn is being traced.
  191.         (putd fn (get 'trace fn))    ;restore original fn def.
  192.         (remprop 'trace fn)        ;remove marker on TRACE's plist
  193.         t))                ;return T
  194.     (t nil)))            ;return NIL, fn not traced.
  195. ;
  196. ;
  197. ; tr-evlist - evaluates a list for TRACE. The tricky thing that
  198. ; this function does (and the reason that we couldn't use EVLIST
  199. ; in TRACE), is that it properly handles lambda-list keywords
  200. ; like &AUX.
  201. ;
  202. (defun tr-evlist (tr-list)
  203.     (cond
  204.         ((eq (car tr-list) '&aux)    'nil)
  205.         ((eq (car tr-list) '&rest)    (cdr tr-list))
  206.         ((null tr-list)            'nil)
  207.         (t   (cons (eval (car tr-list)) (tr-evlist (cdr tr-list)))))))
  208. ;
  209. ; indent_print - indents a new line & prints an object
  210. ;
  211. (defun indent_print (indent object)
  212.     (progn
  213.     (space_to_col    (* indent 2))
  214.     (unprint    object)))
  215. ;
  216. ; indent_princ - indents a new line & prints an object
  217. ;
  218. (defun indent_princ (indent object)
  219.     (progn
  220.     (space_to_col    (* indent 2))
  221.     (unprinc    object)))
  222. ;
  223. ;
  224. ; shstk_print_list - prints out a list of frames for showstack
  225. ;
  226. (defun shstk_print_list (l)
  227.     (cond
  228.         ((atom l)    t)
  229.     (t
  230.         (progn
  231.         (pp (car l))
  232.         (terpri)
  233.         (terpri)
  234.         (princ "<--------------- frame --------------->")
  235.         (terpri)
  236.         (shstk_print_list (cdr l))))))
  237. ;
  238. ;
  239. ; reset - throws control back to toplevel
  240. ;
  241. (def reset (nlambda (&optional (e nil))
  242.     (progn
  243.     (status break_level 0)
  244.     (debugset nil)
  245.     (throw '?*toplevel*? e))))
  246. ;
  247. ;
  248. (popd)    ;return to entry directory
  249. ;
  250. ;**************************** end of debug.l ****************************
  251.  
  252.