Index: ChangeLog =================================================================== RCS file: /project/slime/cvsroot/slime/ChangeLog,v retrieving revision 1.729 diff -u -r1.729 ChangeLog --- ChangeLog 29 Jul 2005 12:34:56 -0000 1.729 +++ ChangeLog 3 Aug 2005 14:56:51 -0000 @@ -1,3 +1,9 @@ +2005-08-03 Juho Snellman + * swank-sbcl.lisp: 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. + 2005-07-29 Marco Baringer * doc/slime.texi (Other configurables): Document Index: swank-sbcl.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v retrieving revision 1.138 diff -u -r1.138 swank-sbcl.lisp --- swank-sbcl.lisp 26 Jul 2005 14:59:45 -0000 1.138 +++ swank-sbcl.lisp 3 Aug 2005 14:56:52 -0000 @@ -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,20 @@ ;;;; 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)))))))) + (let ((fun (with-compilation-hooks () + (with-compilation-unit (:source-plist + (list :emacs-buffer buffer + :emacs-string string + :emacs-position position)) + (compile nil + `(lambda () + ,(read-from-string string))))))) + (funcall fun)))) ;;;; Definitions @@ -513,16 +434,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 +447,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 +663,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))) @@ -793,19 +681,6 @@ ;;; 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))))))) - -#+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 +696,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 +717,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)))