Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

package local nicknames

  Example terminal session using Linedit:

    * (defpackage :foo (:use :cl) (:local-nicknames (:sb :sb-ext)))

    #<PACKAGE "FOO">
    * (in-package :foo)

    #<PACKAGE "FOO">
    * (sb:posix-
    sb:posix-environ  sb:posix-getenv
    * (sb:posix-getenv "USER")

    "nikodemus"

  API:

    function PACKAGE-LOCAL-NICKNAMES package
    function ADD-PACKAGE-LOCAL-NICKNAME nick global &optional package
    function REMOVE-PACKAGE-LOCAL-NICKNAME old-nick &optional package

    DEFPACKAGE option: (:local-nicknames {(local-nick global-name)}*)

  Design issues and considerations:

   * Nicknames are late-bound. This is seems good for usability and
     also keeps the implementation simple. Causes ugliness in
     printing, though.

   * "CL", "COMMON-LISP", "KEYWORD", and "" cannot be used as local
     nicknames. I think this is good for sanity, but not strictly
     required. Because of the way (find-package :keyword) is
     idiomatically used to guarantee print/read consistency across
     packages, I think it at least should be protected.

   * To preserve read/print consistency, we use package local nicknames
     as prefixes when printing.

   * The hook into FIND-PACKAGE is invisible. An alternative solution
     would be to add FIND-PACKAGE-USING-PACKAGE, but that would not
     work out of the box with arbitrary existing code: see for example
     how nicely Linedit was able to utilize the sb: prefix without
     any changes to it.

   * Local nicknames are protected by package locks.

   * If you want to bypass nicknames, you need to first get into
     a known package without nicknames. There could be an explicit
     way as well, but not sure if that's needed or a good idea.

  Random crap mixed in:

     Re-order DEFPACKAGE option docs in rough order of usefulness.
  • Loading branch information...
commit 3c11847d1e12db89b24a7887b18a137c45ed4661 1 parent b9691ef
@nikodemus authored
View
76 doc/manual/beyond-ansi.texinfo
@@ -7,18 +7,19 @@ ANSI standard. SBCL doesn't support as many extensions as CMUCL, but
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
@@ -43,6 +44,51 @@ Example:
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 global-name)}*
+
+The package has the specified local nicknames for the specified global names.
+@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-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
@@ -302,9 +348,9 @@ to the constant @code{+slot-unbound+}.
@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
View
6 doc/manual/package-locks-extended.texinfo
@@ -184,6 +184,12 @@ Renaming a package.
@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
View
8 package-data-list.lisp-expr
@@ -686,7 +686,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
"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"
@@ -702,6 +704,10 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
"WITHOUT-PACKAGE-LOCKS"
"DISABLE-PACKAGE-LOCKS"
"ENABLE-PACKAGE-LOCKS"
+ ;; local nicknames
+ "ADD-PACKAGE-LOCAL-NICKNAME"
+ "REMOVE-PACKAGE-LOCAL-NICKNAME"
+ "PACKAGE-LOCAL-NICKNAMES"
;; Custom conditions & condition accessors for users to handle.
"CODE-DELETION-NOTE"
View
55 src/code/defpackage.lisp
@@ -34,19 +34,21 @@
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 "{nickname 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)
@@ -69,6 +71,14 @@
(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
@@ -142,7 +152,8 @@
`(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)
@@ -208,8 +219,8 @@
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)
@@ -245,6 +256,10 @@
(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
@@ -252,7 +267,8 @@
use
imports interns
exports
- implement lock doc-string)
+ implement local-nicknames
+ lock doc-string)
(let ((old-exports nil)
(old-shadows (package-%shadowing-symbols package))
(old-use (package-use-list package))
@@ -287,10 +303,12 @@
(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
@@ -309,16 +327,19 @@
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)
View
4 src/code/package.lisp
@@ -106,7 +106,9 @@
#!+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))
;;;; iteration macros
View
20 src/code/print.lisp
@@ -584,7 +584,8 @@ variable: an unreadable object representing the error is printed instead.")
(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
@@ -593,19 +594,30 @@ variable: an unreadable object representing the error is printed instead.")
(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.
(unless (and accessible (eq symbol object))
- (output-symbol-name (package-name package) stream)
+ (let ((pname (package-name package))
+ (nicks (package-nicknames package)))
+ ;; To preserve read/print consistency, use
+ ;; the local nickname if one exists.
+ (flet ((test (x)
+ (or (string= x pname)
+ (member x nicks :test #'string=))))
+ (declare (dynamic-extent #'test))
+ (output-symbol-name
+ (or (car (rassoc-if #'test (package-%local-nicknames current)))
+ pname)
+ stream)))
(multiple-value-bind (symbol externalp)
(find-external-symbol name package)
(declare (ignore symbol))
View
83 src/code/target-package.lisp
@@ -342,6 +342,84 @@ 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 fresh alist of \(local-nickname . global-name) 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 package with the corresponding global-name
+instead. This also affects all implied calls to FIND-PACKAGE, including those
+performed by the reader.
+
+When printing a package prefix for a symbol while in the designated package,
+the local nickname (if any) is used instead of the global name in order
+to preserve read/print consistency.
+
+See also: ADD-PACKAGE-LOCAL-NICKNAME, REMOVE-PACKAGE-LOCAL-NICKNAME,
+and the DEFPACKAGE option :LOCAL-NICKNAMES."
+ (copy-tree
+ (package-%local-nicknames
+ (find-undeleted-package-or-lose package-designator))))
+
+(defun add-package-local-nickname (local-nickname global-name
+ &optional (package-designator (sane-package)))
+ "Adds LOCAL-NICKNAME for GLOBAL-NAME in the designated package, defaulting
+to current package. LOCAL-NICKNAME and GLOBAL-NAME must both be string
+designators.
+
+Returns the designated package.
+
+Signals an error if LOCAL-NICKNAME is already a package local nickname for a
+different global name in the designated package, or if LOCAL-NICKNAME is one of
+\"CL\", \"COMMON-LISP\", \"KEYWORD\", or \"\".
+
+When in the designated package, calls to FIND-PACKAGE with the LOCAL-NICKNAME
+will return the package with the specified GLOBAL-NAME instead. This also
+affects all implied calls to FIND-PACKAGE, including those performed by the
+reader.
+
+When printing a package prefix for a symbol while in the designated package,
+the local nickname (if any) is used instead of the global name in order to
+preserve read/print consistency.
+
+See also: PACKAGE-LOCAL-NICKNAMES, REMOVE-PACKAGE-LOCAL-NICKNAME, and the
+DEFPACKAGE option :LOCAL-NICKNAMES."
+ (let* ((nick (string local-nickname))
+ (name (string global-name))
+ (package (find-undeleted-package-or-lose package-designator))
+ (existing (package-%local-nicknames package))
+ (cell (assoc nick existing :test #'string=)))
+ (when (and cell (string/= name (cdr cell)))
+ (error "~@<Cannot add ~A as local nickname for ~A in ~S: already nickname for ~A.~:@>"
+ nick name package (cdr cell)))
+ (when (member nick '("CL" "COMMON-LISP" "KEYWORD" "") :test #'string=)
+ (error "Cannot use ~A as a package local nickname." nick))
+ (unless cell
+ (with-single-package-locked-error
+ (:package package "adding ~A as a local nickname for ~A"
+ nick name))
+ (push (cons nick name) (package-%local-nicknames package)))
+ 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,
+and the DEFPACKAGE option :LOCAL-NICKNAMES."
+ (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)))
+ (setf (package-%local-nicknames package) (remove cell existing))
+ t)))
+
(defun %package-hashtable-symbol-count (table)
(let ((size (the fixnum
(- (package-hashtable-size table)
@@ -385,7 +463,10 @@ error if any of PACKAGES is not a valid package designator."
(defun find-package (package-designator)
(flet ((find-package-from-string (string)
(declare (type string string))
- (let ((packageoid (gethash string *package-names*)))
+ (let* ((nicknamed (when (boundp '*package*)
+ (cdr (assoc string (package-%local-nicknames (sane-package))
+ :test #'string=))))
+ (packageoid (gethash (or nicknamed string) *package-names*)))
(when (and (null packageoid)
(not *in-package-init*) ; KLUDGE
(let ((mismatch (mismatch "SB!" string)))
View
87 tests/packages.impure.lisp
@@ -304,3 +304,90 @@ if a restart was invoked."
(with-timeout 10
(assert (eq 'cons (read-from-string "CL:CONS"))))
(sb-thread:signal-semaphore sem2)))
+
+(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 '("L" . "CL") (assoc "L" alist :test 'string=)))
+ (assert (equal '("SB" . "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))

3 comments on commit 3c11847

@vseloved

Nice!

@naryl

Could you write a CDR so other implementations get the same feature in a portable way?

@nikodemus
Owner
Please sign in to comment.
Something went wrong with that request. Please try again.