[slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-sbcl.lisp slime/swank-lispworks.lisp slime/swank-allegro.lisp
Helmut Eller
heller at common-lisp.net
Mon Feb 28 23:32:09 UTC 2005
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv6997
Modified Files:
swank-cmucl.lisp swank-sbcl.lisp swank-lispworks.lisp
swank-allegro.lisp
Log Message:
(toggle-trace): Update tracing code for new interface.
Date: Tue Mar 1 00:32:06 2005
Author: heller
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.139 slime/swank-cmucl.lisp:1.140
--- slime/swank-cmucl.lisp:1.139 Sat Feb 26 11:39:22 2005
+++ slime/swank-cmucl.lisp Tue Mar 1 00:32:06 2005
@@ -898,7 +898,8 @@
(let ((macro? (and (symbolp name) (macro-function name)))
(special? (and (symbolp name) (special-operator-p name)))
(function? (and (ext:valid-function-name-p name)
- (ext:info :function :definition name))))
+ (ext:info :function :definition name)
+ (if (symbolp name) (fboundp name) t))))
(cond (macro?
(list `((defmacro ,name)
,(function-location (macro-function name)))))
@@ -1329,6 +1330,9 @@
(symbol-function name))))
(defimplementation arglist ((fun function))
+ (function-arglist fun))
+
+(defun function-arglist (fun)
(let ((arglist
(cond ((eval:interpreted-function-p fun)
(eval:interpreted-function-arglist fun))
@@ -1750,6 +1754,9 @@
(let ((values (breakpoint-values breakpoint)))
(brk values "Return value: ~{~S ~}" values)))
(t
+ #+(or)
+ (when (eq (di:code-location-kind what) :call-site)
+ (call-site-function breakpoint frame))
(brk nil "Breakpoint: ~S ~S"
(di:code-location-kind what)
(di::compiled-code-location-pc what)))))
@@ -2181,44 +2188,44 @@
;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
;; <name> can be a normal name or a (setf name)
-(defun toggle-trace (fspec &rest args)
- (cond ((member fspec (eval '(trace)) :test #'equal)
- (eval `(untrace ,fspec))
- (format nil "~S is now untraced." fspec))
- (t
- (eval `(trace ,fspec , at args))
- (format nil "~S is now traced." fspec))))
+(defun tracedp (spec)
+ (member spec (eval '(trace)) :test #'equal))
-(defimplementation toggle-trace-generic-function-methods (name)
- (cond ((member name (eval '(trace)) :test #'equal)
- (eval `(untrace ,name))
- (eval `(untrace :methods ',name))
- (format nil "~S is now untraced." name))
+(defun toggle-trace-aux (spec &rest options)
+ (cond ((tracedp spec)
+ (eval `(untrace ,spec))
+ (format nil "~S is now untraced." spec))
(t
- (eval `(trace ,name))
- (eval `(trace :methods ',name))
- (format nil "~S is now traced." name))))
+ (eval `(trace ,spec , at options))
+ (format nil "~S is now traced." spec))))
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defgeneric)
+ (let ((name (second spec)))
+ (toggle-trace-aux name :methods name)))
+ ((:defmethod)
+ (toggle-trace-aux `(method ,(cdr spec)))
+ ;; Man, is this ugly
+ (toggle-trace-aux `(pcl::fast-method ,(cdr spec))))
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux (process-fspec callee)
+ :wherein (list (process-fspec caller)))))))
(defun process-fspec (fspec)
(cond ((consp fspec)
(ecase (first fspec)
((:defun :defgeneric) (second fspec))
- ((:defmethod) `(method ,@(rest fspec)))
+ ((:defmethod)
+ `(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
+ ;; this isn't actually supported
((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
(t
fspec)))
-
-(defimplementation toggle-trace-function (spec)
- (toggle-trace spec))
-
-#+cmu19
-(defimplementation toggle-trace-method (spec)
- (toggle-trace `(pcl:fast-method ,@(rest (process-fspec spec)))))
-
-#+cmu19
-(defimplementation toggle-trace-fdefinition-wherein (name wherein)
- (toggle-trace name :wherein (process-fspec wherein)))
;; Local Variables:
;; pbook-heading-regexp: "^;;;\\(;+\\)"
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.118 slime/swank-sbcl.lisp:1.119
--- slime/swank-sbcl.lisp:1.118 Thu Feb 24 19:10:02 2005
+++ slime/swank-sbcl.lisp Tue Mar 1 00:32:06 2005
@@ -944,7 +944,7 @@
;; (trace (method <name> <qualifier>? (<specializer>+)))
;; <name> can be a normal name or a (setf name)
-(defun toggle-trace (fspec &rest args)
+(defun toggle-trace-aux (fspec &rest args)
(cond ((member fspec (eval '(trace)) :test #'equal)
(eval `(untrace ,fspec))
(format nil "~S is now untraced." fspec))
@@ -952,9 +952,6 @@
(eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec , at args))
(format nil "~S is now traced." fspec))))
-(defimplementation toggle-trace-generic-function-methods (name)
- (toggle-trace name :methods t))
-
(defun process-fspec (fspec)
(cond ((consp fspec)
(ecase (first fspec)
@@ -965,11 +962,14 @@
(t
fspec)))
-(defimplementation toggle-trace-function (spec)
- (toggle-trace spec))
-
-(defimplementation toggle-trace-method (spec)
- (toggle-trace `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
-
-(defimplementation toggle-trace-fdefinition-wherein (name wherein)
- (toggle-trace name :wherein (process-fspec wherein)))
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defmethod)
+ (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
+ ((:defgeneric)
+ (toggle-trace-aux (second spec) :methods t))
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.66 slime/swank-lispworks.lisp:1.67
--- slime/swank-lispworks.lisp:1.66 Thu Feb 24 19:08:59 2005
+++ slime/swank-lispworks.lisp Tue Mar 1 00:32:06 2005
@@ -533,8 +533,9 @@
(defxref who-calls hcl:who-calls)
(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
-(defxref list-callees hcl:calls-who)
+(defxref calls-who hcl:calls-who)
(defxref list-callers list-callers-internal)
+(defxref list-callees list-callees-internal)
(defun list-callers-internal (name)
(let ((callers (make-array 100
@@ -608,12 +609,12 @@
(defun parse-fspec (fspec)
"Return a dspec for FSPEC."
(ecase (car fspec)
- (:defmethod `(method ,@(cdr fspec)))))
+ ((:defmethod) `(method ,(cdr fspec)))))
(defun tracedp (dspec)
(member dspec (eval '(trace)) :test #'equal))
-(defun toggle-trace (dspec)
+(defun toggle-trace-aux (dspec)
(cond ((tracedp dspec)
(eval `(untrace ,dspec))
(format nil "~S is now untraced." dspec))
@@ -621,8 +622,8 @@
(eval `(trace (,dspec)))
(format nil "~S is now traced." dspec))))
-(defimplementation toggle-trace-method (fspec)
- (toggle-trace (parse-fspec fspec)))
+(defimplementation toggle-trace (fspec)
+ (toggle-trace-aux (parse-fspec fspec)))
;;; Multithreading
Index: slime/swank-allegro.lisp
diff -u slime/swank-allegro.lisp:1.69 slime/swank-allegro.lisp:1.70
--- slime/swank-allegro.lisp:1.69 Tue Feb 22 07:27:17 2005
+++ slime/swank-allegro.lisp Tue Mar 1 00:32:06 2005
@@ -271,7 +271,8 @@
(defimplementation call-with-compilation-hooks (function)
(handler-bind ((warning #'handle-compiler-warning)
- (compiler-note #'handle-compiler-warning))
+ ;;(compiler-note #'handle-compiler-warning)
+ )
(funcall function)))
(defimplementation swank-compile-file (*compile-filename* load-p)
@@ -402,11 +403,11 @@
(xref-result (xref:get-relation ,relation ,name1 ,name2))))
(defxref who-calls :calls :wild x)
+(defxref calls-who :calls x :wild)
(defxref who-references :uses :wild x)
(defxref who-binds :binds :wild x)
(defxref who-macroexpands :macro-calls :wild x)
(defxref who-sets :sets :wild x)
-(defxref list-callees :calls x :wild)
(defun xref-result (fspecs)
(loop for fspec in fspecs
@@ -436,7 +437,7 @@
(when (eq c symbol)
(return-from in-constants-p t)))
3))
-
+
(defun function-callers (name)
(let ((callers '()))
(do-all-symbols (sym)
@@ -449,6 +450,15 @@
(defimplementation list-callers (name)
(xref-result (function-callers name)))
+(defimplementation list-callees (name)
+ (let ((result '()))
+ (map-function-constants (fdefinition name)
+ (lambda (c)
+ (when (fboundp c)
+ (push c result)))
+ 2)
+ (xref-result result)))
+
;;;; Inspecting
(defclass acl-inspector (inspector)
@@ -674,27 +684,39 @@
;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
;; <name> can be a normal name or a (setf name)
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ (:defgeneric (toggle-trace-generic-function-methods (second spec)))
+ ((:defmethod :labels :flet)
+ (toggle-trace-aux (process-fspec-for-allegro spec)))
+ (:call
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux callee
+ :inside (list (process-fspec-for-allegro caller)))))))
+
+(defun tracedp (fspec)
+ (member name (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (fspec &rest args)
+ (cond ((tracedp fspec)
+ (eval `(untrace ,fspec))
+ (format nil "~S is now untraced." fspec))
+ (t
+ (eval `(trace (,fspec , at args)))
+ (format nil "~S is now traced." fspec))))
+
#-allegro-v5.0
-(defimplementation toggle-trace-generic-function-methods (name)
+(defun toggle-trace-generic-function-methods (name)
(let ((methods (mop:generic-function-methods (fdefinition name))))
- (cond ((member name (eval '(trace)) :test #'equal)
+ (cond ((tracedp name)
(eval `(untrace ,name))
(dolist (method methods (format nil "~S is now untraced." name))
(excl:funtrace (mop:method-function method))))
(t
(eval `(trace ,name))
- (dolist (method methods
- (format nil "~S is now traced." name))
+ (dolist (method methods (format nil "~S is now traced." name))
(excl:ftrace (mop:method-function method)))))))
-(defun toggle-trace (fspec &rest args)
- (cond ((member fspec (eval '(trace)) :test #'equal)
- (eval `(untrace ,fspec))
- (format nil "~S is now untraced." fspec))
- (t
- (eval `(trace (,fspec , at args)))
- (format nil "~S is now traced." fspec))))
-
(defun process-fspec-for-allegro (fspec)
(cond ((consp fspec)
(ecase (first fspec)
@@ -706,18 +728,3 @@
,(third fspec)))))
(t
fspec)))
-
-(defimplementation toggle-trace-function (spec)
- (toggle-trace spec))
-
-(defimplementation toggle-trace-method (spec)
- (toggle-trace (process-fspec-for-allegro spec)))
-
-(defimplementation toggle-trace-fdefinition-wherein (name wherein)
- (toggle-trace name :inside (if (and (consp wherein)
- (eq (first wherein) :defmethod))
- (list (process-fspec-for-allegro wherein))
- (process-fspec-for-allegro wherein))))
-
-(defimplementation toggle-trace-fdefinition-within (spec)
- (toggle-trace (process-fspec-for-allegro spec)))
More information about the slime-cvs
mailing list