X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=7a06e73d97c710fb80664b90944e1b108d1f1469;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=238ac91193967902440c816e8bd1728908407a15;hpb=e2c40f8cdd32e299f90cbd7aab985e15928a37cb;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 238ac91..7a06e73 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -342,6 +342,171 @@ error if any of PACKAGES is not a valid package designator." (def package-used-by-list package-%used-by-list) (def package-shadowing-symbols package-%shadowing-symbols)) +(defun package-local-nicknames (package-designator) + "Returns an alist of \(local-nickname . actual-package) describing the +nicknames local to the designated package. + +When in the designated package, calls to FIND-PACKAGE with the any of the +local-nicknames will return the corresponding actual-package instead. This +also affects all implied calls to FIND-PACKAGE, including those performed by +the reader. + +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-LIST, +REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES. + +Experimental: interface subject to change." + (copy-tree + (package-%local-nicknames + (find-undeleted-package-or-lose 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. + +See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCAL-NICKNAMES, +REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES. + +Experimental: interface subject to change." + (copy-list + (package-%locally-nicknamed-by + (find-undeleted-package-or-lose package-designator)))) + +(defun add-package-local-nickname (local-nickname actual-package + &optional (package-designator (sane-package))) + "Adds LOCAL-NICKNAME for ACTUAL-PACKAGE in the designated package, defaulting +to current package. LOCAL-NICKNAME must be a string designator, and +ACTUAL-PACKAGE must be a package designator. + +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\", 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 +affects all implied calls to FIND-PACKAGE, including those performed by the +reader. + +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-LIST, +REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES. + +Experimental: interface subject to change." + (let* ((nick (string local-nickname)) + (actual (find-package-using-package actual-package nil)) + (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) + (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=) + (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 + (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 (package-name (cdr cell))))) + (change-nick () + :report (lambda (s) + (format s "Use ~A as local nickname for ~A instead." + nick (package-name actual))) + (let ((old (cdr cell))) + (with-package-graph () + (setf (package-%locally-nicknamed-by old) + (delete package (package-%locally-nicknamed-by old))) + (push package (package-%locally-nicknamed-by actual)) + (setf (cdr cell) actual))))) + (return-from add-package-local-nickname package)) + (unless cell + (with-package-graph () + (push (cons nick actual) (package-%local-nicknames package)) + (push package (package-%locally-nicknamed-by actual)))) + package)) + +(defun remove-package-local-nickname (old-nickname + &optional (package-designator (sane-package))) + "If the designated package had OLD-NICKNAME as a local nickname for +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-LIST, and the DEFPACKAGE option :LOCAL-NICKNAMES. + +Experimental: interface subject to change." + (let* ((nick (string old-nickname)) + (package (find-undeleted-package-or-lose package-designator)) + (existing (package-%local-nicknames package)) + (cell (assoc nick existing :test #'string=))) + (when cell + (with-single-package-locked-error + (:package package "removing local nickname ~A for ~A" + nick (cdr cell))) + (with-package-graph () + (let ((old (cdr cell))) + (setf (package-%local-nicknames package) (delete cell existing)) + (setf (package-%locally-nicknamed-by old) + (delete package (package-%locally-nicknamed-by old))))) + t))) + (defun %package-hashtable-symbol-count (table) (let ((size (the fixnum (- (package-hashtable-size table) @@ -383,22 +548,49 @@ error if any of PACKAGES is not a valid package designator." (find-restart-or-control-error 'debootstrap-package condition))) (defun find-package (package-designator) + "If PACKAGE-DESIGNATOR is a package, it is returned. Otherwise PACKAGE-DESIGNATOR +must be a string designator, in which case the package it names is located and returned. + +As an SBCL extension, the current package may effect the way a package name is +resolved: if the current package has local nicknames specified, package names +matching those are resolved to the packages associated with them instead. + +Example: + + (defpackage :a) + (defpackage :example (:use :cl) (:local-nicknames (:x :a))) + (let ((*package* (find-package :example))) + (find-package :x)) => # + +See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCAL-NICKNAMES, +REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES." + (find-package-using-package package-designator + (when (boundp '*package*) + *package*))) + +;;; This is undocumented and unexported for now, but the idea is that by +;;; making this a generic function then packages with custom package classes +;;; could hook into this to provide their own resolution. +(defun find-package-using-package (package-designator base) (flet ((find-package-from-string (string) (declare (type string string)) - (let ((packageoid (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 + (let* ((nicknames (when base + (package-%local-nicknames base))) + (nicknamed (when nicknames + (cdr (assoc string nicknames :test #'string=)))) + (packageoid (or nicknamed (gethash string *package-names*)))) + (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))) @@ -566,17 +758,17 @@ error if any of PACKAGES is not a valid package designator." 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*) @@ -594,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. @@ -638,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. @@ -667,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 @@ -678,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 @@ -694,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)) @@ -715,6 +900,15 @@ implementation it is ~S." *default-package-use-list*) (go :restart))) (dolist (used (package-use-list package)) (unuse-package used package)) + (dolist (namer (package-%locally-nicknamed-by package)) + (setf (package-%local-nicknames namer) + (delete package (package-%local-nicknames namer) :key #'cdr))) + (setf (package-%locally-nicknamed-by package) nil) + (dolist (cell (package-%local-nicknames package)) + (let ((actual (cdr cell))) + (setf (package-%locally-nicknamed-by actual) + (delete package (package-%locally-nicknamed-by actual))))) + (setf (package-%local-nicknames package) nil) (do-symbols (sym package) (unintern sym package)) (with-package-names (names) @@ -1044,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) @@ -1113,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)) @@ -1144,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