Permalink
Browse files

* 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.
  • Loading branch information...
1 parent 2612624 commit 4e64b26a012d637ed8ca69cc6134e268959e7928 @trittweiler trittweiler committed Feb 23, 2010
Showing with 41 additions and 18 deletions.
  1. +8 −0 ChangeLog
  2. +5 −0 swank-backend.lisp
  3. +28 −18 swank-ecl.lisp
View
@@ -1,5 +1,13 @@
2010-02-23 Tobias C. Rittweiler <tcr@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@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.
View
@@ -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 @@ EXCEPT is a list of symbol names which should be ignored."
(t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
,@body)))))
+(defmacro when-let ((var value) &body body)
+ `(let ((,var ,value))
+ (when ,var ,@body)))
+
(defun with-symbol (name package)
"Generate a form suitable for testing with #+."
(if (find-symbol (string name) (string package))
View
@@ -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,28 +510,42 @@
(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)
for loc = (source-location method)
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

0 comments on commit 4e64b26

Please sign in to comment.