From 823c389f6d9089f54b83602d0e547c8f0709128c Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Sun, 17 May 2020 04:42:36 +0000 Subject: [PATCH] Make PACKAGE-LOCAL-NICKNAMES support upgradable --- test/test-package-local-nicknames.script | 18 ++-- uiop/driver.lisp | 19 ++-- uiop/package.lisp | 115 ++++++++++++++++------- uiop/utility.lisp | 8 +- 4 files changed, 103 insertions(+), 57 deletions(-) diff --git a/test/test-package-local-nicknames.script b/test/test-package-local-nicknames.script index 06700b87a..3fa7b19ea 100644 --- a/test/test-package-local-nicknames.script +++ b/test/test-package-local-nicknames.script @@ -62,7 +62,7 @@ :package-local-nicknames-test-1 :package-local-nicknames-test-2)) (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)) (assoc (case-lisp-string "L") alist :test 'string=))) (assert (equal (cons +nn-sname+ (find-package +pkg-sname+)) @@ -95,28 +95,28 @@ (define-test test-package-local-nicknames-nickname-removal (reset-test-packages) - (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 (= 1 (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 (= 1 (length (uiop/package*:package-local-nicknames :package-local-nicknames-test-1)))) (let ((*package* (find-package :package-local-nicknames-test-1))) (assert (not (find-package :l))))) (define-test test-package-local-nicknames-nickname-removal-char #+ignore (declare (optimize (debug 3) (speed 0))) (reset-test-packages) - (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 (= 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) :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))) (assert (not (find-package :l))))) (define-test test-package-local-nicknames-nickname-removal-readd-another-package-equality (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) - (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))) (let ((*package* (find-package :package-local-nicknames-test-1))) (let ((cl (find-package :l)) diff --git a/uiop/driver.lisp b/uiop/driver.lisp index 9b7807d7d..ca6aa2c12 100644 --- a/uiop/driver.lisp +++ b/uiop/driver.lisp @@ -2,18 +2,21 @@ ;;;; Re-export all the functionality in UIOP (uiop/package:define-package :uiop/driver - (:nicknames :uiop :asdf/driver) ;; asdf/driver is obsolete (uiop isn't); - ;; but asdf/driver is still used by swap-bytes, static-vectors. + (:nicknames :uiop ;; Official name we recommend should be used for all references to uiop symbols. + :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) - ;; NB: not reexporting uiop/common-lisp - ;; which include all of CL with compatibility modifications on select platforms, - ;; that could cause potential conflicts for packages that would :use (cl uiop) - ;; or :use (closer-common-lisp uiop), etc. + ;; NB: We are not reexporting uiop/common-lisp + ;; which include all of CL with compatibility modifications on select platforms, + ;; because that would cause potential conflicts for packages that + ;; might want to :use (:cl :uiop) or :use (:closer-common-lisp :uiop), etc. (: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/launch-program :uiop/run-program :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") diff --git a/uiop/package.lisp b/uiop/package.lisp index 61a48a012..10bd85836 100644 --- a/uiop/package.lisp +++ b/uiop/package.lisp @@ -4,39 +4,40 @@ ;; 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, -;;; 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. +(defpackage :uiop/package ;;; THOU SHALT NOT modify this definition, EVER. See explanations above. (: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 #:find-package* #:find-symbol* #:symbol-call #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* @@ -48,13 +49,43 @@ #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away #:package-definition-form #:parse-define-package-form #: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) +;;; 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 (eval-when (:load-toplevel :compile-toplevel :execute) @@ -663,8 +694,15 @@ or when loading the package is optional." (rename-package package package-name nicknames) ;; Handle local nicknames #+package-local-nicknames - (install-package-local-nicknames package local-nicknames) - ;; handle uninterning unwanted symbols + (let* ((existing-nicknames (mapcar #'(lambda (x) (string (car x))) + (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) (multiple-value-bind (existing status) (find-symbol name package) (when status @@ -818,3 +856,8 @@ MIX directives, and reexport their contents as per the REEXPORT directive." #+(or clasp ecl gcl mkcl) (defpackage ,package (:use)) (eval-when (:compile-toplevel :load-toplevel :execute) ,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)) diff --git a/uiop/utility.lisp b/uiop/utility.lisp index 071e6bb7a..e41bfae65 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -44,7 +44,8 @@ ;; 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 ;; (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. ;; - 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., @@ -53,9 +54,8 @@ ;; 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 ;; all the methods required for ASDF to successfully continue compiling itself -;; shall be defined in the same file as the one with the FMAKUNBOUND. -;; - When a function goes from DEFGENERIC to DEFUN, you MAY have to use FMAKUNBOUND, too. -;; Please try the upgrade tests on all supported implementations and update this comment afterwards. +;; 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 omit to use FMAKUNBOUND. ;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC, ;; 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; -- GitLab