From b0b221088b889b6d3ae67e551b93fe1a6cfec878 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 PACKAGE-LOCALLY-NICKNAMED-BY 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)}*) :PACKAGE-LOCAL-NICKNAMES in *FEATURES* Design issues and considerations: * "CL", "COMMON-LISP", and "KEYWORD" signal a continuable error when 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, but built on top of FIND-PACKAGE-USING-PACKAGE -- undocumented and unexported, but waiting to be turned into something interesting by Christophe. * 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. --- NEWS | 1 + base-target-features.lisp-expr | 5 + doc/manual/beyond-ansi.texinfo | 78 +++++++++++--- doc/manual/package-locks-extended.texinfo | 6 ++ package-data-list.lisp-expr | 9 +- src/code/defpackage.lisp | 55 +++++++--- src/code/package.lisp | 5 +- src/code/print.lisp | 14 ++- src/code/target-package.lisp | 163 ++++++++++++++++++++++++++++- tests/packages.impure.lisp | 108 +++++++++++++++++++ 10 files changed, 404 insertions(+), 40 deletions(-) diff --git a/NEWS b/NEWS index 6a16271..5f2996c 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,6 @@ ;;;; -*- 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 diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index 9ba7b4d..f48cda1 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -272,6 +272,11 @@ ;; 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. diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index f962206..b365498 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,53 @@ 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 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 @@ -302,9 +350,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 724437c..5bcd108 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 a94fa38..413de56 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,11 @@ 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" + "PACKAGE-LOCALLY-NICKNAMED-BY" ;; Custom conditions & condition accessors for users to handle. "CODE-DELETION-NOTE" diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index 435bd0d..003a73c 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 "{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 "") + (: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) (unless (string= (the string (package-name package)) name) (error 'simple-package-error :package name @@ -320,10 +336,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 @@ -342,16 +360,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 e3d5b84..9e9dd3e 100644 --- a/src/code/package.lisp +++ b/src/code/package.lisp @@ -106,7 +106,10 @@ #!+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)) ;;;; iteration macros diff --git a/src/code/print.lisp b/src/code/print.lisp index 43f379f..f17f4f6 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,24 @@ 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. + ;; + ;; 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)) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 238ac91..6a56f8e 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -342,6 +342,128 @@ 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 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 "~@" + 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) @@ -383,9 +505,37 @@ error if any of PACKAGES is not a valid package designator." (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)) => # + +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))) @@ -393,7 +543,7 @@ error if any of PACKAGES is not a valid package designator." (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 @@ -715,6 +865,15 @@ implementation it is ~S." *default-package-use-list*) (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) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index 4008419..fc49997 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -491,3 +491,111 @@ if a restart was invoked." (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))))) -- 1.7.10.4