lib.c: Make `search_recursive' be static, as it should be.

[runlisp] / dump-ecl

diff --git a/dump-ecl b/dump-ecl
index 538ca27a421cc001d8a5057e4827f404a42ff5cc..0648d86a4a03aecb86d427cfc4b66587d09e7f94 100755 (executable)
--- a/dump-ecl
+++ b/dump-ecl
@@ -30,84 +30,163 @@ image=$1 ecl=$2 eclopt=$3 tmp=$4
 run () { echo "$*"; "$@"; }
 
 ## Start by compiling a copy of ASDF.
 run () { echo "$*"; "$@"; }
 
 ## Start by compiling a copy of ASDF.

-cat >"$tmp/ecl-build.lisp" <<EOF
+cat >"$tmp/ecl-build.lisp" <<'EOF'

 (require "asdf")
 
 (require "asdf")
 

-(defparameter *asdf* (asdf:find-system "asdf"))
+;; Defeat ASDF's built-in knowledge of itself.  If we've just loaded the most
+;; up-to-date version of ASDF then it won't bother loading the system
+;; definition from disk which knows about the actual source files.  And if it
+;; doesn't think it has any source files then it won't compile anything.
+(funcall (symbol-function (find-symbol "LOAD-ASD" "ASDF"))
+        (funcall (let* ((cache-pkg (find-package "ASDF/CACHE"))
+                        (session-pkg (find-package "ASDF/SESSION")))
+                   (symbol-function
+                    (cond (cache-pkg
+                           (find-symbol "CALL-WITH-ASDF-CACHE" cache-pkg))
+                          (session-pkg
+                           (find-symbol "CALL-WITH-ASDF-SESSION" session-pkg))
+                          (t
+                           (error "I don't know how to hack this version ~
+                                   of ASDF: please report this as a bug.")))))
+                 (lambda ()
+                   (asdf:search-for-system-definition "asdf")))
+        :name "asdf")
+
+(defparameter *asdf* (asdf:find-system "asdf")
+  "The `asdf' system itself.")

 
 (defun right-here (pathname pattern)
 
 (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))
   (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*)
 (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.
 (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 ()
 (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")
   (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)))))
   (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)))
   (let ((winning t) (script nil) (marker nil)
        (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc)))

+

     (labels ((lose (msg &rest args)
     (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))
               (format *error-output* "~&~A: ~?~%" prog msg args)
               (setf winning nil))

+

             (quit (rc)
             (quit (rc)

+              ;; End the process, exiting with status RC.

               (si:quit rc))
               (si:quit rc))

+

             (usage (stream)
             (usage (stream)

+              ;; Print a synopsis of this front-end's usage to STREAM.

               (format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
                       prog))
               (format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
                       prog))

+

             (getarg ()
             (getarg ()

+              ;; Collect and the next command-line argument.  Return `nil'
+              ;; if there are none remaining.

               (and (< i argc) (prog1 (si:argv i) (incf i)))))
               (and (< i argc) (prog1 (si:argv i) (incf i)))))

+
+      ;; Work through the options.

       (loop (let ((arg (getarg)))
       (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 \`--'?)"))
       (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))
       (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)))
       (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))))
       (quit 0))))

+
+;; Just run the main function.  (Done this way so that it gets compiled.)

 (main)
 EOF
 (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.
   -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 --------------------------------------------------
 
 ###----- That's all, folks --------------------------------------------------