[slime-cvs] CVS update: slime/swank-sbcl.lisp
Helmut Eller
heller at common-lisp.net
Thu Aug 4 00:03:43 UTC 2005
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv12561
Modified Files:
swank-sbcl.lisp
Log Message:
Remove SBCL 0.9.1 support.
(swank-compile-string): Funcall the compiled function outside
with-compilation-hooks to prevent runtime warnings from popping up a
*compiler-notes* buffer. From Juho Snellman.
(swank-compile-string): Restore honoring of *trap-load-time-warnings*.
>From Zach Beane.
Date: Thu Aug 4 02:03:42 2005
Author: heller
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.138 slime/swank-sbcl.lisp:1.139
--- slime/swank-sbcl.lisp:1.138 Tue Jul 26 16:59:45 2005
+++ slime/swank-sbcl.lisp Thu Aug 4 02:03:41 2005
@@ -14,11 +14,6 @@
(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)
@@ -298,8 +293,7 @@
(list :error "No error location available")))
(defun locate-compiler-note (file source-path source)
- (cond ((and #+swank-backend::source-plist (eq file :lisp)
- #-swank-backend::source-plist (pathnamep file)
+ (cond ((and (eq file :lisp)
*buffer-name*)
;; Compiling from a buffer
(let ((position (+ *buffer-offset*
@@ -385,93 +379,24 @@
;;;; compile-string
-#-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)))
-
- (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))
- (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))
- #+nil
- (with-input-from-string (stream string)
- (load stream))
- (funcall (compile nil
- `(lambda ()
- ,(read-from-string string))))))))
+ (flet ((compileit (cont)
+ (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))
+ (funcall cont (compile nil
+ `(lambda ()
+ ,(read-from-string string)))))))))
+ (if *trap-load-time-warnings*
+ (compileit #'funcall)
+ (funcall (compileit #'identity)))))
+
;;;; Definitions
@@ -513,16 +438,6 @@
;;; 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)
- (ignore name))
- (if (function-from-emacs-buffer-p function)
- (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)
@@ -536,21 +451,6 @@
(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)
- (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))))))
-
-#+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)
@@ -767,14 +667,6 @@
;;; 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)))
@@ -790,22 +682,10 @@
;;; 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)
- (temp-file-source-location code-location)
- (source-file-source-location code-location)))
- (t
- (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)))))))
+;;; 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)
(if (code-location-has-debug-block-info-p code-location)
(source-file-source-location code-location)
@@ -821,18 +701,6 @@
(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
- (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))))))
-
-#+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
@@ -854,28 +722,6 @@
(make-location `(:file ,filename)
`(:position ,(1+ pos))
`(:snippet ,snippet))))))
-
-#-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)))
More information about the slime-cvs
mailing list