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

diff --git a/runlisp-base.conf b/runlisp-base.conf
index 00bfa91..dc1ecef 100644
--- a/runlisp-base.conf
+++ b/runlisp-base.conf
@@ -26,7 +26,7 @@
 ;; Variables are looked up starting in the home (or explicitly specified)
 ;; section, then proceeding to the parents assigned to `@PARENTS'.
 ;; (`@PARENTS' usually defaults to `@COMMON'; the parent of `@COMMON' is
-;; `@BUILTIN'; `@BUILTIN' and `@CONFIG' have no parents.)
+;; `@BUILTIN'; `@BUILTIN' and `@ENV' have no parents.)
 ;;
 ;; At top-level, the text is split into words at whitespace, unless prevented
 ;; by double- and single-quote, or escaped by `\'.  Within single quotes, all
@@ -38,6 +38,13 @@
 ;;;--------------------------------------------------------------------------
 [@COMMON]
 
+;; In order to avoid leaking symbols in `cl-user', the code fragments here
+;; and in implementation definitions need to use uninterned symbols for their
+;; local names, and use `#N=' and `#N#' reader macros to refer to them.  In
+;; order to prevent conflicts with the ID numbers in these, the fragments
+;; here use ID numbers from 1000 up to 9999, leaving 0--999 (and, if you
+;; really need them, 10000 on upwards) for individual implementations.
+
 ;; Turn `#!' into a comment-to-end-of-line.  This is used in all Lisp
 ;; invocations, even though some of them don't apparently need it.  For
 ;; example, SBCL ignores an initial line beginning `#!' as a special feature
@@ -48,22 +55,22 @@
 ignore-shebang =
 	(set-dispatch-macro-character
 	 #\\# #\\!
-	 (lambda (#1=#:stream #2=#:char #3=#:arg)
-	   (declare (ignore #2# #3#))
-	   (values (read-line #1#))))
+	 (lambda (#1000=#:stream #1001=#:char #1002=#:arg)
+	   (declare (ignore #1001# #1002#))
+	   (values (read-line #1000#))))
 
 ;; Clear all present symbols from the `COMMON-LISP-USER' package.  Some Lisps
 ;; leave débris in `COMMON-LISP-USER' -- for example, ECL leaves some
 ;; allegedly useful symbols lying around, while ABCL has a straight-up bug in
 ;; its `adjoin.lisp' file.
 clear-cl-user =
-	(let ((#4=#:pkg (find-package "COMMON-LISP-USER")))
-	  (with-package-iterator (#5=#:next #4# :internal)
-	    (loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how)
-		      (#5#)
-		    (declare (ignore #8#))
-		    (unless #6# (return))
-		    (unintern #7# #4#)))))
+	(let ((#1200=#:pkg (find-package "COMMON-LISP-USER")))
+	  (with-package-iterator (#1201=#:next #1200# :internal)
+	    (loop (multiple-value-bind (#1202=#:anyp #1203=#:sym #1204=#:how)
+		      (#1201#)
+		    (declare (ignore #1204#))
+		    (unless #1202# (return))
+		    (unintern #1203# #1200#)))))
 
 ;; Add `:runlisp-script' to `*features*' so that scripts can tell whether
 ;; they're supposed to sit quietly and be debugged in a Lisp session or run
@@ -78,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 =
@@ -111,12 +131,17 @@ dump-image-prelude =
 	  ${ignore-shebang}
 	  ${set-script-feature})
 
+;; An expression to determine the version information for the running Lisp.
+lisp-version =
+	(list (list* \'lisp
+		     (lisp-implementation-type)
+		     (multiple-value-list (lisp-implementation-version)))
+	      (cons \'asdf
+		    (asdf:component-version (asdf:find-system "asdf"))))
+
 ;; Full pathname to custom image.
 image-path = ${@image-dir}/${image-file}
 
-;; Command to delete image.
-delete-image = rm -f ${image-path}
-
 ;;;--------------------------------------------------------------------------
 [sbcl]
 
@@ -153,13 +178,13 @@ dump-image =
 	${command} -b -n -Q
 		-e "${dump-image-prelude}"
 		-e "(ccl::in-development-mode
-		      (let ((#1=#:real-ccl-dir (ccl::ccl-directory)))
+		      (let ((#0=#:real-ccl-dir (ccl::ccl-directory)))
 			(defun ccl::ccl-directory ()
-			  (let* ((#2=#:dirpath
+			  (let* ((#1=#:dirpath
 				   (ccl:getenv \"CCL_DEFAULT_DIRECTORY\")))
-			    (if (and #2# (plusp (length (namestring #2#))))
-				(ccl::native-to-directory-pathname #2#)
-				#1#))))
+			    (if (and #1# (plusp (length (namestring #1#))))
+				(ccl::native-to-directory-pathname #1#)
+				#0#))))
 		      (compile 'ccl::ccl-directory))"
 		-e "(ccl:save-application \"${@image-new|q}\"
 					  :init-file nil
@@ -230,8 +255,8 @@ run-script =
 	$?@image{"${image-path}" -s "${@script}" |
 		 ${@ENV:ECL?ecl} "${@ecl-opt}norc"
 			 "${@ecl-opt}eval" "(progn
-					    ${run-script-prelude}
-					    ${clear-cl-user})"
+					      ${run-script-prelude}
+					      ${clear-cl-user})"
 			 "${@ecl-opt}shell" "${@script}"}
 		--
 
@@ -248,15 +273,21 @@ image-file = ${@name}+asdf.core
 run-script =
 	${command}
 		$?@image{-core "${image-path}" -eval "${image-restore}" |
-			 -batch -noinit -nositeinit -quiet
-				 -eval "(progn
+			 -batch -noinit -quiet
+				 -eval "(handler-bind
+					    ((warning
+					       (lambda (#0=#:c)
+						 (declare (ignore #0#))
+						 (invoke-restart
+						  'muffle-warning))))
 					  (setf ext:*require-verbose* nil)
-					  ${run-script-prelude})"}
+					  ${run-script-prelude}
+					  ${clear-cl-user})"}
 		-load "${@script}" -eval "(ext:quit)" --
 
 dump-image =
-	${command} -batch -noinit -nositeinit -quiet
-		-eval "${dump-image-prelude}"
+	${command} -batch -noinit -quiet
+		-eval "(progn ${dump-image-prelude} ${clear-cl-user})"
 		-eval "(ext:save-lisp \"${@image-new|q}\"
 				      :batch-mode t :print-herald nil
 				      :site-init nil :load-init-file nil)"
@@ -285,7 +316,7 @@ dump-image =
 command = ${@ENV:ABCL?abcl}
 
 abcl-startup =
-	(let ((#9=#:script "${@script|q}"))
+	(let ((#0=#:script "${@script|q}"))
 	  ${run-script-prelude}
 	  ${clear-cl-user}
 	  (setf *error-output*
@@ -294,9 +325,9 @@ abcl-startup =
 			     (java:jfield "java.lang.System" "err")
 			     \'character
 			     java:+true+))
-	  (handler-case (load #9# :verbose nil :print nil)
+	  (handler-case (load #0# :verbose nil :print nil)
 	    (error (error)
-	      (format *error-output* "~A (unhandled error): ~A~%" #9# error)
+	      (format *error-output* "~A (unhandled error): ~A~%" #0# error)
 	    (ext:quit :status 255))))
 
 run-script =