From 32a579df0e942ab7a71a40250f26c171b405d8be Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Fri, 15 May 2020 23:44:44 -0400
Subject: [PATCH] Ensure upgradability without DEFUN*

---
 action.lisp              |  2 +-
 output-translations.lisp |  4 ++--
 parse-defsystem.lisp     |  7 +++---
 plan.lisp                |  8 +++----
 source-registry.lisp     |  4 ++--
 system.lisp              | 11 +++++----
 uiop/configuration.lisp  |  2 +-
 uiop/lisp-build.lisp     |  2 +-
 uiop/pathname.lisp       |  2 +-
 uiop/utility.lisp        | 49 ++++++++++++++++++++++------------------
 upgrade.lisp             | 26 ++++++++++++++-------
 11 files changed, 67 insertions(+), 50 deletions(-)

diff --git a/action.lisp b/action.lisp
index 384df556b..e47c1b6b3 100644
--- a/action.lisp
+++ b/action.lisp
@@ -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.
diff --git a/output-translations.lisp b/output-translations.lisp
index 7ea330d5d..d2512ba01 100644
--- a/output-translations.lisp
+++ b/output-translations.lisp
@@ -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)
diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp
index a45868603..19c986d7d 100644
--- a/parse-defsystem.lisp
+++ b/parse-defsystem.lisp
@@ -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)
diff --git a/plan.lisp b/plan.lisp
index e9a963e51..af67363ff 100644
--- a/plan.lisp
+++ b/plan.lisp
@@ -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)
diff --git a/source-registry.lisp b/source-registry.lisp
index 60001022e..a086cc88a 100644
--- a/source-registry.lisp
+++ b/source-registry.lisp
@@ -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)
diff --git a/system.lisp b/system.lisp
index 31ff92b07..b05888405 100644
--- a/system.lisp
+++ b/system.lisp
@@ -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))
diff --git a/uiop/configuration.lisp b/uiop/configuration.lisp
index 0d6524007..ba68db762 100644
--- a/uiop/configuration.lisp
+++ b/uiop/configuration.lisp
@@ -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)
diff --git a/uiop/lisp-build.lisp b/uiop/lisp-build.lisp
index 12870ba38..557fae188 100644
--- a/uiop/lisp-build.lisp
+++ b/uiop/lisp-build.lisp
@@ -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)
diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp
index 23fb20661..1daf98cc2 100644
--- a/uiop/pathname.lisp
+++ b/uiop/pathname.lisp
@@ -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,
diff --git a/uiop/utility.lisp b/uiop/utility.lisp
index c985e776a..071e6bb7a 100644
--- a/uiop/utility.lisp
+++ b/uiop/utility.lisp
@@ -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)
-              name)
-        (declare (ignorable supersede))
-        `(progn
-           ;; 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))))
-           ,form))))
+  (defun ensure-function-notinline (definition &aux (name (second definition)))
+    (assert (member (first definition) '(defun defgeneric)))
+    `(progn
+       ,(when (and #+(or clasp ecl) (symbolp name)) ; NB: fails for (SETF functions) on ECL
+          `(declaim (notinline ,name)))
+       ,definition))
   (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))
                    form)))))
 
diff --git a/upgrade.lisp b/upgrade.lisp
index 9eb6a2e8a..e2cc4d6ca 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -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 https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36
-          `(,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2
-            ,@(when (version< previous-version "3.1.7.20") '(#:find-component))))
+          ;; and at https://gitlab.common-lisp.net/asdf/asdf/-/merge_requests/141
+          `(,@(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 "3.1.7.20") '(#: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 "3.3.2.11") ;; 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))))
          (redefined-classes
           ;; redefining the classes causes interim circularities
           ;; with the old ASDF during upgrade, and many implementations bork
-- 
GitLab