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/3] 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/3] 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)


From 3fd837926f408e40f3b248f055b849e44e94ada7 Mon Sep 17 00:00:00 2001
From: Dave Cooper <david.cooper@genworks.com>
Date: Mon, 11 Aug 2014 12:14:46 -0400
Subject: [PATCH 3/3] also perform a register-system as part of
 register-immutable-system. Don't clear immutable-systems as part of
 clear-system and clear-defined-system.

---
 find-system.lisp | 46 +++++++++++++++++++++++++++++++++-------------
 1 file changed, 33 insertions(+), 13 deletions(-)

diff --git a/find-system.lisp b/find-system.lisp
index c9350bd..16b8ff9 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -90,11 +90,17 @@ of which is a system object.")
                     system)))))
 
   (defun clear-defined-system (system)
+    "Perform a clear-system as well as unsetting the cache entries for
+a system, unless the system appears in the table of
+*immutable-systems*. Returns nil if successful, or the system name if
+it was immutable (and thus not cleared)."
     (let ((name (coerce-name system)))
-      (remhash name *defined-systems*)
-      (unset-asdf-cache-entry `(locate-system ,name))
-      (unset-asdf-cache-entry `(find-system ,name))
-      nil))
+      (if (gethash name *immutable-systems*) name
+          (progn
+            (remhash name *defined-systems*)
+            (unset-asdf-cache-entry `(locate-system ,name))
+            (unset-asdf-cache-entry `(find-system ,name))
+            nil))))
 
   (defun clear-defined-systems ()
     ;; Invalidate all systems but ASDF itself, if registered.
@@ -104,13 +110,19 @@ of which is a system object.")
 
   (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
 
-  (defun clear-system (name)
-    "Clear the entry for a system in the database of systems previously loaded.
-Note that this does NOT in any way cause the code of the system to be unloaded."
+  (defun clear-system (system-name)
+    "Clear the entry for a system in the database of systems
+previously loaded, unless the system appears in the table of
+*immutable-systems*. Note that this does NOT in any way cause the code
+of the system to be unloaded. Returns t if cleared, nil if the system
+was either not already there in the *defined-systems* table or was
+found to be immutable."
     ;; There is no "unload" operation in Common Lisp, and
     ;; a general such operation cannot be portably written,
     ;; considering how much CL relies on side-effects to global data structures.
-    (remhash (coerce-name name) *defined-systems*))
+    (let ((name (coerce-name system-name)))
+      (unless (gethash name *immutable-systems*)
+        (remhash (coerce-name name) *defined-systems*))))
 
   (defun map-systems (fn)
     "Apply FN to each defined system.
@@ -249,11 +261,19 @@ Going forward, we recommend new users should be using the source-registry.
   (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
     ;; 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))
+  
+
+  (defun register-immutable-system (system-name &key (version t))
+    (let* ((registered? (system-registered-p system-name))
+           (version (cond ((and (eql version t) registered?)
+                           (component-version (find-system system-name)))
+                          ((eql version t) nil)
+                          (t version))))
+      (register-preloaded-system system-name :version version)
+      (unless (system-registered-p system-name) 
+        (register-system (make-preloaded-system system-name (list :version version))))
+      (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
-- 
1.8.5.2 (Apple Git-48)

