[slime-cvs] CVS update: slime/ChangeLog slime/swank-sbcl.lisp
Nikodemus Siivola
nsiivola at common-lisp.net
Sat Jun 11 16:22:25 UTC 2005
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv11444
Modified Files:
ChangeLog swank-sbcl.lisp
Log Message:
Changes for supporting recent SBCLs.
Date: Sat Jun 11 18:22:23 2005
Author: nsiivola
Index: slime/ChangeLog
diff -u slime/ChangeLog:1.710 slime/ChangeLog:1.711
--- slime/ChangeLog:1.710 Fri Jun 10 19:55:10 2005
+++ slime/ChangeLog Sat Jun 11 18:22:23 2005
@@ -1,3 +1,14 @@
+2005-06-11 Nikodemus Siivola <nikodemus at random-state.net>
+
+ * swank-sbcl.lisp: Patched for SBCL HEAD: utilize the new
+ :source-plist functionality; maintain compatibility with 0.9.1
+ till 0.9.2 is out. Removed cruft left over from previous
+ excercises in supporting both HEAD and latest release.
+
+ * doc/slime.texi: Document Slime as supporting the latest official
+ release of SBCL, as opposed to a specific version number which
+ would need to be updated monthly.
+
2005-06-10 Helmut Eller <heller at common-lisp.net>
* nregex.lisp (slime-nregex): Rename package to avoid name clashes
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.133 slime/swank-sbcl.lisp:1.134
--- slime/swank-sbcl.lisp:1.133 Wed Jun 1 14:22:45 2005
+++ slime/swank-sbcl.lisp Sat Jun 11 18:22:23 2005
@@ -14,6 +14,11 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sb-bsd-sockets)
(require 'sb-introspect)
+ ;; KLUDGE: Support for 0.9.1 and older concurrently with 0.9.1.25
+ ;; and newer -- the #-swank-backend::source-plist cases can be
+ ;; deleted after SBCL 0.9.2 has been released.
+ (when (find-symbol "DEFINITION-SOURCE-PLIST" :sb-introspect)
+ (pushnew 'swank-backend::source-plist *features*))
(require 'sb-posix))
(in-package :swank-backend)
@@ -290,7 +295,9 @@
(list :error "No error location available")))
(defun locate-compiler-note (file source-path source)
- (cond ((and (pathnamep file) *buffer-name*)
+ (cond ((and #+swank-backend::source-plist (eq file :lisp)
+ #-swank-backend::source-plist (pathnamep file)
+ *buffer-name*)
;; Compiling from a buffer
(let ((position (+ *buffer-offset*
(source-path-string-position
@@ -370,59 +377,89 @@
;;;; compile-string
-;;; We patch sb-c::debug-source-for-info so that we can dump our own
-;;; bits of source info. Our *user-source-info* is stored in the
-;;; debug-source-info slot.
-
-(defvar *real-debug-source-for-info*)
-(defvar *user-source-info*)
+#-swank-backend::source-plist
+(progn
+ ;; We patch sb-c::debug-source-for-info so that we can dump our own
+ ;; bits of source info. Our *user-source-info* is stored in the
+ ;; debug-source-info slot.
+ (defvar *real-debug-source-for-info*)
+ (defvar *user-source-info*)
-(defun debug-source-for-info-advice (info)
- (destructuring-bind (source) (funcall *real-debug-source-for-info* info)
- (when (boundp '*user-source-info*)
- (setf (sb-c::debug-source-info source) *user-source-info*))
- (list source)))
-
-(defun install-debug-source-patch ()
- (unless (boundp '*real-debug-source-for-info*)
- (setq *real-debug-source-for-info* #'sb-c::debug-source-for-info))
- (sb-ext:without-package-locks
- (setf (symbol-function 'sb-c::debug-source-for-info)
- #'debug-source-for-info-advice)))
+ (defun debug-source-for-info-advice (info)
+ (destructuring-bind (source) (funcall *real-debug-source-for-info* info)
+ (when (boundp '*user-source-info*)
+ (setf (sb-c::debug-source-info source) *user-source-info*))
+ (list source)))
+
+ (defun install-debug-source-patch ()
+ (unless (boundp '*real-debug-source-for-info*)
+ (setq *real-debug-source-for-info* #'sb-c::debug-source-for-info))
+ (sb-ext:without-package-locks
+ (setf (symbol-function 'sb-c::debug-source-for-info)
+ #'debug-source-for-info-advice)))
+
+ (defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (install-debug-source-patch)
+ (call/temp-file
+ string
+ (lambda (filename)
+ (let ((*user-source-info* (list :emacs-buffer buffer :emacs-string string
+ :emacs-position position))
+ (*buffer-name* buffer)
+ (*buffer-offset* position)
+ (*buffer-substring* string))
+ (let ((fasl (with-compilation-hooks ()
+ (compile-file filename))))
+ (load fasl)
+ (delete-file fasl))))))
+
+ (defun call/temp-file (string fun)
+ (let ((filename (temp-file-name)))
+ (unwind-protect
+ (with-open-file (s filename :direction :output :if-exists :error)
+ (write-string string s)
+ (finish-output s)
+ (funcall fun filename))
+ (when (probe-file filename)
+ (delete-file filename)))))
+
+ (defun temp-file-name ()
+ "Return a temporary file name to compile strings into."
+ (sb-alien:alien-funcall
+ (sb-alien:extern-alien
+ "tmpnam"
+ (function sb-alien:c-string sb-alien:system-area-pointer))
+ (sb-sys:int-sap 0)))
+
+ (defun find-temp-function-source-location (function)
+ (let ((info (function-debug-source-info function)))
+ (with-struct (sb-introspect::definition-source-
+ form-path character-offset)
+ (sb-introspect:find-definition-source function)
+ (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
+ (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))))))))
+#+swank-backend::source-plist
(defimplementation swank-compile-string (string &key buffer position directory)
(declare (ignore directory))
- (install-debug-source-patch)
- (call/temp-file
- string
- (lambda (filename)
- (let ((*user-source-info* (list :emacs-buffer buffer :emacs-string string
- :emacs-position position))
- (*buffer-name* buffer)
- (*buffer-offset* position)
- (*buffer-substring* string))
- (let ((fasl (with-compilation-hooks ()
- (compile-file filename))))
- (load fasl)
- (delete-file fasl))))))
-
-(defun call/temp-file (string fun)
- (let ((filename (temp-file-name)))
- (unwind-protect
- (with-open-file (s filename :direction :output :if-exists :error)
- (write-string string s)
- (finish-output s)
- (funcall fun filename))
- (when (probe-file filename)
- (delete-file filename)))))
-
-(defun temp-file-name ()
- "Return a temporary file name to compile strings into."
- (sb-alien:alien-funcall
- (sb-alien:extern-alien
- "tmpnam"
- (function sb-alien:c-string sb-alien:system-area-pointer))
- (sb-sys:int-sap 0)))
+ (let ((*buffer-name* buffer)
+ (*buffer-offset* position)
+ (*buffer-substring* string))
+ (with-compilation-hooks ()
+ (with-compilation-unit (:source-plist
+ (list :emacs-buffer buffer
+ :emacs-string string
+ :emacs-position position))
+ (with-input-from-string (s string)
+ (load s))))))
;;;; Definitions
@@ -464,6 +501,7 @@
;;; the position of the first code-location; for some reason, that
;;; doesn't seem to work.)
+#-swank-backend::source-plist
(defun function-source-location (function &optional name)
"Try to find the canonical source location of FUNCTION."
(declare (type function function))
@@ -471,6 +509,12 @@
(find-temp-function-source-location function)
(find-function-source-location function)))
+#+swank-backend::source-plist
+(defun function-source-location (function &optional name)
+ "Try to find the canonical source location of FUNCTION."
+ (declare (type function function))
+ (find-function-source-location function))
+
(defun safe-function-source-location (fun name)
(if *debug-definition-finding*
(function-source-location fun name)
@@ -478,6 +522,7 @@
(error (e)
(list :error (format nil "Error: ~A" e))))))
+#-swank-backend::source-plist
(defun find-function-source-location (function)
(cond #+(or) ;; doesn't work for unknown reasons
((function-has-start-location-p function)
@@ -491,6 +536,33 @@
`(:position ,pos)
`(:snippet ,snippet))))))
+#+swank-backend::source-plist
+(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))
@@ -507,8 +579,8 @@
(sb-introspect:find-definition-source function))))))
(defun function-source-write-date (function)
- (definition-source-file-write-date
- (sb-introspect:find-definition-source function)))
+ (sb-introspect:definition-source-file-write-date
+ (sb-introspect:find-definition-source function)))
(defun function-toplevel-form-number (function)
(car
@@ -528,27 +600,6 @@
(let ((dfun (sb-di:fun-debug-fun function)))
(and dfun (sb-di:debug-fun-start-location dfun))))
-(defun find-temp-function-source-location (function)
- (let ((info (function-debug-source-info function)))
- (with-struct (sb-introspect::definition-source-
- form-path character-offset)
- (sb-introspect:find-definition-source function)
- (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
- (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)))))))
-
-;; FIXME: Symbol doesn't exist in released SBCL (0.8.20) yet.
-(defun definition-source-file-write-date (def)
- (let ((sym (find-symbol "DEFINITION-SOURCE-FILE-WRITE-DATE"
- (find-package "SB-INTROSPECT"))))
- (when sym (funcall sym def))))
-
(defun method-definitions (gf)
(let ((methods (sb-mop:generic-function-methods gf))
(name (sb-mop:generic-function-name gf)))
@@ -692,26 +743,7 @@
collect f)))
(defimplementation print-frame (frame stream)
- (macrolet ((printer-form ()
- ;; MEGAKLUDGE: As SBCL 0.8.20.1 fixed its debug IO style
- ;; our usage of unexported interfaces came back to haunt
- ;; us. And since we still use the same interfaces it will
- ;; haunt us again.
- (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug)))
- (if (fboundp print-sym)
- (let* ((args (sb-introspect:function-arglist print-sym))
- (key-pos (position '&key args)))
- (cond ((eql 2 key-pos)
- `(,print-sym frame stream))
- ((eql 1 key-pos)
- `(let ((*standard-output* stream))
- (,print-sym frame)))
- (t
- (error "*THWAP* SBCL changes internals ~
- again!"))))
- (error "You're in a twisty little maze of unsupported
- SBCL interfaces, all different.")))))
- (printer-form)))
+ (sb-debug::print-frame-call frame stream))
;;;; Code-location -> source-location translation
@@ -721,12 +753,33 @@
;;; If there's no debug-block info, we return the (less precise)
;;; source-location of the corresponding function.
+#-swank-backend::source-plist
(defun code-location-source-location (code-location)
(let ((dsource (sb-di:code-location-debug-source code-location)))
(ecase (sb-di:debug-source-from dsource)
(:file (file-source-location code-location))
(:lisp (lisp-source-location code-location)))))
+#+swank-backend::source-plist
+(defun code-location-source-location (code-location)
+ (let* ((dsource (sb-di:code-location-debug-source code-location))
+ (plist (sb-c::debug-source-plist dsource)))
+ (if (getf plist :emacs-buffer)
+ (emacs-buffer-source-location code-location plist)
+ (ecase (sb-di:debug-source-from dsource)
+ (:file (file-source-location code-location))
+ (:lisp (lisp-source-location code-location))))))
+
+;;; FIXME: The naming policy of source-location functions is a bit
+;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
+;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
+;;; which returns the source location for a _code-location_.
+;;;
+;;; Maybe these should be named code-location-file-source-location,
+;;; etc, turned into generic functions, or something. In the very least the names
+;;; should indicate the main entry point vs. helper status.
+
+#-swank-backend::source-plist
(defun file-source-location (code-location)
(cond ((code-location-has-debug-block-info-p code-location)
(if (code-location-from-emacs-buffer-p code-location)
@@ -738,11 +791,23 @@
(t (error "Cannot find source location for: ~A "
code-location)))))))
+#+swank-backend::source-plist
+(defun file-source-location (code-location)
+ (if (code-location-has-debug-block-info-p code-location)
+ (source-file-source-location code-location)
+ (fallback-source-location code-location)))
+
+(defun fallback-source-location (code-location)
+ (let ((fun (code-location-debug-fun-fun code-location)))
+ (cond (fun (function-source-location fun))
+ (t (error "Cannot find source location for: ~A " code-location)))))
+
(defun lisp-source-location (code-location)
- (let ((source (with-output-to-string (*standard-output*)
- (print-code-location-source-form code-location 100))))
+ (let ((source (prin1-to-string
+ (sb-debug::code-location-source-form code-location 100))))
(make-location `(:source-form ,source) '(:position 0))))
+#-swank-backend::source-plist
(defun temp-file-source-location (code-location)
(let ((info (code-location-debug-source-info code-location)))
(destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
@@ -753,6 +818,18 @@
`(:position ,(+ emacs-position pos))
`(:snippet ,snipped))))))
+#+swank-backend::source-plist
+(defun emacs-buffer-source-location (code-location plist)
+ (if (code-location-has-debug-block-info-p code-location)
+ (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist
+ (let* ((pos (string-source-position code-location emacs-string))
+ (snipped (with-input-from-string (s emacs-string)
+ (read-snippet s pos))))
+ (make-location `(:buffer ,emacs-buffer)
+ `(:position ,(+ emacs-position pos))
+ `(:snippet ,snipped))))
+ (fallback-source-location code-location)))
+
(defun source-file-source-location (code-location)
(let* ((code-date (code-location-debug-source-created code-location))
(filename (code-location-debug-source-name code-location))
@@ -764,8 +841,27 @@
`(:position ,(1+ pos))
`(:snippet ,snippet))))))
-(defun code-location-debug-source-info (code-location)
- (sb-c::debug-source-info (sb-di::code-location-debug-source code-location)))
+#-swank-backend::source-plist
+(progn
+ (defun code-location-debug-source-info (code-location)
+ (sb-c::debug-source-info (sb-di::code-location-debug-source code-location)))
+
+ (defun code-location-from-emacs-buffer-p (code-location)
+ (info-from-emacs-buffer-p (code-location-debug-source-info code-location)))
+
+ (defun function-from-emacs-buffer-p (function)
+ (info-from-emacs-buffer-p (function-debug-source-info function)))
+
+ (defun function-debug-source-info (function)
+ (let* ((comp (sb-di::compiled-debug-fun-component
+ (sb-di::fun-debug-fun function))))
+ (sb-c::debug-source-info (car (sb-c::debug-info-source
+ (sb-kernel:%code-debug-info comp))))))
+
+ (defun info-from-emacs-buffer-p (info)
+ (and info
+ (consp info)
+ (eq :emacs-buffer (car info)))))
(defun code-location-debug-source-name (code-location)
(sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
@@ -777,23 +873,6 @@
(defun code-location-debug-fun-fun (code-location)
(sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
-(defun code-location-from-emacs-buffer-p (code-location)
- (info-from-emacs-buffer-p (code-location-debug-source-info code-location)))
-
-(defun function-from-emacs-buffer-p (function)
- (info-from-emacs-buffer-p (function-debug-source-info function)))
-
-(defun function-debug-source-info (function)
- (let* ((comp (sb-di::compiled-debug-fun-component
- (sb-di::fun-debug-fun function))))
- (sb-c::debug-source-info (car (sb-c::debug-info-source
- (sb-kernel:%code-debug-info comp))))))
-
-(defun info-from-emacs-buffer-p (info)
- (and info
- (consp info)
- (eq :emacs-buffer (car info))))
-
(defun code-location-has-debug-block-info-p (code-location)
(handler-case
(progn (sb-di:code-location-debug-block code-location)
@@ -818,30 +897,6 @@
(stream-source-position code-location s)))
;;; source-path-file-position and friends are in swank-source-path-parser
-
-(defun print-code-location-source-form (code-location context)
- (macrolet ((printer-form ()
- ;; KLUDGE: These are both unexported interfaces, used
- ;; by different versions of SBCL. ...sooner or later
- ;; this will change again: hopefully by then we have
- ;; figured out the interface we want to drive the
- ;; debugger with and requested it from the SBCL
- ;; folks.
- (let ((print-code-sym
- (find-symbol "PRINT-CODE-LOCATION-SOURCE-FORM"
- :sb-debug))
- (code-sym
- (find-symbol "CODE-LOCATION-SOURCE-FORM"
- :sb-debug)))
- (cond ((fboundp print-code-sym)
- `(,print-code-sym code-location context))
- ((fboundp code-sym)
- `(prin1 (,code-sym code-location context)))
- (t
- (error
- "*THWAP* SBCL changes its debugger interface ~
- again!"))))))
- (printer-form)))
(defun safe-source-location-for-emacs (code-location)
(if *debug-definition-finding*
More information about the slime-cvs
mailing list