[slime-cvs] CVS slime
heller
heller at common-lisp.net
Mon Jun 26 06:28:06 UTC 2006
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2257
Modified Files:
swank-sbcl.lisp
Log Message:
(find-definitions): Remove backward compatibly code.
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/06/26 06:24:24 1.156
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/06/26 06:28:06 1.157
@@ -419,19 +419,6 @@
"When true don't handle errors while looking for definitions.
This is useful when debugging the definition-finding code.")
-;;; As of SBCL 0.9.7 most of the gritty details of source location handling
-;;; are supported reasonably well by SB-INTROSPECT.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun new-definition-source-p ()
- (if (find-symbol "FIND-DEFINITION-SOURCES-BY-NAME" "SB-INTROSPECT")
- '(and)
- '(or))))
-
-;;; SBCL > 0.9.6
-#+#.(swank-backend::new-definition-source-p)
-(progn
-
(defparameter *definition-types*
'(:variable defvar
:constant defconstant
@@ -528,164 +515,6 @@
(handler-case (function-source-location fun name)
(error (e)
(list :error (format nil "Error: ~A" e))))))
-) ;; End >0.9.6
-
-;;; Support for SBCL 0.9.6 and earlier. Feel free to delete this
-;;; after January 2006.
-#-#.(swank-backend::new-definition-source-p)
-(progn
-(defimplementation find-definitions (name)
- (append (function-definitions name)
- (compiler-definitions name)))
-
-;;;;; Function definitions
-
-(defun function-definitions (name)
- (flet ((loc (fn name) (safe-function-source-location fn name)))
- (append
- (cond ((and (symbolp name) (macro-function name))
- (list (list `(defmacro ,name)
- (loc (macro-function name) name))))
- ((fboundp name)
- (let ((fn (fdefinition name)))
- (typecase fn
- (generic-function
- (cons (list `(defgeneric ,name) (loc fn name))
- (method-definitions fn)))
- (t
- (list (list `(function ,name) (loc fn name))))))))
- (when (compiler-macro-function name)
- (list (list `(define-compiler-macro ,name)
- (loc (compiler-macro-function name) name)))))))
-
-;;;; function -> soucre location translation
-
-;;; Here we try to find the source locations for function objects. We
-;;; have to special case functions which were compiled with C-c C-c.
-;;; For the other functions we used the toplevel form number as
-;;; returned by the sb-introspect package to find the offset in the
-;;; source file. (If the function has debug-blocks, we should search
-;;; the position of the first code-location; for some reason, that
-;;; doesn't seem to work.)
-
-(defun function-source-location (function &optional name)
- "Try to find the canonical source location of FUNCTION."
- (declare (type function function)
- (ignore name))
- (find-function-source-location function))
-
-(defun safe-function-source-location (fun name)
- (if *debug-definition-finding*
- (function-source-location fun name)
- (handler-case (function-source-location fun name)
- (error (e)
- (list :error (format nil "Error: ~A" e))))))
-
-(defun find-function-source-location (function)
- (with-struct (sb-introspect::definition-source- form-path character-offset plist)
- (sb-introspect:find-definition-source function)
- (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist
- (if emacs-buffer
- (let ((pos (if form-path
- (with-debootstrapping
- (source-path-string-position
- form-path emacs-string))
- character-offset)))
- (make-location `(:buffer ,emacs-buffer)
- `(:position ,(+ pos emacs-position))
- `(:snippet ,emacs-string)))
- (cond #+(or)
- ;; doesn't work for unknown reasons
- ((function-has-start-location-p function)
- (code-location-source-location (function-start-location function)))
- ((not (function-source-filename function))
- (error "Source filename not recorded for ~A" function))
- (t
- (let* ((pos (function-source-position function))
- (snippet (function-hint-snippet function pos)))
- (make-location `(:file ,(function-source-filename function))
- `(:position ,pos)
- `(:snippet ,snippet)))))))))
-
-(defun function-source-position (function)
- ;; We only consider the toplevel form number here.
- (let* ((tlf (function-toplevel-form-number function))
- (filename (function-source-filename function))
- (*readtable* (guess-readtable-for-filename filename)))
- (with-debootstrapping
- (source-path-file-position (list tlf) filename))))
-
-(defun function-source-filename (function)
- (ignore-errors
- (namestring
- (truename
- (sb-introspect:definition-source-pathname
- (sb-introspect:find-definition-source function))))))
-
-(defun function-source-write-date (function)
- (sb-introspect:definition-source-file-write-date
- (sb-introspect:find-definition-source function)))
-
-(defun function-toplevel-form-number (function)
- (car
- (sb-introspect:definition-source-form-path
- (sb-introspect:find-definition-source function))))
-
-(defun function-hint-snippet (function position)
- (let ((source (get-source-code (function-source-filename function)
- (function-source-write-date function))))
- (with-input-from-string (s source)
- (read-snippet s position))))
-
-(defun function-has-start-location-p (function)
- (ignore-errors (function-start-location function)))
-
-(defun function-start-location (function)
- (let ((dfun (sb-di:fun-debug-fun function)))
- (and dfun (sb-di:debug-fun-start-location dfun))))
-
-(defun method-definitions (gf)
- (let ((methods (sb-mop:generic-function-methods gf))
- (name (sb-mop:generic-function-name gf)))
- (loop for method in methods
- collect (list `(method ,name ,@(method-qualifiers method)
- ,(sb-pcl::unparse-specializers method))
- (method-source-location method)))))
-
-(defun method-source-location (method)
- (safe-function-source-location (or (sb-pcl::method-fast-function method)
- (sb-pcl:method-function method))
- nil))
-
-;;;;; Compiler definitions
-
-(defun compiler-definitions (name)
- (let ((fun-info (sb-int:info :function :info name)))
- (when fun-info
- (append (transform-definitions fun-info name)
- (optimizer-definitions fun-info name)))))
-
-(defun transform-definitions (fun-info name)
- (loop for xform in (sb-c::fun-info-transforms fun-info)
- for loc = (safe-function-source-location
- (sb-c::transform-function xform) name)
- for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
- for note = (sb-c::transform-note xform)
- for spec = (if (consp typespec)
- `(sb-c:deftransform ,(second typespec) ,note)
- `(sb-c:deftransform ,note))
- collect `(,spec ,loc)))
-
-(defun optimizer-definitions (fun-info fun-name)
- (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
- (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
- (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
- (sb-c::fun-info-optimizer . sb-c:optimizer))))
- (loop for (reader . name) in otypes
- for fn = (funcall reader fun-info)
- when fn collect `((sb-c:defoptimizer ,name)
- ,(safe-function-source-location fn fun-name)))))
-) ;; End SBCL <= 0.9.6 compability
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
More information about the slime-cvs
mailing list