X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=7a06e73d97c710fb80664b90944e1b108d1f1469;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=312cb6e5a68eb854edd0ada83917d9b29b970949;hpb=7290a82b4dba4b7f42e98d8475709f4a29e46574;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 312cb6e..7a06e73 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -355,7 +355,7 @@ When printing a package prefix for a symbol with a package local nickname, the local nickname is used instead of the real name in order to preserve print-read consistency. -See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCALLY-NICKNAMED-BY, +See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCALLY-NICKNAMED-BY-LIST, REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES. Experimental: interface subject to change." @@ -363,7 +363,21 @@ Experimental: interface subject to change." (package-%local-nicknames (find-undeleted-package-or-lose package-designator)))) -(defun package-locally-nicknamed-by (package-designator) +(defun signal-package-error (package format-control &rest format-args) + (error 'simple-package-error + :package package + :format-control format-control + :format-arguments format-args)) + +(defun signal-package-cerror (package continue-string + format-control &rest format-args) + (cerror continue-string + 'simple-package-error + :package package + :format-control format-control + :format-arguments format-args)) + +(defun package-locally-nicknamed-by-list (package-designator) "Returns a list of packages which have a local nickname for the designated package. @@ -385,7 +399,8 @@ Returns the designated package. Signals a continuable error if LOCAL-NICKNAME is already a package local nickname for a different package, or if LOCAL-NICKNAME is one of \"CL\", -\"COMMON-LISP\", or, \"KEYWORD\". +\"COMMON-LISP\", or, \"KEYWORD\", or if LOCAL-NICKNAME is a global name or +nickname for the package to which the nickname would be added. When in the designated package, calls to FIND-PACKAGE with the LOCAL-NICKNAME will return the package the designated ACTUAL-PACKAGE instead. This also @@ -396,7 +411,7 @@ When printing a package prefix for a symbol with a package local nickname, local nickname is used instead of the real name in order to preserve print-read consistency. -See also: PACKAGE-LOCAL-NICKNAMES, PACKAGE-LOCALLY-NICKNAMED-BY, +See also: PACKAGE-LOCAL-NICKNAMES, PACKAGE-LOCALLY-NICKNAMED-BY-LIST, REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES. Experimental: interface subject to change." @@ -405,27 +420,55 @@ Experimental: interface subject to change." (package (find-undeleted-package-or-lose package-designator)) (existing (package-%local-nicknames package)) (cell (assoc nick existing :test #'string=))) + (unless actual + (signal-package-error + package-designator + "The name ~S does not designate any package." + actual-package)) (unless (package-name actual) - (error "Cannot add ~A as local nickname for a deleted package: ~S" - nick actual)) + (signal-package-error + actual + "Cannot add ~A as local nickname for a deleted package: ~S" + nick actual)) (with-single-package-locked-error (:package package "adding ~A as a local nickname for ~A" nick actual)) (when (member nick '("CL" "COMMON-LISP" "KEYWORD") :test #'string=) - (cerror "Continue, use it as local nickname anyways." - "Attempt to use ~A as a package local nickname." nick)) + (signal-package-cerror + actual + "Continue, use it as local nickname anyways." + "Attempt to use ~A as a package local nickname (for ~A)." + nick (package-name actual))) + (when (string= nick (package-name package)) + (signal-package-cerror + package + "Continue, use it as a local nickname anyways." + "Attempt to use ~A as a package local nickname (for ~A) in ~ + package named globally ~A." + nick (package-name actual) nick)) + (when (member nick (package-nicknames package) :test #'string=) + (signal-package-cerror + package + "Continue, use it as a local nickname anyways." + "Attempt to use ~A as a package local nickname (for ~A) in ~ + package nicknamed globally ~A." + nick (package-name actual) nick)) (when (and cell (neq actual (cdr cell))) (restart-case - (error "~@" - nick actual package (cdr cell)) + (signal-package-error + actual + "~@" + nick (package-name actual) + (package-name package) (package-name (cdr cell))) (keep-old () :report (lambda (s) (format s "Keep ~A as local nicname for ~A." - nick (cdr cell)))) + nick (package-name (cdr cell))))) (change-nick () :report (lambda (s) (format s "Use ~A as local nickname for ~A instead." - nick actual)) + nick (package-name actual))) (let ((old (cdr cell))) (with-package-graph () (setf (package-%locally-nicknamed-by old) @@ -446,7 +489,7 @@ another package, it is removed. Returns true if the nickname existed and was removed, and NIL otherwise. See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCAL-NICKNAMES, -PACKAGE-LOCALLY-NICKNAMED-BY, and the DEFPACKAGE option :LOCAL-NICKNAMES. +PACKAGE-LOCALLY-NICKNAMED-BY-LIST, and the DEFPACKAGE option :LOCAL-NICKNAMES. Experimental: interface subject to change." (let* ((nick (string old-nickname)) @@ -536,19 +579,18 @@ REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES." (nicknamed (when nicknames (cdr (assoc string nicknames :test #'string=)))) (packageoid (or nicknamed (gethash string *package-names*)))) - (when (and (null packageoid) - (not *in-package-init*) ; KLUDGE - (let ((mismatch (mismatch "SB!" string))) - (and mismatch (= mismatch 3)))) - (restart-case - (signal 'bootstrap-package-not-found :name string) - (debootstrap-package () - (return-from find-package-using-package + (if (and (null packageoid) + (not *in-package-init*) ; KLUDGE + (let ((mismatch (mismatch "SB!" string))) + (and mismatch (= mismatch 3)))) + (restart-case + (signal 'bootstrap-package-not-found :name string) + (debootstrap-package () (if (string= string "SB!XC") (find-package "COMMON-LISP") (find-package - (substitute #\- #\! string :count 1))))))) - packageoid))) + (substitute #\- #\! string :count 1))))) + packageoid)))) (typecase package-designator (package package-designator) (symbol (find-package-from-string (symbol-name package-designator))) @@ -716,17 +758,17 @@ REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES." package))))) (cond ((eq found package)) ((string= (the string (package-%name found)) n) - (cerror "Ignore this nickname." - 'simple-package-error - :package package - :format-control "~S is a package name, so it cannot be a nickname for ~S." - :format-arguments (list n (package-%name package)))) + (signal-package-cerror + package + "Ignore this nickname." + "~S is a package name, so it cannot be a nickname for ~S." + n (package-%name package))) (t - (cerror "Leave this nickname alone." - 'simple-package-error - :package package - :format-control "~S is already a nickname for ~S." - :format-arguments (list n (package-%name found)))))))) + (signal-package-cerror + package + "Leave this nickname alone." + "~S is already a nickname for ~S." + n (package-%name found))))))) (defun make-package (name &key (use '#.*default-package-use-list*) @@ -744,8 +786,10 @@ implementation it is ~S." *default-package-use-list*) :restart (when (find-package name) ;; ANSI specifies that this error is correctable. - (cerror "Clobber existing package." - "A package named ~S already exists" name) + (signal-package-cerror + name + "Clobber existing package." + "A package named ~S already exists" name) (setf clobber t)) (with-package-graph () ;; Check for race, signal the error outside the lock. @@ -788,23 +832,20 @@ implementation it is ~S." *default-package-use-list*) (defun rename-package (package-designator name &optional (nicknames ())) #!+sb-doc "Changes the name and nicknames for a package." - (let ((package nil)) - (tagbody :restart - (setq package (find-undeleted-package-or-lose package-designator)) - (let* ((name (package-namify name)) - (found (find-package name)) - (nicks (mapcar #'string nicknames))) + (prog () :restart + (let ((package (find-undeleted-package-or-lose package-designator)) + (name (package-namify name)) + (found (find-package name)) + (nicks (mapcar #'string nicknames))) (unless (or (not found) (eq found package)) - (error 'simple-package-error - :package name - :format-control "A package named ~S already exists." - :format-arguments (list name))) + (signal-package-error name + "A package named ~S already exists." name)) (with-single-package-locked-error () (unless (and (string= name (package-name package)) (null (set-difference nicks (package-nicknames package) :test #'string=))) (assert-package-unlocked package "rename as ~A~@[ with nickname~P ~ - ~{~A~^, ~}~]" + ~{~A~^, ~}~]" name (length nicks) nicks)) (with-package-names (names) ;; Check for race conditions now that we have the lock. @@ -817,8 +858,8 @@ implementation it is ~S." *default-package-use-list*) (setf (package-%name package) name (gethash name names) package (package-%nicknames package) ())) - (%enter-new-nicknames package nicknames)))) - package)) + (%enter-new-nicknames package nicknames)) + (return package)))) (defun delete-package (package-designator) #!+sb-doc @@ -828,14 +869,11 @@ implementation it is ~S." *default-package-use-list*) (let ((package (find-package package-designator))) (cond ((not package) ;; This continuable error is required by ANSI. - (cerror - "Return ~S." - (make-condition - 'simple-package-error - :package package-designator - :format-control "There is no package named ~S." - :format-arguments (list package-designator)) - (return-from delete-package nil))) + (signal-package-cerror + package-designator + "Ignore." + "There is no package named ~S." package-designator) + (return-from delete-package nil)) ((not (package-name package)) ; already deleted (return-from delete-package nil)) (t @@ -844,16 +882,13 @@ implementation it is ~S." *default-package-use-list*) (let ((use-list (package-used-by-list package))) (when use-list ;; This continuable error is specified by ANSI. - (cerror + (signal-package-cerror + package "Remove dependency in other packages." - (make-condition - 'simple-package-error - :package package - :format-control - "~@" - :format-arguments (list (package-name package) - (length use-list) - (mapcar #'package-name use-list)))) + "~@" + (package-name package) + (length use-list) + (mapcar #'package-name use-list)) (dolist (p use-list) (unuse-package package p)))) (dolist (p (package-implements-list package)) @@ -1203,11 +1238,15 @@ uninterned." (defun symbol-listify (thing) (cond ((listp thing) (dolist (s thing) - (unless (symbolp s) (error "~S is not a symbol." s))) + (unless (symbolp s) + (signal-package-error nil + "~S is not a symbol." s))) thing) ((symbolp thing) (list thing)) (t - (error "~S is neither a symbol nor a list of symbols." thing)))) + (signal-package-error nil + "~S is neither a symbol nor a list of symbols." + thing)))) (defun string-listify (thing) (mapcar #'string (if (listp thing) @@ -1272,15 +1311,12 @@ uninterned." ((eq w :inherited) (push sym imports))))) (when missing - (cerror - "~S these symbols into the ~A package." - (make-condition - 'simple-package-error - :package package - :format-control - "~@" - :format-arguments (list (package-%name package) missing)) - 'import (package-%name package)) + (signal-package-cerror + package + (format nil "~S these symbols into the ~A package." + 'import (package-%name package)) + "~@" + (package-%name package) missing) (import missing package)) (import imports package)) @@ -1303,10 +1339,10 @@ uninterned." (dolist (sym symbols) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (cond ((or (not w) (not (eq s sym))) - (error 'simple-package-error - :package package - :format-control "~S is not accessible in the ~A package." - :format-arguments (list sym (package-%name package)))) + (signal-package-error + package + "~S is not accessible in the ~A package." + sym (package-%name package))) ((eq w :external) (pushnew sym syms))))) (with-single-package-locked-error () (when syms