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