;; 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
;;;--------------------------------------------------------------------------
[@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
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
;; 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 =
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}" |
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}\")"
;;;--------------------------------------------------------------------------
${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
$?@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}"}
--
run-script =
${command}
$?@image{-core "${image-path}" -eval "${image-restore}" |
- -batch -noinit -nositeinit -quiet
- -eval "(progn
+ -batch -noinit -quiet
+ -eval "(handler-bind
+ ((warning #'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)"
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*
(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 =
~mdw / runlisp / blobdiff