Index: slime.el
===================================================================
RCS file: /project/slime/cvsroot/slime/slime.el,v
retrieving revision 1.456
diff -u -r1.456 slime.el
--- slime.el	2 Feb 2005 20:33:23 -0000	1.456
+++ slime.el	16 Feb 2005 19:34:48 -0000
@@ -2190,6 +2190,9 @@
       ((:read-string thread tag)
        (assert thread)
        (slime-repl-read-string thread tag))
+      ((:evaluate-in-emacs string thread tag);;AML
+       (assert thread)
+       (evaluate-in-emacs (car (read-from-string string)) thread tag))
       ((:read-aborted thread tag)
        (assert thread)
        (slime-repl-abort-read thread tag))
@@ -3025,6 +3028,11 @@
   (slime-mark-input-start)
   (slime-repl-read-mode 1))
 
+(defun evaluate-in-emacs (expr thread tag)
+  (push thread slime-read-string-threads)
+  (push tag slime-read-string-tags)
+  (slime-repl-return-string (eval expr)))
+
 (defun slime-repl-return-string (string)
   (slime-dispatch-event `(:emacs-return-string 
                           ,(pop slime-read-string-threads)
@@ -5284,11 +5292,149 @@
     ;; prefix is not `-', compile defun
     (otherwise (slime-compile-defun))))
 
-(defun slime-toggle-trace-fdefinition (fname-string)
-  "Toggle trace for FNAME-STRING."
-  (interactive (list (slime-read-from-minibuffer
-		      "(Un)trace: " (slime-symbol-name-at-point))))
-  (message "%s" (slime-eval `(swank:toggle-trace-fdefinition ,fname-string))))
+;;This is an extension for the trace command.
+;;Several interesting cases (the . shows the point position):
+
+;; (defun n.ame (...) ...)                                   -> (:defun name)
+;; (defun (setf n.ame) (...) ...)                            -> (:defun (setf name))
+;; (defmethod n.ame (...) ...)                               -> (:defmethod name (...))
+;; (defun ... (...) (labels ((n.ame (...) ...) ...) ...)...) -> (:labels (:defun ...) name)
+;; (defun ... (...) (flet ((n.ame (...) ...) ...) ...)...)   -> (:flet (:defun ...) name)
+;; (defun ... (...) ... (n.ame ...) ...)                     -> (:call (:defun ...) name)
+;; (defun ... (...) ... (setf (n.ame ...) ...))              -> (:call (:defun ...) (setf name))
+
+;; All other context should be identified as normal, traditional,
+;; function calls.
+
+(defun complete-name-context-at-point ()
+  "Return the name of the function at point, otherwise nil.  This
+tries to be clever to understand a bit of the context."
+  (let ((name (thing-at-point 'symbol)))
+    (and name
+	 (or (ignore-errors
+	       (save-excursion
+		 (name-context-at-point (intern name))))
+	     (intern name)))))
+
+(defun name-context-at-point (name)
+  (out-first 1)
+  (cond ((looking-at "defun") ;;a function definition
+	 `(:defun ,name))
+	((looking-at "defmacro") ;;a macro definition
+	 `(:defmacro ,name))
+	((looking-at "defgeneric") ;;a defgeneric form, maybe trace all methods
+	 `(:defgeneric ,name))
+	((looking-at "defmethod") ;;a defmethod, maybe trace just this method
+	 (forward-sexp 3) ;;jump defmethod, name, and possibly, arglist 
+	 (let ((qualifier
+		(if (= (or (char-before) -1) ?\)) ;;ok, after arglist
+		  (progn
+		    (forward-sexp -1)
+		    (list))
+		  (list (read (current-buffer))))) ;;it was a qualifier
+	       (arglist (read (current-buffer))))
+	   `(:defmethod ,name ,@qualifier ,(parameter-specializers arglist))))
+	((looking-at "setf ") ;;looks like a setf-definition, but which?
+	 (up-list -1)
+	 (name-context-at-point `(setf ,name)))
+	((and (symbolp name) (looking-at (symbol-name name))) ;;the name itself, we need further investigation
+	 (out-first 2)
+	 (cond ((looking-at "setf ") ;;a setf-call
+		(let ((def (ignore-errors (definition-name))))
+		  (if def
+		    `(:call ,def (setf ,name))
+		    `(setf ,name))))
+	       ((ignore-errors
+		  (save-excursion
+		    (out-first 2)
+		    (cond ((or (looking-at "labels") (looking-at "flet"))
+			   (let ((fdef (definition-name)))
+			     (if (looking-at "labels")
+			       `(:labels ,fdef ,name)
+			       `(:flet ,fdef ,name))))
+			  (t `(:call ,(definition-name) ,name))))))
+	       (t `(:call ,(definition-name) ,name))))
+	(t 
+	 name)))
+
+(defun out-first (n)
+  (up-list (- n))
+  (forward-char 1)
+  (skip-syntax-forward " "))
+
+(defun definition-name ()
+  (save-excursion
+    (beginning-of-defun)
+    (forward-char 1)
+    (forward-sexp 1)
+    (name-context-at-point (read (current-buffer)))))
+		 
+(defun parameter-specializers (arglist)
+  (cond ((or (null arglist)
+	     (member (first arglist) '(&optional &key &rest &aux)))
+	 (list))
+	((consp (first arglist))
+	 (cons (second (first arglist))
+	       (parameter-specializers (rest arglist))))
+	(t
+	 (cons 't 
+	       (parameter-specializers (rest arglist))))))
+
+
+;;Now, we need to present the options for the user to choose
+
+(defun slime-toggle-trace-fdefinition ()
+  "Toggle trace."
+  (interactive)
+  (let ((spec (complete-name-context-at-point)))
+    (cond ((symbolp spec) ;;trivial case
+	   (slime-toggle-trace-function spec))
+	  (t
+	   (ecase (first spec)
+	     ((setf)
+	      (slime-toggle-trace-function spec))
+	     ((:defun :defmacro) 
+	      (slime-toggle-trace-function (second spec)))
+	     (:defgeneric
+	      (slime-toggle-trace-defgeneric (second spec)))
+	     (:defmethod
+	      (slime-toggle-trace-defmethod spec))
+	     (:call 
+	      (slime-toggle-trace-maybe-wherein (third spec) (second spec)))
+	     ((:labels :flet)
+	      (slime-toggle-trace-within spec)))))))
+
+(defun slime-toggle-trace-function (name)
+  (let ((real-name (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string name))))
+    (message "%s" (slime-eval `(swank:toggle-trace-function (swank::from-string ,real-name))))))
+
+(defun slime-toggle-trace-defgeneric (name)
+  (let ((name (prin1-to-string name)))
+    (let ((real-name (slime-read-from-minibuffer "(Un)trace: " name)))
+      (if (and (string= name real-name)
+	       (y-or-n-p (format "(Un)trace also all methods implementing %s " real-name)))
+	(message "%s" (slime-eval `(swank:toggle-trace-generic-function-methods 
+				    (swank::from-string ,real-name))))
+	(message "%s" (slime-eval `(swank:toggle-trace-function (swank::from-string ,real-name))))))))
+
+(defun slime-toggle-trace-defmethod (spec)
+  (let ((real-name (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))))
+    (message "%s" (slime-eval `(swank:toggle-trace-method (swank::from-string ,real-name))))))
+
+(defun slime-toggle-trace-maybe-wherein (name wherein)
+  (let ((real-name (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string name)))
+	(wherein (prin1-to-string wherein)))
+    (if (and (string= name real-name)
+	     (y-or-n-p (format "(Un)trace only when %s call is made from %s " real-name wherein)))
+      (message "%s" (slime-eval `(swank:toggle-trace-fdefinition-wherein
+				  (swank::from-string ,real-name)
+				  (swank::from-string ,wherein))))
+      (message "%s" (slime-eval `(swank:toggle-trace-fdefinition ,real-name))))))
+
+(defun slime-toggle-trace-within (spec)
+  (let ((real-name (slime-read-from-minibuffer "(Un)trace local function: " (prin1-to-string spec))))
+    (message "%s" (slime-eval `(swank:toggle-trace-fdefinition-within
+				(swank::from-string ,real-name))))))
 
 (defun slime-untrace-all ()
   "Untrace all functions."
Index: swank-allegro.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-allegro.lisp,v
retrieving revision 1.67
diff -u -r1.67 swank-allegro.lisp
--- swank-allegro.lisp	20 Jan 2005 16:09:23 -0000	1.67
+++ swank-allegro.lisp	16 Feb 2005 19:34:48 -0000
@@ -663,3 +663,57 @@
 
 (defimplementation quit-lisp ()
   (excl:exit 0 :quiet t))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;;In Allegro 7.0, we have:
+;; (trace <name>)
+;; (trace ((method <name> <qualifier>? (<specializer>+))))
+;; (trace ((labels <name> <label-name>)))
+;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
+;; <name> can be a normal name or a (setf name)
+
+(defimplementation toggle-trace-generic-function-methods (name)
+  (let ((methods (mop:generic-function-methods (fdefinition name))))
+    (cond ((member name (eval '(trace)) :test #'equal)
+           (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))
+             (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 ,@args)))
+         (format nil "~S is now traced." fspec))))
+
+(defun process-fspec-for-allegro (fspec)
+  (cond ((consp fspec)
+         (ecase (first fspec)
+           ((:defun :defgeneric) (second fspec))
+           ((:defmethod) `(method ,@(rest fspec)))
+           ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) ,(third fspec)))
+           ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) ,(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)))
Index: swank-backend.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v
retrieving revision 1.77
diff -u -r1.77 swank-backend.lisp
--- swank-backend.lisp	15 Dec 2004 22:45:20 -0000	1.77
+++ swank-backend.lisp	16 Feb 2005 19:34:49 -0000
@@ -780,3 +780,21 @@
 
 (definterface receive ()
   "Return the next message from current thread's mailbox.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;AML Changes for trace
+
+(definterface toggle-trace-function (spec)
+  "Trace one function, including (setf name) forms.")
+
+(definterface toggle-trace-generic-function-methods (name)
+  "Trace the generic function and all methods of the generic function.")
+
+(definterface toggle-trace-method (spec)
+  "Trace one method.")
+
+(definterface toggle-trace-fdefinition-wherein (name wherein)
+  "Trace function when called by another function.")
+
+(definterface toggle-trace-fdefinition-within (spec)
+  "Trace local function within other function.")
\ No newline at end of file
Index: swank-cmucl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-cmucl.lisp,v
retrieving revision 1.137
diff -u -r1.137 swank-cmucl.lisp
--- swank-cmucl.lisp	19 Jan 2005 18:27:47 -0000	1.137
+++ swank-cmucl.lisp	16 Feb 2005 19:34:54 -0000
@@ -2173,6 +2173,56 @@
   (when *install-gc-hooks*
     (install-gc-hooks)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;;In CMUCL, we have:
+;; (trace <name>)
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; (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 ,@args))
+         (format nil "~S is now traced." fspec))))
+
+(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))
+        (t
+         (eval `(trace ,name))
+         (eval `(trace :methods ',name))
+         (format nil "~S is now traced." name))))
+
+(defun process-fspec (fspec)
+  (cond ((consp fspec)
+         (ecase (first fspec)
+           ((:defun :defgeneric) (second fspec))
+           ((:defmethod) `(method ,@(rest fspec)))
+           ((: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))
+
+(defimplementation toggle-trace-method (spec)
+  (toggle-trace `(pcl:fast-method ,@(rest (process-fspec spec)))))
+
+(defimplementation toggle-trace-fdefinition-wherein (name wherein)
+  (toggle-trace name :wherein (process-fspec wherein)))
+
+(defimplementation toggle-trace-fdefinition-within (spec)
+  "Sorry! CMUCL doesn't support tracing local definitions")
+
+
+
 ;; Local Variables:
 ;; pbook-heading-regexp:    "^;;;\\(;+\\)"
 ;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"
Index: swank-sbcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v
retrieving revision 1.116
diff -u -r1.116 swank-sbcl.lisp
--- swank-sbcl.lisp	10 Jan 2005 19:33:29 -0000	1.116
+++ swank-sbcl.lisp	16 Feb 2005 19:34:54 -0000
@@ -935,3 +935,45 @@
                                               mutex))))))))
 
   )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;;In SBCL, we have:
+;; (trace <name>)
+;; (trace :methods '<name>) ;;to trace all methods of the gf <name>
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; <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 ,@(if args `(:encapsulate nil) (list)) ,fspec ,@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)
+           ((:defun :defgeneric) (second fspec))
+           ((:defmethod) `(method ,@(rest fspec)))
+           ((: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))
+
+(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-fdefinition-within (spec)
+  "Sorry! SBCL doesn't support tracing local definitions")
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.278
diff -u -r1.278 swank.lisp
--- swank.lisp	27 Jan 2005 19:56:06 -0000	1.278
+++ swank.lisp	16 Feb 2005 19:34:54 -0000
@@ -51,7 +51,12 @@
            #:default-directory
            #:set-default-directory
            #:quit-lisp
-           ))
+           #:toggle-trace-function
+           #:toggle-trace-generic-function-methods
+           #:toggle-trace-method
+           #:toggle-trace-fdefinition-wherein
+           #:toggle-trace-fdefinition-within
+))
 
 (in-package :swank)
 
@@ -532,6 +537,8 @@
      (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
     ((:read-string thread &rest args)
      (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
+    ((:evaluate-in-emacs string thread &rest args) ;;AML
+     (encode-message `(:evaluate-in-emacs ,string ,(thread-id thread) ,@args) socket-io))
     ((:read-aborted thread &rest args)
      (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
     ((:emacs-return-string thread-id tag string)
@@ -949,6 +956,20 @@
 (defslimefun take-input (tag input)
   "Return the string INPUT to the continuation TAG."
   (throw (intern-catch-tag tag) input))
+
+
+(defun evaluate-in-emacs (string)
+  (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))
+    (force-output)
+    (send-to-emacs `(:evaluate-in-emacs ,string ,(current-thread) ,*read-input-catch-tag*))
+    (let ((ok nil))
+      (unwind-protect
+           (prog1 (catch (intern-catch-tag *read-input-catch-tag*)
+                    (loop (read-from-emacs)))
+             (setq ok t))
+        (unless ok 
+          (send-to-emacs `(:read-aborted ,(current-thread)
+                                         *read-input-catch-tag*)))))))
 
 (defslimefun connection-info ()
   "Return a list of the form: