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:
* 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:
* 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
;;
;; locks
("PACKAGE-LOCKED-P"
"LOCK-PACKAGE"
"UNLOCK-PACKAGE"
"PACKAGE-IMPLEMENTED-BY-LIST"
"PACKAGE-IMPLEMENTS-LIST"
"ADD-IMPLEMENTATION-PACKAGE"
"REMOVE-IMPLEMENTATION-PACKAGE"
"WITH-UNLOCKED-PACKAGES"
"PACKAGE-LOCK-VIOLATION"
"PACKAGE-LOCKED-ERROR"
"SYMBOL-PACKAGE-LOCKED-ERROR"
"PACKAGE-LOCKED-ERROR-SYMBOL")
"PACKAGE-LOCKED-P"
"LOCK-PACKAGE"
"UNLOCK-PACKAGE"
"PACKAGE-IMPLEMENTED-BY-LIST"
"PACKAGE-IMPLEMENTS-LIST"
"ADD-IMPLEMENTATION-PACKAGE"
"REMOVE-IMPLEMENTATION-PACKAGE"
"WITH-UNLOCKED-PACKAGES"
"PACKAGE-LOCK-VIOLATION"
"PACKAGE-LOCKED-ERROR"
"SYMBOL-PACKAGE-LOCKED-ERROR"
"PACKAGE-LOCKED-ERROR-SYMBOL"
"WITHOUT-PACKAGE-LOCKS"
"DISABLE-PACKAGE-LOCKS"
"ENABLE-PACKAGE-LOCKS"
@ -782,6 +782,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
"REMOVE-PACKAGE-LOCAL-NICKNAME"
"PACKAGE-LOCAL-NICKNAMES"
"PACKAGE-LOCALLY-NICKNAMED-BY-LIST"
"PACKAGE-DOES-NOT-EXIST" "READER-PACKAGE-DOES-NOT-EXIST"
;; behaviour on DEFPACKAGE variance
"*ON-PACKAGE-VARIANCE*"
@ -1238,7 +1240,8 @@ possibly temporarily, because it might be used internally."
"PATHNAME="
"%HASH-TABLE-ALIST"
"HASH-TABLE-EQUALP"
"READ-EVALUATED-FORM"
"READ-EVALUATED-FORM" "READ-EVALUATED-FORM-OF-TYPE"
"MAKE-UNPRINTABLE-OBJECT"
"POSSIBLY-BASE-STRINGIZE"
"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 package-does-not-exist (simple-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)
((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
(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
;;; instead of this function. (The distinction only actually matters when
;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
;;; you generally do want to signal an error instead of proceeding.)
(defun %find-package-or-lose (package-designator)
#-sb-xc-host(declare (optimize allow-non-returning-tail-call))
(or (find-package package-designator)
(error 'simple-package-error
:package package-designator
:format-control "The name ~S does not designate any package."
:format-arguments (list package-designator))))
(let ((package-designator package-designator))
(prog () retry
(let ((result (find-package package-designator)))
(if result
(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
;;; consequences of most operations on deleted packages are
;;; unspecified. We try to signal errors in such cases.
(defun find-undeleted-package-or-lose (package-designator)
#-sb-xc-host(declare (optimize allow-non-returning-tail-call))
(let ((maybe-result (%find-package-or-lose package-designator)))
(if (package-%name maybe-result) ; if not deleted
maybe-result
(error 'simple-package-error
:package maybe-result
:format-control "The package ~S has been deleted."
:format-arguments (list maybe-result)))))
(let ((package-designator package-designator))
(prog () retry
(let ((maybe-result (%find-package-or-lose package-designator)))
(if (package-%name maybe-result) ; if not deleted
(return maybe-result)
(find-package-restarts (package-designator)
(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

92
src/code/reader.lisp
View file

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