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 @@
: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))
......
......@@ -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")
......@@ -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))
......@@ -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;
......
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