--- slime/swank-backend.lisp 2004-06-09 13:35:22.000000000 +0100 +++ /home/csr21/misc-cvs/slime/swank-backend.lisp 2004-06-09 17:37:23.000000000 +0100 @@ -175,7 +175,10 @@ (declare (ignore ignore)) `(call-with-compilation-hooks (lambda () (progn ,@body)))) +(defmacro with-sbcl-protection ((&key) &body body) + `(call-with-sbcl-protection (lambda () (progn ,@body)))) + (definterface swank-compile-string (string &key buffer position) "Compile source from STRING. During compilation, compiler conditions must be trapped and resignalled as COMPILER-CONDITIONs. --- slime/swank.lisp 2004-06-09 00:57:57.000000000 +0100 +++ /home/csr21/misc-cvs/slime/swank.lisp 2004-06-09 17:43:09.000000000 +0100 @@ -788,11 +788,15 @@ (let ((*package* *buffer-package*)) (prin1-to-string string))) +(defun find-package/sbcl (arg) + (handler-bind + ((sb-int:bootstrap-package-not-found #'sb-int:debootstrap-package)) + (find-package arg))) + (defun guess-package-from-string (name &optional (default-package *package*)) (or (and name - (or (find-package name) - (find-package (string-upcase name)) - (find-package (substitute #\- #\! name)))) + (or (find-package/sbcl name) + (find-package/sbcl (string-upcase name)))) default-package)) (defun find-symbol-designator (string &optional @@ -802,10 +806,11 @@ resolution. Return nil if no such symbol exists." (multiple-value-bind (name package-name internal-p) (tokenize-symbol-designator (case-convert-input string)) - (cond ((and package-name (not (find-package package-name))) + (cond ((and package-name (not (find-package/sbcl package-name))) (values nil nil)) (t - (let ((package (or (find-package package-name) default-package))) + (let ((package (or (find-package/sbcl package-name) + default-package))) (multiple-value-bind (symbol access) (find-symbol name package) (cond ((and package-name (not internal-p) (not (eq access :external))) @@ -1130,27 +1135,89 @@ (force-output) (format-values-for-echo-area values))) +(defun feature-in-list-p (feature list) + (etypecase feature + (symbol (member feature list :test #'eq)) + (cons (flet ((subfeature-in-list-p (subfeature) + (feature-in-list-p subfeature list))) + (ecase (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (let ((rest (cdr feature))) + (if (or (null (car rest)) (cdr rest)) + (error "wrong number of terms in compound feature ~S" + feature) + (not (subfeature-in-list-p (second feature))))))))))) +(defun shebang-reader (stream sub-character infix-parameter) + (declare (ignore sub-character)) + (when infix-parameter + (error "illegal read syntax: #~D!" infix-parameter)) + (let ((next-char (read-char stream))) + (unless (find next-char "+-") + (error "illegal read syntax: #!~C" next-char)) + ;; When test is not satisfied + ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then + ;; would become "unless test is satisfied".. + (when (let* ((*package* (find-package "KEYWORD")) + (*read-suppress* nil) + (not-p (char= next-char #\-)) + (feature (read stream))) + (if (feature-in-list-p feature *features*) + not-p + (not not-p))) + ;; Read (and discard) a form from input. + (let ((*read-suppress* t)) + (read stream t nil t)))) + (values)) + +(defun swank-backend::call-with-sbcl-protection (fun) + (let (new-readtable) + (unwind-protect + (let ((*readtable* *readtable*) + (readtable *readtable*)) + (unwind-protect + (progn + (when (let ((mismatch + (mismatch "SB-" (package-name *buffer-package*)))) + (and mismatch (= mismatch 3))) + (setq *readtable* (copy-readtable nil)) + (set-dispatch-macro-character #\# #\! #'shebang-reader)) + (handler-bind ((sb-int:bootstrap-package-not-found #'sb-int:debootstrap-package)) + (funcall fun))) + ;; if we were exectuting sbcl code, set the readtable back + (when (let ((mismatch + (mismatch "SB-" (package-name *buffer-package*)))) + (and mismatch (= mismatch 3))) + (setq *readtable* readtable)) + ;; if we weren't and *readtable* is different from what + ;; it was, propagate that. + (unless (eq *readtable* readtable) + (setq new-readtable *readtable*)))) + (when new-readtable + (setq *readtable* new-readtable))))) + (defun eval-region (string &optional package-update-p) "Evaluate STRING and return the result. If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package change, then send Emacs an update." - (let ((*package* *buffer-package*) - - values) - (unwind-protect - (with-input-from-string (stream string) - (loop for form = (read stream nil stream) - until (eq form stream) - do (progn - (setq - form) - (setq values (multiple-value-list (eval form))) - (force-output)) - finally (progn - (fresh-line) - (force-output) - (return (values values -))))) - (when (and package-update-p (not (eq *package* *buffer-package*))) - (send-to-emacs - (list :new-package (shortest-package-nickname *package*))))))) + (swank-backend::with-sbcl-protection () + (let ((*package* *buffer-package*) + - values) + (unwind-protect + (with-input-from-string (stream string) + (loop for form = (read stream nil stream) + until (eq form stream) + do (progn + (setq - form) + (setq values (multiple-value-list (eval form))) + (force-output)) + finally (progn + (fresh-line) + (force-output) + (return (values values -))))) + (when (and package-update-p (not (eq *package* *buffer-package*))) + (send-to-emacs + (list :new-package (shortest-package-nickname *package*)))))))) (defun shortest-package-nickname (package) "Return the shortest nickname (or canonical name) of PACKAGE." @@ -1855,8 +1922,9 @@ (format nil "~S" (fmakunbound fname)))) (defslimefun load-file (filename) - (to-string (load filename))) + (swank-backend::with-sbcl-protection () + (to-string (load filename)))) (defun requires-compile-p (pathname) (let ((compile-file-truename (probe-file (compile-file-pathname pathname)))) --- slime/swank-sbcl.lisp 2004-06-09 00:57:35.000000000 +0100 +++ /home/csr21/misc-cvs/slime/swank-sbcl.lisp 2004-06-09 17:37:29.000000000 +0100 @@ -266,7 +266,8 @@ (sb-ext:compiler-note #'handle-notification-condition) (style-warning #'handle-notification-condition) (warning #'handle-notification-condition)) - (funcall function))) + (with-sbcl-protection () + (funcall function)))) (defimplementation swank-compile-file (filename load-p) (with-compilation-hooks ()