;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-1.1.4:
+ * new feature: package local nicknames. See manual for details.
* enhancement: easier to use restarts for resolving name-conflicts
resulting from IMPORT, EXPORT, or USE-PACKAGE.
* enhancement: variant DEFPACKAGE forms now signal a full error with
;; It'll increase the core size by major 5-6mB, though.
; :sb-xref-for-internals
+ ;; We support package local nicknames. No :sb-prefix here as we vainly
+ ;; believe our API is worth copying to other implementations as well.
+ ;; This doesn't affect the build at all, merely declares how things are.
+ :local-nicknames
+
;; This affects the definition of a lot of things in bignum.lisp. It
;; doesn't seem to be documented anywhere what systems it might apply
;; to. It doesn't seem to be needed for X86 systems anyway.
it still has quite a few. @xref{Contributed Modules}.
@menu
-* Reader Extensions::
-* Garbage Collection::
-* Metaobject Protocol::
-* Support For Unix::
-* Customization Hooks for Users::
-* Tools To Help Developers::
-* Resolution of Name Conflicts::
-* Hash Table Extensions::
-* Random Number Generation::
-* Miscellaneous Extensions::
-* Stale Extensions::
-* Efficiency Hacks::
+* Reader Extensions::
+* Package-Local Nicknames::
+* Garbage Collection::
+* Metaobject Protocol::
+* Support For Unix::
+* Customization Hooks for Users::
+* Tools To Help Developers::
+* Resolution of Name Conflicts::
+* Hash Table Extensions::
+* Random Number Generation::
+* Miscellaneous Extensions::
+* Stale Extensions::
+* Efficiency Hacks::
@end menu
@node Reader Extensions
Doesn't alter @code{*package*}: if @code{foo::bar} would cause a
read-time package lock violation, so does @code{foo::(bar)}.
+@node Package-Local Nicknames
+@comment node-name, next, previous, up
+@section Package-Local Nicknames
+@cindex Package-Local Nicknames
+
+SBCL allows giving packages local nicknames: they allow short and
+easy-to-use names to be used without fear of name conflict associated
+with normal nicknames.
+
+A local nickname is valid only when inside the package for which it
+has been specified. Different packages can use same local nickname for
+different global names, or different local nickname for same global
+name.
+
+@findex @cl{defpackage}
+@defmac @cl{defpackage} name [[option]]* @result{} package
+
+Options are extended to include
+
+@itemize
+@item
+@code{:local-nicknames} @var{(local-nickname actual-package-name)}*
+
+The package has the specified local nicknames for the corresponding
+actual packages.
+@end itemize
+
+Example:
+
+@lisp
+(defpackage :bar (:intern "X"))
+(defpackage :foo (:intern "X"))
+(defpackage :quux (:use :cl) (:local-nicknames (:bar :foo) (:foo :bar)))
+(find-symbol "X" :foo) ; => FOO::X
+(find-symbol "X" :bar) ; => BAR::X
+(let ((*package* (find-package :quux)))
+ (find-symbol "X" :foo)) ; => BAR::X
+(let ((*package* (find-package :quux)))
+ (find-symbol "X" :bar)) ; => FOO::X
+@end lisp
+@end defmac
+
+@include fun-sb-ext-package-local-nicknames.texinfo
+@include fun-sb-ext-package-locally-nicknamed-by.texinfo
+@include fun-sb-ext-add-package-local-nickname.texinfo
+@include fun-sb-ext-remove-package-local-nickname.texinfo
+
@node Garbage Collection
@comment node-name, next, previous, up
@section Garbage Collection
@section Support For Unix
@menu
-* Command-line arguments::
-* Querying the process environment::
-* Running external programs::
+* Command-line arguments::
+* Querying the process environment::
+* Running external programs::
@end menu
@node Command-line arguments
@item
Deleting a package.
+@item
+Adding a new package local nickname to a package.
+
+@item
+Removing an existing package local nickname to a package.
+
@end enumerate
@subsubsection Operations on Symbols
"DEFGLOBAL"
"SYMBOL-GLOBAL-VALUE"
- ;; package-locking stuff
+ ;; package extensions
+ ;;
+ ;; locks
#!+sb-package-locks "PACKAGE-LOCKED-P"
#!+sb-package-locks "LOCK-PACKAGE"
#!+sb-package-locks "UNLOCK-PACKAGE"
"WITHOUT-PACKAGE-LOCKS"
"DISABLE-PACKAGE-LOCKS"
"ENABLE-PACKAGE-LOCKS"
+ ;; local nicknames
+ "ADD-PACKAGE-LOCAL-NICKNAME"
+ "REMOVE-PACKAGE-LOCAL-NICKNAME"
+ "PACKAGE-LOCAL-NICKNAMES"
+ "PACKAGE-LOCALLY-NICKNAMED-BY"
;; Custom conditions & condition accessors for users to handle.
"CODE-DELETION-NOTE"
following: ~{~&~4T~A~}
All options except ~{~A, ~}and :DOCUMENTATION can be used multiple
times."
- '((:nicknames "{package-name}*")
- (:size "<integer>")
+ '((:use "{package-name}*")
+ (:export "{symbol-name}*")
+ (:import-from "<package-name> {symbol-name}*")
(:shadow "{symbol-name}*")
(:shadowing-import-from "<package-name> {symbol-name}*")
- (:use "{package-name}*")
- (:import-from "<package-name> {symbol-name}*")
- (:intern "{symbol-name}*")
- (:export "{symbol-name}*")
- #!+sb-package-locks (:implement "{package-name}*")
+ (:local-nicknames "{local-nickname actual-package-name}*")
#!+sb-package-locks (:lock "boolean")
- (:documentation "doc-string"))
+ #!+sb-package-locks (:implement "{package-name}*")
+ (:documentation "doc-string")
+ (:intern "{symbol-name}*")
+ (:size "<integer>")
+ (:nicknames "{package-name}*"))
'(:size #!+sb-package-locks :lock))
(let ((nicknames nil)
+ (local-nicknames nil)
(size nil)
(shadows nil)
(shadowing-imports nil)
(case (car option)
(:nicknames
(setf nicknames (stringify-package-designators (cdr option))))
+ (:local-nicknames
+ (setf local-nicknames
+ (append local-nicknames
+ (mapcar (lambda (spec)
+ (destructuring-bind (nick name) spec
+ (cons (stringify-package-designator nick)
+ (stringify-package-designator name))))
+ (cdr option)))))
(:size
(cond (size
(error 'simple-program-error
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%defpackage ,(stringify-string-designator package) ',nicknames ',size
',shadows ',shadowing-imports ',(if use-p use :default)
- ',imports ',interns ',exports ',implement ',lock ',doc
+ ',imports ',interns ',exports ',implement ',local-nicknames
+ ',lock ',doc
(sb!c:source-location)))))
(defun check-disjoint (&rest args)
shadows shadowing-imports
use
imports interns
- exports
- implement lock doc-string)
+ exports implement local-nicknames
+ lock doc-string)
(declare #!-sb-package-locks
(ignore implement lock))
(%enter-new-nicknames package nicknames)
(add-implementation-package package p))
;; Handle lock
(setf (package-lock package) lock))
+ ;; Local nicknames. Throw out the old ones.
+ (setf (package-%local-nicknames package) nil)
+ (dolist (spec local-nicknames)
+ (add-package-local-nickname (car spec) (cdr spec) package))
package)
(defun update-package-with-variance (package name nicknames source-location
use
imports interns
exports
- implement lock doc-string)
+ implement local-nicknames
+ lock doc-string)
(unless (string= (the string (package-name package)) name)
(error 'simple-package-error
:package name
(update-package package nicknames source-location
shadows shadowing-imports
use imports interns exports
- implement lock doc-string))
+ implement local-nicknames
+ lock doc-string))
(defun %defpackage (name nicknames size shadows shadowing-imports
- use imports interns exports implement lock doc-string
+ use imports interns exports implement local-nicknames
+ lock doc-string
source-location)
(declare (type simple-string name)
(type list nicknames shadows shadowing-imports
nicknames source-location
shadows shadowing-imports
use imports interns exports
- implement lock doc-string)
+ implement local-nicknames
+ lock doc-string)
(let ((package (make-package name
:use nil
:internal-symbols (or size 10)
:external-symbols (length exports))))
(update-package package
- nicknames source-location
+ nicknames
+ source-location
shadows shadowing-imports
use imports interns exports
- implement lock doc-string))))))
+ implement local-nicknames
+ lock doc-string))))))
(defun find-or-make-symbol (name package)
(multiple-value-bind (symbol how) (find-symbol name package)
#!+sb-package-locks
(%implementation-packages nil :type list)
;; Definition source location
- (source-location nil :type (or null sb!c:definition-source-location)))
+ (source-location nil :type (or null sb!c:definition-source-location))
+ ;; Local package nicknames.
+ (%local-nicknames nil :type list)
+ (%locally-nicknamed-by nil :type list))
\f
;;;; iteration macros
(defun output-symbol (object stream)
(if (or *print-escape* *print-readably*)
(let ((package (symbol-package object))
- (name (symbol-name object)))
+ (name (symbol-name object))
+ (current (sane-package)))
(cond
;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols"
;; requires that keywords be printed with preceding colons
(write-char #\: stream))
;; Otherwise, if the symbol's home package is the current
;; one, then a prefix is never necessary.
- ((eq package (sane-package)))
+ ((eq package current))
;; Uninterned symbols print with a leading #:.
((null package)
(when (or *print-gensym* *print-readably*)
(write-string "#:" stream)))
(t
(multiple-value-bind (symbol accessible)
- (find-symbol name (sane-package))
+ (find-symbol name current)
;; If we can find the symbol by looking it up, it need not
;; be qualified. This can happen if the symbol has been
;; inherited from a package other than its home package.
+ ;;
+ ;; To preserve read/print consistency, use the local nickname if
+ ;; one exists.
(unless (and accessible (eq symbol object))
- (output-symbol-name (package-name package) stream)
+ (let ((prefix (or (car (rassoc package (package-%local-nicknames current)))
+ (package-name package))))
+ (output-symbol-name prefix stream))
(multiple-value-bind (symbol externalp)
(find-external-symbol name package)
(declare (ignore symbol))
(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
+read/print consistency.
+
+See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCALLY-NICKNAMED-BY,
+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 package-locally-nicknamed-by (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\".
+
+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
+read/print consistency.
+
+See also: PACKAGE-LOCAL-NICKNAMES, PACKAGE-LOCALLY-NICKNAMED-BY,
+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 (package-name actual)
+ (error "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))
+ (when (and cell (neq actual (cdr cell)))
+ (restart-case
+ (error "~@<Cannot add ~A as local nickname for ~A in ~S: already nickname for ~A.~:@>"
+ nick actual package (cdr cell))
+ (keep-old ()
+ :report (lambda (s)
+ (format s "Keep ~A as local nicname for ~A."
+ nick (cdr cell))))
+ (change-nick ()
+ :report (lambda (s)
+ (format s "Use ~A as local nickname for ~A instead."
+ nick 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, 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*)))
+ (let* ((nicknames (when base
+ (package-%local-nicknames base)))
+ (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)))
(restart-case
(signal 'bootstrap-package-not-found :name string)
(debootstrap-package ()
- (return-from find-package
+ (return-from find-package-using-package
(if (string= string "SB!XC")
(find-package "COMMON-LISP")
(find-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)
(assert (= 0 (length (package-implements-list p2)))))
(when p1 (delete-package p1))
(when p2 (delete-package p2)))))
+
+(with-test (:name :package-local-nicknames)
+ ;; Clear slate
+ (without-package-locks
+ (delete-package :package-local-nicknames-test-1)
+ (delete-package :package-local-nicknames-test-2))
+ (eval `(defpackage :package-local-nicknames-test-1
+ (:local-nicknames (:l :cl) (:sb :sb-ext))))
+ (eval `(defpackage :package-local-nicknames-test-2
+ (:export "CONS")))
+ ;; Introspection
+ (let ((alist (package-local-nicknames :package-local-nicknames-test-1)))
+ (assert (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=)))
+ (assert (equal (cons "SB" (find-package "SB-EXT")) (assoc "SB" alist :test 'string=)))
+ (assert (eql 2 (length alist))))
+ ;; Usage
+ (let ((*package* (find-package :package-local-nicknames-test-1)))
+ (let ((cons0 (read-from-string "L:CONS"))
+ (exit0 (read-from-string "SB:EXIT"))
+ (cons1 (find-symbol "CONS" :l))
+ (exit1 (find-symbol "EXIT" :sb))
+ (cl (find-package :l))
+ (sb (find-package :sb)))
+ (assert (eq 'cons cons0))
+ (assert (eq 'cons cons1))
+ (assert (equal "L:CONS" (prin1-to-string cons0)))
+ (assert (eq 'sb-ext:exit exit0))
+ (assert (eq 'sb-ext:exit exit1))
+ (assert (equal "SB:EXIT" (prin1-to-string exit0)))
+ (assert (eq cl (find-package :common-lisp)))
+ (assert (eq sb (find-package :sb-ext)))))
+ ;; Can't add same name twice for different global names.
+ (assert (eq :oopsie
+ (handler-case
+ (add-package-local-nickname :l :package-local-nicknames-test-2
+ :package-local-nicknames-test-1)
+ (error ()
+ :oopsie))))
+ ;; But same name twice is OK.
+ (add-package-local-nickname :l :cl :package-local-nicknames-test-1)
+ ;; Removal.
+ (assert (remove-package-local-nickname :l :package-local-nicknames-test-1))
+ (let ((*package* (find-package :package-local-nicknames-test-1)))
+ (let ((exit0 (read-from-string "SB:EXIT"))
+ (exit1 (find-symbol "EXIT" :sb))
+ (sb (find-package :sb)))
+ (assert (eq 'sb-ext:exit exit0))
+ (assert (eq 'sb-ext:exit exit1))
+ (assert (equal "SB:EXIT" (prin1-to-string exit0)))
+ (assert (eq sb (find-package :sb-ext)))
+ (assert (not (find-package :l)))))
+ ;; Adding back as another package.
+ (assert (eq (find-package :package-local-nicknames-test-1)
+ (add-package-local-nickname :l :package-local-nicknames-test-2
+ :package-local-nicknames-test-1)))
+ (let ((*package* (find-package :package-local-nicknames-test-1)))
+ (let ((cons0 (read-from-string "L:CONS"))
+ (exit0 (read-from-string "SB:EXIT"))
+ (cons1 (find-symbol "CONS" :l))
+ (exit1 (find-symbol "EXIT" :sb))
+ (cl (find-package :l))
+ (sb (find-package :sb)))
+ (assert (eq cons0 cons1))
+ (assert (not (eq 'cons cons0)))
+ (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2)
+ cons0))
+ (assert (equal "L:CONS" (prin1-to-string cons0)))
+ (assert (eq 'sb-ext:exit exit0))
+ (assert (eq 'sb-ext:exit exit1))
+ (assert (equal "SB:EXIT" (prin1-to-string exit0)))
+ (assert (eq cl (find-package :package-local-nicknames-test-2)))
+ (assert (eq sb (find-package :sb-ext)))))
+ ;; Interaction with package locks.
+ (lock-package :package-local-nicknames-test-1)
+ (assert (eq :package-oopsie
+ (handler-case
+ (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
+ (package-lock-violation ()
+ :package-oopsie))))
+ (assert (eq :package-oopsie
+ (handler-case
+ (remove-package-local-nickname :l :package-local-nicknames-test-1)
+ (package-lock-violation ()
+ :package-oopsie))))
+ (unlock-package :package-local-nicknames-test-1)
+ (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
+ (remove-package-local-nickname :l :package-local-nicknames-test-1))
+
+(with-test (:name (:delete-package :locally-nicknames-others))
+ (let (p1 p2)
+ (unwind-protect
+ (progn
+ (setf p1 (make-package "LOCALLY-NICKNAMES-OTHERS")
+ p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS"))
+ (add-package-local-nickname :foo p2 p1)
+ (assert (package-locally-nicknamed-by p2))
+ (delete-package p1)
+ (assert (not (package-locally-nicknamed-by p2))))
+ (when p1 (delete-package p1))
+ (when p2 (delete-package p2)))))
+
+(with-test (:name (:delete-package :locally-nicknamed-by-others))
+ (let ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
+ (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
+ (add-package-local-nickname :foo p2 p1)
+ (assert (package-local-nicknames p1))
+ (delete-package p2)
+ (assert (not (package-local-nicknames p1)))))
projects / sbcl.git / commitdiff