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.

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

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

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"

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,14 +256,19 @@
       (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
                                      shadows shadowing-imports
                                      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)

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
 

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))