(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
+ "~@<Cannot add ~A as local nickname for ~A in ~A: ~
+ already nickname for ~A.~:@>"
+ 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)
(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)) => #<PACKAGE A>
+
+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)))
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*)
: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.
(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.
(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
(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
(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
- "~@<Package ~S is used by package~P:~2I~_~S~@:>"
- :format-arguments (list (package-name package)
- (length use-list)
- (mapcar #'package-name use-list))))
+ "~@<Package ~S is used by package~P:~2I~_~S~@:>"
+ (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))
(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)
(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)
((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
- "~@<These symbols are not accessible in the ~A package:~2I~_~S~@:>"
- :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))
+ "~@<These symbols are not accessible in the ~A package:~2I~_~S~@:>"
+ (package-%name package) missing)
(import missing package))
(import imports package))
(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
projects / sbcl.git / blobdiff