X-Git-Url: https://git.distorted.org.uk/~mdw/runlisp/blobdiff_plain/59d4ae8bbbd70e257b4db14a45d092ae7c8d6361..HEAD:/runlisp-base.conf

diff --git a/runlisp-base.conf b/runlisp-base.conf
index d733c1c..7634e42 100644
--- a/runlisp-base.conf
+++ b/runlisp-base.conf
@@ -85,11 +85,24 @@ require-asdf =
 ;; Prevent ASDF from upgrading itself.  Otherwise it will do this
 ;; automatically if a script invokes `asdf:load-system', but that will have a
 ;; bad effect on startup time, and risks spamming the output streams with
-;; drivel.
+;; drivel.  Some ancient Lisps come with an ASDF which doesn't understand
+;; `register-immutable-system', so do the job by hand if necessary.
 inhibit-asdf-upgrade =
-	(funcall (intern "REGISTER-IMMUTABLE-SYSTEM"
-			 (find-package "ASDF"))
-		 "asdf")
+	(let* ((#1300=#:root (find-package "ASDF"))
+	       (#1301=#:ris (find-symbol "REGISTER-IMMUTABLE-SYSTEM" #1300#)))
+	  (if (and #1301# (fboundp #1301#))
+	      (funcall #1301# "asdf")
+	      (let* ((#1302=#:fsys (find-package "ASDF/FIND-SYSTEM"))
+		     (#1303=#:iss (find-symbol "*IMMUTABLE-SYSTEMS*" #1302#))
+		     (#1304=#:dss (find-symbol "*DEFINED-SYSTEMS*" #1302#))
+		     (#1305=#:sys (find-symbol "SYSTEM" #1300#)))
+		(unless (symbol-value #1303#)
+		  (setf (symbol-value #1303#)
+			  (make-hash-table :test (function equal))))
+		(setf (gethash "asdf" (symbol-value #1303#)) t
+		      (gethash "asdf" (symbol-value #1304#))
+			(cons (get-universal-time)
+			      (make-instance #1305# :name "asdf"))))))
 
 ;; Upgrade ASDF from the source registry.
 upgrade-asdf =
@@ -135,6 +148,19 @@ image-path = ${@image-dir}/${image-file}
 command = ${@ENV:SBCL?sbcl}
 image-file = ${@name}+asdf.core
 
+;; Older versions of SBCL forget their home directory when an image is
+;; dumped, so we must help this one to remember.
+etch-sbcl-home =
+	(let* ((#100=#:sfs (find-symbol "*STATIC-FOREIGN-SYMBOLS*" "SB-IMPL"))
+	       (#101=#:shp (find-symbol "SBCL-HOMEDIR-PATHNAME" "SB-IMPL")))
+	  (unless (or (not #100#) (not #101#)
+		      (gethash "sbcl_home" (symbol-value #100#)))
+	    (#+sb-package-locks without-package-locks
+	     #-sb-package-locks progn
+	      (setf (symbol-function #101#)
+		    (let ((#102=#:etched-sbcl-home (funcall #101#)))
+		      (lambda () #102#))))))
+
 run-script =
 	${command} --noinform
 		$?@image{--core "${image-path}" --eval "${image-restore}" |
@@ -144,6 +170,7 @@ run-script =
 dump-image =
 	${command} --noinform --no-userinit --no-sysinit --disable-debugger
 		--eval "${dump-image-prelude}"
+		--eval "${etch-sbcl-home}"
 		--eval "(sb-ext:save-lisp-and-die \"${@image-new|q}\")"
 
 ;;;--------------------------------------------------------------------------
@@ -261,7 +288,12 @@ run-script =
 	${command}
 		$?@image{-core "${image-path}" -eval "${image-restore}" |
 			 -batch -noinit -quiet
-				 -eval "(progn
+				 -eval "(handler-bind
+					    ((warning
+					       (lambda (#0=#:c)
+						 (declare (ignore #0#))
+						 (invoke-restart
+						  'muffle-warning))))
 					  (setf ext:*require-verbose* nil)
 					  ${run-script-prelude}
 					  ${clear-cl-user})"}