From cbca8e6ff5e6af49d4cea75ff0373b58b6b7f1c9 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Mon, 7 Oct 2013 22:35:51 -0400
Subject: [PATCH] When loading a system with non-primary name (e.g. foo/bar),
 load the system with primary name first (e.g. foo), but avoid infinite loops
 by checking for system being defined. This should help with Quicklisp and
 other extensions that define functions for
 *system-definition-search-functions* so they don't have to pay special
 attention to primary name canonicalization unless they really want to. Also,
 use the ensure-gethash utility in a few more places.

---
 find-system.lisp | 24 +++++++++++++++---------
 operation.lisp   |  7 ++-----
 2 files changed, 17 insertions(+), 14 deletions(-)

diff --git a/find-system.lisp b/find-system.lisp
index cee8d4a7..43681ef1 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -258,7 +258,8 @@ Going forward, we recommend new users should be using the source-registry.
 
   (defun find-system-if-being-defined (name)
     (when *systems-being-defined*
-      (gethash (coerce-name name) *systems-being-defined*)))
+      ;; notable side effect: mark the system as being defined, to avoid infinite loops
+      (ensure-gethash (coerce-name name) *systems-being-defined* nil)))
 
   (defun call-with-system-definitions (thunk)
     (if *systems-being-defined*
@@ -310,13 +311,13 @@ Going forward, we recommend new users should be using the source-registry.
                              (read-file-form version-pathname)))
                (old-version (asdf-version)))
           (or (version<= old-version version)
-              (let ((old-pathname
-                      (if-let (pair (system-registered-p "asdf"))
-                        (system-source-file (cdr pair))))
-                    (key (list pathname old-version)))
-                (unless (gethash key *old-asdf-systems*)
-                  (setf (gethash key *old-asdf-systems*) t)
-                  (warn "~@<~
+              (ensure-gethash
+               (list pathname old-version) *old-asdf-systems*
+                 #'(lambda ()
+                     (let ((old-pathname
+                             (if-let (pair (system-registered-p "asdf"))
+                               (system-source-file (cdr pair)))))
+                       (warn "~@<~
         You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
         or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
         ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
@@ -338,7 +339,8 @@ Going forward, we recommend new users should be using the source-registry.
         then you might indeed want to either install and register a more recent version, ~
         or use :ignore-inherited-configuration to avoid registering the old one. ~
         Please consult ASDF documentation and/or experts.~@:>~%"
-                    old-version old-pathname version pathname)))))))
+                             old-version old-pathname version pathname)
+                       t)))))))
 
   (defun locate-system (name)
     "Given a system NAME designator, try to locate where to load the system from.
@@ -375,6 +377,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
 
   (defmethod find-system ((name string) &optional (error-p t))
     (with-system-definitions ()
+      (let ((primary-name (primary-system-name name)))
+        (unless (or (equal name primary-name)
+                    (nth-value 1 (gethash primary-name *systems-being-defined*)))
+          (find-system primary-name nil)))
       (loop
         (restart-case
             (multiple-value-bind (foundp found-system pathname previous previous-time)
diff --git a/operation.lisp b/operation.lisp
index ca6c5c09..989f8dbb 100644
--- a/operation.lisp
+++ b/operation.lisp
@@ -38,11 +38,8 @@
 (with-upgradability ()
   (defparameter *operations* (make-hash-table :test 'equal))
   (defun make-operation (operation-class &rest initargs)
-    (let ((key (cons operation-class initargs)))
-      (multiple-value-bind (operation foundp) (gethash key *operations*)
-        (if foundp operation
-            (setf (gethash key *operations*)
-                  (apply 'make-instance operation-class initargs))))))
+    (ensure-gethash (cons operation-class initargs) *operations*
+                    (list* 'make-instance operation-class initargs)))
 
   (defgeneric find-operation (context spec)
     (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
-- 
GitLab