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 (asdf:load-asd
  41  (funcall (let* ((cache-pkg (find-package "ASDF/CACHE"))
  42                                (with-cache (and cache-pkg
  43                                                 ))
  44                                (session-pkg (find-package "ASDF/SESSION"))
  45                                (with-session (and session-pkg
  46                                                   (find-symbol
  47                                                    "CALL-WITH-ASDF-SESSION"))))
  48             (symbol-function
  49              (cond (cache-pkg
  50                     (find-symbol "CALL-WITH-ASDF-CACHE" cache-pkg))
  51                    (session-pkg
  52                     (find-symbol "CALL-WITH-ASDF-SESSION" session-pkg))
  53                    (t
  54                     (error "I don't know how to hack this version of ASDF: ~
  55                             please report this as a bug.")))))
  56           (lambda ()
  57             (asdf:search-for-system-definition "asdf")))
  58  :name "asdf")
  59
  60 (defparameter *asdf* (asdf:find-system "asdf")
  61   "The `asdf' system itself.")
  62
  63 (defun right-here (pathname pattern)
  64   "An `asdf:initialize-output-translations' function: use current directory.
  65
  66    This function should be used in a `(:function ...)' form as the right hand
  67    side of an `asdf:initialize-output-translations' entry.  It causes the
  68    output file to be written to the current directory, regardless of the
  69    pathname of the input file(s)."
  70   (declare (ignore pattern))
  71   (merge-pathnames (make-pathname :name (pathname-name pathname)
  72                                   :type nil
  73                                   :version nil
  74                                   :defaults *default-pathname-defaults*)
  75                    pathname))
  76
  77 ;; Configure the translations.
  78 (asdf:initialize-output-translations
  79  '(:output-translations ((#p"/" :**/ :*.*.*) (:function right-here))
  80                         :ignore-inherited-configuration))
  81
  82 ;; Generate a linkable library for `asdf'.
  83 (asdf:operate 'asdf:lib-op *asdf*)
  84
  85 ;; We're done.
  86 (si:quit 0)
  87 EOF
  88 (cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-build.lisp")
  89
  90 ## And now compile our driver code.
  91 cat >"$tmp/ecl-run.lisp" <<'EOF'
  92 (cl:defpackage #:runlisp
  93   (:use #:common-lisp))
  94 (cl:in-package #:runlisp)
  95
  96 (defun main ()
  97   "Run a script, passing it some arguments."
  98
  99   ;; Ensure that `#!' is treated as a comment-to-end-of-line.
 100   (set-dispatch-macro-character
 101    #\# #\!
 102    (lambda (#1=#:stream #2=#:char #3=#:arg)
 103      (declare (ignore #2# #3#))
 104      (values (read-line #1#))))
 105
 106   ;; Inhibit `asdf' from trying to update itself.  This will only make script
 107   ;; startup even slower than it already is.
 108   (asdf:register-immutable-system "asdf")
 109
 110   ;; Remove extraneous symbols from the `COMMON-LISP-USER' package.  For some
 111   ;; reason, ECL likes to intern symbols in this package.  They're at best
 112   ;; useless to us, and possibly a nuisance.
 113   (let ((pkg (find-package "COMMON-LISP-USER")))
 114     (with-package-iterator (next pkg :internal)
 115       (loop (multiple-value-bind (anyp sym how) (next)
 116               (declare (ignore how))
 117               (unless anyp (return))
 118               (unintern sym pkg)))))
 119
 120   ;; Inform the script that it's being run from the command line.
 121   (pushnew :runlisp-script *features*)
 122
 123   ;; Work through our command-line arguments to figure out what to do.
 124   (let ((winning t) (script nil) (marker nil)
 125         (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc)))
 126
 127     (labels ((lose (msg &rest args)
 128                ;; Report an error and give up; MSG and ARGS are as for
 129                ;; `format'.
 130                (format *error-output* "~&~A: ~?~%" prog msg args)
 131                (setf winning nil))
 132
 133              (quit (rc)
 134                ;; End the process, exiting with status RC.
 135                (si:quit rc))
 136
 137              (usage (stream)
 138                ;; Print a synopsis of this front-end's usage to STREAM.
 139                (format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
 140                        prog))
 141
 142              (getarg ()
 143                ;; Collect and the next command-line argument.  Return `nil'
 144                ;; if there are none remaining.
 145                (and (< i argc) (prog1 (si:argv i) (incf i)))))
 146
 147       ;; Work through the options.
 148       (loop (let ((arg (getarg)))
 149               (cond
 150
 151                 ;; If there's nothing left, we're done parsing.
 152                 ((null arg) (return))
 153
 154                 ;; If we've found `--' then remember this, and stop.
 155                 ((string= arg "--") (setf marker t) (return))
 156
 157                 ;; If we've found `-s' then the next argument is the script.
 158                 ((string= arg "-s") (setf script (getarg)))
 159
 160                 ;; If we've found `-h' then give a very brief usage summary.
 161                 ((string= arg "-h") (usage *standard-output*) (quit 0))
 162
 163                 ;; Otherwise it's an error.
 164                 (t (lose "unrecognized option \`~A'" arg)))))
 165
 166       ;; Check various things.  If there's no script, then there's nothing
 167       ;; for us to do.  The `uiop' library uses a `--' marker to find the
 168       ;; start of the user options, so things won't work if it's missing.
 169       (unless marker (lose "unexpected end of options (missing \`--'?)"))
 170
 171       ;; If anything went wrong then remind the user of the usage, and exit
 172       ;; unsuccessfully.
 173       (unless winning (usage *error-output*) (quit 255))
 174
 175       ;; Run the script.  If it encounters an error and fails to handle it,
 176       ;; then report it briefly and exit.
 177       (handler-case
 178           (let ((*package* (find-package "COMMON-LISP-USER")))
 179             (load script :verbose nil :print nil))
 180         (error (err)
 181           (format *error-output* "~&~A (uncaught error): ~A~%" prog err)
 182           (quit 255)))
 183
 184       ;; Everything worked.  We're done.
 185       (quit 0))))
 186
 187 ;; Just run the main function.  (Done this way so that it gets compiled.)
 188 (main)
 189 EOF
 190 (cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "asdf.fas" \
 191   -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp")
 192
 193 ## Finally link everything together.
 194 run "$ecl" ${eclopt}norc -o "$image" \
 195   ${eclopt}link "$tmp/asdf.o" "$tmp/ecl-run.o"
 196
 197 ###----- That's all, folks --------------------------------------------------