Commit c54a6e37 authored by Robert Goldman's avatar Robert Goldman
Browse files

Merge branch 'fix-find-definition' into 'master'

Simplify WITH-UPGRADABILITY

See merge request !142
parents 1c997636 7b4a25ca
Pipeline #4034 canceled with stage
......@@ -132,7 +132,7 @@ Use it in FORMAT control strings as ~/asdf-action:format-action/"
;;;; Detection of circular dependencies
(with-upgradability ()
(defun (action-valid-p) (operation component)
(defun action-valid-p (operation component)
"Is this action valid to include amongst dependencies?"
;; If either the operation or component was resolved to nil, the action is invalid.
;; :if-feature will invalidate actions on components for which the features don't apply.
......
......@@ -19,6 +19,8 @@ cl-asdf (2:3.3.5-1) unstable; urgency=low IN PROGRESS
* Fixes for feature handling from Eric Timmons.
* Replaced some of the internals of `parse-defsystem` with generic functions to
enable modular extension. Thanks to Eric Timmons.
* Faré provided more graceful upgrade capabilities, fixing bugs with upgrading
support for local package nicknames, and with upgrading ABCL.
cl-asdf (2:3.3.4-1) unstable; urgency=low
Bug fix release:
......
......@@ -116,13 +116,16 @@ Upgrade test:
- l: [abcl, ccl, clasp, clisp, cmucl, ecl, sbcl]
IMAGE_TAG: latest
Upgrade test known failure:
extends: .Upgrade test template
parallel:
matrix:
- l: [abcl]
IMAGE_TAG: latest
allow_failure: true
# No more tests are known to fail. But leave commented out in case it needs to
# be resurrected.
# Upgrade test known failure:
# extends: .Upgrade test template
# parallel:
# matrix:
# - l: []
# IMAGE_TAG: latest
# allow_failure: true
.REQUIRE upgrade test template:
extends: .Upgrade test template
......@@ -137,15 +140,18 @@ REQUIRE upgrade test:
ASDF_UPGRADE_TEST_TAGS: REQUIRE
parallel:
matrix:
- l: [ccl, clasp, clisp, cmucl, ecl, sbcl]
- l: [abcl, ccl, clasp, clisp, cmucl, ecl, sbcl]
IMAGE_TAG: latest
REQUIRE upgrade test known failure:
extends: .REQUIRE upgrade test template
variables:
ASDF_UPGRADE_TEST_TAGS: REQUIRE
parallel:
matrix:
- l: abcl
IMAGE_TAG: latest
allow_failure: true
# No more tests are known to fail. But leave commented out in case it needs to
# be resurrected.
# REQUIRE upgrade test known failure:
# extends: .REQUIRE upgrade test template
# variables:
# ASDF_UPGRADE_TEST_TAGS: REQUIRE
# parallel:
# matrix:
# - l: []
# IMAGE_TAG: latest
# allow_failure: true
......@@ -194,7 +194,7 @@ and the order is by decreasing length of namestring of the source pathname.")
(when inherit
(process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
(defun* (process-output-translations-directive) (directive &key inherit collect)
(defun process-output-translations-directive (directive &key inherit collect)
(if (atom directive)
(ecase directive
((:enable-user-cache)
......@@ -287,7 +287,7 @@ effectively disabling the output translation facility."
;; Top-level entry-point to _use_ output-translations
(defun* (apply-output-translations) (path)
(defun apply-output-translations (path)
(etypecase path
(logical-pathname
path)
......
......@@ -148,7 +148,8 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~
;; Given a form used as :version specification, in the context of a system definition
;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form
;; to an acceptable ASDF-format version.
(defun* (normalize-version) (form &key pathname component parent)
(fmakunbound 'normalize-version) ;; signature changed between 2.27 and 2.31
(defun normalize-version (form &key pathname component parent)
(labels ((invalid (&optional (continuation "using NIL instead"))
(warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
form component parent pathname continuation))
......@@ -293,11 +294,11 @@ COMPONENTS is a list of the explicitly defined children descriptions.
SERIAL-P is non-NIL if each child in COMPONENTS should depend on the previous
children."))
(defun* stable-union (s1 s2 &key (test #'eql) (key 'identity))
(defun stable-union (s1 s2 &key (test #'eql) (key 'identity))
(append s1
(remove-if #'(lambda (e2) (member (funcall key e2) (funcall key s1) :test test)) s2)))
(defun* (parse-component-form) (parent options &key previous-serial-components)
(defun parse-component-form (parent options &key previous-serial-components)
(destructuring-bind
(type name &rest rest &key
(builtin-system-p () bspp)
......
......@@ -224,7 +224,7 @@ to be meaningful, or could it just as well have been done in another Lisp image?
;;;; Visiting dependencies of an action and computing action stamps
(with-upgradability ()
(defun* (map-direct-dependencies) (operation component fun)
(defun map-direct-dependencies (operation component fun)
"Call FUN on all the valid dependencies of the given action in the given plan"
(loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
:for dep-o = (find-operation operation dep-o-spec)
......@@ -234,7 +234,7 @@ to be meaningful, or could it just as well have been done in another Lisp image?
:when (action-valid-p dep-o dep-c)
:do (funcall fun dep-o dep-c))))
(defun* (reduce-direct-dependencies) (operation component combinator seed)
(defun reduce-direct-dependencies (operation component combinator seed)
"Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
for each dependency action on the dependency's operation and component and an accumulator
initialized with SEED."
......@@ -243,7 +243,7 @@ initialized with SEED."
#'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed))))
seed)
(defun* (direct-dependencies) (operation component)
(defun direct-dependencies (operation component)
"Compute a list of the direct dependencies of the action within the plan"
(reverse (reduce-direct-dependencies operation component #'acons nil)))
......@@ -527,7 +527,7 @@ Update the VISITED-ACTIONS table with the known status, but don't add anything t
:do (collect-action-dependencies plan (action-operation action) (action-component action)))
(plan-actions plan)))
(defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
(defun required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
"Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and
return a list of the components involved in building the desired action."
(with-asdf-session (:override t)
......
......@@ -233,11 +233,11 @@ after having found a .asd file? True by default.")
(defgeneric process-source-registry (spec &key inherit register))
(defun* (inherit-source-registry) (inherit &key register)
(defun inherit-source-registry (inherit &key register)
(when inherit
(process-source-registry (first inherit) :register register :inherit (rest inherit))))
(defun* (process-source-registry-directive) (directive &key inherit register)
(defun process-source-registry-directive (directive &key inherit register)
(destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
(ecase kw
((:include)
......
......@@ -186,10 +186,11 @@ the primary one."
(slot-value (find-system (primary-system-name system))
slot-name))))
(defmacro define-system-virtual-slot-reader (slot-name)
`(defun* ,(intern (concatenate 'string (string :system-)
(string slot-name)))
(system)
(system-virtual-slot-value system ',slot-name)))
(let ((name (intern (strcat (string :system-) (string slot-name)))))
`(progn
(fmakunbound ',name) ;; These were gf from defgeneric before 3.3.2.11
(declaim (notinline ,name))
(defun ,name (system) (system-virtual-slot-value system ',slot-name)))))
(defmacro define-system-virtual-slot-readers ()
`(progn ,@(mapcar (lambda (slot-name)
`(define-system-virtual-slot-reader ,slot-name))
......@@ -214,7 +215,7 @@ the primary one."
in which the system specification (.asd file) is located."
(pathname-directory-pathname (system-source-file system-designator)))
(defun* (system-relative-pathname) (system name &key type)
(defun system-relative-pathname (system name &key type)
"Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
return the absolute pathname of a corresponding file under that system's source code pathname."
(subpathname (system-source-directory system) name :type type))
......
......@@ -434,33 +434,36 @@ extract_all_tagged_asdf () {
}
valid_upgrade_test_p () {
case "${1}:${2}:${3}" in
# It's damn slow. Also, for some reason, we punt on anything earlier than 2.25,
# and only need to test it once, below for 2.24.
abcl:1.*|abcl:2.00[0-9]:*|abcl:201[0-9]:*|abcl:2.2[0-3]:*) : ;;
# ccl fasl numbering broke loading of old asdf 2.0
ccl:2.0[01]*|ccl:2.2[0-6]*) : ;;
# It's damn slow. Also, we punt on anything 2.26 or earlier.
abcl:1.*|abcl:2.[01]*|abcl:2.2[0-5]:*) : ;;
# Allegro ships with versions 3*, so give up testing 2
# Also, unpatched Allegro 10 has bug updating from 2.26 and before
allegro*:[12].*) : ;;
# My old ubuntu 10.04LTS clisp 2.44.1 came wired in
# ccl fasl numbering broke loading of old asdf 2.0. 2.27 has trouble with deferred-warnings.
ccl:2.[01]*|ccl:2.2[0-7]*) : ;;
# clasp only since 3.1.4.3
clasp:2.*|clasp:3.0*|clasp:3.1.[0-4]*) : ;;
# CLISP: My old ubuntu 10.04LTS clisp 2.44.1 came wired in
# with an antique ASDF 1.374 from CLC that can't be downgraded.
# More recent CLISPs work.
# 2.00[0-7] use UID, which fails on some old CLISPs.
# Note that for the longest time, CLISP has included 2.011 in its distribution.
# Now its hg repository includes 3.0.2.29, but clisp hasn't released in many years(!)
# Note that for the longest time, CLISP has included 2.011 in its source repository.
# Now its hg repository includes 3.x, but clisp hasn't released in many years(!)
# We don't punt on upgrade anymore, so we can go at it!
#clisp:2.00[0-7]:*|clisp:1.*|clisp:2.0[01]*|clisp:2.2[0-5]:*) : ;;
# CMUCL has problems with 2.32 and earlier because of
# CMUCL has problems with 3.2.1 and earlier because of
# the redefinition of system's superclass component.
cmucl:1.*|cmucl:2.[012]*|cmucl:2.3[012]*) : ;;
cmucl:1.*|cmucl:2.*|cmucl:3.[012]*) : ;;
# Skip many ECL tests, for various ASDF issues
ecl*:1.*|ecl*:2.0[01]*|ecl*:2.20:*) : ;;
# GCL 2.7.0 from late November 2013 is required, with ASDF 3.1.2
gcl:REQUIRE:*|gcl:1.*|gcl:2.*|gcl:3.0*) : ;;
gcl:REQUIRE:*|gcl:1.*|gcl:2.*|gcl:3.0*|gcl:3.1.[0-3]*) : ;;
# LispWorks is broken at ASDF 3.0.3, but can upgrade from earlier and later ASDFs.
lispworks:3.0.3:*) : ;;
lispworks:1*|lispworks:2.[0-2]*|lispworks:2.3[0-2]*|lispworks:3.0.3:*) : ;;
# MKCL is only supported starting with specific versions 2.24, 2.26.x, 3.0.3.0.x, so skip.
mkcl:[12]*|mkcl:3.0*) : ;;
# SBCL won't run ASDF 1 anymore
sbcl:1*) : ;;
# XCL support starts with ASDF 2.014.2
# — It also dies during upgrade trying to show the backtrace.
xcl:1.*|xcl:2.00*|xcl:2.01[0-4]:*|xcl:*) : ;;
......
......@@ -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))
......
......@@ -16,7 +16,10 @@
;; The 3.3 series provides the asdf3.3 feature, meaning users can rely on
;; all its new features (proper phase separation) as well as earlier features.
"3.3.1" ;; (2017-11-14) bug fixes, second and latest in 3.3 series
"3.3.4" ;; (2020-02-14) bug fixes, fifth and latest in 3.3 series
"3.3.3" ;; (2019-03-27) bug fixes, fourth in 3.3 series
"3.3.2" ;; (2018-05-04) bug fixes, third in 3.3 series
"3.3.1" ;; (2017-11-14) bug fixes, second in 3.3 series, SBCL has been stuck there for years
"3.3.0" ;; (2017-10-06) first in 3.3 series
;; The 3.2 series provides the asdf3.2 feature, meaning users can rely on
......@@ -133,9 +136,10 @@ Use at a given tag, put it under build/asdf-${tag}.lisp"
:allegro_64_s :allegromodern_64_s :allegro8_64_s :allegromodern8_64_s)
(version<= "2.27" tag))
;; CCL fasl numbering broke loading of old asdf 2.0, and the punting for 2.26 fails,
;; but who cares since CCL has always been shipping recent versions of ASDF.
((:ccl) (version<= "2.27" tag))
;; CCL fasl numbering broke loading of old asdf 2.0, the punting for 2.26 fails, and
;; 2.27 enables deferred-warnings then the new UIOP causes confusion with its changed format.
;; But who cares since CCL has always been shipping recent versions of ASDF.
((:ccl) (version<= "2.32" tag))
;; CLASP is only supported as of 3.1.4.3
((:clasp) (version<= "3.1.4.3" tag))
......@@ -149,9 +153,9 @@ Use at a given tag, put it under build/asdf-${tag}.lisp"
;; However, whether we punt or don't punt, these should all work.
((:clisp) t)
;; CMUCL has problems with 2.32 and earlier because of
;; the redefinition of system's superclass component.
((:cmucl) (version<= "2.33" tag))
;; CMUCL has problems with 3.2.1 and earlier because of the redefinition of
;; some classes that causes its subtype to answer NIL when it shouldn't.
((:cmucl) (version<= "3.3.0" tag))
;; Skip many ECL tests, for various ASDF issues
((:ecl :ecl_bytecodes) (version<= "2.21" tag))
......@@ -161,14 +165,20 @@ Use at a given tag, put it under build/asdf-${tag}.lisp"
;; against anything but the latest release.
((:gcl) (version<= "3.1.4" tag))
;; LispWorks is fine, but ASDF 3.0.3 has a bug and can't be loaded.
((:lispworks) (not (equal "3.0.3" tag)))
;; LispWorks is fine, but ASDF 3.0.3 can't be loaded due to a bug it has a bug,
;; while 2.27 to 2.32 use system:pid-exit-status that doesn't exist anymore in LispWorks 7.
((:lispworks) (and (version<= "2.33" tag) (not (equal "3.0.3" tag))))
;; MKCL is only supported starting with specific versions 2.24, 2.26.x, 3.0.3.0.x, so skip.
((:mkcl) (version<= "3.1.2" tag))
;; The bundle support also changed a lot in 3.2.0 and this breaks upgrading from 3.1.
((:mkcl) (version<= "3.2.0" tag))
;; all clear on these implementations
((:sbcl :scl) t)
;; SBCL fails to load ASDF as a system 1.369 because ASDF 1.369's builtin
;; asdf-binary-locations gets confused when SBCL_HOME is not set by SBCL anymore.
((:sbcl) (version<= "2.000" tag))
;; SCL is all good.
((:scl) (version<= "2.000" tag))
;; XCL support starts with ASDF 2.014.2
;; — It also dies during upgrade trying to show the backtrace.
......@@ -196,6 +206,7 @@ Use the preferred lisp implementation"
(extract-tagged-asdf tag)
(run-test-lisp description
`((load "test/script-support.lisp")
(asdf-test::debug-asdf)
(asdf-test::test-upgrade ,@method ,tag))
:lisp lisp :log log))
description))
......
......@@ -215,7 +215,7 @@ directive.")
(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
(:ensure-directory boolean)) t) resolve-location))
(defun* (resolve-location) (x &key ensure-directory wilden directory)
(defun resolve-location (x &key ensure-directory wilden directory)
"Resolve location designator X into a PATHNAME"
;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
(loop :with dirp = (or directory ensure-directory)
......
......@@ -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")
......@@ -662,7 +662,7 @@ possibly in a different process. Otherwise just call THUNK."
(defvar *compile-check* nil
"A hook for user-defined compile-time invariants")
(defun* (compile-file*) (input-file &rest keys
(defun compile-file* (input-file &rest keys
&key (compile-check *compile-check*) output-file warnings-file
#+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl
&allow-other-keys)
......
......@@ -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)
......@@ -605,13 +636,15 @@ or when loading the package is optional."
#+package-local-nicknames
(defun install-package-local-nicknames (destination-package new-nicknames)
;; First, remove all package-local nicknames. (We'll reinstall any desired ones later.)
(dolist (pair-to-remove (package-local-nicknames destination-package))
(remove-package-local-nickname (string (car pair-to-remove)) destination-package))
(dolist (pair-to-remove (uiop/package-local-nicknames:package-local-nicknames destination-package))
(uiop/package-local-nicknames:remove-package-local-nickname
(string (car pair-to-remove)) destination-package))
;; Then, install all desired nicknames.
(loop :for (nickname package) :in new-nicknames
:do (add-package-local-nickname (string nickname)
(find-package package)
destination-package)))
:do (uiop/package-local-nicknames:add-package-local-nickname
(string nickname)
(find-package package)
destination-package)))
(defun ensure-package (name &key
nicknames documentation use
......@@ -664,7 +697,6 @@ or when loading the package is optional."
;; Handle local nicknames
#+package-local-nicknames
(install-package-local-nicknames package local-nicknames)
;; handle uninterning unwanted symbols
(dolist (name unintern)
(multiple-value-bind (existing status) (find-symbol name package)
(when status
......@@ -818,3 +850,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))
......@@ -715,7 +715,7 @@ added to its DIRECTORY component. This is useful for output translations."
:defaults pathname)))
pathname)))
(defun* (translate-pathname*) (path absolute-source destination &optional root source)
(defun translate-pathname* (path absolute-source destination &optional root source)
"A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility.
PATH is the pathname to be translated.
ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname,
......
......@@ -12,7 +12,6 @@
;; magic helper to define debugging functions:
#:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
#:with-upgradability ;; (un)defining functions in an upgrade-friendly way
#:defun* #:defgeneric*
#:nest #:if-let ;; basic flow control
#:parse-body ;; macro definition helper
#:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
......@@ -41,29 +40,33 @@
(in-package :uiop/utility)
;;;; Defining functions in a way compatible with hot-upgrade:
;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
;; thus replacing the function without warning or error
;; even if the signature and/or generic-ness of the function has changed.
;; For a generic function, this invalidates any previous DEFMETHOD.
;; - The WTIH-UPGRADABILITY infrastructure below ensures that functions are declared NOTINLINE,
;; 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,
;; 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.,
;; because the change other caused a huge incompatibility during upgrade.
;; - Whenever a function goes from a DEFUN to a DEFGENERIC, or the DEFGENERIC signature changes, etc.,
;; 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, *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;
;; put that comment on the same line as FMAKUNBOUND, it you use FMAKUNBOUND.
(eval-when (:load-toplevel :compile-toplevel :execute)
(macrolet
((