一个很有趣的用于调试函数代码的函数 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)
’())))