From bcfbac2f9793a27b251c0cf4899edbea85e2eaf8 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Wed, 22 Mar 2017 18:07:31 -0400
Subject: [PATCH] More backward compatible REQUIRE behavior

Don't warn when OPERATE is called by REQUIRE.

Don't use :FORCE-NOT in REQUIRE-SYSTEM (only check that
the required system isn't present yet; otherwise inherit ambient force-not).
---
 find-system.lisp |  5 ++---
 operate.lisp     | 25 +++++++++++++++++++------
 2 files changed, 21 insertions(+), 9 deletions(-)

diff --git a/find-system.lisp b/find-system.lisp
index 00693bc66..e6ae3a7c9 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -61,9 +61,8 @@
                  (push (cons operation component) (definition-dependency-list parent-component))
                  (setf (gethash action (definition-dependency-set parent-component)) t))))
             (t
-             (warn (compatfmt "~@<Deprecated recursive use of (~S '~S '~S) while visiting ~S ~
-- please use proper dependencies instead~@:>")
-                   'operate (type-of operation) (component-find-path component) (action-path action))))))))
+             (warn 'recursive-operate
+                   :operation operation :component component :action action)))))))
 
   (defmethod component-depends-on ((o define-op) (s system))
     `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below.
diff --git a/operate.lisp b/operate.lisp
index 87bb46d65..ddee05463 100644
--- a/operate.lisp
+++ b/operate.lisp
@@ -10,7 +10,8 @@
    #:operate #:oos #:build-op #:make
    #:load-system #:load-systems #:load-systems*
    #:compile-system #:test-system #:require-system #:module-provide-asdf
-   #:component-loaded-p #:already-loaded-systems))
+   #:component-loaded-p #:already-loaded-systems
+   #:recursive-operate))
 (in-package :asdf/operate)
 
 (with-upgradability ()
@@ -106,8 +107,19 @@ But do NOT depend on it, for this is deprecated behavior."))
 
   (setf (documentation 'oos 'function)
         (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
-                (documentation 'operate 'function))))
-
+                (documentation 'operate 'function)))
+
+  (define-condition recursive-operate (warning)
+    ((operation :initarg :operation :reader condition-operation)
+     (component :initarg :component :reader condition-component)
+     (action :initarg :action :reader condition-action))
+    (:report (lambda (c s)
+               (format s (compatfmt "~@<Deprecated recursive use of (~S '~S '~S) while visiting ~S ~
+- please use proper dependencies instead~@:>")
+                       'operate
+                       (type-of (condition-operation c))
+                       (component-find-path (condition-component c))
+                       (action-path (condition-action c)))))))
 
 ;;;; Common operations
 (when-upgrading ()
@@ -175,9 +187,10 @@ Note that this returns true even if the component is not up to date."
 
   (defun require-system (system &rest keys &key &allow-other-keys)
     "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the
-system or its dependencies if they have already been loaded."
+system or its dependencies if it has already been loaded."
+    (declare (ignore keys))
     (unless (component-loaded-p system)
-      (apply 'load-system system :force-not (already-loaded-systems) keys))))
+      (load-system system))))
 
 
 ;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
@@ -236,7 +249,7 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
         (let ((*modules-being-required* (cons module-name *modules-being-required*))
               #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal)))
           (handler-bind
-              ((style-warning #'muffle-warning)
+              (((or style-warning recursive-operate) #'muffle-warning)
                (missing-component (constantly nil))
                (fatal-condition
                 #'(lambda (e)
-- 
GitLab