Commit 823c389f authored by Francois-Rene Rideau's avatar Francois-Rene Rideau Committed by Robert Goldman
Browse files

Make PACKAGE-LOCAL-NICKNAMES support upgradable

parent 0d9883a9
...@@ -62,7 +62,7 @@ ...@@ -62,7 +62,7 @@
:package-local-nicknames-test-1 :package-local-nicknames-test-1
:package-local-nicknames-test-2)) :package-local-nicknames-test-2))
(let ((*package* (find-package p))) (let ((*package* (find-package p)))
(let ((alist (uiop/package:package-local-nicknames :package-local-nicknames-test-1))) (let ((alist (uiop/package*:package-local-nicknames :package-local-nicknames-test-1)))
(assert (equal (cons (case-lisp-string "L") (find-package :cl)) (assert (equal (cons (case-lisp-string "L") (find-package :cl))
(assoc (case-lisp-string "L") alist :test 'string=))) (assoc (case-lisp-string "L") alist :test 'string=)))
(assert (equal (cons +nn-sname+ (find-package +pkg-sname+)) (assert (equal (cons +nn-sname+ (find-package +pkg-sname+))
...@@ -95,28 +95,28 @@ ...@@ -95,28 +95,28 @@
(define-test test-package-local-nicknames-nickname-removal (define-test test-package-local-nicknames-nickname-removal
(reset-test-packages) (reset-test-packages)
(assert (= 2 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))) (assert (= 2 (length (uiop/package*:package-local-nicknames :package-local-nicknames-test-1))))
(assert (uiop/package:remove-package-local-nickname :l :package-local-nicknames-test-1)) (assert (uiop/package*:remove-package-local-nickname :l :package-local-nicknames-test-1))
(assert (= 1 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))) (assert (= 1 (length (uiop/package*:package-local-nicknames :package-local-nicknames-test-1))))
(let ((*package* (find-package :package-local-nicknames-test-1))) (let ((*package* (find-package :package-local-nicknames-test-1)))
(assert (not (find-package :l))))) (assert (not (find-package :l)))))
(define-test test-package-local-nicknames-nickname-removal-char (define-test test-package-local-nicknames-nickname-removal-char
#+ignore (declare (optimize (debug 3) (speed 0))) #+ignore (declare (optimize (debug 3) (speed 0)))
(reset-test-packages) (reset-test-packages)
(assert (= 2 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))) (assert (= 2 (length (uiop/package*:package-local-nicknames :package-local-nicknames-test-1))))
(assert (uiop/package:remove-package-local-nickname (if (eq (readtable-case *readtable*) :preserve) #\l #\L) (assert (uiop/package*:remove-package-local-nickname (if (eq (readtable-case *readtable*) :preserve) #\l #\L)
:package-local-nicknames-test-1)) :package-local-nicknames-test-1))
(assert (= 1 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))) (assert (= 1 (length (uiop/package*:package-local-nicknames :package-local-nicknames-test-1))))
(let ((*package* (find-package :package-local-nicknames-test-1))) (let ((*package* (find-package :package-local-nicknames-test-1)))
(assert (not (find-package :l))))) (assert (not (find-package :l)))))
(define-test test-package-local-nicknames-nickname-removal-readd-another-package-equality (define-test test-package-local-nicknames-nickname-removal-readd-another-package-equality
(reset-test-packages) (reset-test-packages)
(assert (uiop/package:remove-package-local-nickname :l :package-local-nicknames-test-1)) (assert (uiop/package*:remove-package-local-nickname :l :package-local-nicknames-test-1))
(assert (eq (find-package :package-local-nicknames-test-1) (assert (eq (find-package :package-local-nicknames-test-1)
(uiop/package:add-package-local-nickname :l :package-local-nicknames-test-2 (uiop/package*:add-package-local-nickname :l :package-local-nicknames-test-2
:package-local-nicknames-test-1))) :package-local-nicknames-test-1)))
(let ((*package* (find-package :package-local-nicknames-test-1))) (let ((*package* (find-package :package-local-nicknames-test-1)))
(let ((cl (find-package :l)) (let ((cl (find-package :l))
......
...@@ -2,18 +2,21 @@ ...@@ -2,18 +2,21 @@
;;;; Re-export all the functionality in UIOP ;;;; Re-export all the functionality in UIOP
(uiop/package:define-package :uiop/driver (uiop/package:define-package :uiop/driver
(:nicknames :uiop :asdf/driver) ;; asdf/driver is obsolete (uiop isn't); (:nicknames :uiop ;; Official name we recommend should be used for all references to uiop symbols.
;; but asdf/driver is still used by swap-bytes, static-vectors. :asdf/driver) ;; DO NOT USE, a deprecated name, not supported anymore.
;; We should remove the name :asdf/driver at some point,
;; but not until it has been eradicated from Quicklisp for a year or two.
;; The last known user was cffi (PR merged in May 2020).
(:use :uiop/common-lisp) (:use :uiop/common-lisp)
;; NB: not reexporting uiop/common-lisp ;; NB: We are not reexporting uiop/common-lisp
;; which include all of CL with compatibility modifications on select platforms, ;; which include all of CL with compatibility modifications on select platforms,
;; that could cause potential conflicts for packages that would :use (cl uiop) ;; because that would cause potential conflicts for packages that
;; or :use (closer-common-lisp uiop), etc. ;; might want to :use (:cl :uiop) or :use (:closer-common-lisp :uiop), etc.
(:use-reexport (:use-reexport
:uiop/package :uiop/utility :uiop/version :uiop/package* :uiop/utility :uiop/version
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image
:uiop/launch-program :uiop/run-program :uiop/launch-program :uiop/run-program
:uiop/lisp-build :uiop/configuration :uiop/backward-driver)) :uiop/lisp-build :uiop/configuration :uiop/backward-driver))
;; Provide both lowercase and uppercase, to satisfy more people. ;; Provide both lowercase and uppercase, to satisfy more implementations.
(provide "uiop") (provide "UIOP") (provide "uiop") (provide "UIOP")
...@@ -4,39 +4,40 @@ ...@@ -4,39 +4,40 @@
;; See https://bugs.launchpad.net/asdf/+bug/485687 ;; See https://bugs.launchpad.net/asdf/+bug/485687
;; ;;
;; CAUTION: The definition of the UIOP/PACKAGE package MUST NOT CHANGE,
;; NOT NOW, NOT EVER, NOT UNDER ANY CIRCUMSTANCE. NEVER.
;; ... and the same goes for UIOP/PACKAGE-LOCAL-NICKNAMES.
;;
;; The entire point of UIOP/PACKAGE is to address the fact that the CL standard
;; *leaves it unspecified what happens when a package is redefined incompatibly*.
;; For instance, SBCL 1.4.2 will signal a full WARNING when this happens,
;; throwing a wrench in upgrading code with ASDF itself, while continuing to
;; export old symbols it now shouldn't as it also exports new ones,
;; causing problems with code that relies on the new/current exports.
;; CLISP and CCL also exports both sets of symbols, though without any WARNING.
;; ABCL 1.6.1 will plainly ignore the new definition.
;; Other implementations may do whatever they want and change their behavior at any time.
;; ***Using DEFPACKAGE twice with different definitions is nasal-demon territory.***
;;
;; Thus we define UIOP/PACKAGE:DEFINE-PACKAGE with which packages can be defined
;; in an upgrade-friendly way: the new definition is authoritative, and
;; the package will define and export exactly those symbols in the new definition,
;; no more and no fewer, whereas it is well-defined what happens to previous symbols.
;; However, for obvious bootstrap reasons, we cannot use DEFINE-PACKAGE
;; to define UIOP/PACKAGE itself, only DEFPACKAGE.
;; Therefore, unlike the other packages in ASDF, UIOP/PACKAGE is immutable,
;; now and forever. It is frozen for the aeons to come, like the CL package itself,
;; to the same exact state it was defined at its inception, in ASDF 2.27 in 2013.
;; The same goes for UIOP/PACKAGE-LOCAL-NICKNAMES, that we use internally.
;;
;; If you ever must define new symbols in this file, you can and must
;; export them from a different package, possibly defined in the same file,
;; say a package UIOP/PACKAGE* defined at the end of this file with DEFINE-PACKAGE,
;; that might use :import-from to import the symbols from UIOP/PACKAGE,
;; if you must somehow define them in UIOP/PACKAGE.
;;; package local nicknames feature. Can't be deferred until common-lisp.lisp, (defpackage :uiop/package ;;; THOU SHALT NOT modify this definition, EVER. See explanations above.
;;; where most such features are set.
;;; ABCL and CCL already define this feature appropriately.
;;; Seems to be unconditionally present for SBCL, ACL, and clasp
;;; Don't know about ecl, or others
(eval-when (:load-toplevel :compile-toplevel :execute)
;; abcl pushes :package-local-nicknames without UIOP interfering,
;; and Lispworks will do so
#+(or sbcl clasp)
(pushnew :package-local-nicknames *features*)
#+allegro
(let ((fname (find-symbol (symbol-name '#:add-package-local-nickname) '#:excl)))
(when (and fname (fboundp fname))
(pushnew :package-local-nicknames *features*))))
(defpackage :uiop/package
;; CAUTION: we must handle the first few packages specially for hot-upgrade.
;; This package definition MUST NOT change unless its name too changes;
;; if/when it changes, don't forget to add new functions missing from below.
;; Until then, uiop/package is frozen to forever
;; import and export the same exact symbols as for ASDF 2.27.
;; Any other symbol must be import-from'ed and re-export'ed in a different package.
(:use :common-lisp) (:use :common-lisp)
#+package-local-nicknames
(:import-from #+allegro #:excl
#+sbcl #:sb-ext
#+(or clasp abcl ecl) #:ext
#+ccl #:ccl
#+lispworks #:hcl
#-(or allegro sbcl clasp abcl ccl lispworks ecl)
(error "Don't know from which package this lisp supplies the local-package-nicknames API.")
#:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname)
(:export (:export
#:find-package* #:find-symbol* #:symbol-call #:find-package* #:find-symbol* #:symbol-call
#:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
...@@ -48,13 +49,43 @@ ...@@ -48,13 +49,43 @@
#:package-names #:packages-from-names #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
#:package-definition-form #:parse-define-package-form #:package-definition-form #:parse-define-package-form
#:ensure-package #:define-package #:ensure-package #:define-package
#+package-local-nicknames #:add-package-local-nickname
#+package-local-nicknames #:remove-package-local-nickname
#+package-local-nicknames #:package-local-nicknames
)) ))
(in-package :uiop/package) (in-package :uiop/package)
;;; package local nicknames feature.
;;; This can't be deferred until common-lisp.lisp, where most such features are set.
;;; ABCL and CCL already define this feature appropriately.
;;; Seems to be unconditionally present for SBCL, ACL, and CLASP
;;; Don't know about ECL, or others
(eval-when (:load-toplevel :compile-toplevel :execute)
;; ABCL pushes :package-local-nicknames without UIOP interfering,
;; and Lispworks will do so
#+(or sbcl clasp)
(pushnew :package-local-nicknames *features*)
#+allegro
(let ((fname (find-symbol (symbol-name '#:add-package-local-nickname) '#:excl)))
(when (and fname (fboundp fname))
(pushnew :package-local-nicknames *features*))))
;;; THOU SHALT NOT modify this definition, EVER, *EXCEPT* to add a new implementation.
;; If you somehow need to modify the API in any way,
;; you will need to create another, differently named, and just as immutable package.
#+package-local-nicknames
(defpackage :uiop/package-local-nicknames
(:use :cl)
(:import-from
#+allegro #:excl
#+sbcl #:sb-ext
#+(or clasp abcl ecl) #:ext
#+ccl #:ccl
#+lispworks #:hcl
#-(or allegro sbcl clasp abcl ccl lispworks ecl)
(error "Don't know from which package this lisp supplies the local-package-nicknames API.")
#:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname)
(:export
#:add-package-local-nickname #:remove-package-local-nickname #:package-local-nicknames))
;;;; General purpose package utilities ;;;; General purpose package utilities
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
...@@ -663,8 +694,15 @@ or when loading the package is optional." ...@@ -663,8 +694,15 @@ or when loading the package is optional."
(rename-package package package-name nicknames) (rename-package package package-name nicknames)
;; Handle local nicknames ;; Handle local nicknames
#+package-local-nicknames #+package-local-nicknames
(install-package-local-nicknames package local-nicknames) (let* ((existing-nicknames (mapcar #'(lambda (x) (string (car x)))
;; handle uninterning unwanted symbols (uiop/package-local-nicknames:package-local-nicknames package)))
(new-nicknames (mapcar #'(lambda (x) (string (first x))) local-nicknames))
(to-remove (set-difference existing-nicknames new-nicknames :test 'equal)))
(map () #'(lambda (x) (uiop/package-local-nicknames:remove-package-local-nickname x package))
to-remove)
(loop :for (nick-str package-str) :in local-nicknames
:do (uiop/package-local-nicknames:add-package-local-nickname
nick-str package-str package)))
(dolist (name unintern) (dolist (name unintern)
(multiple-value-bind (existing status) (find-symbol name package) (multiple-value-bind (existing status) (find-symbol name package)
(when status (when status
...@@ -818,3 +856,8 @@ MIX directives, and reexport their contents as per the REEXPORT directive." ...@@ -818,3 +856,8 @@ MIX directives, and reexport their contents as per the REEXPORT directive."
#+(or clasp ecl gcl mkcl) (defpackage ,package (:use)) #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
,ensure-form)))) ,ensure-form))))
;; This package, unlike UIOP/PACKAGE, is allowed to evolve and acquire new symbols or drop old ones.
(define-package :uiop/package*
(:use-reexport :uiop/package
#+package-local-nicknames :uiop/package-local-nicknames))
...@@ -44,7 +44,8 @@ ...@@ -44,7 +44,8 @@
;; so that new definitions are always seen by all callers, even those up the stack. ;; so that new definitions are always seen by all callers, even those up the stack.
;; - WITH-UPGRADABILITY also uses EVAL-WHEN so that definitions used by ASDF are in a limbo state ;; - WITH-UPGRADABILITY also uses EVAL-WHEN so that definitions used by ASDF are in a limbo state
;; (especially for gf's) in between the COMPILE-OP and LOAD-OP operations on the defining file. ;; (especially for gf's) in between the COMPILE-OP and LOAD-OP operations on the defining file.
;; - THOU SHALT NOT redefine a function with a backward-incompatible semantics without renaming it. ;; - THOU SHALT NOT redefine a function with a backward-incompatible semantics without renaming it,
;; at least if that function is used by ASDF while performing the plan to load ASDF.
;; - THOU SHALT change the name of a function whenever thou makest an incompatible change. ;; - THOU SHALT change the name of a function whenever thou makest an incompatible change.
;; - For instance, when the meanings of NIL and T for timestamps was inverted, ;; - For instance, when the meanings of NIL and T for timestamps was inverted,
;; functions in the STAMP<, STAMP<=, etc. family had to be renamed to TIMESTAMP<, TIMESTAMP<=, etc., ;; functions in the STAMP<, STAMP<=, etc. family had to be renamed to TIMESTAMP<, TIMESTAMP<=, etc.,
...@@ -53,9 +54,8 @@ ...@@ -53,9 +54,8 @@
;; even in a backward-compatible way, you MUST precede the definition by FMAKUNBOUND. ;; even in a backward-compatible way, you MUST precede the definition by FMAKUNBOUND.
;; - Since FMAKUNBOUND will remove all the methods on the generic function, make sure that ;; - Since FMAKUNBOUND will remove all the methods on the generic function, make sure that
;; all the methods required for ASDF to successfully continue compiling itself ;; all the methods required for ASDF to successfully continue compiling itself
;; shall be defined in the same file as the one with the FMAKUNBOUND. ;; shall be defined in the same file as the one with the FMAKUNBOUND, *after* the DEFGENERIC.
;; - When a function goes from DEFGENERIC to DEFUN, you MAY have to use FMAKUNBOUND, too. ;; - When a function goes from DEFGENERIC to DEFUN, you may omit to use FMAKUNBOUND.
;; Please try the upgrade tests on all supported implementations and update this comment afterwards.
;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC, ;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC,
;; in the same WITH-UPGRADABILITY form (and its implicit EVAL-WHEN). ;; in the same WITH-UPGRADABILITY form (and its implicit EVAL-WHEN).
;; - Any time you change a signature, please keep a comment specifying the first release after the change; ;; - Any time you change a signature, please keep a comment specifying the first release after the change;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment