Commit 32a579df authored by Francois-Rene Rideau's avatar Francois-Rene Rideau Committed by Robert Goldman
Browse files

Ensure upgradability without DEFUN*

parent 3bb042cb
......@@ -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.
......@@ -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
......@@ -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
......@@ -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
(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)
(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))))
(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
......@@ -186,10 +186,11 @@ the primary one."
(slot-value (find-system (primary-system-name system))
(defmacro define-system-virtual-slot-reader (slot-name)
`(defun* ,(intern (concatenate 'string (string :system-)
(string slot-name)))
(system-virtual-slot-value system ',slot-name)))
(let ((name (intern (strcat (string :system-) (string slot-name)))))
(fmakunbound ',name) ;; These were gf from defgeneric before
(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))
......@@ -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)
......@@ -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
......@@ -715,7 +715,7 @@ added to its DIRECTORY component. This is useful for output translations."
:defaults 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,27 +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.
;; - 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.
;; - 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.
;; - 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)
(defun frob-defun/defgeneric (form)
(assert (member (first form) '(defun defgeneric)))
(let ((name (second form)))
(destructuring-bind (name &key (supersede t))
(if (or (atom name) (eq (car name) 'setf))
(list name :supersede nil)
(declare (ignorable supersede))
;; We usually try to do it only for the functions that need it,
;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
,@(when supersede
`((fmakunbound ',name)))
,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl
`((declaim (notinline ,name))))
(defun ensure-function-notinline (definition &aux (name (second definition)))
(assert (member (first definition) '(defun defgeneric)))
,(when (and #+(or clasp ecl) (symbolp name)) ; NB: fails for (SETF functions) on ECL
`(declaim (notinline ,name)))
(defmacro with-upgradability ((&optional) &body body)
"Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
to also declare the functions NOTINLINE and to accept a wrapping the function name
......@@ -72,7 +77,7 @@ to supersede any previous definition."
,@(loop :for form :in body :collect
(if (consp form)
(case (first form)
((defun defgeneric) (frob-defun/defgeneric form))
((defun defgeneric) (ensure-function-notinline form))
(otherwise form))
......@@ -108,18 +108,28 @@ previously-loaded version of ASDF."
(when-upgrading ()
(let* ((previous-version (first *previous-asdf-versions*))
(redefined-functions ;; List of functions that changed incompatibly since 2.27:
;; gf signature changed (should NOT happen), defun that became a generic function,
;; method removed that will mess up with new ones (especially :around :before :after,
;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops.
;; gf signature changed (should NOT happen), defun that became a generic function or
;; the other way around, method removed that will mess up with new ones
;; (especially :around :before :after, more specific or call-next-method'ed method)
;; and/or semantics otherwise modified. Oops.
;; NB: it's too late to do anything about functions in UIOP!
;; If you introduce some critical incompatibility there, you must change the function name.
;; If you introduce some critical incompatibility there, you MUST change the function name.
;; Note that we don't need do anything about functions that changed incompatibly
;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade.
;; Also note that we don't include the defgeneric=>defun, because they are
;; done directly with defun* and need not trigger a punt on data.
;; See discussion at
`(,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2
,@(when (version< previous-version "") '(#:find-component))))
;; and at
`(,@(when (version< previous-version "2.31") '(#:normalize-version)) ;; pathname became &key
,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2
,@(when (version< previous-version "") '(#:find-component))
,@(when (version< previous-version "3.2.0") '(#:required-components)) ; was a gf
,@(when (version< previous-version "3.3.0")
'(#:action-valid-p #:map-direct-dependencies ;; were gfs with plan first
#:reduce-direct-dependencies #:direct-dependencies))
,@(when (version< previous-version "") ;; were gfs
'(#:system-long-name #:system-description #:system-long-description
#:system-author #:system-maintainer #:system-mailto
#:system-homepage #:system-source-control
#:system-licence #:system-license #:system-version #:system-bug-tracker))))
;; redefining the classes causes interim circularities
;; with the old ASDF during upgrade, and many implementations bork
Supports Markdown
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