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