From 3c11847d1e12db89b24a7887b18a137c45ed4661 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 22 Jan 2013 04:04:49 +0200 Subject: [PATCH] package local nicknames Example terminal session using Linedit: * (defpackage :foo (:use :cl) (:local-nicknames (:sb :sb-ext))) # * (in-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 | 76 ++++++++++++++++---- doc/manual/package-locks-extended.texinfo | 6 ++ package-data-list.lisp-expr | 8 ++- src/code/defpackage.lisp | 55 +++++++++----- src/code/package.lisp | 4 +- src/code/print.lisp | 20 ++++-- src/code/target-package.lisp | 83 ++++++++++++++++++++- tests/packages.impure.lisp | 87 +++++++++++++++++++++++ 8 files changed, 300 insertions(+), 39 deletions(-) diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index f9622064c..01380f55f 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/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 diff --git a/doc/manual/package-locks-extended.texinfo b/doc/manual/package-locks-extended.texinfo index 724437c0e..5bcd108c7 100644 --- a/doc/manual/package-locks-extended.texinfo +++ b/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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 691a0400b..4200ac49c 100644 --- a/package-data-list.lisp-expr +++ b/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" diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index 3e76f6353..6c62a3d06 100644 --- a/src/code/defpackage.lisp +++ b/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 "") + '((:use "{package-name}*") + (:export "{symbol-name}*") + (:import-from " {symbol-name}*") (:shadow "{symbol-name}*") (:shadowing-import-from " {symbol-name}*") - (:use "{package-name}*") - (:import-from " {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 "") + (: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) diff --git a/src/code/package.lisp b/src/code/package.lisp index e3d5b84ea..4821d041d 100644 --- a/src/code/package.lisp +++ b/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 diff --git a/src/code/print.lisp b/src/code/print.lisp index 43f379f31..be007f829 100644 --- a/src/code/print.lisp +++ b/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)) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 00cbc54ef..60c62ce9d 100644 --- a/src/code/target-package.lisp +++ b/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 "~@" + 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))) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index 0e782181e..9aa69ae96 100644 --- a/tests/packages.impure.lisp +++ b/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))