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