[slime-cvs] CVS slime

[CVS User trittweiler]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv772

Modified Files:
	ChangeLog swank-backend.lisp swank-ecl.lisp 
Log Message:
	* swank-backend.lisp (when-let): New macro. For backends and
	swank.lisp.

	* swank-ecl.lisp: Use it. Also use new location support of ECL git
	HEAD.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/23 20:54:30	1.1997
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/23 22:57:25	1.1998
@@ -1,5 +1,13 @@
 2010-02-23  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank-backend.lisp (when-let): New macro. For backends and
+	swank.lisp.
+
+	* swank-ecl.lisp: Use it. Also use new location support of ECL git
+	HEAD.
+
+2010-02-23  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* slime.el (slime-postprocess-xref): Show a TAGS entry's hints as
 	part of an Xref's dspec for the case of multiple matches.
 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/22 21:38:46	1.194
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/23 22:57:25	1.195
@@ -34,6 +34,7 @@
            #:declaration-arglist
            #:type-specifier-arglist
            #:with-struct
+           #:when-let
            ;; interrupt macro for the backend
            #:*pending-slime-interrupts*
            #:check-slime-interrupts
@@ -253,6 +254,10 @@
                      (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
           , at body)))))
 
+(defmacro when-let ((var value) &body body)
+  `(let ((,var ,value))
+     (when ,var , at body)))
+
 (defun with-symbol (name package)
   "Generate a form suitable for testing with #+."
   (if (find-symbol (string name) (string package))
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/23 20:50:55	1.56
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/23 22:57:25	1.57
@@ -177,9 +177,8 @@
       (cond ((check-slime-interrupts) (return :interrupt))
             (timeout (return (poll-streams streams 0)))
             (t
-             (let ((ready (poll-streams streams 0.2)))
-               (when ready
-                 (return ready)))))))  
+             (when-let (ready (poll-streams streams 0.2))
+               (return ready))))))  
 
 ) ; #+serve-event (progn ...
 
@@ -270,7 +269,7 @@
 
 (defimplementation arglist (name)
   (multiple-value-bind (arglist foundp)
-      (si::function-lambda-list name)
+      (ext:function-lambda-list name)
     (if foundp arglist :not-available)))
 
 (defimplementation function-name (f)
@@ -284,9 +283,8 @@
 (defimplementation describe-symbol-for-emacs (symbol)
   (let ((result '()))
     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
-      (let ((doc (describe-definition symbol type)))
-        (when doc
-          (setf result (list* type doc result)))))
+      (when-let (doc (describe-definition symbol type))
+        (setf result (list* type doc result))))
     result))
 
 (defimplementation describe-definition (name type)
@@ -371,12 +369,10 @@
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
-  (let* ((*tpl-commands* si::tpl-commands)
-         (*ihs-top* (ihs-top))
+  (let* ((*ihs-top* (ihs-top))
          (*ihs-current* *ihs-top*)
          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
          (*frs-top* (frs-top))
-         (*read-suppress* nil)
          (*tpl-level* (1+ *tpl-level*))
          (*backtrace* (loop for ihs from 0 below *ihs-top*
                             collect (list (si::ihs-fun ihs)
@@ -514,14 +510,27 @@
              (push :c-function types))
             (t
              (push :lisp-function types))))
+    (when (boundp name)
+      (cond ((constantp name)
+             (push :constant types))
+            (t
+             (push :global-variable types))))
     types))
 
-(defun find-definitions-for-type (name type)
+(defun find-definitions-by-name (name)
+  (when-let (annotations (ext:get-annotation name 'si::location :all))
+    (loop for annotation in annotations
+          collect (destructuring-bind (op file . pos) annotation
+                    `((,op ,name) ,(make-file-location file pos))))))
+
+(defun find-definitions-by-type (name type)
   (ecase type
     (:lisp-function
-     (list `((defun ,name) ,(source-location (fdefinition name)))))
+     (when-let (loc (source-location (fdefinition name)))
+       (list `((defun ,name) ,loc))))
     (:c-function
-     (list `((c-source ,name) ,(source-location (fdefinition name)))))
+     (when-let (loc (source-location (fdefinition name)))
+       (list `((c-source ,name) ,loc))))
     (:generic-function
      (loop for method in (clos:generic-function-methods (fdefinition name))
            for specs = (clos:method-specializers method)
@@ -529,13 +538,14 @@
            when loc
              collect `((defmethod ,name ,specs) ,loc)))
     (:macro
-     (list `((defmacro ,name) ,(source-location (macro-function name)))))
-    (:special-operator)))
+     (when-let (loc (source-location (macro-function name)))
+       (list `((defmacro ,name) ,loc))))
+    ((:special-operator :constant :global-variable))))
 
 (defimplementation find-definitions (name)
-  (mapcan #'(lambda (type) (find-definitions-for-type name type))
-          (classify-definition-name name)))
-
+  (nconc (find-definitions-by-name name)
+         (mapcan #'(lambda (type) (find-definitions-by-type name type))
+                 (classify-definition-name name))))
 
 (defun source-location (object)
   (converting-errors-to-error-location