From 016d6baec89099f369452446c1848c3a3693b86c Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Sun, 11 Sep 2016 23:51:12 -0400
Subject: [PATCH] Make module provider wrapping idempotent

Tweak the footer a little bit.
---
 footer.lisp | 54 ++++++++++++++++++++++++++++-------------------------
 1 file changed, 29 insertions(+), 25 deletions(-)

diff --git a/footer.lisp b/footer.lisp
index 21213f99f..5b5ca4fbf 100644
--- a/footer.lisp
+++ b/footer.lisp
@@ -4,44 +4,48 @@
 (uiop/package:define-package :asdf/footer
   (:recycle :asdf/footer :asdf)
   (:use :uiop/common-lisp :uiop
-        :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle))
+        :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle)
+  ;; Happily, all those implementations all have the same module-provider hook interface.
+  #+(or abcl clasp cmucl clozure ecl mkcl sbcl)
+  (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext
+		#:*module-provider-functions*
+		#+(or clasp ecl mkcl) #:*load-hooks*)
+  #+mkcl (:import-from :si #:*load-hooks*))
+
 (in-package :asdf/footer)
 
 ;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
 #+(or abcl clasp clisp clozure cmucl ecl mkcl sbcl)
 (with-upgradability ()
-  (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
-    (eval `(pushnew 'module-provide-asdf
-                    #+abcl sys::*module-provider-functions*
-                    #+(or clasp cmucl ecl) ext:*module-provider-functions*
-                    #+clisp ,x
-                    #+clozure ccl:*module-provider-functions*
-                    #+mkcl mk-ext:*module-provider-functions*
-                    #+sbcl sb-ext:*module-provider-functions*)))
+  #-clisp (pushnew 'module-provide-asdf *module-provider-functions*)
+  #+clisp (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
+            (eval `(pushnew 'module-provide-asdf ,x)))
 
   #+(or clasp ecl mkcl)
   (progn
-    (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car)
-
-    #+(or (and clasp windows) (and ecl win32) (and mkcl windows))
-    (unless (assoc "asd" #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
-      (appendf #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
-
-    (setf #+(or clasp ecl) ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
-          (loop :for f :in #+(or clasp ecl) ext:*module-provider-functions*
-                #+mkcl mk-ext::*module-provider-functions*
-                :collect
-                (if (eq f 'module-provide-asdf) f
-                    #'(lambda (name)
-                        (let ((l (multiple-value-list (funcall f name))))
-                          (and (first l) (register-preloaded-system (coerce-name name)))
-                          (values-list l))))))))
+    (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car)
+
+    #+os-windows
+    (unless (assoc "asd" *load-hooks* :test 'equal)
+      (appendf *load-hooks* '(("asd" . si::load-source))))
+
+    ;; Wrap module provider functions in an idempotent, upgrade friendly way
+    (defvar *wrapped-module-provider* (make-hash-table))
+    (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf)
+    (defun wrap-module-provider (provider name)
+      (let ((results (multiple-value-list (funcall provider name))))
+	(when (first results) (register-preloaded-system (coerce-name name)))
+	(values-list results)))
+    (setf *module-provider-functions*
+          (loop :for provider :in *module-provider-functions* :collect
+	    (ensure-gethash provider *wrapped-module-provider*
+			    #'(lambda (module-name) (wrap-module-provider provider module-name)))))))
 
 #+cmucl ;; Hook into the CMUCL herald.
 (with-upgradability ()
   (defun herald-asdf (stream)
     (format stream "    ASDF ~A" (asdf-version)))
-  (setf (getf ext:*herald-items* :asdf) `(herald-asdf)))
+  (setf (getf ext:*herald-items* :asdf) '(herald-asdf)))
 
 
 ;;;; Done!
-- 
GitLab