一個頗有趣的用於調試函數代碼的函數 dtrace.lisp

一個頗有趣的用於調試函數代碼的函數 dtrace.lisp，來自這本書《COMMON LISP:A Gentle Introduction to Symbolic Computation》。

Common Lisp 中原來就有一個跟蹤函數 trace，使用時把你要跟蹤的函數名稱做爲參數，而後你的函數就能夠顯示一些內部信息了。

dtrace 則使用了一些更形象的符號，看起來好像稍微直觀了一些，我把原來的符號改爲了用製表符，效果以下：

CL-USER> (defun 迭代 (積 次數 最大次數)
            (if (> 次數 最大次數)
                積
                (迭代 (* 次數 積)
                      (+ 次數 1)
                      最大次數)))
迭代
CL-USER> (defun 階乘 (數)
            (迭代 1 1 數))
階乘
CL-USER> (階乘 5)
120

這裏定義了兩個用於求階乘的函數，接下來爲這兩個函數創建跟蹤，創建好跟蹤以後執行該函數，命令以下：

    CL-USER> (dtrace 階乘 迭代)
    (階乘 迭代)
    CL-USER> (階乘 15)
    ┌─── [進入-> 階乘
    │      數 = 15
    │    ┌─── [進入-> 迭代
    │    │      積 = 1
    │    │      次數 = 1
    │    │      最大次數 = 15
    │    └─── 迭代 <-返回] 1307674368000
    └─── 階乘 <-返回] 1307674368000
    1307674368000
    CL-USER>

是否是感受挺好玩，這裏是 dtracez.lisp 的源代碼：

;;; -*- Mode: Lisp; Package: DTRACE -*-
;;; DTRACE is a portable alternative to the Common Lisp TRACE and UNTRACE
;;; macros.  It offers a more detailed display than most tracing tools.
;;;
;;; From the book "Common Lisp:  A Gentle Introduction to
;;;      Symbolic Computation" by David S. Touretzky.
;;; The Benjamin/Cummings Publishing Co., 1989.
;;;
;;; User-level routines:
;;;   DTRACE  - same syntax as TRACE
;;;   DUNTRACE - same syntax as UNTRACE
;(in-package "DTRACE" :use "LISP")
#|(export ’(dtrace::dtrace dtrace::duntrace
          *dtrace-print-length* *dtrace-print-level*
          *dtrace-print-circle* *dtrace-print-pretty*
          *dtrace-print-array*))
(shadowing-import ’(dtrace::dtrace dtrace::duntrace) (find-package "USER"))
(use-package "DTRACE" "USER")
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DTRACE and subordinate routines.
(defparameter *dtrace-print-length* 7)
(defparameter *dtrace-print-level*  4)
(defparameter *dtrace-print-circle* t)
(defparameter *dtrace-print-pretty* nil)
(defparameter *dtrace-print-array* *print-array*)
(defparameter *entry-arrow-string* "┌─── ")
(defparameter *vertical-string*    "│    ")
(defparameter *exit-arrow-string*  "└─── ")
(defparameter *trace-wraparound* 15)
(defvar *traced-functions* nil)
(defvar *trace-level* 0)
(defmacro with-dtrace-printer-settings (&body body)
  `(let ((*print-length* *dtrace-print-length*)
         (*print-level* *dtrace-print-level*)
         (*print-circle* *dtrace-print-circle*)
         (*print-pretty* *dtrace-print-pretty*)
         (*print-array* *dtrace-print-array*))
     ,@body))
(defmacro dtrace (&rest function-names)
  "Turns on detailed tracing for specified functions.  Undo with DUNTRACE."
  (if (null function-names)
      (list `quote *traced-functions*)
      (list `quote (mapcan #'dtrace1 function-names))))
(defun dtrace1 (name)
  (unless (symbolp name)
    (format *error-output* "~&~S is an invalid function name." name)
    (return-from dtrace1 nil))
  (unless (fboundp name)
    (format *error-output* "~&~S undefined function." name)
    (return-from dtrace1 nil))
  (eval `(untrace ,name))       ;; if they’re tracing it, undo their trace
  (duntrace1 name)              ;; if we’re tracing it, undo our trace
  (when (special-form-p name)
    (format *error-output*
            "~&Can’t trace ~S because it’s a special form." name)
    (return-from dtrace1 nil))
  (if (macro-function name)
      (trace-macro name)
      (trace-function1 name))
  (setf *traced-functions* (nconc *traced-functions* (list name)))
  (list name))
;;; The functions below reference DISPLAY-xxx routines that can be made
;;; implementation specific for fancy graphics.  Generic versions of
;;; these routines are defined later in this file.
(defun trace-function1 (name)
  (let* ((formal-arglist (fetch-arglist name))
         (old-defn (symbol-function name))
         (new-defn
          #'(lambda (&rest argument-list)
              (let ((result nil))
                (display-function-entry name)
                (let ((*trace-level* (1+ *trace-level*)))
                  (with-dtrace-printer-settings
                   (show-function-args argument-list formal-arglist))
                  (setf result (multiple-value-list
                                (apply old-defn argument-list))))
                (display-function-return name result)
                (values-list result)))))
    (setf (get name `original-definition) old-defn)
    (setf (get name `traced-definition) new-defn)
    (setf (get name `traced-type) `defun)
    (setf (symbol-function name) new-defn)))
(defun trace-macro (name)
  (let* ((formal-arglist (fetch-arglist name))
         (old-defn (macro-function name))
         (new-defn
          #'(lambda (macro-args env)
              (let ((result nil))
                (display-function-entry name `macro)
                (let ((*trace-level* (1+ *trace-level*)))
                  (with-dtrace-printer-settings
                   (show-function-args macro-args formal-arglist))
                  (setf result (funcall old-defn macro-args env)))
        (display-function-return name (list result) `macro)
                (values result)))))
    (setf (get name `original-definition) old-defn)
    (setf (get name `traced-definition) new-defn)
    (setf (get name `traced-type) `defmacro)
    (setf (macro-function name) new-defn)))
(defun show-function-args (actuals formals &optional (argcount 0))
  (cond ((null actuals) nil)
        ((null formals) (handle-args-numerically actuals argcount))
        (t (case (first formals)
             (&optional (show-function-args
                         actuals (rest formals) argcount))
             (&rest (show-function-args
                     (list actuals) (rest formals) argcount))
             (&key (handle-keyword-args actuals))
             (&aux (show-function-args actuals nil argcount))
             (t (handle-one-arg (first actuals) (first formals))
                (show-function-args (rest actuals)
                                    (rest formals)
                                    (1+ argcount)))))))
(defun handle-args-numerically (actuals argcount)
  (dolist (x actuals)
    (incf argcount)
    (display-arg-numeric x argcount)))
(defun handle-one-arg (val varspec)
  (cond ((atom varspec) (display-one-arg val varspec))
        (t (display-one-arg val (first varspec))
           (if (third varspec)
               (display-one-arg t (third varspec))))))
(defun handle-keyword-args (actuals)
  (cond ((null actuals))
        ((keywordp (first actuals))
         (display-one-arg (second actuals) (first actuals))
         (handle-keyword-args (rest (rest actuals))))
        (t (display-one-arg actuals "Extra args:"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DUNTRACE and subordinate routines.
(defmacro duntrace (&rest function-names)
  "Turns off tracing for specified functions.
   With no args, turns off all tracing."
  (setf *trace-level* 0)  ;; safety precaution
  (list `quote
        (mapcan #'duntrace1 (or function-names *traced-functions*))))
(defun duntrace1 (name)
  (unless (symbolp name)
    (format *error-output* "~&~S is an invalid function name." name)
    (return-from duntrace1 nil))
  (setf *traced-functions* (delete name *traced-functions*))
  (let ((orig-defn (get name `original-definition `none))
        (traced-defn (get name `traced-definition))
        (traced-type (get name `traced-type `none)))
    (unless (or (eq orig-defn `none)
                (not (fboundp name))
                (not (equal traced-defn  ;; did it get redefined?
                         (ecase traced-type
                           (defun (symbol-function name))
                           (defmacro (macro-function name))))))
      (ecase traced-type
        (defun (setf (symbol-function name) orig-defn))
        (defmacro (setf (macro-function name) orig-defn)))))
  (remprop name `traced-definition)
  (remprop name `traced-type)
  (remprop name `original-definition)
  (list name))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Display routines.
;;;
;;; The code below generates vanilla character output for ordinary
;;; displays.  It can be replaced with special graphics code if the
;;; implementation permits, e.g., on a PC you can use the IBM graphic
;;; character set to draw nicer-looking arrows.  On a color PC you
;;; can use different colors for arrows, for function names, for
;;; argument values, and so on.
(defun display-function-entry (name &optional ftype)
  (space-over)
  (draw-entry-arrow)
  (format *trace-output* "[進入-> ~S" name)
  (if (eq ftype `macro)
      (format *trace-output* " macro")))
(defun display-one-arg (val name)
  (space-over)
  (format *trace-output*
          (typecase name
            (keyword "  ~S ~S")
            (string  "  ~A ~S")
            (t "  ~S = ~S"))
name val))
(defun display-arg-numeric (val num)
  (space-over)
  (format *trace-output* "  參數-~D = ~S" num val))
(defun display-function-return (name results &optional ftype)
  (with-dtrace-printer-settings
    (space-over)
    (draw-exit-arrow)
    (format *trace-output* "~S ~A"
	    name
            (if (eq ftype `macro) "[展開->" "<-返回]"))
    (cond ((null results))
          ((null (rest results))
           (format *trace-output* " ~S" (first results)))
          (t (format *trace-output* " values ~{~S, ~}~s"
                     (butlast results)
                     (car (last results)))))))
(defun space-over ()
  (format *trace-output* "~&")
  (dotimes (i (mod *trace-level* *trace-wraparound*))
    (format *trace-output* "~A" *vertical-string*)))
(defun draw-entry-arrow ()
  (format *trace-output* "~A" *entry-arrow-string*))
(defun draw-exit-arrow ()
  (format *trace-output* "~A" *exit-arrow-string*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The function FETCH-ARGLIST is implementation dependent.  It
;;; returns the formal argument list of a function as it would
;;; appear in a DEFUN or lambda expression, including any lambda
;;; list keywords.  Here are versions of FETCH-ARGLIST for three
;;; Lisp implementations.
;;; CCL version
#+ccl
(defun fetch-arglist (fn)
  (arglist fn))
;;; Lucid version
#+LUCID
  (defun fetch-arglist (fn)
    (system::arglist fn))
;;; GCLisp 3.1 version
#+GCLISP
(defun fetch-arglist (name)
  (let* ((s (sys:lambda-list name))
         (a (read-from-string s)))
    (if s
        (if (eql (elt s 0) #\Newline)
            (edit-arglist (rest a))
            a))))
#+GCLISP
(defun edit-arglist (arglist)
  (let ((result nil)
        (skip-non-keywords nil))
    (dolist (arg arglist (nreverse result))
      (unless (and skip-non-keywords
                   (symbolp arg)
                   (not (keywordp arg)))
        (push arg result))
      (if (eq arg ’&key) (setf skip-non-keywords t)))))
;;; CMU Common Lisp version.  This version looks in a symbol’s
;;; function cell and knows how to take apart lexical closures
;;; and compiled code objects found there.
#+cmu
  (defun fetch-arglist (x &optional original-x)
    (cond ((symbolp x) (fetch-arglist (symbol-function x) x))
          ((compiled-function-p x)
           (read-from-string
            (lisp::%primitive header-ref x
                              lisp::%function-arg-names-slot)))
          ((listp x) (case (first x)
                       (lambda (second x))
                       (%lexical-closure% (fetch-arglist (second x)))
                       (system:macro ’(&rest "Form ="))
                       (t ’(&rest "Arglist:"))))
          (t (cerror (format nil
                        "Use a reasonable default argument list for ~S"
                        original-x)
                "Unkown object in function cell of ~S:  ~S" original-x x)
’())))