Commit | Line | Data |
---|---|---|
7b8ff279 MW |
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. | |
8996f767 | 33 | cat >"$tmp/ecl-build.lisp" <<'EOF' |
7b8ff279 MW |
34 | (require "asdf") |
35 | ||
8996f767 MW |
36 | (defparameter *asdf* (asdf:find-system "asdf") |
37 | "The `asdf' system itself.") | |
7b8ff279 MW |
38 | |
39 | (defun right-here (pathname pattern) | |
8996f767 MW |
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)." | |
7b8ff279 | 46 | (declare (ignore pattern)) |
8996f767 MW |
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)) | |
7b8ff279 | 57 | |
8996f767 | 58 | ;; Generate a linkable library for `asdf'. |
7b8ff279 | 59 | (asdf:operate 'asdf:lib-op *asdf*) |
8996f767 MW |
60 | |
61 | ;; We're done. | |
7b8ff279 MW |
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. | |
8996f767 | 67 | cat >"$tmp/ecl-run.lisp" <<'EOF' |
7b8ff279 MW |
68 | (cl:defpackage #:runlisp |
69 | (:use #:common-lisp)) | |
70 | (cl:in-package #:runlisp) | |
71 | ||
72 | (defun main () | |
8996f767 MW |
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. | |
7b8ff279 | 84 | (asdf:register-immutable-system "asdf") |
8996f767 MW |
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. | |
7b8ff279 MW |
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))))) | |
8996f767 MW |
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. | |
7b8ff279 MW |
100 | (let ((winning t) (script nil) (marker nil) |
101 | (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc))) | |
8996f767 | 102 | |
7b8ff279 | 103 | (labels ((lose (msg &rest args) |
8996f767 MW |
104 | ;; Report an error and give up; MSG and ARGS are as for |
105 | ;; `format'. | |
7b8ff279 MW |
106 | (format *error-output* "~&~A: ~?~%" prog msg args) |
107 | (setf winning nil)) | |
8996f767 | 108 | |
7b8ff279 | 109 | (quit (rc) |
8996f767 | 110 | ;; End the process, exiting with status RC. |
7b8ff279 | 111 | (si:quit rc)) |
8996f767 | 112 | |
7b8ff279 | 113 | (usage (stream) |
8996f767 | 114 | ;; Print a synopsis of this front-end's usage to STREAM. |
7b8ff279 MW |
115 | (format stream "~&usage: ~A -s SCRIPT -- ARGS~%" |
116 | prog)) | |
8996f767 | 117 | |
7b8ff279 | 118 | (getarg () |
8996f767 MW |
119 | ;; Collect and the next command-line argument. Return `nil' |
120 | ;; if there are none remaining. | |
7b8ff279 | 121 | (and (< i argc) (prog1 (si:argv i) (incf i))))) |
8996f767 MW |
122 | |
123 | ;; Work through the options. | |
7b8ff279 | 124 | (loop (let ((arg (getarg))) |
8996f767 MW |
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. | |
7b8ff279 | 145 | (unless marker (lose "unexpected end of options (missing \`--'?)")) |
8996f767 MW |
146 | |
147 | ;; If anything went wrong then remind the user of the usage, and exit | |
148 | ;; unsuccessfully. | |
7b8ff279 | 149 | (unless winning (usage *error-output*) (quit 255)) |
8996f767 MW |
150 | |
151 | ;; Run the script. If it encounters an error and fails to handle it, | |
152 | ;; then report it briefly and exit. | |
7b8ff279 MW |
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))) | |
8996f767 MW |
159 | |
160 | ;; Everything worked. We're done. | |
7b8ff279 | 161 | (quit 0)))) |
8996f767 MW |
162 | |
163 | ;; Just run the main function. (Done this way so that it gets compiled.) | |
7b8ff279 MW |
164 | (main) |
165 | EOF | |
8996f767 | 166 | (cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "asdf.fas" \ |
7b8ff279 MW |
167 | -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp") |
168 | ||
169 | ## Finally link everything together. | |
170 | run "$ecl" ${eclopt}norc -o "$image"\ | |
8996f767 | 171 | ${eclopt}link "$tmp/asdf.o" "$tmp/ecl-run.o" |
7b8ff279 MW |
172 | |
173 | ###----- That's all, folks -------------------------------------------------- |