dump-ecl: Defeat ASDF's magic internal knowledge of itself.

[runlisp] / dump-ecl

### -*-sh-*-
###
### Auxiliary script for dumping ECL
###
### (c) 2020 Mark Wooding
###

###----- Licensing notice ---------------------------------------------------
###
### This file is part of Runlisp, a tool for invoking Common Lisp scripts.
###
### Runlisp is free software: you can redistribute it and/or modify it
### under the terms of the GNU General Public License as published by the
### Free Software Foundation; either version 3 of the License, or (at your
### option) any later version.
###
### Runlisp is distributed in the hope that it will be useful, but WITHOUT
### ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
### FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
### for more details.
###
### You should have received a copy of the GNU General Public License
### along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.

set -e

case $# in 4) ;; *) echo >&2 "usage: $0 IMAGE ECL ECLOPT TMP"; exit 2 ;; esac
image=$1 ecl=$2 eclopt=$3 tmp=$4

run () { echo "$*"; "$@"; }

## Start by compiling a copy of ASDF.
cat >"$tmp/ecl-build.lisp" <<'EOF'
(require "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.
(asdf:load-asd
 (funcall (let* ((cache-pkg (find-package "ASDF/CACHE"))
                               (with-cache (and cache-pkg
                                                ))
                               (session-pkg (find-package "ASDF/SESSION"))
                               (with-session (and session-pkg
                                                  (find-symbol
                                                   "CALL-WITH-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)
  "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 (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'
(cl:defpackage #:runlisp
  (:use #:common-lisp))
(cl:in-package #:runlisp)

(defun main ()
  "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)))))

  ;; 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

                ;; 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 "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/asdf.o" "$tmp/ecl-run.o"

###----- That's all, folks --------------------------------------------------