;; Tracer
;; Bruno Haible 13.2.1990, 15.3.1991, 4.4.1991

; (TRACE) liefert Liste der getraceten Funktionen
; (TRACE fun ...) tracet die Funktionen fun, ... zusätzlich.
; Format für fun:
;   Entweder ein Symbol
;        symbol
;   oder eine Liste aus einem Symbol und einigen Keyword-Argumenten (paarig!)
;        (symbol
;          [:suppress-if form]   ; kein Trace-Output, solange form erfüllt ist
;          [:step-if form]       ; Trace geht in den Stepper, falls form erfüllt
;          [:pre form]           ; führt vor Funktionsaufruf form aus
;          [:post form]          ; führt nach Funktionsaufruf form aus
;          [:pre-break-if form]  ; Trace geht vor Funktionsaufruf in die Break-Loop,
;                                ; falls form erfüllt
;          [:post-break-if form] ; Trace geht nach Funktionsaufruf in die Break-Loop,
;                                ; falls form erfüllt
;          [:pre-print form]     ; gibt die Werte von form vor Funktionsaufruf aus
;          [:post-print form]    ; gibt die Werte von form nach Funktionsaufruf aus
;          [:print form]         ; gibt die Werte von form vor und nach Funktionsaufruf aus
;        )
;   In all diesen Formen kann auf *TRACE-FUNCTION* (die Funktion selbst)
;   und *TRACE-ARGS* (die Argumente an die Funktion)
;   und *TRACE-FORM* (der Funktions-/Macro-Aufruf als Form)
;   und nach Funktionsaufruf auch auf *TRACE-VALUES* (die Liste der Werte
;   des Funktionsaufrufs) zugegriffen werden,
;   und mit RETURN kann der Aufruf mit gegebenen Werten verlassen werden.
; (UNTRACE) liefert Liste der getraceten Funktionen, streicht sie alle.
; (UNTRACE symbol ...) streicht symbol, ... aus der Liste der getraceten
;   Funktionen.
; TRACE und UNTRACE sind auch auf Funktionen (SETF symbol) und auf Macros anwendbar,
;   nicht jedoch auf lokal definierte Funktionen und Macros.

(in-package "LISP")
(export '(trace untrace
          *trace-function* *trace-args* *trace-form* *trace-values*
)        )
(in-package "SYSTEM")

(proclaim '(special *trace-function* *trace-args* *trace-form* *trace-values*))
(defvar *traced-functions* nil) ; Liste der momentan getraceden Funktionsnamen
  ; Solange ein Funktionsname funname [bzw. genauer: das Symbol
  ; symbol = (get-funname-symbol funname)] getraced ist, enthält
  ; die Property sys::traced-definition den alten Inhalt der Funktionszelle,
  ; die Property sys::tracing-definition den neuen Inhalt der Funktionszelle,
  ; und ist der Funktionsname Element der Liste *traced-functions*.
  ; Währenddessen kann sich der Inhalt der Funktionszelle jedoch ändern!
  ; Jedenfalls gilt stets:
  ;        (and (fboundp symbol)
  ;             (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
  ;        )
  ; ===>   (member funname *traced-functions* :test #'equal)
  ; <==>   (get symbol 'sys::traced-definition)
(defvar *trace-level* 0) ; Verschachtelungstiefe bei der Trace-Ausgabe

; Funktionen, die der Tracer zur Laufzeit aufruft und die der Benutzer
; tracen könnte, müssen in ihrer ungetraceden Form aufgerufen werden.
; Statt (fun arg ...) verwende daher (SYS::%FUNCALL '#,#'fun arg ...)
; oder (SYS::%FUNCALL (LOAD-TIME-VALUE #'fun) arg ...).
; Dies gilt für alle hier verwendeten Funktionen von #<PACKAGE LISP> außer
; CAR, CDR, CONS, APPLY, VALUES-LIST (die alle inline compiliert werden).

(defmacro trace (&rest funs)
  (if (null funs)
    '*traced-functions*
    (cons 'append
      (mapcar #'(lambda (fun)
                  (if (or (atom fun) (function-name-p fun))
                    (trace1 fun)
                    (apply #'trace1 fun)
                ) )
              funs
    ) )
) )

(defun trace1 (funname &key (suppress-if nil) (step-if nil)
                            (pre nil) (post nil)
                            (pre-break-if nil) (post-break-if nil)
                            (pre-print nil) (post-print nil) (print nil)
                       &aux (old-function (gensym)) (macro-flag (gensym))
              )
  (unless (function-name-p funname)
    (error-of-type 'program-error
      (DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
       ENGLISH "~S: function name should be a symbol, not ~S"
       FRANCAIS "~S : Le nom de la fonction doit être un symbole et non ~S")
      'trace funname
  ) )
  (let ((symbolform
          (if (atom funname)
            `',funname
            `(load-time-value (get-setf-symbol ',(second funname)))
       )) )
    `(block nil
       (unless (fboundp ,symbolform) ; Funktion überhaupt definiert?
         (warn (DEUTSCH "~S: Funktion ~S ist nicht definiert."
                ENGLISH "~S: undefined function ~S"
                FRANCAIS "~S : La fonction ~S n'est pas définie.")
               'trace ',funname
         )
         (return nil)
       )
       (when (special-form-p ,symbolform) ; Special-Form: nicht tracebar
         (warn (DEUTSCH "~S: Special-Form ~S kann nicht getraced werden."
                ENGLISH "~S: cannot trace special form ~S"
                FRANCAIS "~S : La forme spéciale ~S ne peut pas être tracée.")
               'trace ',funname
         )
         (return nil)
       )
       (let* ((,old-function (symbol-function ,symbolform))
              (,macro-flag (consp ,old-function)))
         (unless (eq ,old-function (get ,symbolform 'sys::tracing-definition)) ; schon getraced?
           (setf (get ,symbolform 'sys::traced-definition) ,old-function)
           (pushnew ',funname *traced-functions* :test #'equal)
         )
         (format t (DEUTSCH "~&;; ~:[Funktion~;Macro~] ~S wird getraced."
                    ENGLISH "~&;; Tracing ~:[function~;macro~] ~S."
                    FRANCAIS "~&;; Traçage ~:[de la fonction~;du macro~] ~S.")
                   ,macro-flag ',funname
         )
         (replace-in-fenv (get ,symbolform 'sys::traced-definition) ',funname
           ,old-function
           (setf (get ,symbolform 'sys::tracing-definition)
             (setf (symbol-function ,symbolform)
               ; neue Funktion, die die ursprüngliche ersetzt:
               ,(let ((newname (concat-pnames "TRACED-" (get-funname-symbol funname)))
                      (body
                        `((declare (compile) (inline car cdr cons apply values-list))
                          (let ((*trace-level* (trace-level-inc)))
                            (block nil
                              (unless ,suppress-if
                                (trace-pre-output)
                              )
                              ,@(when pre-print
                                  `((trace-print (multiple-value-list ,pre-print)))
                                )
                              ,@(when print
                                  `((trace-print (multiple-value-list ,print)))
                                )
                              ,pre
                              ,@(when pre-break-if
                                  `((when ,pre-break-if (sys::break-loop t)))
                                )
                              (let ((*trace-values*
                                      (multiple-value-list
                                        (if ,step-if
                                          (trace-step-apply)
                                          (apply *trace-function* *trace-args*)
                                   )) ) )
                                ,@(when post-break-if
                                    `((when ,post-break-if (sys::break-loop t)))
                                  )
                                ,post
                                ,@(when print
                                    `((trace-print (multiple-value-list ,print)))
                                  )
                                ,@(when post-print
                                    `((trace-print (multiple-value-list ,post-print)))
                                  )
                                (unless ,suppress-if
                                  (trace-post-output)
                                )
                                (values-list *trace-values*)
                         )) ) )
                     ))
                  `(if (not ,macro-flag)
                     (function ,newname
                       (lambda (&rest *trace-args*
                                &aux (*trace-form* (make-apply-form ',funname *trace-args*))
                                     (*trace-function* (get-traced-definition ,symbolform))
                               )
                         ,@body
                     ) )
                     (cons 'sys::macro
                       (function ,newname
                         (lambda (&rest *trace-args*
                                  &aux (*trace-form* (car *trace-args*))
                                       (*trace-function* (cdr (get-traced-definition ,symbolform)))
                                 )
                           ,@body
                     ) ) )
                   )
                )
       ) ) ) )
       '(,funname)
     )
) )

;; Hilfsfunktionen:
; Funktionsreferenzen, die vom LABELS bei DEFUN kommen, ersetzen:
(defun replace-in-fenv (fun funname old new)
  (when (and (sys::closurep fun) (not (compiled-function-p fun)))
    ; interpretierte Closure
    (let ((fenv (sys::%record-ref fun 5))) ; Funktions-Environment
      (when fenv ; falls nichtleer, durchlaufen:
        (do ((l (length fenv)) ; l = 2 * Anzahl der Bindungen + 1
             (i 1 (+ i 2)))
            ((eql i l))
          (when (and (equal (svref fenv (- i 1)) funname) (eq (svref fenv i) old))
            (setf (svref fenv i) new)
        ) )
) ) ) )
; Nächsthöheres Trace-Level liefern:
(defun trace-level-inc ()
  (%funcall '#,#'1+ *trace-level*)
)
; Ursprüngliche Funktionsdefinition holen:
(defun get-traced-definition (symbol)
  (%funcall '#,#'get symbol 'sys::traced-definition)
)
; Anwenden, aber durchsteppen:
(defun trace-step-apply ()
  ;(eval `(step (apply ',*trace-function* ',*trace-args*)))
  (%funcall '#,#'eval
    (cons 'step
     (cons
       (cons 'apply
        (cons (cons 'quote (cons *trace-function* nil))
         (cons (cons 'quote (cons *trace-args* nil))
          nil
       )))
      nil
    ))
  )
)
; Eval-Form bauen, die einem Apply (näherungsweise) entspricht:
(defun make-apply-form (funname args)
  (declare (inline cons mapcar))
  (cons funname
    (mapcar #'(lambda (arg)
                ;(list 'quote arg)
                (cons 'quote (cons arg nil))
              )
            args
  ) )
)
; Output vor Aufruf, benutzt *trace-level* und *trace-form*
(defun trace-pre-output ()
  (%funcall '#,#'terpri *trace-output*)
  (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  (%funcall '#,#'write-string " Trace: " *trace-output*)
  (%funcall '#,#'prin1 *trace-form* *trace-output*)
)
; Output nach Aufruf, benutzt *trace-level*, *trace-form* und *trace-values*
(defun trace-post-output ()
  (declare (inline car cdr consp atom))
  (%funcall '#,#'terpri *trace-output*)
  (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  (%funcall '#,#'write-string " Trace: " *trace-output*)
  (%funcall '#,#'write (car *trace-form*) :stream *trace-output*)
  (%funcall '#,#'write-string " ==> " *trace-output*)
  (trace-print *trace-values* nil)
)
; Output einer Liste von Werten:
(defun trace-print (vals &optional (nl-flag t))
  (when nl-flag (%funcall '#,#'terpri *trace-output*))
  (when (consp vals)
    (loop
      (let ((val (car vals)))
        (%funcall '#,#'prin1 val *trace-output*)
      )
      (setq vals (cdr vals))
      (when (atom vals) (return))
      (%funcall '#,#'write-string ", " *trace-output*)
) ) )

(defmacro untrace (&rest funs)
  `(mapcan #'untrace1 ,(if (null funs) `(copy-list *traced-functions*) `',funs))
)

(defun untrace1 (funname)
  (unless (function-name-p funname)
    (error-of-type 'program-error
      (DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
       ENGLISH "~S: function name should be a symbol, not ~S"
       FRANCAIS "~S : Le nom de la fonction doit être un symbole et non ~S")
      'untrace funname
  ) )
  (let* ((symbol (get-funname-symbol funname))
         (old-definition (get symbol 'sys::traced-definition)))
    (prog1
      (if old-definition
        ; symbol war getraced
        (progn
          (if (and (fboundp symbol)
                   (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
              )
            (progn
              (replace-in-fenv old-definition funname (symbol-function symbol) old-definition)
              (setf (symbol-function symbol) old-definition)
            )
            (warn (DEUTSCH "~S: ~S war getraced und wurde umdefiniert!"
                   ENGLISH "~S: ~S was traced and has been redefined!"
                   FRANCAIS "~S : ~S était tracée et a été redéfinie!")
                  'untrace funname
          ) )
          `(,funname)
        )
        ; funname war nicht getraced
        '()
      )
      (untrace2 funname)
) ) )

(defun untrace2 (funname)
  (let ((symbol (get-funname-symbol funname)))
    (remprop symbol 'sys::traced-definition)
    (remprop symbol 'sys::tracing-definition)
  )
  (setq *traced-functions* (delete funname *traced-functions* :test #'equal))
)

