[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Mon Dec 29 11:51:46 UTC 2008
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv10464
Modified Files:
ChangeLog swank-openmcl.lisp
Log Message:
* swank-openmcl.lisp (find-definitions, source-locations): Use
ccl:find-definition-sources.
--- /project/slime/cvsroot/slime/ChangeLog 2008/12/28 15:45:42 1.1607
+++ /project/slime/cvsroot/slime/ChangeLog 2008/12/29 11:51:45 1.1608
@@ -1,3 +1,8 @@
+2008-12-29 Helmut Eller <heller at common-lisp.net>
+
+ * swank-openmcl.lisp (find-definitions, source-locations): Use
+ ccl:find-definition-sources.
+
2008-12-28 Helmut Eller <heller at common-lisp.net>
Recent CCLs support much better source location recording.
--- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/12/28 15:45:42 1.146
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/12/29 11:51:45 1.147
@@ -648,74 +648,111 @@
(list :error (format nil "No source info available for ~A" function))))
(defun pc-source-location (function pc)
- (function-source-location function)))
-
+ (function-source-location function))
+
+ ;; source-locations THING => LOCATIONS NAMES
+ ;; LOCATIONS ... a list of source-locations. Most "specific" first.
+ ;; NAMES ... a list of names.
+ (labels ((str (obj) (princ-to-string obj))
+ (str* (list) (mapcar #'princ-to-string list))
+ (unzip (list) (values (mapcar #'car list) (mapcar #'cdr list)))
+ (filename (file) (namestring (truename file)))
+ (src-loc (file pos)
+ (etypecase file
+ (null `(:error "No source-file info available"))
+ ((or string pathname)
+ (handler-case (make-location `(:file ,(filename file)) pos)
+ (error (c) `(:error ,(princ-to-string c)))))))
+ (fallback (thing)
+ (cond ((functionp thing)
+ (let ((name (ccl::function-name thing)))
+ (and (consp name) (eq (car name) :internal)
+ (ccl::edit-definition-p (second name))))))))
+
+ ;; FIXME: reorder result, e.g. if THING is a function then return
+ ;; the locations for type 'function before those with type
+ ;; 'variable. (Otherwise the debugger jumps to compiler-macros
+ ;; instead of functions :-)
+ (defun source-locations (thing)
+ (multiple-value-bind (files name) (ccl::edit-definition-p thing)
+ (when (null files)
+ (multiple-value-setq (files name) (fallback thing)))
+ (unzip
+ (loop for (type . file) in files collect
+ (etypecase type
+ ((member function macro variable compiler-macro
+ ccl:defcallback ccl::x8664-vinsn)
+ (cons (src-loc file (list :function-name (str name)))
+ (list type name)))
+ (method
+ (let* ((met type)
+ (name (ccl::method-name met))
+ (specs (ccl::method-specializers met))
+ (specs (mapcar #'specializer-name specs))
+ (quals (ccl::method-qualifiers met)))
+ (cons (src-loc file (list :method (str name)
+ (str* specs) (str* quals)))
+ `(method ,name , at quals ,specs)))))))))))
+
#+#.(cl:if (cl:fboundp 'ccl::function-source-note) '(:and) '(:or))
(progn
(defun function-source-location (function)
- (let ((note (ccl:function-source-note function)))
- (if note
- (source-note-to-source-location note)
- (list :error
- (format nil "No source info available for ~A" function)))))
+ (source-note-to-source-location
+ (ccl:function-source-note function)
+ (lambda ()
+ (format nil "Function has no source note: ~A" function))))
(defun pc-source-location (function pc)
- (let ((note (ccl:find-source-note-at-pc function pc)))
- (if note
- (source-note-to-source-location note)
- (list :error
- (format nil "No source note at ~A:#~x" function pc)))))
-
- (defun source-note-to-source-location (note)
- (let ((filename (namestring (truename (ccl:source-note-filename note)))))
- (make-location
- (list :file filename)
- (list :position (1+ (ccl:source-note-start-pos note)))))))
-
-;; source-locations THING => LOCATIONS NAMES
-;; LOCATIONS ... a list of source-locations. Most "specific" first.
-;; NAMES ... a list of names.
-(labels ((str (obj) (princ-to-string obj))
- (str* (list) (mapcar #'princ-to-string list))
- (unzip (list) (values (mapcar #'car list) (mapcar #'cdr list)))
- (filename (file) (namestring (truename file)))
- (src-loc (file pos)
- (etypecase file
- (null `(:error "No source-file info available"))
- ((or string pathname)
- (handler-case (make-location `(:file ,(filename file)) pos)
- (error (c) `(:error ,(princ-to-string c)))))))
- (fallback (thing)
- (cond ((functionp thing)
- (let ((name (ccl::function-name thing)))
- (and (consp name) (eq (car name) :internal)
- (ccl::edit-definition-p (second name))))))))
-
- ;; FIXME: reorder result, e.g. if THING is a function then return
- ;; the locations for type 'function before those with type
- ;; 'variable. (Otherwise the debugger jumps to compiler-macros
- ;; instead of functions :-)
- (defun source-locations (thing)
- (multiple-value-bind (files name) (ccl::edit-definition-p thing)
- (when (null files)
- (multiple-value-setq (files name) (fallback thing)))
- (unzip
- (loop for (type . file) in files collect
- (etypecase type
- ((member function macro variable compiler-macro
- ccl:defcallback ccl::x8664-vinsn)
- (cons (src-loc file (list :function-name (str name)))
- (list type name)))
- (method
- (let* ((met type)
- (name (ccl::method-name met))
- (specs (ccl::method-specializers met))
- (specs (mapcar #'specializer-name specs))
- (quals (ccl::method-qualifiers met)))
- (cons (src-loc file (list :method (str name)
- (str* specs) (str* quals)))
- `(method ,name ,quals ,specs))))))))))
-
+ (source-note-to-source-location
+ (ccl:find-source-note-at-pc function pc)
+ (lambda ()
+ (format nil "No source note at PC: ~A:#x~x" function pc))))
+
+ (defun source-note-to-source-location (note if-nil-thunk)
+ (cond (note
+ (handler-case
+ (let* ((file (ccl:source-note-filename note))
+ (file (namestring (truename file))))
+ (make-location
+ (list :file file)
+ (list :position (1+ (ccl:source-note-start-pos note)))))
+ (error (c) `(:error ,(princ-to-string c)))))
+ (t `(:error ,(funcall if-nil-thunk)))))
+
+ (defimplementation find-definitions (symbol)
+ (loop for (loc . name) in (source-locations symbol)
+ collect (list name loc)))
+
+ (defgeneric source-locations (thing))
+
+ (defmethod source-locations ((f function))
+ (list (cons (function-source-location f)
+ (list 'function (ccl:function-name f)))))
+
+ (defmethod source-locations ((s symbol))
+ (append
+ #+(or)
+ (if (and (fboundp s)
+ (not (macro-function s))
+ (not (special-operator-p s))
+ (functionp (symbol-function s)))
+ (source-locations (symbol-function s)))
+ (loop for ((type . name) source . _) in (ccl:find-definition-sources s)
+ collect (cons (source-note-to-source-location
+ source (lambda () "No source info available"))
+ (definition-name type name)))))
+
+ (defgeneric definition-name (type name)
+ (:method ((type ccl::definition-type) name)
+ (list (ccl::definition-type-name type) name)))
+
+ (defmethod definition-name ((type ccl::method-definition-type)
+ (met method))
+ `(,(ccl::definition-type-name type)
+ ,(ccl::method-name met)
+ ,@(ccl::method-qualifiers met)
+ ,(mapcar #'specializer-name (ccl::method-specializers met)))))
+
(defimplementation frame-source-location-for-emacs (index)
"Return to Emacs the location of the source code for the
function in a debugger frame. In OpenMCL, we are not able to
More information about the slime-cvs
mailing list