chiark / gitweb /
@@@ work in progress
[runlisp] / dump-ecl
... / ...
CommitLineData
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
25set -e
26
27case $# in 4) ;; *) echo >&2 "usage: $0 IMAGE ECL ECLOPT TMP"; exit 2 ;; esac
28image=$1 ecl=$2 eclopt=$3 tmp=$4
29
30run () { echo "$*"; "$@"; }
31
32## Start by compiling a copy of ASDF.
33cat >"$tmp/ecl-build.lisp" <<EOF
34(require "asdf")
35
36(defparameter *asdf* (asdf:find-system "asdf"))
37
38(defun right-here (pathname pattern)
39 (declare (ignore pattern))
40 (merge-pathnames
41 (make-pathname :name (concatenate 'string
42 (string-downcase
43 (lisp-implementation-type))
44 "-"
45 (pathname-name pathname))
46 :type nil
47 :version nil
48 :defaults *default-pathname-defaults*)
49 pathname))
50(asdf:initialize-output-translations '(:output-translations
51 ((#p"/" :**/ :*.*.*)
52 (:function right-here))
53 :ignore-inherited-configuration))
54
55(asdf:operate 'asdf:lib-op *asdf*)
56(si:quit 0)
57EOF
58(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-build.lisp")
59
60## And now compile our driver code.
61cat >"$tmp/ecl-run.lisp" <<EOF
62(cl:defpackage #:runlisp
63 (:use #:common-lisp))
64(cl:in-package #:runlisp)
65
66(defun main ()
67 $ignore_shebang_rune
68 (asdf:register-immutable-system "asdf")
69 (let ((pkg (find-package "COMMON-LISP-USER")))
70 (with-package-iterator (next pkg :internal)
71 (loop (multiple-value-bind (anyp sym how) (next)
72 (declare (ignore how))
73 (unless anyp (return))
74 (unintern sym pkg)))))
75 $set_script_feature_rune
76 (let ((winning t) (script nil) (marker nil)
77 (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc)))
78 (labels ((lose (msg &rest args)
79 (format *error-output* "~&~A: ~?~%" prog msg args)
80 (setf winning nil))
81 (quit (rc)
82 (si:quit rc))
83 (usage (stream)
84 (format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
85 prog))
86 (getarg ()
87 (and (< i argc) (prog1 (si:argv i) (incf i)))))
88 (loop (let ((arg (getarg)))
89 (cond ((null arg) (return))
90 ((string= arg "--") (setf marker t) (return))
91 ((string= arg "-s") (setf script (getarg)))
92 ((string= arg "-h") (usage *standard-output*) (quit 0))
93 (t (lose "unrecognized option \`~A'" arg)))))
94 (unless script (lose "nothing to do"))
95 (unless marker (lose "unexpected end of options (missing \`--'?)"))
96 (unless winning (usage *error-output*) (quit 255))
97 (handler-case
98 (let ((*package* (find-package "COMMON-LISP-USER")))
99 (load script :verbose nil :print nil))
100 (error (err)
101 (format *error-output* "~&~A (uncaught error): ~A~%" prog err)
102 (quit 255)))
103 (quit 0))))
104(main)
105EOF
106(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-asdf.fas" \
107 -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp")
108
109## Finally link everything together.
110run "$ecl" ${eclopt}norc -o "$image"\
111 ${eclopt}link "$tmp/ecl-asdf.o" "$tmp/ecl-run.o"
112
113###----- That's all, folks --------------------------------------------------