chiark - git - mdw - runlisp/blob - dump-ecl

   1 ### -*-sh-*-
   2 ###
   3 ### Auxiliary script for dumping ECL
   4 ###
   5 ### (c) 2020 Mark Wooding
   6 ###
   7
   8 ###----- Licensing notice ---------------------------------------------------
   9 ###
  10 ### This file is part of Runlisp, a tool for invoking Common Lisp scripts.
  11 ###
  12 ### Runlisp is free software: you can redistribute it and/or modify it
  13 ### under the terms of the GNU General Public License as published by the
  14 ### Free Software Foundation; either version 3 of the License, or (at your
  15 ### option) any later version.
  16 ###
  17 ### Runlisp is distributed in the hope that it will be useful, but WITHOUT
  18 ### ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  19 ### FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  20 ### for more details.
  21 ###
  22 ### You should have received a copy of the GNU General Public License
  23 ### along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 set -e
  26
  27 case $# in 4) ;; *) echo >&2 "usage: $0 IMAGE ECL ECLOPT TMP"; exit 2 ;; esac
  28 image=$1 ecl=$2 eclopt=$3 tmp=$4
  29
  30 run () { echo "$*"; "$@"; }
  31
  32 ## Start by compiling a copy of ASDF.
  33 cat >"$tmp/ecl-build.lisp" <<'EOF'
  34 (require "asdf")
  35
  36 ;; Defeat ASDF's built-in knowledge of itself.  If we've just loaded the most
  37 ;; up-to-date version of ASDF then it won't bother loading the system
  38 ;; definition from disk which knows about the actual source files.  And if it
  39 ;; doesn't think it has any source files then it won't compile anything.
  40 (funcall (symbol-function (find-symbol "LOAD-ASD" "ASDF"))
  41          (funcall (let* ((cache-pkg (find-package "ASDF/CACHE"))
  42                          (session-pkg (find-package "ASDF/SESSION")))
  43                     (symbol-function
  44                      (cond (cache-pkg
  45                             (find-symbol "CALL-WITH-ASDF-CACHE" cache-pkg))
  46                            (session-pkg
  47                             (find-symbol "CALL-WITH-ASDF-SESSION" session-pkg))
  48                            (t
  49                             (error "I don't know how to hack this version ~
  50                                     of ASDF: please report this as a bug.")))))
  51                   (lambda ()
  52                     (asdf:search-for-system-definition "asdf")))
  53          :name "asdf")
  54
  55 (defparameter *asdf* (asdf:find-system "asdf")
  56   "The `asdf' system itself.")
  57
  58 (defun right-here (pathname pattern)
  59   "An `asdf:initialize-output-translations' function: use current directory.
  60
  61    This function should be used in a `(:function ...)' form as the right hand
  62    side of an `asdf:initialize-output-translations' entry.  It causes the
  63    output file to be written to the current directory, regardless of the
  64    pathname of the input file(s)."
  65   (declare (ignore pattern))
  66   (merge-pathnames (make-pathname :name (pathname-name pathname)
  67                                   :type nil
  68                                   :version nil
  69                                   :defaults *default-pathname-defaults*)
  70                    pathname))
  71
  72 ;; Configure the translations.
  73 (asdf:initialize-output-translations
  74  '(:output-translations ((#p"/" :**/ :*.*.*) (:function right-here))
  75                         :ignore-inherited-configuration))
  76
  77 ;; Generate a linkable library for `asdf'.
  78 (asdf:operate 'asdf:lib-op *asdf*)
  79
  80 ;; We're done.
  81 (si:quit 0)
  82 EOF
  83 (cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-build.lisp")
  84
  85 ## And now compile our driver code.
  86 cat >"$tmp/ecl-run.lisp" <<'EOF'
  87 (cl:defpackage #:runlisp
  88   (:use #:common-lisp))
  89 (cl:in-package #:runlisp)
  90
  91 (defun main ()
  92   "Run a script, passing it some arguments."
  93
  94   ;; Ensure that `#!' is treated as a comment-to-end-of-line.
  95   (set-dispatch-macro-character
  96    #\# #\!
  97    (lambda (#1=#:stream #2=#:char #3=#:arg)
  98      (declare (ignore #2# #3#))
  99      (values (read-line #1#))))
 100
 101   ;; Inhibit `asdf' from trying to update itself.  This will only make script
 102   ;; startup even slower than it already is.
 103   (asdf:register-immutable-system "asdf")
 104
 105   ;; Remove extraneous symbols from the `COMMON-LISP-USER' package.  For some
 106   ;; reason, ECL likes to intern symbols in this package.  They're at best
 107   ;; useless to us, and possibly a nuisance.
 108   (let ((pkg (find-package "COMMON-LISP-USER")))
 109     (with-package-iterator (next pkg :internal)
 110       (loop (multiple-value-bind (anyp sym how) (next)
 111               (declare (ignore how))
 112               (unless anyp (return))
 113               (unintern sym pkg)))))
 114
 115   ;; Inform the script that it's being run from the command line.
 116   (pushnew :runlisp-script *features*)
 117
 118   ;; Work through our command-line arguments to figure out what to do.
 119   (let ((winning t) (script nil) (marker nil)
 120         (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc)))
 121
 122     (labels ((lose (msg &rest args)
 123                ;; Report an error and give up; MSG and ARGS are as for
 124                ;; `format'.
 125                (format *error-output* "~&~A: ~?~%" prog msg args)
 126                (setf winning nil))
 127
 128              (quit (rc)
 129                ;; End the process, exiting with status RC.
 130                (si:quit rc))
 131
 132              (usage (stream)
 133                ;; Print a synopsis of this front-end's usage to STREAM.
 134                (format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
 135                        prog))
 136
 137              (getarg ()
 138                ;; Collect and the next command-line argument.  Return `nil'
 139                ;; if there are none remaining.
 140                (and (< i argc) (prog1 (si:argv i) (incf i)))))
 141
 142       ;; Work through the options.
 143       (loop (let ((arg (getarg)))
 144               (cond
 145
 146                 ;; If there's nothing left, we're done parsing.
 147                 ((null arg) (return))
 148
 149                 ;; If we've found `--' then remember this, and stop.
 150                 ((string= arg "--") (setf marker t) (return))
 151
 152                 ;; If we've found `-s' then the next argument is the script.
 153                 ((string= arg "-s") (setf script (getarg)))
 154
 155                 ;; If we've found `-h' then give a very brief usage summary.
 156                 ((string= arg "-h") (usage *standard-output*) (quit 0))
 157
 158                 ;; Otherwise it's an error.
 159                 (t (lose "unrecognized option \`~A'" arg)))))
 160
 161       ;; Check various things.  If there's no script, then there's nothing
 162       ;; for us to do.  The `uiop' library uses a `--' marker to find the
 163       ;; start of the user options, so things won't work if it's missing.
 164       (unless marker (lose "unexpected end of options (missing \`--'?)"))
 165
 166       ;; If anything went wrong then remind the user of the usage, and exit
 167       ;; unsuccessfully.
 168       (unless winning (usage *error-output*) (quit 255))
 169
 170       ;; Run the script.  If it encounters an error and fails to handle it,
 171       ;; then report it briefly and exit.
 172       (handler-case
 173           (let ((*package* (find-package "COMMON-LISP-USER")))
 174             (load script :verbose nil :print nil))
 175         (error (err)
 176           (format *error-output* "~&~A (uncaught error): ~A~%" prog err)
 177           (quit 255)))
 178
 179       ;; Everything worked.  We're done.
 180       (quit 0))))
 181
 182 ;; Just run the main function.  (Done this way so that it gets compiled.)
 183 (main)
 184 EOF
 185 (cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "asdf.fas" \
 186   -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp")
 187
 188 ## Finally link everything together.
 189 run "$ecl" ${eclopt}norc -o "$image" \
 190   ${eclopt}link "$tmp/asdf.o" "$tmp/ecl-run.o"
 191
 192 ###----- That's all, folks --------------------------------------------------