X-Git-Url: https://git.distorted.org.uk/~mdw/runlisp/blobdiff_plain/7b8ff279e7304e41b243459d78c3b6703bb8c3f5..e41cbc79e39d62f0343a48efc4d832ed99c83aaf:/dump-ecl

diff --git a/dump-ecl b/dump-ecl
index 538ca27..1f5373e 100755
--- a/dump-ecl
+++ b/dump-ecl
@@ -30,84 +30,144 @@ image=$1 ecl=$2 eclopt=$3 tmp=$4
 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"
+  ${eclopt}link "$tmp/asdf.o" "$tmp/ecl-run.o"
 
 ###----- That's all, folks --------------------------------------------------