指定した関数の機能を置きかえる手段を提供します。
特定ファイルの名前を固定したり、正規表現で表示を抑制したりします。
(defvar *my-sticking-files* '("~/memo")) ; 固定するファイルのリスト
(defvar *my-recent-files-mask* '("\\.bak$")) ; 表示を抑制するための正規表現のリスト
(encapsulate 'add-file-history-to-menu
'stick
'(let* ((history
(remove-if #'(lambda (fn)
(or
(member fn (mapcar #'namestring *my-sticking-files*) :test #'string-equal)
(member-if #'(lambda (re)
(string-matchp re fn))
*my-recent-files-mask*)))
*minibuffer-file-name-history*))
(*minibuffer-file-name-history* (append *my-sticking-files* history)))
(apply basic-definition argument-list)))
指定した関数の実行時の引数と戻り値を"*Trace Output*"バッファに出力します。
;;; trace.l
; (trace function1 function2 ...) makes the functions `traced'.
; (trace) returns `traced' functions.
; (untrace function1 function2 ...) makes the functions `untraced'.
; (untrace) makes all `traced' functions `untraced'.
(require "encap")
(defvar *trace-function-list* nil)
(defvar *trace-depth* 0)
(defun trace-encap (func)
(unless (encapsulated-p func 'traced-function)
(encapsulate func 'traced-function
`((ed::setup-trace-output-buffer)
(setq *trace-depth* (1+ *trace-depth*))
(format *error-output* "~ACalling ~S~%" (make-sequence 'string *trace-depth* :initial-element #\SPC) (cons ',func argument-list))
(let ((#1=#:result (multiple-value-list (apply basic-definition argument-list))))
(format *error-output* "~A~S returned~{ ~A~}~%" (make-sequence 'string *trace-depth* :initial-element #\SPC) ',func #1#)
(setq *trace-depth* (1- *trace-depth*))
(values-list #1#))))
(push func *trace-function-list*)
func))
(defun trace-unencap (func)
(when (encapsulated-p func 'traced-function)
(unencapsulate func 'traced-function)
(setq *trace-function-list* (remove func *trace-function-list* :test #'eq))
func))
(defmacro trace (&rest args)
(if (null args)
'*trace-function-list*
`(let (lst)
(dolist (func ',args (reverse lst))
(when (trace-encap func)
(setq lst (cons func lst)))))))
(defmacro untrace (&rest args)
(if (null args)
'(let (lst)
(dolist (func *trace-function-list* lst)
(when (trace-unencap func)
(setq lst (cons func lst)))))
`(let (lst)
(dolist (func ',args (reverse lst))
(when (trace-unencap func)
(setq lst (cons func lst)))))))
;;; trace.l ends here.
簡単プロファイラです。呼出し回数や実行時間を計測しますが厳密じゃないです。
;;; profile.l
; (profile function1 function2 ...) makes the functions `profiled'.
; (profile) returns `profiled' functions.
; (unprofile function1 function2 ...) makes the functions `unprofiled'.
; (unprofile) makes all `profiled' functions `unprofiled'.
; (profile-clear) clears profile results.
; (profile-results) shows profile results.
(require "encap")
(defvar *profile-function-list* nil)
(defvar *profile-results* nil)
(unless *profile-results*
(setq *profile-results* (make-hash-table :test #'eq)))
(defun profile-record (func time)
(let ((result (gethash func *profile-results*)))
(if result
(progn
(setf (car result) (1+ (car result)))
(setf (cdr result) (+ time (cdr result))))
(setf (gethash func *profile-results*)
(cons 1 time)))))
(defun profile-encap (func)
(unless (encapsulated-p func 'profiled-function)
(encapsulate func 'profiled-function
`(let ((#1=#:begin (get-internal-real-time)))
(multiple-value-prog1
(apply basic-definition argument-list)
(profile-record ',func (- (get-internal-real-time) #1#)))))
(push func *profile-function-list*)
func))
(defun profile-unencap (func)
(when (encapsulated-p func 'profiled-function)
(unencapsulate func 'profiled-function)
(remhash func *profile-results*)
(setq *profile-function-list* (remove func *profile-function-list* :test #'eq))
func))
(defun profile-results ()
(let ((max (apply #'max (cons 8 (mapcar #'(lambda (x) (length (format nil "~S" x))) *profile-function-list*)))))
(insert (format nil (format nil "~~~D@A Calls Total time (msec) Avg time/call~~%" max) "Function"))
(insert (make-sequence 'string max :initial-element #\=) " ====== ================= =============" #\LFD)
(let ((fmt (format nil "~~~D@S ~~6D ~~17D ~~13F~~%" max)))
(mapc #'(lambda (func)
(let ((result (gethash func *profile-results*)))
(if result
(insert (format nil fmt func (car result) (cdr result) (/ (cdr result) (car result))))
(insert (format nil fmt func 0 0 0)))))
(mapcar #'(lambda (x) (car x))
(sort (mapcar #'(lambda (x)
(let ((result (gethash x *profile-results*)))
(if result
(cons x (cdr result))
(cons x 0))))
*profile-function-list*)
#'>
:key #'cdr))))
t))
(defun profile-clear ()
(clrhash *profile-results*)
t)
(defmacro profile (&rest args)
(if (null args)
'*profile-function-list*
`(let (lst)
(dolist (func ',args (reverse lst))
(when (profile-encap func)
(setq lst (cons func lst)))))))
(defmacro unprofile (&rest args)
(if (null args)
'(let (lst)
(dolist (func *profile-function-list* (reverse lst))
(when (profile-unencap func)
(setq lst (cons func lst)))))
`(let (lst)
(dolist (func ',args (reverse lst))
(when (profile-unencap func)
(setq lst (cons func lst)))))))
;;; profile.l ends here.