home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.src.lha / src / trace.lsp < prev    next >
Lisp/Scheme  |  1996-04-15  |  13KB  |  331 lines
  1. ;; Tracer
  2. ;; Bruno Haible 13.2.1990, 15.3.1991, 4.4.1991
  3.  
  4. ; (TRACE) liefert Liste der getraceten Funktionen
  5. ; (TRACE fun ...) tracet die Funktionen fun, ... zusätzlich.
  6. ; Format für fun:
  7. ;   Entweder ein Symbol
  8. ;        symbol
  9. ;   oder eine Liste aus einem Symbol und einigen Keyword-Argumenten (paarig!)
  10. ;        (symbol
  11. ;          [:suppress-if form]   ; kein Trace-Output, solange form erfüllt ist
  12. ;          [:step-if form]       ; Trace geht in den Stepper, falls form erfüllt
  13. ;          [:pre form]           ; führt vor Funktionsaufruf form aus
  14. ;          [:post form]          ; führt nach Funktionsaufruf form aus
  15. ;          [:pre-break-if form]  ; Trace geht vor Funktionsaufruf in die Break-Loop,
  16. ;                                ; falls form erfüllt
  17. ;          [:post-break-if form] ; Trace geht nach Funktionsaufruf in die Break-Loop,
  18. ;                                ; falls form erfüllt
  19. ;          [:pre-print form]     ; gibt die Werte von form vor Funktionsaufruf aus
  20. ;          [:post-print form]    ; gibt die Werte von form nach Funktionsaufruf aus
  21. ;          [:print form]         ; gibt die Werte von form vor und nach Funktionsaufruf aus
  22. ;        )
  23. ;   In all diesen Formen kann auf *TRACE-FUNCTION* (die Funktion selbst)
  24. ;   und *TRACE-ARGS* (die Argumente an die Funktion)
  25. ;   und *TRACE-FORM* (der Funktions-/Macro-Aufruf als Form)
  26. ;   und nach Funktionsaufruf auch auf *TRACE-VALUES* (die Liste der Werte
  27. ;   des Funktionsaufrufs) zugegriffen werden,
  28. ;   und mit RETURN kann der Aufruf mit gegebenen Werten verlassen werden.
  29. ; (UNTRACE) liefert Liste der getraceten Funktionen, streicht sie alle.
  30. ; (UNTRACE symbol ...) streicht symbol, ... aus der Liste der getraceten
  31. ;   Funktionen.
  32. ; TRACE und UNTRACE sind auch auf Funktionen (SETF symbol) und auf Macros anwendbar,
  33. ;   nicht jedoch auf lokal definierte Funktionen und Macros.
  34.  
  35. (in-package "LISP")
  36. (export '(trace untrace
  37.           *trace-function* *trace-args* *trace-form* *trace-values*
  38. )        )
  39. (in-package "SYSTEM")
  40.  
  41. (proclaim '(special *trace-function* *trace-args* *trace-form* *trace-values*))
  42. (defvar *traced-functions* nil) ; Liste der momentan getraceden Funktionsnamen
  43.   ; Solange ein Funktionsname funname [bzw. genauer: das Symbol
  44.   ; symbol = (get-funname-symbol funname)] getraced ist, enthält
  45.   ; die Property sys::traced-definition den alten Inhalt der Funktionszelle,
  46.   ; die Property sys::tracing-definition den neuen Inhalt der Funktionszelle,
  47.   ; und ist der Funktionsname Element der Liste *traced-functions*.
  48.   ; Währenddessen kann sich der Inhalt der Funktionszelle jedoch ändern!
  49.   ; Jedenfalls gilt stets:
  50.   ;        (and (fboundp symbol)
  51.   ;             (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
  52.   ;        )
  53.   ; ===>   (member funname *traced-functions* :test #'equal)
  54.   ; <==>   (get symbol 'sys::traced-definition)
  55. (defvar *trace-level* 0) ; Verschachtelungstiefe bei der Trace-Ausgabe
  56.  
  57. ; Funktionen, die der Tracer zur Laufzeit aufruft und die der Benutzer
  58. ; tracen könnte, müssen in ihrer ungetraceden Form aufgerufen werden.
  59. ; Statt (fun arg ...) verwende daher (SYS::%FUNCALL '#,#'fun arg ...)
  60. ; oder (SYS::%FUNCALL (LOAD-TIME-VALUE #'fun) arg ...).
  61. ; Dies gilt für alle hier verwendeten Funktionen von #<PACKAGE LISP> außer
  62. ; CAR, CDR, CONS, APPLY, VALUES-LIST (die alle inline compiliert werden).
  63.  
  64. (defmacro trace (&rest funs)
  65.   (if (null funs)
  66.     '*traced-functions*
  67.     (cons 'append
  68.       (mapcar #'(lambda (fun)
  69.                   (if (or (atom fun) (function-name-p fun))
  70.                     (trace1 fun)
  71.                     (apply #'trace1 fun)
  72.                 ) )
  73.               funs
  74.     ) )
  75. ) )
  76.  
  77. (defun trace1 (funname &key (suppress-if nil) (step-if nil)
  78.                             (pre nil) (post nil)
  79.                             (pre-break-if nil) (post-break-if nil)
  80.                             (pre-print nil) (post-print nil) (print nil)
  81.                        &aux (old-function (gensym)) (macro-flag (gensym))
  82.               )
  83.   (unless (function-name-p funname)
  84.     (error-of-type 'program-error
  85.       #L{
  86.       DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
  87.       ENGLISH "~S: function name should be a symbol, not ~S"
  88.       FRANCAIS "~S : Le nom de la fonction doit être un symbole et non ~S"
  89.       }
  90.       'trace funname
  91.   ) )
  92.   (let ((symbolform
  93.           (if (atom funname)
  94.             `',funname
  95.             `(load-time-value (get-setf-symbol ',(second funname)))
  96.        )) )
  97.     `(block nil
  98.        (unless (fboundp ,symbolform) ; Funktion überhaupt definiert?
  99.          (warn 
  100.           #L{
  101.           DEUTSCH "~S: Funktion ~S ist nicht definiert."
  102.           ENGLISH "~S: undefined function ~S"
  103.           FRANCAIS "~S : La fonction ~S n'est pas définie."
  104.           }
  105.           'trace ',funname
  106.          )
  107.          (return nil)
  108.        )
  109.        (when (special-form-p ,symbolform) ; Special-Form: nicht tracebar
  110.          (warn 
  111.           #L{
  112.           DEUTSCH "~S: Special-Form ~S kann nicht getraced werden."
  113.           ENGLISH "~S: cannot trace special form ~S"
  114.           FRANCAIS "~S : La forme spéciale ~S ne peut pas être tracée."
  115.           }
  116.           'trace ',funname
  117.          )
  118.          (return nil)
  119.        )
  120.        (let* ((,old-function (symbol-function ,symbolform))
  121.               (,macro-flag (consp ,old-function)))
  122.          (unless (eq ,old-function (get ,symbolform 'sys::tracing-definition)) ; schon getraced?
  123.            (setf (get ,symbolform 'sys::traced-definition) ,old-function)
  124.            (pushnew ',funname *traced-functions* :test #'equal)
  125.          )
  126.          (format t 
  127.                  #L{
  128.                  DEUTSCH "~&;; ~:[Funktion~;Macro~] ~S wird getraced."
  129.                  ENGLISH "~&;; Tracing ~:[function~;macro~] ~S."
  130.                  FRANCAIS "~&;; Traçage ~:[de la fonction~;du macro~] ~S."
  131.                  }
  132.                  ,macro-flag ',funname
  133.          )
  134.          (replace-in-fenv (get ,symbolform 'sys::traced-definition) ',funname
  135.            ,old-function
  136.            (setf (get ,symbolform 'sys::tracing-definition)
  137.              (setf (symbol-function ,symbolform)
  138.                ; neue Funktion, die die ursprüngliche ersetzt:
  139.                ,(let ((newname (concat-pnames "TRACED-" (get-funname-symbol funname)))
  140.                       (body
  141.                         `((declare (compile) (inline car cdr cons apply values-list))
  142.                           (let ((*trace-level* (trace-level-inc)))
  143.                             (block nil
  144.                               (unless ,suppress-if
  145.                                 (trace-pre-output)
  146.                               )
  147.                               ,@(when pre-print
  148.                                   `((trace-print (multiple-value-list ,pre-print)))
  149.                                 )
  150.                               ,@(when print
  151.                                   `((trace-print (multiple-value-list ,print)))
  152.                                 )
  153.                               ,pre
  154.                               ,@(when pre-break-if
  155.                                   `((when ,pre-break-if (sys::break-loop t)))
  156.                                 )
  157.                               (let ((*trace-values*
  158.                                       (multiple-value-list
  159.                                         (if ,step-if
  160.                                           (trace-step-apply)
  161.                                           (apply *trace-function* *trace-args*)
  162.                                    )) ) )
  163.                                 ,@(when post-break-if
  164.                                     `((when ,post-break-if (sys::break-loop t)))
  165.                                   )
  166.                                 ,post
  167.                                 ,@(when print
  168.                                     `((trace-print (multiple-value-list ,print)))
  169.                                   )
  170.                                 ,@(when post-print
  171.                                     `((trace-print (multiple-value-list ,post-print)))
  172.                                   )
  173.                                 (unless ,suppress-if
  174.                                   (trace-post-output)
  175.                                 )
  176.                                 (values-list *trace-values*)
  177.                          )) ) )
  178.                      ))
  179.                   `(if (not ,macro-flag)
  180.                      (function ,newname
  181.                        (lambda (&rest *trace-args*
  182.                                 &aux (*trace-form* (make-apply-form ',funname *trace-args*))
  183.                                      (*trace-function* (get-traced-definition ,symbolform))
  184.                                )
  185.                          ,@body
  186.                      ) )
  187.                      (cons 'sys::macro
  188.                        (function ,newname
  189.                          (lambda (&rest *trace-args*
  190.                                   &aux (*trace-form* (car *trace-args*))
  191.                                        (*trace-function* (cdr (get-traced-definition ,symbolform)))
  192.                                  )
  193.                            ,@body
  194.                      ) ) )
  195.                    )
  196.                 )
  197.        ) ) ) )
  198.        '(,funname)
  199.      )
  200. ) )
  201.  
  202. ;; Hilfsfunktionen:
  203. ; Funktionsreferenzen, die vom LABELS bei DEFUN kommen, ersetzen:
  204. (defun replace-in-fenv (fun funname old new)
  205.   (when (and (sys::closurep fun) (not (compiled-function-p fun)))
  206.     ; interpretierte Closure
  207.     (let ((fenv (sys::%record-ref fun 5))) ; Funktions-Environment
  208.       (when fenv ; falls nichtleer, durchlaufen:
  209.         (do ((l (length fenv)) ; l = 2 * Anzahl der Bindungen + 1
  210.              (i 1 (+ i 2)))
  211.             ((eql i l))
  212.           (when (and (equal (svref fenv (- i 1)) funname) (eq (svref fenv i) old))
  213.             (setf (svref fenv i) new)
  214.         ) )
  215. ) ) ) )
  216. ; Nächsthöheres Trace-Level liefern:
  217. (defun trace-level-inc ()
  218.   (%funcall '#,#'1+ *trace-level*)
  219. )
  220. ; Ursprüngliche Funktionsdefinition holen:
  221. (defun get-traced-definition (symbol)
  222.   (%funcall '#,#'get symbol 'sys::traced-definition)
  223. )
  224. ; Anwenden, aber durchsteppen:
  225. (defun trace-step-apply ()
  226.   ;(eval `(step (apply ',*trace-function* ',*trace-args*)))
  227.   (%funcall '#,#'eval
  228.     (cons 'step
  229.      (cons
  230.        (cons 'apply
  231.         (cons (cons 'quote (cons *trace-function* nil))
  232.          (cons (cons 'quote (cons *trace-args* nil))
  233.           nil
  234.        )))
  235.       nil
  236.     ))
  237.   )
  238. )
  239. ; Eval-Form bauen, die einem Apply (näherungsweise) entspricht:
  240. (defun make-apply-form (funname args)
  241.   (declare (inline cons mapcar))
  242.   (cons funname
  243.     (mapcar #'(lambda (arg)
  244.                 ;(list 'quote arg)
  245.                 (cons 'quote (cons arg nil))
  246.               )
  247.             args
  248.   ) )
  249. )
  250. ; Output vor Aufruf, benutzt *trace-level* und *trace-form*
  251. (defun trace-pre-output ()
  252.   (%funcall '#,#'terpri *trace-output*)
  253.   (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  254.   (%funcall '#,#'write-string " Trace: " *trace-output*)
  255.   (%funcall '#,#'prin1 *trace-form* *trace-output*)
  256. )
  257. ; Output nach Aufruf, benutzt *trace-level*, *trace-form* und *trace-values*
  258. (defun trace-post-output ()
  259.   (declare (inline car cdr consp atom))
  260.   (%funcall '#,#'terpri *trace-output*)
  261.   (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  262.   (%funcall '#,#'write-string " Trace: " *trace-output*)
  263.   (%funcall '#,#'write (car *trace-form*) :stream *trace-output*)
  264.   (%funcall '#,#'write-string " ==> " *trace-output*)
  265.   (trace-print *trace-values* nil)
  266. )
  267. ; Output einer Liste von Werten:
  268. (defun trace-print (vals &optional (nl-flag t))
  269.   (when nl-flag (%funcall '#,#'terpri *trace-output*))
  270.   (when (consp vals)
  271.     (loop
  272.       (let ((val (car vals)))
  273.         (%funcall '#,#'prin1 val *trace-output*)
  274.       )
  275.       (setq vals (cdr vals))
  276.       (when (atom vals) (return))
  277.       (%funcall '#,#'write-string ", " *trace-output*)
  278. ) ) )
  279.  
  280. (defmacro untrace (&rest funs)
  281.   `(mapcan #'untrace1 ,(if (null funs) `(copy-list *traced-functions*) `',funs))
  282. )
  283.  
  284. (defun untrace1 (funname)
  285.   (unless (function-name-p funname)
  286.     (error-of-type 'program-error
  287.       #L{
  288.       DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
  289.       ENGLISH "~S: function name should be a symbol, not ~S"
  290.       FRANCAIS "~S : Le nom de la fonction doit être un symbole et non ~S"
  291.       }
  292.       'untrace funname
  293.   ) )
  294.   (let* ((symbol (get-funname-symbol funname))
  295.          (old-definition (get symbol 'sys::traced-definition)))
  296.     (prog1
  297.       (if old-definition
  298.         ; symbol war getraced
  299.         (progn
  300.           (if (and (fboundp symbol)
  301.                    (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
  302.               )
  303.             (progn
  304.               (replace-in-fenv old-definition funname (symbol-function symbol) old-definition)
  305.               (setf (symbol-function symbol) old-definition)
  306.             )
  307.             (warn 
  308.              #L{
  309.              DEUTSCH "~S: ~S war getraced und wurde umdefiniert!"
  310.              ENGLISH "~S: ~S was traced and has been redefined!"
  311.              FRANCAIS "~S : ~S était tracée et a été redéfinie!"
  312.              }
  313.              'untrace funname
  314.           ) )
  315.           `(,funname)
  316.         )
  317.         ; funname war nicht getraced
  318.         '()
  319.       )
  320.       (untrace2 funname)
  321. ) ) )
  322.  
  323. (defun untrace2 (funname)
  324.   (let ((symbol (get-funname-symbol funname)))
  325.     (remprop symbol 'sys::traced-definition)
  326.     (remprop symbol 'sys::tracing-definition)
  327.   )
  328.   (setq *traced-functions* (delete funname *traced-functions* :test #'equal))
  329. )
  330.  
  331.