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