From 93c463fb2e2caf066ede042b0d24edc3f77a0b35 Mon Sep 17 00:00:00 2001
From: Dave Cooper <david.cooper@genworks.com>
Date: Sun, 10 Aug 2014 13:40:16 -0400
Subject: [PATCH 1/2] added register-immutable-system function, made
 *immutable-systems* also respect preloaded-systems

---
 find-system.lisp | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

diff --git a/find-system.lisp b/find-system.lisp
index 3ecc03b..7eb877c 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -19,7 +19,7 @@
    #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
    #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
    #:clear-defined-system #:clear-defined-systems #:*defined-systems*
-   #:*immutable-systems*
+   #:*immutable-systems* #:register-immutable-system
    ;; defined in source-registry, but specially mentioned here:
    #:initialize-source-registry #:sysdef-source-registry-search))
 (in-package :asdf/find-system)
@@ -250,6 +250,11 @@ Going forward, we recommend new users should be using the source-registry.
     ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
     (register-preloaded-system s :version *asdf-version*))
 
+  (defun register-immutable-system (system-name)
+    (register-preloaded-system system-name)
+    (unless *immutable-systems* (setq *immutable-systems* (list-to-hash-set nil)))
+    (setf (gethash (coerce-name system-name) *immutable-systems*) t))
+
   (defmethod find-system ((name null) &optional (error-p t))
     (when error-p
       (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
@@ -343,6 +348,7 @@ downgrade, before you dump an image, use:
     (let ((name (coerce-name requested)))
       (when (and *immutable-systems* (gethash name *immutable-systems*))
         (or (cdr (system-registered-p requested))
+	    (sysdef-preloaded-system-search name)
             (error 'formatted-system-definition-error
                    :format-control "Requested system ~A is in the *immutable-systems* set, ~
 but not loaded in memory"
@@ -387,7 +393,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
         (unless (equal name primary-name)
           (find-system primary-name nil)))
       (or (and *immutable-systems* (gethash name *immutable-systems*)
-               (cdr (system-registered-p name)))
+               (or (cdr (system-registered-p name))
+		   (sysdef-preloaded-system-search name)))
           (multiple-value-bind (foundp found-system pathname previous previous-time)
               (locate-system name)
             (assert (eq foundp (and (or found-system pathname previous) t)))
-- 
1.8.5.2 (Apple Git-48)


From a576c24077f5e9c661cd414ac43d168a169f3215 Mon Sep 17 00:00:00 2001
From: Dave Cooper <david.cooper@genworks.com>
Date: Sun, 10 Aug 2014 20:25:59 -0400
Subject: [PATCH 2/2] removed tab characters

---
 find-system.lisp | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/find-system.lisp b/find-system.lisp
index 7eb877c..c9350bd 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -348,7 +348,7 @@ downgrade, before you dump an image, use:
     (let ((name (coerce-name requested)))
       (when (and *immutable-systems* (gethash name *immutable-systems*))
         (or (cdr (system-registered-p requested))
-	    (sysdef-preloaded-system-search name)
+            (sysdef-preloaded-system-search name)
             (error 'formatted-system-definition-error
                    :format-control "Requested system ~A is in the *immutable-systems* set, ~
 but not loaded in memory"
@@ -394,7 +394,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
           (find-system primary-name nil)))
       (or (and *immutable-systems* (gethash name *immutable-systems*)
                (or (cdr (system-registered-p name))
-		   (sysdef-preloaded-system-search name)))
+                   (sysdef-preloaded-system-search name)))
           (multiple-value-bind (foundp found-system pathname previous previous-time)
               (locate-system name)
             (assert (eq foundp (and (or found-system pathname previous) t)))
-- 
1.8.5.2 (Apple Git-48)

