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 | ||
627ff527 MW |
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 | ||
8996f767 MW |
60 | (defparameter *asdf* (asdf:find-system "asdf") |
61 | "The `asdf' system itself.") | |
7b8ff279 MW |
62 | |
63 | (defun right-here (pathname pattern) | |
8996f767 MW |
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)." | |
7b8ff279 | 70 | (declare (ignore pattern)) |
8996f767 MW |
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)) | |
7b8ff279 | 81 | |
8996f767 | 82 | ;; Generate a linkable library for `asdf'. |
7b8ff279 | 83 | (asdf:operate 'asdf:lib-op *asdf*) |
8996f767 MW |
84 | |
85 | ;; We're done. | |
7b8ff279 MW |
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. | |
8996f767 | 91 | cat >"$tmp/ecl-run.lisp" <<'EOF' |
7b8ff279 MW |
92 | (cl:defpackage #:runlisp |
93 | (:use #:common-lisp)) | |
94 | (cl:in-package #:runlisp) | |
95 | ||
96 | (defun main () | |
8996f767 MW |
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. | |
7b8ff279 | 108 | (asdf:register-immutable-system "asdf") |
8996f767 MW |
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. | |
7b8ff279 MW |
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))))) | |
8996f767 MW |
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. | |
7b8ff279 MW |
124 | (let ((winning t) (script nil) (marker nil) |
125 | (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc))) | |
8996f767 | 126 | |
7b8ff279 | 127 | (labels ((lose (msg &rest args) |
8996f767 MW |
128 | ;; Report an error and give up; MSG and ARGS are as for |
129 | ;; `format'. | |
7b8ff279 MW |
130 | (format *error-output* "~&~A: ~?~%" prog msg args) |
131 | (setf winning nil)) | |
8996f767 | 132 | |
7b8ff279 | 133 | (quit (rc) |
8996f767 | 134 | ;; End the process, exiting with status RC. |
7b8ff279 | 135 | (si:quit rc)) |
8996f767 | 136 | |
7b8ff279 | 137 | (usage (stream) |
8996f767 | 138 | ;; Print a synopsis of this front-end's usage to STREAM. |
7b8ff279 MW |
139 | (format stream "~&usage: ~A -s SCRIPT -- ARGS~%" |
140 | prog)) | |
8996f767 | 141 | |
7b8ff279 | 142 | (getarg () |
8996f767 MW |
143 | ;; Collect and the next command-line argument. Return `nil' |
144 | ;; if there are none remaining. | |
7b8ff279 | 145 | (and (< i argc) (prog1 (si:argv i) (incf i))))) |
8996f767 MW |
146 | |
147 | ;; Work through the options. | |
7b8ff279 | 148 | (loop (let ((arg (getarg))) |
8996f767 MW |
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. | |
7b8ff279 | 169 | (unless marker (lose "unexpected end of options (missing \`--'?)")) |
8996f767 MW |
170 | |
171 | ;; If anything went wrong then remind the user of the usage, and exit | |
172 | ;; unsuccessfully. | |
7b8ff279 | 173 | (unless winning (usage *error-output*) (quit 255)) |
8996f767 MW |
174 | |
175 | ;; Run the script. If it encounters an error and fails to handle it, | |
176 | ;; then report it briefly and exit. | |
7b8ff279 MW |
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))) | |
8996f767 MW |
183 | |
184 | ;; Everything worked. We're done. | |
7b8ff279 | 185 | (quit 0)))) |
8996f767 MW |
186 | |
187 | ;; Just run the main function. (Done this way so that it gets compiled.) | |
7b8ff279 MW |
188 | (main) |
189 | EOF | |
8996f767 | 190 | (cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "asdf.fas" \ |
7b8ff279 MW |
191 | -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp") |
192 | ||
193 | ## Finally link everything together. | |
82cc0835 | 194 | run "$ecl" ${eclopt}norc -o "$image" \ |
8996f767 | 195 | ${eclopt}link "$tmp/asdf.o" "$tmp/ecl-run.o" |
7b8ff279 MW |
196 | |
197 | ###----- That's all, folks -------------------------------------------------- |