common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Add restarts for missing package errors.

Browse source
This commit is contained in:
Stas Boukarev 2019-03-19 22:04:53 +03:00
parent f8a877b872
commit 5472ca6ed8
6 changed files with 153 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
NEWS
View file

@ -2,6 +2,7 @@
changes relative to sbcl-1.5.0: changes relative to sbcl-1.5.0:
* bug fix: thread-safety problems in RUN-PROGRAM with :PTY. * bug fix: thread-safety problems in RUN-PROGRAM with :PTY.
* enhancement: restarts for missing package errors.
changes in sbcl-1.5.0 relative to sbcl-1.4.16: changes in sbcl-1.5.0 relative to sbcl-1.4.16:
* enhancement: SB-COVER emulates IN-PACKAGE when recording source maps; * enhancement: SB-COVER emulates IN-PACKAGE when recording source maps;

29
package-data-list.lisp-expr
View file

@ -762,18 +762,18 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
;; package extensions ;; package extensions
;; ;;
;; locks ;; locks
("PACKAGE-LOCKED-P" "PACKAGE-LOCKED-P"
"LOCK-PACKAGE" "LOCK-PACKAGE"
"UNLOCK-PACKAGE" "UNLOCK-PACKAGE"
"PACKAGE-IMPLEMENTED-BY-LIST" "PACKAGE-IMPLEMENTED-BY-LIST"
"PACKAGE-IMPLEMENTS-LIST" "PACKAGE-IMPLEMENTS-LIST"
"ADD-IMPLEMENTATION-PACKAGE" "ADD-IMPLEMENTATION-PACKAGE"
"REMOVE-IMPLEMENTATION-PACKAGE" "REMOVE-IMPLEMENTATION-PACKAGE"
"WITH-UNLOCKED-PACKAGES" "WITH-UNLOCKED-PACKAGES"
"PACKAGE-LOCK-VIOLATION" "PACKAGE-LOCK-VIOLATION"
"PACKAGE-LOCKED-ERROR" "PACKAGE-LOCKED-ERROR"
"SYMBOL-PACKAGE-LOCKED-ERROR" "SYMBOL-PACKAGE-LOCKED-ERROR"
"PACKAGE-LOCKED-ERROR-SYMBOL") "PACKAGE-LOCKED-ERROR-SYMBOL"
"WITHOUT-PACKAGE-LOCKS" "WITHOUT-PACKAGE-LOCKS"
"DISABLE-PACKAGE-LOCKS" "DISABLE-PACKAGE-LOCKS"
"ENABLE-PACKAGE-LOCKS" "ENABLE-PACKAGE-LOCKS"
@ -782,6 +782,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
"REMOVE-PACKAGE-LOCAL-NICKNAME" "REMOVE-PACKAGE-LOCAL-NICKNAME"
"PACKAGE-LOCAL-NICKNAMES" "PACKAGE-LOCAL-NICKNAMES"
"PACKAGE-LOCALLY-NICKNAMED-BY-LIST" "PACKAGE-LOCALLY-NICKNAMED-BY-LIST"
"PACKAGE-DOES-NOT-EXIST" "READER-PACKAGE-DOES-NOT-EXIST"
;; behaviour on DEFPACKAGE variance ;; behaviour on DEFPACKAGE variance
"*ON-PACKAGE-VARIANCE*" "*ON-PACKAGE-VARIANCE*"
@ -1238,7 +1240,8 @@ possibly temporarily, because it might be used internally."
"PATHNAME=" "PATHNAME="
"%HASH-TABLE-ALIST" "%HASH-TABLE-ALIST"
"HASH-TABLE-EQUALP" "HASH-TABLE-EQUALP"
"READ-EVALUATED-FORM" "READ-EVALUATED-FORM" "READ-EVALUATED-FORM-OF-TYPE"
"MAKE-UNPRINTABLE-OBJECT" "MAKE-UNPRINTABLE-OBJECT"
"POSSIBLY-BASE-STRINGIZE" "POSSIBLY-BASE-STRINGIZE"
"POWER-OF-TWO-CEILING" "POWER-OF-TWO-CEILING"

3
src/code/condition.lisp
View file

@ -1179,7 +1179,10 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
(define-condition simple-package-error (simple-condition package-error) ()) (define-condition simple-package-error (simple-condition package-error) ())
(define-condition package-does-not-exist (simple-package-error) ())
(define-condition simple-reader-package-error (simple-reader-error package-error) ()) (define-condition simple-reader-package-error (simple-reader-error package-error) ())
(define-condition reader-package-does-not-exist (simple-reader-package-error package-does-not-exist) ())
(define-condition reader-eof-error (end-of-file) (define-condition reader-eof-error (end-of-file)
((context :reader reader-eof-error-context :initarg :context)) ((context :reader reader-eof-error-context :initarg :context))

79
src/code/early-extensions.lisp
View file

@ -792,30 +792,85 @@ NOTE: This interface is experimental and subject to change."
;;;; package idioms ;;;; package idioms
(defmacro find-package-restarts ((package-designator &optional reader)
&body body)
#+sb-xc-host
(declare (ignore package-designator package symbol current))
#+sb-xc-host
`(progn ,@body)
#-sb-xc-host
(let ((package `(or ,(if reader
'*reader-package*
'*package*)
(sane-package))))
`(locally
;; Used before make-restart is defined
(declare (notinline make-restart))
(restart-case ,@body
(continue ()
:report (lambda (stream)
(format stream "Use the current package, ~a."
(package-name ,package)))
(return (values ,package
,@(and reader
'(:current)))))
(retry ()
:report "Retry finding the package.")
(use-value (value)
:report "Specify a different package"
:interactive
(lambda ()
(read-evaluated-form-of-type 'package-designator))
(when (packagep value)
(return (values value ,@(and reader
'(nil)))))
(setf ,package-designator (truly-the package-designator value)))
,@(and reader
`((unintern ()
:report "Read the symbol as uninterned."
(return (values nil :uninterned)))))
,@(and reader
`((symbol (value)
:report "Specify a symbol to return"
:interactive
(lambda ()
(read-evaluated-form-of-type 'symbol))
(values value :symbol)))))
(go retry))))
;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
;;; instead of this function. (The distinction only actually matters when ;;; instead of this function. (The distinction only actually matters when
;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
;;; you generally do want to signal an error instead of proceeding.) ;;; you generally do want to signal an error instead of proceeding.)
(defun %find-package-or-lose (package-designator) (defun %find-package-or-lose (package-designator)
#-sb-xc-host(declare (optimize allow-non-returning-tail-call)) #-sb-xc-host(declare (optimize allow-non-returning-tail-call))
(or (find-package package-designator) (let ((package-designator package-designator))
(error 'simple-package-error (prog () retry
:package package-designator (let ((result (find-package package-designator)))
:format-control "The name ~S does not designate any package." (if result
:format-arguments (list package-designator)))) (return result)
(find-package-restarts (package-designator)
(error 'package-does-not-exist
:package package-designator
:format-control "The name ~S does not designate any package."
:format-arguments (list package-designator))))))))
;;; ANSI specifies (in the section for FIND-PACKAGE) that the ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
;;; consequences of most operations on deleted packages are ;;; consequences of most operations on deleted packages are
;;; unspecified. We try to signal errors in such cases. ;;; unspecified. We try to signal errors in such cases.
(defun find-undeleted-package-or-lose (package-designator) (defun find-undeleted-package-or-lose (package-designator)
#-sb-xc-host(declare (optimize allow-non-returning-tail-call)) #-sb-xc-host(declare (optimize allow-non-returning-tail-call))
(let ((maybe-result (%find-package-or-lose package-designator))) (let ((package-designator package-designator))
(if (package-%name maybe-result) ; if not deleted (prog () retry
maybe-result (let ((maybe-result (%find-package-or-lose package-designator)))
(error 'simple-package-error (if (package-%name maybe-result) ; if not deleted
:package maybe-result (return maybe-result)
:format-control "The package ~S has been deleted." (find-package-restarts (package-designator)
:format-arguments (list maybe-result))))) (error 'package-does-not-exist
:package maybe-result
:format-control "The package ~S has been deleted."
:format-arguments (list maybe-result))))))))
;;;; various operations on names ;;;; various operations on names

92
src/code/reader.lisp
View file

@ -1185,20 +1185,27 @@ standard Lisp readtable when NIL."
(declaim (type (or null package) *reader-package*) (declaim (type (or null package) *reader-package*)
(always-bound *reader-package*)) (always-bound *reader-package*))
(defun reader-find-package (package-designator stream) (defun reader-find-package (package-designator stream restarts)
(if (%instancep package-designator) (if (%instancep package-designator)
package-designator package-designator
(let ((package (find-package package-designator))) (block nil
(cond (package (tagbody retry
;; Release the token-buf that was used for the designator (let ((package (find-package package-designator)))
(release-token-buf (shiftf (token-buf-next *read-buffer*) nil)) (cond (package
package) ;; Release the token-buf that was used for the designator
(t (release-token-buf (shiftf (token-buf-next *read-buffer*) nil))
(error 'simple-reader-package-error (return (values package nil)))
:package package-designator (t
:stream stream (macrolet ((err ()
:format-control "Package ~A does not exist." `(error 'simple-reader-package-error
:format-arguments (list package-designator))))))) :package package-designator
:stream stream
:format-control "Package ~A does not exist."
:format-arguments (list package-designator))))
(if restarts
(find-package-restarts (package-designator t)
(err))
(err))))))))))
(defun read-token (stream firstchar) (defun read-token (stream firstchar)
"Default readmacro function. Handles numbers, symbols, and SBCL's "Default readmacro function. Handles numbers, symbols, and SBCL's
@ -1527,7 +1534,7 @@ extended <package-name>::<form-in-package> syntax."
(unread-char char stream) (unread-char char stream)
(if package-designator (if package-designator
(let* ((*reader-package* (let* ((*reader-package*
(reader-find-package package-designator stream))) (reader-find-package package-designator stream nil)))
(return (read stream t nil t))) (return (read stream t nil t)))
(simple-reader-error stream (simple-reader-error stream
"illegal terminating character after a double-colon: ~S" "illegal terminating character after a double-colon: ~S"
@ -1540,33 +1547,38 @@ extended <package-name>::<form-in-package> syntax."
package-designator)) package-designator))
(t (go SYMBOL))) (t (go SYMBOL)))
RETURN-SYMBOL RETURN-SYMBOL
(setf buf (normalize-read-buffer buf)) (setf buf (normalize-read-buffer buf))
(casify-read-buffer buf) (casify-read-buffer buf)
(let* ((pkg (if package-designator (multiple-value-bind (pkg restart-kind)
(reader-find-package package-designator stream) (if package-designator
(or *reader-package* (sane-package)))) (reader-find-package package-designator stream t)
(intern-p (or (/= colons 1) (eq pkg *keyword-package*)))) (or *reader-package* (sane-package)))
(unless intern-p ; Try %FIND-SYMBOL (if (eq restart-kind :uninterned)
(multiple-value-bind (symbol accessibility) (return (make-symbol (copy-token-buf-string buf)))
(%find-symbol (token-buf-string buf) (token-buf-fill-ptr buf) pkg) (let* ((intern-p (or (/= colons 1)
(when (eq accessibility :external) (return symbol)) (eq pkg *keyword-package*)
(with-simple-restart (continue "Use symbol anyway.") (eq restart-kind :current))))
(error 'simple-reader-package-error (unless intern-p ; Try %FIND-SYMBOL
:package pkg (multiple-value-bind (symbol accessibility)
:stream stream (%find-symbol (token-buf-string buf) (token-buf-fill-ptr buf) pkg)
:format-arguments (when (eq accessibility :external) (return symbol))
(list (copy-token-buf-string buf) (package-name pkg)) (with-simple-restart (continue "Use symbol anyway.")
:format-control (error 'simple-reader-package-error
(if accessibility :package pkg
"The symbol ~S is not external in the ~A package." :stream stream
"Symbol ~S not found in the ~A package."))))) :format-arguments
(return (%intern (token-buf-string buf) (list (copy-token-buf-string buf) (package-name pkg))
(token-buf-fill-ptr buf) :format-control
pkg (if accessibility
(if (token-buf-only-base-chars buf) "The symbol ~S is not external in the ~A package."
(%readtable-symbol-preference rt) "Symbol ~S not found in the ~A package.")))))
'character) (return (%intern (token-buf-string buf)
nil))))))) (token-buf-fill-ptr buf)
pkg
(if (token-buf-only-base-chars buf)
(%readtable-symbol-preference rt)
'character)
nil)))))))))
;;; For semi-external use: Return 3 values: the token-buf, ;;; For semi-external use: Return 3 values: the token-buf,
;;; a flag for whether there was an escape char, and the position of ;;; a flag for whether there was an escape char, and the position of

17
src/code/target-error.lisp
View file

@ -250,16 +250,27 @@ with that condition (or with no condition) will be returned."
(defun read-evaluated-form (&optional (prompt-control nil promptp) (defun read-evaluated-form (&optional (prompt-control nil promptp)
&rest prompt-args) &rest prompt-args)
(apply #'format *query-io* (apply #'format *query-io*
(if promptp prompt-control "~&Type a form to be evaluated: ") (if promptp prompt-control "~&Enter a form to be evaluated: ")
prompt-args) prompt-args)
(finish-output *query-io*) (finish-output *query-io*)
(list (eval (read *query-io*)))) (list (eval (read *query-io*))))
(defun read-evaluated-form-of-type (type &optional (prompt-control nil promptp)
&rest prompt-args)
(loop (apply #'format *query-io*
(if promptp prompt-control "~&Enter a form evaluating to a value of type ~a: ")
(if promptp prompt-args (list type)))
(finish-output *query-io*)
(let ((result (eval (read *query-io*))))
(when (typep result type)
(return (list result)))
(format *query-io* "~s is not of type ~s" result type))))
;;; Same as above but returns multiple values ;;; Same as above but returns multiple values
(defun mv-read-evaluated-form (&optional (prompt-control nil promptp) (defun mv-read-evaluated-form (&optional (prompt-control nil promptp)
&rest prompt-args) &rest prompt-args)
(apply #'format *query-io* (apply #'format *query-io*
(if promptp prompt-control "~&Type a form to be evaluated: ") (if promptp prompt-control "~&Enter a form to be evaluated: ")
prompt-args) prompt-args)
(finish-output *query-io*) (finish-output *query-io*)
(multiple-value-list (eval (read *query-io*)))) (multiple-value-list (eval (read *query-io*))))