run () { echo "$*"; "$@"; }
## Start by compiling a copy of ASDF.
-cat >"$tmp/ecl-build.lisp" <<EOF
+cat >"$tmp/ecl-build.lisp" <<'EOF'
(require "asdf")
-(defparameter *asdf* (asdf:find-system "asdf"))
+(defparameter *asdf* (asdf:find-system "asdf")
+ "The `asdf' system itself.")
(defun right-here (pathname pattern)
+ "An `asdf:initialize-output-translations' function: use current directory.
+
+ This function should be used in a `(:function ...)' form as the right hand
+ side of an `asdf:initialize-output-translations' entry. It causes the
+ output file to be written to the current directory, regardless of the
+ pathname of the input file(s)."
(declare (ignore pattern))
- (merge-pathnames
- (make-pathname :name (concatenate 'string
- (string-downcase
- (lisp-implementation-type))
- "-"
- (pathname-name pathname))
- :type nil
- :version nil
- :defaults *default-pathname-defaults*)
- pathname))
-(asdf:initialize-output-translations '(:output-translations
- ((#p"/" :**/ :*.*.*)
- (:function right-here))
- :ignore-inherited-configuration))
+ (merge-pathnames (make-pathname :name (pathname-name pathname)
+ :type nil
+ :version nil
+ :defaults *default-pathname-defaults*)
+ pathname))
+
+;; Configure the translations.
+(asdf:initialize-output-translations
+ '(:output-translations ((#p"/" :**/ :*.*.*) (:function right-here))
+ :ignore-inherited-configuration))
+;; Generate a linkable library for `asdf'.
(asdf:operate 'asdf:lib-op *asdf*)
+
+;; We're done.
(si:quit 0)
EOF
(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-build.lisp")
## And now compile our driver code.
-cat >"$tmp/ecl-run.lisp" <<EOF
+cat >"$tmp/ecl-run.lisp" <<'EOF'
(cl:defpackage #:runlisp
(:use #:common-lisp))
(cl:in-package #:runlisp)
(defun main ()
- $ignore_shebang_rune
+ "Run a script, passing it some arguments."
+
+ ;; Ensure that `#!' is treated as a comment-to-end-of-line.
+ (set-dispatch-macro-character
+ #\# #\!
+ (lambda (#1=#:stream #2=#:char #3=#:arg)
+ (declare (ignore #2# #3#))
+ (values (read-line #1#))))
+
+ ;; Inhibit `asdf' from trying to update itself. This will only make script
+ ;; startup even slower than it already is.
(asdf:register-immutable-system "asdf")
+
+ ;; Remove extraneous symbols from the `COMMON-LISP-USER' package. For some
+ ;; reason, ECL likes to intern symbols in this package. They're at best
+ ;; useless to us, and possibly a nuisance.
(let ((pkg (find-package "COMMON-LISP-USER")))
(with-package-iterator (next pkg :internal)
(loop (multiple-value-bind (anyp sym how) (next)
(declare (ignore how))
(unless anyp (return))
(unintern sym pkg)))))
- $set_script_feature_rune
+
+ ;; Inform the script that it's being run from the command line.
+ (pushnew :runlisp-script *features*)
+
+ ;; Work through our command-line arguments to figure out what to do.
(let ((winning t) (script nil) (marker nil)
(prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc)))
+
(labels ((lose (msg &rest args)
+ ;; Report an error and give up; MSG and ARGS are as for
+ ;; `format'.
(format *error-output* "~&~A: ~?~%" prog msg args)
(setf winning nil))
+
(quit (rc)
+ ;; End the process, exiting with status RC.
(si:quit rc))
+
(usage (stream)
+ ;; Print a synopsis of this front-end's usage to STREAM.
(format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
prog))
+
(getarg ()
+ ;; Collect and the next command-line argument. Return `nil'
+ ;; if there are none remaining.
(and (< i argc) (prog1 (si:argv i) (incf i)))))
+
+ ;; Work through the options.
(loop (let ((arg (getarg)))
- (cond ((null arg) (return))
- ((string= arg "--") (setf marker t) (return))
- ((string= arg "-s") (setf script (getarg)))
- ((string= arg "-h") (usage *standard-output*) (quit 0))
- (t (lose "unrecognized option \`~A'" arg)))))
- (unless script (lose "nothing to do"))
+ (cond
+
+ ;; If there's nothing left, we're done parsing.
+ ((null arg) (return))
+
+ ;; If we've found `--' then remember this, and stop.
+ ((string= arg "--") (setf marker t) (return))
+
+ ;; If we've found `-s' then the next argument is the script.
+ ((string= arg "-s") (setf script (getarg)))
+
+ ;; If we've found `-h' then give a very brief usage summary.
+ ((string= arg "-h") (usage *standard-output*) (quit 0))
+
+ ;; Otherwise it's an error.
+ (t (lose "unrecognized option \`~A'" arg)))))
+
+ ;; Check various things. If there's no script, then there's nothing
+ ;; for us to do. The `uiop' library uses a `--' marker to find the
+ ;; start of the user options, so things won't work if it's missing.
(unless marker (lose "unexpected end of options (missing \`--'?)"))
+
+ ;; If anything went wrong then remind the user of the usage, and exit
+ ;; unsuccessfully.
(unless winning (usage *error-output*) (quit 255))
+
+ ;; Run the script. If it encounters an error and fails to handle it,
+ ;; then report it briefly and exit.
(handler-case
(let ((*package* (find-package "COMMON-LISP-USER")))
(load script :verbose nil :print nil))
(error (err)
(format *error-output* "~&~A (uncaught error): ~A~%" prog err)
(quit 255)))
+
+ ;; Everything worked. We're done.
(quit 0))))
+
+;; Just run the main function. (Done this way so that it gets compiled.)
(main)
EOF
-(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-asdf.fas" \
+(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "asdf.fas" \
-s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp")
## Finally link everything together.
-run "$ecl" ${eclopt}norc -o "$image"\
- ${eclopt}link "$tmp/ecl-asdf.o" "$tmp/ecl-run.o"
+run "$ecl" ${eclopt}norc -o "$image" \
+ ${eclopt}link "$tmp/asdf.o" "$tmp/ecl-run.o"
###----- That's all, folks --------------------------------------------------
~mdw / runlisp / blobdiff