Add primary system support to modules

Also add CLASP_MUTABLE_SYSTEMS environment variable which will
preload asdf systems which means they can be overwritten. This is
useful for kernel development.

src/koga/scripts.lisp

@@ -204,13 +204,32 @@ exec $(dirname \"$0\")/iclasp -f ignore-extensions --base \"$@\""))
   (ql-dist:install-dist \"http://quickclasp.thirdlaw.tech/quickclasp/quickclasp.txt\" :prompt nil))"))
 
 (defun pprint-immutable-systems (stream object &aux (*print-pretty* t))
-  (format stream "(in-package \"SYSTEM\")~%~%(defparameter *immutable-systems*~%")
+  (format stream "(in-package \"SYSTEM\")~%~%(defparameter *primary-systems*~%  '")
+  (let ((source-files (make-hash-table :test #'equalp)))
+    (loop for (name . properties) in object
+          for source-file = (getf properties :source-file)
+          when source-file
+            do (let ((p (gethash (file-namestring source-file) source-files)))
+                 (if p
+                     (incf (cdr p))
+                     (setf (gethash (file-namestring source-file) source-files)
+                           (cons name 1)))))
+    (asdf:map-systems (lambda (system)
+                        (let ((source-file (asdf:system-source-file system)))
+                          (when (and source-file
+                                     (gethash (file-namestring source-file) source-files))
+                            (decf (cdr (gethash (file-namestring source-file) source-files 0)))))))
+    (pprint-fill stream
+                 (loop for (name . count) being the hash-values of source-files
+                       when (minusp count)
+                         collect (asdf:primary-system-name name))))
+  (format stream ")~%~%(defparameter *immutable-systems*~%")
   (pprint-logical-block (stream (sort (copy-seq object)
                                       (lambda (x y)
                                         (string-lessp (car x) (car y))))
                          :prefix "  '(" :suffix ")")
     (loop do (pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")")
-               (write (pprint-pop) :case :downcase :stream stream)
+               (write (asdf:coerce-name (pprint-pop)) :stream stream)
                (loop do (pprint-exit-if-list-exhausted)
                         (pprint-newline :mandatory stream)
                         (write (pprint-pop) :case :downcase :stream stream)

src/lisp/kernel/lsp/module.lisp

@@ -35,6 +35,10 @@ elements are key/values passed to ASDF:REGISTER-IMMUTABLE-SYSTEM. For
 example, (:ASDF :VERSION \"3.0.0\") will register ASDF as immutable with
 version number of 3.0.0")
 
+(defvar *primary-systems* nil
+    "The primary systems that should immediately be registered when ASDF
+has been initially provided.")
+
 ;;;; PROVIDE and REQUIRE
 
 (defun provide (module-name)
@@ -44,9 +48,17 @@ Module-name is a string designator"
     (pushnew module-as-string *modules* :test #'string=)
     (when (and (find-package :asdf)
                (string= "ASDF" (string-upcase module-as-string)))
-      (let ((register-immutable-system (find-symbol "REGISTER-IMMUTABLE-SYSTEM" :asdf)))
+      (let ((find-system (find-symbol "FIND-SYSTEM" :asdf))
+            (register-immutable-system (find-symbol (if (ext:getenv "CLASP_MUTABLE_SYSTEMS")
+                                                        "REGISTER-PRELOADED-SYSTEM"
+                                                        "REGISTER-IMMUTABLE-SYSTEM")
+                                                    :asdf)))
+        (dolist (name *primary-systems*)
+          (funcall find-system name nil))
         (dolist (args *immutable-systems*)
-          (apply register-immutable-system args)))))
+          (apply register-immutable-system args))
+        (setf *primary-systems* nil
+              *immutable-systems* nil))))
   t)
 
 (defparameter *requiring* nil)