bin_PROGRAMS += runlisp
runlisp_SOURCES = runlisp.c
+runlisp_SOURCES += common.c common.h
+runlisp_SOURCES += lib.c lib.h
+runlisp_SOURCES += mdwopt.c mdwopt.h
man_MANS += runlisp.1
+noinst_PROGRAMS += old-runlisp
+old_runlisp_SOURCES = old-runlisp.c
+old_runlisp_SOURCES += lib.c lib.h
+
+noinst_PROGRAMS += toy
+toy_SOURCES = toy.c
+toy_SOURCES += lib.c lib.h
+
###--------------------------------------------------------------------------
### Additional machinery.
###--------------------------------------------------------------------------
### Image dumping.
-nodist_bin_SCRIPTS += dump-runlisp-image
+bin_PROGRAMS += dump-runlisp-image
+dump_runlisp_image_SOURCES = dump-runlisp-image.c
+dump_runlisp_image_SOURCES += common.c common.h
+dump_runlisp_image_SOURCES += lib.c lib.h
+dump_runlisp_image_SOURCES += mdwopt.c mdwopt.h
man_MANS += dump-runlisp-image.1
+DUMP_RUNLISP_IMAGE = $(v_dump)./dump-runlisp-image \
+ -f -c$(srcdir)/runlisp.conf -O$@
+
v_dump = $(v_dump_@AM_V@)
v_dump_ = $(v_dump_@AM_DEFAULT_V@)
v_dump_0 = @echo " DUMP $@";
-EXTRA_DIST += dump-runlisp-image.in
-CLEANFILES += dump-runlisp-image
-dump-runlisp-image: dump-runlisp-image.in
- $(SUBST) $(srcdir)/dump-runlisp-image.in >$@.new \
- $(SUBSTITUTIONS) && \
- chmod +x $@.new && mv $@.new $@
-
if DUMP_SBCL
image_DATA += sbcl+asdf.core
CLEANFILES += sbcl+asdf.core
-sbcl+asdf.core: dump-runlisp-image
- $(v_dump)./dump-runlisp-image -o$@ sbcl
+sbcl+asdf.core: dump-runlisp-image runlisp.conf
+ $(DUMP_RUNLISP_IMAGE) sbcl
endif
if DUMP_CCL
image_DATA += ccl+asdf.image
CLEANFILES += ccl+asdf.image
-ccl+asdf.image: dump-runlisp-image
- $(v_dump)./dump-runlisp-image -o$@ ccl
+ccl+asdf.image: dump-runlisp-image runlisp.conf
+ $(DUMP_RUNLISP_IMAGE) ccl
endif
if DUMP_CLISP
image_DATA += clisp+asdf.mem
CLEANFILES += clisp+asdf.mem
-clisp+asdf.mem: dump-runlisp-image
- $(v_dump)./dump-runlisp-image -o$@ clisp
+clisp+asdf.mem: dump-runlisp-image runlisp.conf
+ $(DUMP_RUNLISP_IMAGE) clisp
endif
if DUMP_ECL
image_SCRIPTS += ecl+asdf
CLEANFILES += ecl+asdf
-ecl+asdf: dump-runlisp-image
- $(v_dump)./dump-runlisp-image -o$@ ecl
+ecl+asdf: dump-runlisp-image runlisp.conf
+ $(DUMP_RUNLISP_IMAGE) -odata-dir=$(srcdir) ecl
endif
if DUMP_CMUCL
image_DATA += cmucl+asdf.core
CLEANFILES += cmucl+asdf.core
-cmucl+asdf.core: dump-runlisp-image
- $(v_dump)./dump-runlisp-image -o$@ cmucl
+cmucl+asdf.core: dump-runlisp-image runlisp.conf
+ $(DUMP_RUNLISP_IMAGE) cmucl
endif
###--------------------------------------------------------------------------
###--------------------------------------------------------------------------
### Lisp systems using `runlisp'.
-RUNLISP = $(top_builddir)/runlisp -I$(top_builddir)/
+RUNLISP = $(top_builddir)/runlisp \
+ -c$(top_srcdir)/runlisp.conf \
+ -oimage-dir=$(top_builddir)
EXTRA_DIST += t.lisp
RUNLISP_BENCHES = $(foreach l,$(LISPS), runlisp.$l.bench)
BENCHES += $(RUNLISP_BENCHES)
$(RUNLISP_BENCHES): runlisp.%.bench: timeit $(FORCE)
- $(v_bench)./timeit $(RUNLISP) -L$* -- $(srcdir)/t.lisp a b c >runlisp.$*.out 2>$@
+ $(v_bench)./timeit $(RUNLISP) -L$* -- \
+ $(srcdir)/t.lisp a b c >runlisp.$*.out 2>$@
RUNLISP_NOIMAGE_BENCHES = $(foreach l,$(LISPS), runlisp-noimage.$l.bench)
BENCHES += $(RUNLISP_NOIMAGE_BENCHES)
$(RUNLISP_NOIMAGE_BENCHES): runlisp-noimage.%.bench: timeit $(FORCE)
- $(v_bench)./timeit $(RUNLISP) -D -L$* -- $(srcdir)/t.lisp a b c >runlisp-noimage.$*.out 2>$@
+ $(v_bench)./timeit $(RUNLISP) -D -L$* -- \
+ $(srcdir)/t.lisp a b c >runlisp-noimage.$*.out 2>$@
###--------------------------------------------------------------------------
### Lisp systems using `cl-launch'.
--- /dev/null
+/* -*-c-*-
+ *
+ * Common functionality of a less principled nature
+ *
+ * (c) 2020 Mark Wooding
+ */
+
+/*----- Licensing notice --------------------------------------------------*
+ *
+ * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
+ *
+ * Runlisp is free software: you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License as published by the
+ * Free Software Foundation; either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Runlisp is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ * for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with Runlisp. If not, see <https://www.gnu.org/licenses/>.
+ */
+
+/*----- Header files ------------------------------------------------------*/
+
+#include "config.h"
+
+#include <assert.h>
+#include <ctype.h>
+#include <errno.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <dirent.h>
+#include <pwd.h>
+#include <unistd.h>
+
+#include <sys/stat.h>
+
+#include "common.h"
+#include "lib.h"
+
+/*----- Public variables --------------------------------------------------*/
+
+struct config config = CONFIG_INIT;
+struct config_section *toplevel, *builtin, *common, *env;
+unsigned verbose = 1;
+
+/*----- Internal utilities ------------------------------------------------*/
+
+static void escapify(struct dstr *d, const char *p)
+{
+ size_t n;
+
+ for (;;) {
+ n = strcspn(p, "\"'\\");
+ if (n) { dstr_putm(d, p, n); p += n; }
+ if (!*p) break;
+ dstr_putc(d, '\\'); dstr_putc(d, *p++);
+ }
+ dstr_putz(d);
+}
+
+static void homedir(struct dstr *d)
+{
+ static const char *home = 0;
+ const char *p;
+ struct passwd *pw;
+
+ if (!home) {
+ p = my_getenv("HOME", 0);
+ if (p) home = p;
+ else {
+ pw = getpwuid(getuid());
+ if (!pw) lose("can't find user in password database");
+ home = xstrdup(pw->pw_dir);
+ }
+ }
+ dstr_puts(d, home);
+}
+
+static void user_config_dir(struct dstr *d)
+{
+ const char *p;
+
+ p = my_getenv("XDG_CONFIG_HOME", 0);
+ if (p) dstr_puts(d, p);
+ else { homedir(d); dstr_puts(d, "/.config"); }
+}
+
+/*----- Miscellany --------------------------------------------------------*/
+
+const char *my_getenv(const char *name, const char *dflt)
+{
+ struct config_var *var;
+
+ var = config_find_var(&config, env, 0, name);
+ return (var ? var->val : dflt);
+}
+
+long parse_int(const char *what, const char *p, long min, long max)
+{
+ long n;
+ int oerr = errno;
+ char *q;
+
+ errno = 0;
+ n = strtol(p, &q, 0);
+ while (ISSPACE(*q)) q++;
+ if (errno || *q) lose("invalid %s `%s'", what, p);
+ if (n < min || n > max)
+ lose("%s %ld out of range (must be between %ld and %ld)",
+ what, n, min, max);
+ errno = oerr;
+ return (n);
+}
+
+void argv_string(struct dstr *d, const struct argv *av)
+{
+ size_t i;
+
+ for (i = 0; i < av->n; i++) {
+ if (i) { dstr_putc(d, ','); dstr_putc(d, ' '); }
+ dstr_putc(d, '`'); escapify(d, av->v[i]); dstr_putc(d, '\'');
+ }
+ dstr_putz(d);
+}
+
+/*----- File utilities ----------------------------------------------------*/
+
+int file_exists_p(const char *path, unsigned f)
+{
+ struct stat st;
+
+ if (stat(path, &st)) {
+ if (f&FEF_VERBOSE) moan("file `%s' not found", path);
+ return (0);
+ } else if (!(S_ISREG(st.st_mode))) {
+ if (f&FEF_VERBOSE) moan("`%s' is not a regular file", path);
+ return (0);
+ } else if ((f&FEF_EXEC) && access(path, X_OK)) {
+ if (f&FEF_VERBOSE) moan("file `%s' is not executable", path);
+ return (0);
+ } else {
+ if (f&FEF_VERBOSE) moan("found file `%s'", path);
+ return (1);
+ }
+}
+
+int found_in_path_p(const char *prog, unsigned f)
+{
+ struct dstr p = DSTR_INIT, d = DSTR_INIT;
+ const char *path;
+ char *q;
+ size_t n, avail, proglen;
+ int i, rc;
+
+ if (strchr(prog, '/'))
+ return (file_exists_p(prog, f));
+ path = my_getenv("PATH", 0);
+ if (path)
+ dstr_puts(&p, path);
+ else {
+ dstr_puts(&p, ".:");
+ i = 0;
+ again:
+ avail = p.sz - p.len;
+ n = confstr(_CS_PATH, p.p + p.len, avail);
+ if (avail > n) { i++; assert(i < 2); dstr_ensure(&p, n); goto again; }
+ }
+
+ q = p.p; proglen = strlen(prog);
+ for (;;) {
+ n = strcspn(q, ":");
+ dstr_reset(&d);
+ if (n) dstr_putm(&d, q, n);
+ else dstr_putc(&d, '.');
+ dstr_putc(&d, '/');
+ dstr_putm(&d, prog, proglen);
+ dstr_putz(&d);
+ if (file_exists_p(d.p, verbose >= 4 ? f : f&~FEF_VERBOSE)) {
+ if (verbose == 2) moan("found program `%s'", d.p);
+ rc = 1; goto end;
+ }
+ q += n; if (!*q) break; else q++;
+ }
+
+ rc = 0;
+end:
+ dstr_release(&p); dstr_release(&d);
+ return (rc);
+}
+
+int try_exec(struct argv *av, unsigned f)
+{
+ struct dstr d = DSTR_INIT;
+ int rc;
+
+ assert(av->n); argv_appendz(av);
+ if (verbose >= 2) { argv_string(&d, av); moan("trying %s...", d.p); }
+ if (f&TEF_DRYRUN) {
+ if (found_in_path_p(av->v[0], f&TEF_VERBOSE ? FEF_VERBOSE : 0))
+ { rc = 0; goto end; }
+ } else {
+ execvp(av->v[0], (/*unconst*/ char **)av->v);
+ if (errno != ENOENT) {
+ moan("failed to exec `%s': %s", av->v[0], strerror(errno));
+ _exit(2);
+ }
+ }
+
+ if (verbose >= 2) moan("`%s' not found", av->v[0]);
+ rc = -1;
+end:
+ dstr_release(&d);
+ return (rc);
+}
+
+/*----- Configuration -----------------------------------------------------*/
+
+void read_config_file(const char *what, const char *file, unsigned f)
+{
+ if (!config_read_file(&config, file, f)) {
+ if (verbose >= 2)
+ moan("read %s configuration file `%s'", what, file);
+ } else {
+ if (verbose >= 3)
+ moan("ignoring missing %s configuration file `%s'", what, file);
+ }
+}
+
+static int order_strings(const void *xx, const void *yy)
+ { const char *const *x = xx, *const *y = yy; return (strcmp(*x, *y)); }
+
+void read_config_dir(const char *what, const char *path, unsigned f)
+{
+ struct argv av = ARGV_INIT;
+ struct dstr dd = DSTR_INIT;
+ struct stat st;
+ DIR *dir;
+ struct dirent *d;
+ size_t i, n, len;
+
+ dir = opendir(path);
+ if (!dir) {
+ if (!(f&CF_NOENTOK) || errno != ENOENT)
+ lose("failed to read %s configuration directory `%s': %s",
+ what, path, strerror(errno));
+ if (verbose >= 3)
+ moan("ignoring missing %s configuration directory `%s'", what, path);
+ return;
+ }
+
+ dstr_puts(&dd, path); dstr_putc(&dd, '/'); n = dd.len;
+ for (;;) {
+ d = readdir(dir); if (!d) break;
+ len = strlen(d->d_name);
+ if (len < 5 || STRCMP(d->d_name + len - 5, !=, ".conf")) continue;
+ dd.len = n; dstr_putm(&dd, d->d_name, len); dstr_putz(&dd);
+ if (stat(dd.p, &st))
+ lose("failed to read file metadata for `%s': %s",
+ dd.p, strerror(errno));
+ if (!S_ISREG(st.st_mode)) continue;
+ argv_append(&av, xstrdup(d->d_name));
+ }
+
+ qsort(av.v, av.n, sizeof(*av.v), order_strings);
+
+ for (i = 0; i < av.n; i++) {
+ dd.len = n; dstr_puts(&dd, av.v[i]);
+ read_config_file(what, dd.p, f&~CF_NOENTOK);
+ }
+
+ for (i = 0; i < av.n; i++) free((/*unconst*/ char *)av.v[i]);
+ argv_release(&av); dstr_release(&dd); closedir(dir);
+ return;
+}
+
+void read_config_path(const char *path, unsigned f)
+{
+ struct stat st;
+
+ if (!stat(path, &st) && S_ISDIR(st.st_mode))
+ read_config_dir("command-line specified ", path, f);
+ else
+ read_config_file("command-line specified", path, f);
+}
+
+int set_config_var(const char *assign)
+{
+ struct config_section *sect;
+ const char *p, *q;
+
+ p = strchr(assign, '=');
+ if (!p) { moan("missing `=' in option assignment"); return (-1); }
+ q = strchr(assign, ':');
+ if (!q || q > p)
+ { sect = toplevel; q = assign; }
+ else {
+ sect = config_find_section_n(&config, CF_CREAT, assign, q - assign);
+ q++;
+ }
+ config_set_var_n(&config, sect, CF_LITERAL | CF_OVERRIDE,
+ q, p - q, p + 1, strlen(p + 1));
+ return (0);
+}
+
+void init_config(void)
+{
+ toplevel = config_find_section(&config, CF_CREAT, "@CONFIG");
+ builtin = config_find_section(&config, CF_CREAT, "@BUILTIN");
+ common = config_find_section(&config, CF_CREAT, "@COMMON");
+ env = config_find_section(&config, CF_CREAT, "@ENV");
+ config_set_fallback(&config, common);
+ config_set_parent(builtin, 0);
+ config_set_parent(common, builtin);
+ config_set_parent(toplevel, 0);
+ config_read_env(&config, env);
+
+ config_set_var(&config, toplevel, CF_LITERAL, "data-dir",
+ my_getenv("RUNLISP_DATADIR", DATADIR));
+ config_set_var(&config, toplevel, CF_LITERAL, "image-dir",
+ my_getenv("RUNLISP_IMAGEDIR", IMAGEDIR));
+
+#ifdef ECL_OPTIONS_GNU
+ config_set_var(&config, builtin, CF_LITERAL, "@ECLOPT", "--");
+#else
+ config_set_var(&config, builtin, CF_LITERAL, "@ECLOPT", "-");
+#endif
+}
+
+void load_default_config(void)
+{
+ const char *p;
+ struct dstr d = DSTR_INIT;
+
+ p = my_getenv("RUNLISP_SYSCONFIG", ETCDIR "/runlisp.conf");
+ read_config_file("system", p, 0);
+ p = my_getenv("RUNLISP_SYSCONFIG_DIR", ETCDIR "/runlisp.d");
+ read_config_dir("system", p, CF_NOENTOK);
+ p = my_getenv("RUNLISP_USERCONFIG", 0);
+ if (p)
+ read_config_file("user", p, CF_NOENTOK);
+ else {
+ dstr_reset(&d); homedir(&d); dstr_puts(&d, "/.runlisp.conf");
+ read_config_file("user", d.p, CF_NOENTOK);
+ dstr_reset(&d); user_config_dir(&d); dstr_puts(&d, "/runlisp.conf");
+ read_config_file("user", d.p, CF_NOENTOK);
+ }
+ dstr_release(&d);
+}
+
+void dump_config(void)
+{
+ struct config_section_iter si;
+ struct config_section *sect;
+ struct config_var_iter vi;
+ struct config_var *var;
+ struct dstr d = DSTR_INIT;
+
+ for (config_start_section_iter(&config, &si);
+ (sect = config_next_section(&si)); )
+ for (config_start_var_iter(sect, &vi);
+ (var = config_next_var(&vi)); ) {
+ dstr_reset(&d); escapify(&d, var->val);
+ moan("config %s:%s = `%s'",
+ CONFIG_SECTION_NAME(sect), CONFIG_VAR_NAME(var), d.p);
+ }
+ dstr_release(&d);
+}
+
+/*----- That's all, folks -------------------------------------------------*/
--- /dev/null
+/* -*-c-*-
+ *
+ * Common functionality of a less principled nature
+ *
+ * (c) 2020 Mark Wooding
+ */
+
+/*----- Licensing notice --------------------------------------------------*
+ *
+ * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
+ *
+ * Runlisp is free software: you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License as published by the
+ * Free Software Foundation; either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Runlisp is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ * for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with Runlisp. If not, see <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef COMMON_H
+#define COMMON_H
+
+#ifdef __cplusplus
+ extern "C" {
+#endif
+
+/*----- Externally defined types ------------------------------------------*/
+
+struct dstr;
+struct argv;
+
+/*----- Public variables --------------------------------------------------*/
+
+extern struct config config;
+extern struct config_section *toplevel, *builtin, *common, *env;
+extern unsigned verbose;
+
+/*----- Functions provided ------------------------------------------------*/
+
+extern const char *my_getenv(const char */*name*/, const char */*dflt*/);
+extern long parse_int(const char */*what*/, const char */*p*/,
+ long /*min*/, long /*max*/);
+extern void argv_string(struct dstr */*d*/, const struct argv */*av*/);
+
+#define FEF_EXEC 1u
+#define FEF_VERBOSE 2u
+extern int file_exists_p(const char */*path*/, unsigned /*f*/);
+extern int found_in_path_p(const char */*prog*/, unsigned /*f*/);
+
+#define TEF_DRYRUN 1u
+#define TEF_VERBOSE 2u
+extern int try_exec(struct argv */*av*/, unsigned /*f*/);
+
+extern void read_config_file(const char */*what*/,
+ const char */*file*/, unsigned /*f*/);
+extern void read_config_dir(const char */*what*/,
+ const char */*path*/, unsigned /*f*/);
+extern void read_config_path(const char */*path*/, unsigned /*f*/);
+extern int set_config_var(const char */*assign*/);
+extern void init_config(void);
+extern void load_default_config(void);
+extern void dump_config(void);
+
+/*----- That's all, folks -------------------------------------------------*/
+
+#ifdef __cplusplus
+ }
+#endif
+
+#endif
AC_PROG_CC
AX_CFLAGS_WARN_ALL
+mdw_DECL_ENVIRON
+AC_CHECK_FUNC([strsignal])
+case $ac_cv_func_strsignal in no) AC_DECL_SYS_SIGLIST ;; esac
AC_CHECK_PROGS([AUTOM4TE], [autom4te])
imagedir=$localstatedir/$PACKAGE_NAME; AC_SUBST(imagedir)
mdw_DEFINE_PATHS([
mdw_DEFINE_PATH([IMAGEDIR], [$imagedir])
+ mdw_DEFINE_PATH([ETCDIR], [$sysconfdir])
mdw_DEFINE_PATH([DATADIR], [$datadir/$PACKAGE_NAME])])
AC_ARG_ENABLE([imagedump],
--- /dev/null
+### -*-sh-*-
+###
+### Auxiliary script for dumping ECL
+###
+### (c) 2020 Mark Wooding
+###
+
+###----- Licensing notice ---------------------------------------------------
+###
+### This file is part of Runlisp, a tool for invoking Common Lisp scripts.
+###
+### Runlisp is free software: you can redistribute it and/or modify it
+### under the terms of the GNU General Public License as published by the
+### Free Software Foundation; either version 3 of the License, or (at your
+### option) any later version.
+###
+### Runlisp is distributed in the hope that it will be useful, but WITHOUT
+### ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+### FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+### for more details.
+###
+### You should have received a copy of the GNU General Public License
+### along with Runlisp. If not, see <https://www.gnu.org/licenses/>.
+
+set -e
+
+case $# in 4) ;; *) echo >&2 "usage: $0 IMAGE ECL ECLOPT TMP"; exit 2 ;; esac
+image=$1 ecl=$2 eclopt=$3 tmp=$4
+
+run () { echo "$*"; "$@"; }
+
+## Start by compiling a copy of ASDF.
+cat >"$tmp/ecl-build.lisp" <<EOF
+(require "asdf")
+
+(defparameter *asdf* (asdf:find-system "asdf"))
+
+(defun right-here (pathname pattern)
+ (declare (ignore pattern))
+ (merge-pathnames
+ (make-pathname :name (concatenate 'string
+ (string-downcase
+ (lisp-implementation-type))
+ "-"
+ (pathname-name pathname))
+ :type nil
+ :version nil
+ :defaults *default-pathname-defaults*)
+ pathname))
+(asdf:initialize-output-translations '(:output-translations
+ ((#p"/" :**/ :*.*.*)
+ (:function right-here))
+ :ignore-inherited-configuration))
+
+(asdf:operate 'asdf:lib-op *asdf*)
+(si:quit 0)
+EOF
+(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-build.lisp")
+
+## And now compile our driver code.
+cat >"$tmp/ecl-run.lisp" <<EOF
+(cl:defpackage #:runlisp
+ (:use #:common-lisp))
+(cl:in-package #:runlisp)
+
+(defun main ()
+ $ignore_shebang_rune
+ (asdf:register-immutable-system "asdf")
+ (let ((pkg (find-package "COMMON-LISP-USER")))
+ (with-package-iterator (next pkg :internal)
+ (loop (multiple-value-bind (anyp sym how) (next)
+ (declare (ignore how))
+ (unless anyp (return))
+ (unintern sym pkg)))))
+ $set_script_feature_rune
+ (let ((winning t) (script nil) (marker nil)
+ (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc)))
+ (labels ((lose (msg &rest args)
+ (format *error-output* "~&~A: ~?~%" prog msg args)
+ (setf winning nil))
+ (quit (rc)
+ (si:quit rc))
+ (usage (stream)
+ (format stream "~&usage: ~A -s SCRIPT -- ARGS~%"
+ prog))
+ (getarg ()
+ (and (< i argc) (prog1 (si:argv i) (incf i)))))
+ (loop (let ((arg (getarg)))
+ (cond ((null arg) (return))
+ ((string= arg "--") (setf marker t) (return))
+ ((string= arg "-s") (setf script (getarg)))
+ ((string= arg "-h") (usage *standard-output*) (quit 0))
+ (t (lose "unrecognized option \`~A'" arg)))))
+ (unless script (lose "nothing to do"))
+ (unless marker (lose "unexpected end of options (missing \`--'?)"))
+ (unless winning (usage *error-output*) (quit 255))
+ (handler-case
+ (let ((*package* (find-package "COMMON-LISP-USER")))
+ (load script :verbose nil :print nil))
+ (error (err)
+ (format *error-output* "~&~A (uncaught error): ~A~%" prog err)
+ (quit 255)))
+ (quit 0))))
+(main)
+EOF
+(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-asdf.fas" \
+ -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp")
+
+## Finally link everything together.
+run "$ecl" ${eclopt}norc -o "$image"\
+ ${eclopt}link "$tmp/ecl-asdf.o" "$tmp/ecl-run.o"
+
+###----- That's all, folks --------------------------------------------------
--- /dev/null
+/* -*-c-*-
+ *
+ * Dump custom Lisp images for faster script execution
+ *
+ * (c) 2020 Mark Wooding
+ */
+
+/*----- Licensing notice --------------------------------------------------*
+ *
+ * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
+ *
+ * Runlisp is free software: you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License as published by the
+ * Free Software Foundation; either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Runlisp is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ * for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with Runlisp. If not, see <https://www.gnu.org/licenses/>.
+ */
+
+/*----- Header files ------------------------------------------------------*/
+
+#include "config.h"
+
+#include <assert.h>
+#include <ctype.h>
+#include <errno.h>
+#include <signal.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+
+#include <dirent.h>
+#include <fcntl.h>
+#include <unistd.h>
+
+#include <sys/select.h>
+#include <sys/stat.h>
+#include <sys/time.h>
+#include <sys/uio.h>
+#include <sys/wait.h>
+
+#include "common.h"
+#include "lib.h"
+#include "mdwopt.h"
+
+/*----- Static data -------------------------------------------------------*/
+
+#define MAXLINE 16384u
+struct linebuf {
+ int fd;
+ char *buf;
+ unsigned off, len;
+};
+
+enum {
+ JST_READY,
+ JST_RUN,
+ JST_DEAD,
+ JST_NSTATE
+};
+
+struct job {
+ struct treap_node _node;
+ struct job *next;
+ struct argv av;
+ unsigned st;
+ FILE *log;
+ pid_t kid;
+ int exit;
+ struct linebuf out, err;
+};
+#define JOB_NAME(job) TREAP_NODE_KEY(job)
+#define JOB_NAMELEN(job) TREAP_NODE_KEYLEN(job)
+
+static struct treap jobs = TREAP_INIT;
+static struct job *job_ready, *job_run, *job_dead;
+static unsigned nrun, maxrun = 1;
+static int rc = 0;
+static int nullfd;
+
+static int sig_pipe[2] = { -1, -1 };
+static sigset_t caught, pending;
+static int sigloss = -1;
+
+static unsigned flags = 0;
+#define AF_BOGUS 0x0001u
+#define AF_SETCONF 0x0002u
+#define AF_DRYRUN 0x0004u
+#define AF_ALL 0x0008u
+#define AF_FORCE 0x0010u
+#define AF_CHECKINST 0x0020u
+
+/*----- Main code ---------------------------------------------------------*/
+
+static PRINTF_LIKE(1, 2) void bad(const char *msg, ...)
+ { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); rc = 2; }
+
+static const char *tmpdir;
+
+static void set_tmpdir(void)
+{
+ struct dstr d = DSTR_INIT;
+ size_t n;
+ unsigned i;
+
+ dstr_putf(&d, "%s/runlisp.%d.", my_getenv("TMPDIR", "/tmp"), getpid());
+ i = 0; n = d.len;
+ for (;;) {
+ d.len = n; dstr_putf(&d, "%d", rand());
+ if (!mkdir(d.p, 0700)) break;
+ else if (errno != EEXIST)
+ lose("failed to create temporary directory `%s': %s",
+ d.p, strerror(errno));
+ else if (++i >= 32) {
+ dstr_puts(&d, "???");
+ lose("failed to create temporary directory `%s': too many attempts",
+ d.p);
+ }
+ }
+ tmpdir = xstrndup(d.p, d.len); dstr_release(&d);
+}
+
+static void recursive_delete_(struct dstr *dd)
+{
+ size_t n = dd->len;
+ DIR *dir;
+ struct dirent *d;
+
+ dd->p[n] = 0;
+ dir = opendir(dd->p);
+ if (!dir)
+ lose("failed to open directory `%s' for cleanup: %s",
+ dd->p, strerror(errno));
+
+ dd->p[n++] = '/';
+ for (;;) {
+ d = readdir(dir); if (!d) break;
+ if (d->d_name[0] == '.' && (!d->d_name[1] ||
+ (d->d_name[1] == '.' && !d->d_name[2])))
+ continue;
+ dd->len = n; dstr_puts(dd, d->d_name);
+ if (!unlink(dd->p));
+ else if (errno == EISDIR) recursive_delete_(dd);
+ else lose("failed to delete file `%s': %s", dd->p, strerror(errno));
+ }
+ closedir(dir);
+ dd->p[--n] = 0;
+ if (rmdir(dd->p))
+ lose("failed to delete directory `%s': %s", dd->p, strerror(errno));
+}
+
+static void recursive_delete(const char *path)
+{
+ struct dstr d = DSTR_INIT;
+ dstr_puts(&d, path); recursive_delete_(&d); dstr_release(&d);
+}
+
+static void cleanup(void)
+ { if (tmpdir) { recursive_delete(tmpdir); tmpdir = 0; } }
+
+static int configure_fd(const char *what, int fd, int nonblock, int cloexec)
+{
+ int fl, nfl;
+
+ if (nonblock != -1) {
+ fl = fcntl(fd, F_GETFL); if (fl < 0) goto fail;
+ if (nonblock) nfl = fl | O_NONBLOCK;
+ else nfl = fl&~O_NONBLOCK;
+ if (fl != nfl && fcntl(fd, F_SETFL, nfl)) goto fail;
+ }
+
+ if (cloexec != -1) {
+ fl = fcntl(fd, F_GETFD); if (fl < 0) goto fail;
+ if (cloexec) nfl = fl | FD_CLOEXEC;
+ else nfl = fl&~FD_CLOEXEC;
+ if (fl != nfl && fcntl(fd, F_SETFD, nfl)) goto fail;
+ }
+
+ return (0);
+
+fail:
+ bad("failed to configure %s descriptor: %s", what, strerror(errno));
+ return (-1);
+}
+
+static void handle_signal(int sig)
+{
+ sigset_t old;
+ char x = '!';
+
+ sigprocmask(SIG_BLOCK, &caught, &old);
+ sigaddset(&pending, sig);
+ sigprocmask(SIG_SETMASK, &old, 0);
+
+ DISCARD(write(sig_pipe[1], &x, 1));
+}
+
+#define JF_QUIET 1u
+static void add_job(struct job ***tail_inout, unsigned f,
+ const char *name, size_t len)
+{
+ struct job *job;
+ struct treap_path path;
+ struct config_section *sect;
+ struct config_var *dump_var, *cmd_var;
+ struct dstr d = DSTR_INIT;
+ struct argv av = ARGV_INIT;
+ unsigned fef;
+
+ job = treap_probe(&jobs, name, len, &path);
+ if (job) {
+ if (verbose >= 2) {
+ moan("ignoring duplicate Lisp `%s'", JOB_NAME(job));
+ return;
+ }
+ }
+
+ sect = config_find_section_n(&config, 0, name, len);
+ if (!sect) lose("unknown Lisp implementation `%.*s'", (int)len, name);
+ name = CONFIG_SECTION_NAME(sect);
+ dump_var = config_find_var(&config, sect, 0, "dump-image");
+ if (!dump_var) {
+ if (!(f&JF_QUIET))
+ lose("don't know how to dump images for Lisp implementation `%s'",
+ name);
+ goto end;
+ }
+ cmd_var = config_find_var(&config, sect, 0, "command");
+ if (!cmd_var)
+ lose("no `command' defined for Lisp implementation `%s'", name);
+
+ config_subst_split_var(&config, sect, dump_var, &av);
+ if (!av.n) lose("empty command for Lisp implementation `%s'", name);
+
+ if (flags&AF_CHECKINST) {
+ dstr_reset(&d);
+ fef = (verbose >= 2 ? FEF_VERBOSE : 0);
+ config_subst_var(&config, sect, cmd_var, &d);
+ if (!found_in_path_p(d.p, fef) ||
+ (STRCMP(d.p, !=, av.v[0]) && !found_in_path_p(av.v[0], fef))) {
+ if (verbose >= 2) moan("skipping Lisp implementation `%s'", name);
+ goto end;
+ }
+ }
+
+ if (!(flags&AF_FORCE)) {
+ dstr_reset(&d);
+ config_subst_string(&config, sect, "<internal>", "${@IMAGE}", &d);
+ if (!access(d.p, F_OK)) {
+ if (verbose >= 2)
+ moan("image `%s' already exists: skipping `%s'", d.p, name);
+ goto end;
+ }
+ }
+
+ job = xmalloc(sizeof(*job));
+ job->st = JST_READY;
+ job->kid = -1;
+ job->out.fd = -1; job->out.buf = 0;
+ job->err.fd = -1; job->err.buf = 0;
+ job->av = av; argv_init(&av);
+ treap_insert(&jobs, &path, &job->_node, name, len);
+ **tail_inout = job; *tail_inout = &job->next;
+end:
+ dstr_release(&d); argv_release(&av);
+}
+
+static void release_job(struct job *job)
+{
+ if (job->kid > 0) kill(job->kid, SIGKILL); /* ?? */
+ if (job->log && job->log != stdout) fclose(job->log);
+ free(job->out.buf); if (job->out.fd >= 0) close(job->out.fd);
+ free(job->err.buf); if (job->err.fd >= 0) close(job->err.fd);
+ free(job);
+}
+
+static void finish_job(struct job *job)
+{
+ char buf[16483];
+ size_t n;
+ int ok = 0;
+
+ fprintf(job->log, "%-13s > ", JOB_NAME(job));
+ if (WIFEXITED(job->exit)) {
+ if (!WEXITSTATUS(job->exit))
+ { fputs("completed successfully\n", job->log); ok = 1; }
+ else
+ fprintf(job->log, "failed with exit status %d\n",
+ WEXITSTATUS(job->exit));
+ } else if (WIFSIGNALED(job->exit))
+ fprintf(job->log, "killed by signal %d (%s%s)", WTERMSIG(job->exit),
+#if defined(HAVE_STRSIGNAL)
+ strsignal(WTERMSIG(job->exit)),
+#elif defined(HAVE_DECL_SYS_SIGLIST)
+ sys_siglist[WTERMSIG(job->exit)],
+#else
+ "unknown signal",
+#endif
+#ifdef WCOREDUMP
+ WCOREDUMP(job->exit) ? "; core dumped" :
+#endif
+ "");
+ else
+ fprintf(job->log, "exited with incomprehensible status %06o\n",
+ job->exit);
+
+ if (!ok && verbose < 2) {
+ rewind(job->log);
+ for (;;) {
+ n = fread(buf, 1, sizeof(buf), job->log);
+ if (n) fwrite(buf, 1, n, stdout);
+ if (n < sizeof(buf)) break;
+ }
+ }
+
+ release_job(job);
+}
+
+static int find_newline(struct linebuf *buf, size_t *linesz_out)
+{
+ char *nl;
+
+ if (buf->off + buf->len <= MAXLINE) {
+ nl = memchr(buf->buf + buf->off, '\n', buf->len);
+ if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); }
+ } else {
+ nl = memchr(buf->buf + buf->off, '\n', MAXLINE - buf->off);
+ if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); }
+ nl = memchr(buf->buf, '\n', buf->len - (MAXLINE - buf->off));
+ if (nl)
+ { *linesz_out = (nl - buf->buf) + (MAXLINE - buf->off); return (0); }
+ }
+ return (-1);
+}
+
+static void write_line(struct job *job, struct linebuf *buf,
+ size_t n, char marker, const char *tail)
+{
+ fprintf(job->log, "%-13s %c ", JOB_NAME(job), marker);
+ if (buf->off + n <= MAXLINE)
+ fwrite(buf->buf + buf->off, 1, n, job->log);
+ else {
+ fwrite(buf->buf + buf->off, 1, MAXLINE - buf->off, job->log);
+ fwrite(buf->buf, 1, n - (MAXLINE - buf->off), job->log);
+ }
+ fputs(tail, job->log);
+}
+
+static void prefix_lines(struct job *job, struct linebuf *buf, char marker)
+{
+ struct iovec iov[2]; int niov;
+ ssize_t n;
+ size_t linesz;
+
+ assert(buf->len < MAXLINE);
+ if (!buf->off) {
+ iov[0].iov_base = buf->buf + buf->len;
+ iov[0].iov_len = MAXLINE - buf->len;
+ niov = 1;
+ } else if (buf->off + buf->len >= MAXLINE) {
+ iov[0].iov_base = buf->buf + buf->off + buf->len - MAXLINE;
+ iov[0].iov_len = MAXLINE - buf->len;
+ niov = 1;
+ } else {
+ iov[0].iov_base = buf->buf + buf->off + buf->len;
+ iov[0].iov_len = MAXLINE - (buf->off + buf->len);
+ iov[1].iov_base = buf->buf;
+ iov[1].iov_len = buf->off;
+ niov = 1;
+ }
+
+ n = readv(buf->fd, iov, niov);
+ if (n < 0) {
+ if (errno == EAGAIN || errno == EWOULDBLOCK) return;
+ lose("failed to read job `%s' output stream: %s",
+ JOB_NAME(job), strerror(errno));
+ }
+ buf->len += n;
+
+ while (!find_newline(buf, &linesz)) {
+ write_line(job, buf, linesz, marker, "\n");
+ buf->len -= linesz + 1;
+ buf->off += linesz + 1; if (buf->off >= MAXLINE) buf->off -= MAXLINE;
+ }
+ if (!buf->len)
+ buf->off = 0;
+ else if (buf->len == MAXLINE) {
+ write_line(job, buf, MAXLINE, marker, " [...]\n");
+ buf->off = buf->len = 0;
+ }
+
+ if (!n) {
+ close(buf->fd); buf->fd = -1;
+ if (buf->len)
+ write_line(job, buf, buf->len, marker, " [missing final newline]\n");
+ }
+}
+
+static void reap_children(void)
+{
+ struct job *job, **link;
+ pid_t kid;
+ int st;
+
+ for (;;) {
+ kid = waitpid(0, &st, WNOHANG);
+ if (kid <= 0) break;
+ for (link = &job_run; (job = *link); link = &job->next)
+ if (job->kid == kid) goto found;
+ moan("unexpected child process %d exited with status %06o", kid, st);
+ continue;
+ found:
+ job->exit = st; job->st = JST_DEAD; job->kid = -1; nrun--;
+ *link = job->next; job->next = job_dead; job_dead = job;
+ }
+ if (kid < 0 && errno != ECHILD)
+ lose("failed to collect child process exit status: %s", strerror(errno));
+}
+
+static void check_signals(void)
+{
+ sigset_t old, pend;
+ char buf[32];
+ ssize_t n;
+
+ sigprocmask(SIG_BLOCK, &caught, &old);
+ pend = pending; sigemptyset(&pending);
+ for (;;) {
+ n = read(sig_pipe[0], buf, sizeof(buf));
+ if (!n) lose("(internal) signal pipe closed!");
+ if (n < 0) break;
+ }
+ if (errno != EAGAIN && errno != EWOULDBLOCK)
+ lose("failed to read signal pipe: %s", strerror(errno));
+ sigprocmask(SIG_SETMASK, &old, 0);
+
+ if (sigismember(&pend, SIGINT)) sigloss = SIGINT;
+ else if (sigismember(&pend, SIGHUP)) sigloss = SIGHUP;
+ else if (sigismember(&pend, SIGTERM)) sigloss = SIGTERM;
+ if (sigismember(&pend, SIGCHLD)) reap_children();
+}
+
+#define SIGF_IGNOK 1u
+static void set_signal_handler(const char *what, int sig, unsigned f)
+{
+ struct sigaction sa, sa_old;
+
+ sigaddset(&caught, sig);
+
+ if (f&SIGF_IGNOK) {
+ if (sigaction(sig, 0, &sa_old)) goto fail;
+ if (sa_old.sa_handler == SIG_IGN) return;
+ }
+
+ sa.sa_handler = handle_signal;
+ sigemptyset(&sa.sa_mask);
+ sa.sa_flags = SA_NOCLDSTOP;
+ if (sigaction(sig, &sa, 0)) goto fail;
+
+ return;
+
+fail:
+ lose("failed to set %s signal handler: %s", what, strerror(errno));
+}
+
+static NORETURN void job_child(struct job *job)
+{
+ try_exec(&job->av,
+ !(flags&AF_CHECKINST) && verbose >= 2 ? TEF_VERBOSE : 0);
+ moan("failed to run `%s': %s", job->av.v[0], strerror(errno));
+ _exit(2);
+}
+
+static void start_jobs(void)
+{
+ struct dstr d = DSTR_INIT;
+ int p_out[2], p_err[2];
+ struct job *job;
+ pid_t kid;
+
+ while (job_ready && nrun < maxrun) {
+ job = job_ready; job_ready = job->next;
+ p_out[0] = p_out[1] = p_err[0] = p_err[1] = -1;
+ dstr_reset(&d); dstr_putf(&d, "%s/%s", tmpdir, JOB_NAME(job));
+ if (mkdir(d.p, 0700)) {
+ bad("failed to create working directory for job `%s': %s",
+ JOB_NAME(job), strerror(errno));
+ goto fail;
+ }
+ if (verbose >= 2)
+ job->log = stdout;
+ else {
+ dstr_puts(&d, "/log"); job->log = fopen(d.p, "w+");
+ if (!job->log)
+ lose("failed to open log file `%s': %s", d.p, strerror(errno));
+ }
+ if (pipe(p_out) || pipe(p_err)) {
+ bad("failed to create pipes for job `%s': %s",
+ JOB_NAME(job), strerror(errno));
+ goto fail;
+ }
+ if (configure_fd("job stdout pipe", p_out[0], 1, 1) ||
+ configure_fd("job stdout pipe", p_out[1], 0, 1) ||
+ configure_fd("job stderr pipe", p_err[0], 1, 1) ||
+ configure_fd("job stderr pipe", p_err[1], 0, 1) ||
+ configure_fd("log file", fileno(job->log), 1, 1))
+ goto fail;
+ job->out.buf = xmalloc(MAXLINE); job->out.off = job->out.len = 0;
+ job->out.fd = p_out[0]; p_out[0] = -1;
+ job->err.buf = xmalloc(MAXLINE); job->err.off = job->err.len = 0;
+ job->err.fd = p_err[0]; p_err[0] = -1;
+ dstr_reset(&d); argv_string(&d, &job->av);
+ fprintf(job->log, "%-13s > starting %s\n", JOB_NAME(job), d.p);
+ fflush(stdout);
+ kid = fork();
+ if (kid < 0) {
+ bad("failed to fork process for job `%s': %s",
+ JOB_NAME(job), strerror(errno));
+ goto fail;
+ }
+ if (!kid) {
+ if (dup2(nullfd, 0) < 0 ||
+ dup2(p_out[1], 1) < 0 ||
+ dup2(p_err[1], 2) < 0)
+ lose("failed to juggle job `%s' file descriptors: %s",
+ JOB_NAME(job), strerror(errno));
+ job_child(job);
+ }
+ close(p_out[1]); close(p_err[1]);
+ job->kid = kid;
+ job->st = JST_RUN; job->next = job_run; job_run = job; nrun++;
+ continue;
+ fail:
+ if (p_out[0] >= 0) close(p_out[0]);
+ if (p_out[1] >= 0) close(p_out[1]);
+ if (p_err[0] >= 0) close(p_err[0]);
+ if (p_err[1] >= 0) close(p_err[1]);
+ release_job(job);
+ }
+ dstr_release(&d);
+}
+
+static void version(FILE *fp)
+ { fprintf(fp, "%s, runlisp version %s\n", progname, PACKAGE_VERSION); }
+
+static void usage(FILE *fp)
+{
+ fprintf(fp, "\
+usage: %s [-afnqv] [-c CONF] [-o [SECT:]VAR=VAL]\n\
+ [-O FILE|DIR] [-j NJOBS] [LISP ...]\n",
+ progname);
+}
+
+static void help(FILE *fp)
+{
+ version(fp); fputc('\n', fp); usage(fp);
+ fputs("\n\
+Help options:\n\
+ -h, --help Show this help text and exit successfully.\n\
+ -V, --version Show version number and exit successfully.\n\
+\n\
+Diagnostics:\n\
+ -n, --dry-run Don't run run anything (useful with `-v').\n\
+ -q, --quiet Don't print warning messages.\n\
+ -v, --verbose Print informational messages (repeatable).\n\
+\n\
+Configuration:\n\
+ -c, --config-file=CONF Read configuration from CONF (repeatable).\n\
+ -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
+\n\
+Image dumping:\n\
+ -O, --output=FILE|DIR Store image(s) in FILE or DIR.\n\
+ -a, --all-configured Dump all implementations configured.\n\
+ -f, --force Dump images even if they already exist.\n\
+ -i, --check-installed Check Lisp systems exist before invoking.\n\
+ -j, --jobs=NJOBS Run up to NJOBS jobs in parallel.\n",
+ fp);
+}
+
+int main(int argc, char *argv[])
+{
+ struct config_section_iter si;
+ struct config_section *sect;
+ struct config_var *var;
+ const char *out = 0, *p, *q, *l;
+ struct job *job, **tail, **link, *next;
+ struct stat st;
+ struct dstr d = DSTR_INIT;
+ int i, fd, nfd, first;
+ fd_set fd_in;
+
+ static const struct option opts[] = {
+ { "help", 0, 0, 'h' },
+ { "version", 0, 0, 'V' },
+ { "output", OPTF_ARGREQ, 0, 'O' },
+ { "all-configured", 0, 0, 'a' },
+ { "config-file", OPTF_ARGREQ, 0, 'c' },
+ { "force", OPTF_NEGATE, 0, 'f' },
+ { "check-installed", OPTF_NEGATE, 0, 'i' },
+ { "jobs", OPTF_ARGREQ, 0, 'j' },
+ { "dry-run", OPTF_NEGATE, 0, 'n' },
+ { "set-option", OPTF_ARGREQ, 0, 'o' },
+ { "quiet", 0, 0, 'q' },
+ { "verbose", 0, 0, 'v' },
+ { 0, 0, 0, 0 }
+ };
+
+ set_progname(argv[0]);
+ init_config();
+
+ optprog = (/*unconst*/ char *)progname;
+ for (;;) {
+ i = mdwopt(argc - 1, argv + 1, "hVO:ac:f+i+j:n+o:qv", opts, 0, 0,
+ OPTF_NEGATION | OPTF_NOPROGNAME);
+ if (i < 0) break;
+ switch (i) {
+ case 'h': help(stdout); exit(0);
+ case 'V': version(stdout); exit(0);
+ case 'O': out = optarg; break;
+ case 'a': flags |= AF_ALL; break;
+ case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break;
+ case 'f': flags |= AF_FORCE; break;
+ case 'f' | OPTF_NEGATED: flags &= ~AF_FORCE; break;
+ case 'i': flags |= AF_CHECKINST; break;
+ case 'i' | OPTF_NEGATED: flags &= ~AF_CHECKINST; break;
+ case 'j': maxrun = parse_int("number of jobs", optarg, 1, 65535); break;
+ case 'n': flags |= AF_DRYRUN; break;
+ case 'n' | OPTF_NEGATED: flags &= ~AF_DRYRUN; break;
+ case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break;
+ case 'q': if (verbose) verbose--; break;
+ case 'v': verbose++; break;
+ default: flags |= AF_BOGUS; break;
+ }
+ }
+
+ optind++;
+ if ((flags&AF_ALL) ? optind < argc : optind >= argc) flags |= AF_BOGUS;
+ if (flags&AF_BOGUS) { usage(stderr); exit(2); }
+
+ if (!(flags&AF_SETCONF)) load_default_config();
+
+ if (!out)
+ config_set_var(&config, builtin, 0,
+ "@IMAGE", "${@CONFIG:image-dir}/${image-file}");
+ else if (stat(out, &st) || !S_ISDIR(st.st_mode))
+ config_set_var(&config, builtin, CF_LITERAL, "@IMAGE", out);
+ else {
+ config_set_var(&config, builtin, CF_LITERAL, "@%OUTDIR", out);
+ config_set_var(&config, builtin, 0,
+ "@IMAGE", "${@BUILTIN:@%OUTDIR}/${image-file}");
+ }
+
+ atexit(cleanup);
+ if (pipe(sig_pipe))
+ lose("failed to create signal pipe: %s", strerror(errno));
+ configure_fd("signal pipe (read end)", sig_pipe[0], 1, 1);
+ configure_fd("signal pipe (write end)", sig_pipe[1], 1, 1);
+ sigemptyset(&caught); sigemptyset(&pending);
+ set_signal_handler("SIGTERM", SIGTERM, SIGF_IGNOK);
+ set_signal_handler("SIGINT", SIGINT, SIGF_IGNOK);
+ set_signal_handler("SIGHUP", SIGHUP, SIGF_IGNOK);
+ set_signal_handler("SIGCHLD", SIGCHLD, 0);
+
+ set_tmpdir();
+ config_set_var(&config, builtin, CF_LITERAL, "@%TMPDIR", tmpdir);
+ config_set_var(&config, builtin, 0,
+ "@TMPDIR", "${@BUILTIN:@%TMPDIR}/${@NAME}");
+
+ if (verbose >= 5) dump_config();
+
+ tail = &job_ready;
+ if (!(flags&AF_ALL))
+ for (i = optind; i < argc; i++)
+ add_job(&tail, 0, argv[i], strlen(argv[i]));
+ else {
+ var = config_find_var(&config, toplevel, 0, "dump");
+ if (!var)
+ for (config_start_section_iter(&config, &si);
+ (sect = config_next_section(&si)); )
+ add_job(&tail, JF_QUIET,
+ CONFIG_SECTION_NAME(sect),
+ CONFIG_SECTION_NAMELEN(sect));
+ else {
+ p = var->val; l = p + var->n;
+ for (;;) {
+ while (p < l && ISSPACE(*p)) p++;
+ if (p >= l) break;
+ q = p;
+ while (p < l && !ISSPACE(*p) && *p != ',') p++;
+ add_job(&tail, 0, q, p - q);
+ if (p < l) p++;
+ }
+ }
+ }
+ *tail = 0;
+
+ if (verbose >= 3) {
+ dstr_reset(&d);
+ first = 1;
+ for (job = job_ready; job; job = job->next) {
+ if (first) first = 0;
+ else dstr_puts(&d, ", ");
+ dstr_putf(&d, "`%s'", JOB_NAME(job));
+ }
+ if (first) dstr_puts(&d, "(none)");
+ dstr_putz(&d);
+ moan("dumping Lisps: %s", d.p);
+ }
+
+ if (flags&AF_DRYRUN) {
+ for (job = job_ready; job; job = job->next) {
+ if (try_exec(&job->av,
+ TEF_DRYRUN |
+ (verbose >= 2 && !(flags&AF_CHECKINST) ?
+ TEF_VERBOSE : 0)))
+ rc = 2;
+ else if (verbose >= 2)
+ printf("%-13s > (not dumping `%s': dry run)\n",
+ JOB_NAME(job), JOB_NAME(job));
+ }
+ return (rc);
+ }
+
+ for (;;) {
+ fd = open("/dev/null", O_RDWR);
+ if (fd < 0) lose("failed to open `/dev/null': %s", strerror(errno));
+ if (fd > 2) { nullfd = fd; break; }
+ }
+ configure_fd("null fd", nullfd, 0, 1);
+
+ for (;;) {
+ start_jobs();
+ if (!job_run && !job_dead) break;
+
+#define SET_FD(dir, fd) do { \
+ int _fd = (fd); \
+ \
+ FD_SET(_fd, &fd_##dir); \
+ if (_fd >= nfd) nfd = _fd + 1; \
+} while (0)
+
+ FD_ZERO(&fd_in); nfd = 0;
+ SET_FD(in, sig_pipe[0]);
+ for (job = job_run; job; job = job->next) {
+ if (job->out.fd >= 0) SET_FD(in, job->out.fd);
+ if (job->err.fd >= 0) SET_FD(in, job->err.fd);
+ }
+ for (job = job_dead; job; job = job->next) {
+ if (job->out.fd >= 0) SET_FD(in, job->out.fd);
+ if (job->err.fd >= 0) SET_FD(in, job->err.fd);
+ }
+
+#undef SET_FD
+
+ if (select(nfd, &fd_in, 0, 0, 0) < 0) {
+ if (errno == EINTR) continue;
+ else lose("select failed: %s", strerror(errno));
+ }
+
+ if (FD_ISSET(sig_pipe[0], &fd_in)) {
+ check_signals();
+ if (sigloss >= 0) {
+ for (job = job_ready; job; job = next)
+ { next = job->next; release_job(job); }
+ for (job = job_run; job; job = next)
+ { next = job->next; release_job(job); }
+ for (job = job_dead; job; job = next)
+ { next = job->next; release_job(job); }
+ break;
+ }
+ }
+
+ for (job = job_run; job; job = job->next) {
+ if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in))
+ prefix_lines(job, &job->out, '|');
+ if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in))
+ prefix_lines(job, &job->err, '*');
+ }
+ for (link = &job_dead, job = *link; job; job = next) {
+ next = job->next;
+ if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in))
+ prefix_lines(job, &job->out, '|');
+ if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in))
+ prefix_lines(job, &job->err, '*');
+ if (job->out.fd >= 0 || job->err.fd >= 0) link = &job->next;
+ else { *link = next; finish_job(job); }
+ }
+ }
+
+ check_signals();
+ if (sigloss) { cleanup(); signal(sigloss, SIG_DFL); raise(sigloss); }
+
+ return (rc);
+}
+
+/*----- That's all, folks -------------------------------------------------*/
--- /dev/null
+/* -*-c-*-
+ *
+ * Common definitions for `runlisp'
+ *
+ * (c) 2020 Mark Wooding
+ */
+
+/*----- Licensing notice --------------------------------------------------*
+ *
+ * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
+ *
+ * Runlisp is free software: you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License as published by the
+ * Free Software Foundation; either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Runlisp is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ * for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with Runlisp. If not, see <https://www.gnu.org/licenses/>.
+ */
+
+/*----- Header files ------------------------------------------------------*/
+
+#include "config.h"
+
+#include <assert.h>
+
+#include <ctype.h>
+#include <errno.h>
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <unistd.h>
+
+#include "lib.h"
+
+/*----- Miscellany --------------------------------------------------------*/
+
+int str_lt(const char *a, size_t an, const char *b, size_t bn)
+{
+ if (an < bn) return (MEMCMP(a, <=, b, an));
+ else return (MEMCMP(a, <, b, bn));
+}
+
+/*----- Diagnostic utilities ----------------------------------------------*/
+
+const char *progname = "???";
+
+void set_progname(const char *prog)
+{
+ const char *p;
+
+ p = strrchr(prog, '/');
+ progname = p ? p + 1 : progname;
+}
+
+void vmoan(const char *msg, va_list ap)
+{
+ fprintf(stderr, "%s: ", progname);
+ vfprintf(stderr, msg, ap);
+ fputc('\n', stderr);
+}
+
+void moan(const char *msg, ...)
+ { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); }
+
+void lose(const char *msg, ...)
+ { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); exit(127); }
+
+/*----- Memory allocation -------------------------------------------------*/
+
+void *xmalloc(size_t n)
+{
+ void *p;
+
+ if (!n) return (0);
+ p = malloc(n); if (!p) lose("failed to allocate memory");
+ return (p);
+}
+
+void *xrealloc(void *p, size_t n)
+{
+ if (!n) { free(p); return (0); }
+ else if (!p) return (xmalloc(n));
+ p = realloc(p, n); if (!p) lose("failed to allocate memory");
+ return (p);
+}
+
+char *xstrndup(const char *p, size_t n)
+{
+ char *q = xmalloc(n + 1);
+
+ memcpy(q, p, n); q[n] = 0;
+ return (q);
+}
+
+char *xstrdup(const char *p) { return (xstrndup(p, strlen(p))); }
+
+/*----- Dynamic strings ---------------------------------------------------*/
+
+void dstr_init(struct dstr *d) { d->p = 0; d->len = d->sz = 0; }
+
+void dstr_reset(struct dstr *d) { d->len = 0; }
+
+void dstr_ensure(struct dstr *d, size_t n)
+{
+ size_t need = d->len + n, newsz;
+
+ if (need <= d->sz) return;
+ newsz = d->sz ? 2*d->sz : 16;
+ while (newsz < need) newsz *= 2;
+ d->p = xrealloc(d->p, newsz); d->sz = newsz;
+}
+
+void dstr_release(struct dstr *d) { free(d->p); }
+
+void dstr_putm(struct dstr *d, const void *p, size_t n)
+ { dstr_ensure(d, n); memcpy(d->p + d->len, p, n); d->len += n; }
+
+void dstr_puts(struct dstr *d, const char *p)
+{
+ size_t n = strlen(p);
+
+ dstr_ensure(d, n + 1);
+ memcpy(d->p + d->len, p, n + 1);
+ d->len += n;
+}
+
+void dstr_putc(struct dstr *d, int ch)
+ { dstr_ensure(d, 1); d->p[d->len++] = ch; }
+
+void dstr_putcn(struct dstr *d, int ch, size_t n)
+ { dstr_ensure(d, n); memset(d->p + d->len, ch, n); d->len += n; }
+
+void dstr_putz(struct dstr *d)
+ { dstr_ensure(d, 1); d->p[d->len] = 0; }
+
+void dstr_vputf(struct dstr *d, const char *p, va_list ap)
+{
+ va_list ap2;
+ size_t r;
+ int n;
+
+ r = d->sz - d->len;
+ va_copy(ap2, ap);
+ n = vsnprintf(d->p + d->len, r, p, ap2); assert(n >= 0);
+ va_end(ap2);
+ if (n >= r) {
+ dstr_ensure(d, n + 1); r = d->sz - d->len;
+ n = vsnprintf(d->p + d->len, r, p, ap); assert(n >= 0); assert(n < r);
+ }
+ d->len += n;
+}
+
+PRINTF_LIKE(2, 3) void dstr_putf(struct dstr *d, const char *p, ...)
+ { va_list ap; va_start(ap, p); dstr_vputf(d, p, ap); va_end(ap); }
+
+int dstr_readline(struct dstr *d, FILE *fp)
+{
+ size_t n;
+ int any = 0;
+
+ for (;;) {
+ dstr_ensure(d, 2);
+ if (!fgets(d->p + d->len, d->sz - d->len, fp)) break;
+ n = strlen(d->p + d->len); assert(n > 0); any = 1;
+ d->len += n;
+ if (d->p[d->len - 1] == '\n') { d->p[--d->len] = 0; break; }
+ }
+
+ if (!any) return (-1);
+ else return (0);
+}
+
+/*----- Dynamic vectors of strings ----------------------------------------*/
+
+void argv_init(struct argv *av)
+ { av->v = 0; av->o = av->n = av->sz = 0; }
+
+void argv_reset(struct argv *av) { av->n = 0; }
+
+void argv_ensure(struct argv *av, size_t n)
+{
+ size_t need = av->n + av->o + n, newsz;
+
+ if (need <= av->sz) return;
+ newsz = av->sz ? 2*av->sz : 8;
+ while (newsz < need) newsz *= 2;
+ av->v =
+ (const char **)xrealloc(av->v - av->o, newsz*sizeof(const char *)) +
+ av->o;
+ av->sz = newsz;
+}
+
+void argv_ensure_offset(struct argv *av, size_t n)
+{
+ size_t newoff;
+
+ /* Stupid version. We won't, in practice, be prepending lots of stuff, so
+ * avoid the extra bookkeeping involved in trying to make a double-ended
+ * extendable array asymptotically efficient.
+ */
+ if (av->o >= n) return;
+ newoff = 16;
+ while (newoff < n) newoff *= 2;
+ argv_ensure(av, newoff - av->o);
+ memmove(av->v + newoff - av->o, av->v, av->n*sizeof(const char *));
+ av->v += newoff - av->o; av->o = newoff;
+}
+
+void argv_release(struct argv *av) { free(av->v - av->o); }
+
+void argv_append(struct argv *av, const char *p)
+ { argv_ensure(av, 1); av->v[av->n++] = p; }
+
+void argv_appendz(struct argv *av)
+ { argv_ensure(av, 1); av->v[av->n] = 0; }
+
+void argv_appendn(struct argv *av, const char *const *v, size_t n)
+{
+ argv_ensure(av, n);
+ memcpy(av->v + av->n, v, n*sizeof(const char *));
+ av->n += n;
+}
+
+void argv_appendav(struct argv *av, const struct argv *bv)
+ { argv_appendn(av, bv->v, bv->n); }
+
+void argv_appendv(struct argv *av, va_list ap)
+{
+ const char *p;
+
+ for (;;)
+ { p = va_arg(ap, const char *); if (!p) break; argv_append(av, p); }
+}
+
+void argv_appendl(struct argv *av, ...)
+ { va_list ap; va_start(ap, av); argv_appendv(av, ap); va_end(ap); }
+
+void argv_prepend(struct argv *av, const char *p)
+ { argv_ensure_offset(av, 1); *--av->v = p; av->o--; av->n++; }
+
+void argv_prependn(struct argv *av, const char *const *v, size_t n)
+{
+ argv_ensure_offset(av, n);
+ av->o -= n; av->v -= n; av->n += n;
+ memcpy(av->v, v, n*sizeof(const char *));
+}
+
+void argv_prependav(struct argv *av, const struct argv *bv)
+ { argv_prependn(av, bv->v, bv->n); }
+
+void argv_prependv(struct argv *av, va_list ap)
+{
+ const char *p, **v;
+ size_t n = 0;
+
+ for (;;) {
+ p = va_arg(ap, const char *); if (!p) break;
+ argv_prepend(av, p); n++;
+ }
+ v = av->v;
+ while (n >= 2) {
+ p = v[0]; v[0] = v[n - 1]; v[n - 1] = p;
+ v++; n -= 2;
+ }
+}
+
+void argv_prependl(struct argv *av, ...)
+ { va_list ap; va_start(ap, av); argv_prependv(av, ap); va_end(ap); }
+
+/*----- Treaps ------------------------------------------------------------*/
+
+void treap_init(struct treap *t) { t->root = 0; }
+
+void *treap_lookup(const struct treap *t, const char *k, size_t kn)
+{
+ struct treap_node *n = t->root, *candidate = 0;
+
+ while (n) {
+ if (str_lt(k, kn, n->k, n->kn)) n = n->left;
+ else { candidate = n; n = n->right; }
+ }
+ if (!candidate || str_lt(candidate->k, candidate->kn, k, kn)) return (0);
+ return (candidate);
+}
+
+void *treap_probe(struct treap *t, const char *k, size_t kn,
+ struct treap_path *p)
+{
+ struct treap_node **nn = &t->root, *candidate = 0;
+ unsigned i = 0;
+
+ for (;;) {
+ assert(i < TREAP_PATHMAX); p->path[i++] = nn;
+ if (!*nn) break;
+ if (str_lt(k, kn, (*nn)->k, (*nn)->kn)) nn = &(*nn)->left;
+ else { candidate = *nn; nn = &(*nn)->right; }
+ }
+ p->nsteps = i;
+ if (!candidate || str_lt(candidate->k, candidate->kn, k, kn)) return (0);
+ return (candidate);
+}
+
+void treap_insert(struct treap *t, const struct treap_path *p,
+ struct treap_node *n, const char *k, size_t kn)
+{
+ size_t i = p->nsteps;
+ struct treap_node **nn, **uu, *u;
+ unsigned wt;
+
+ n->k = xstrndup(k, kn); n->kn = kn;
+ n->wt = wt = rand(); n->left = n->right = 0;
+ assert(i); nn = p->path[--i];
+ while (i--) {
+ uu = p->path[i]; u = *uu;
+ if (wt <= u->wt) break;
+ if (nn == &u->left) { u->left = n->right; n->right = u; }
+ else { u->right = n->left; n->left = u; }
+ nn = uu;
+ }
+ *nn = n;
+}
+
+void *treap_remove(struct treap *t, const char *k, size_t kn)
+{
+ struct treap_node **nn = &t->root, **candidate = 0, *n, *l, *r;
+
+ while (*nn) {
+ if (str_lt(k, kn, (*nn)->k, (*nn)->kn)) nn = &(*nn)->left;
+ else { candidate = nn; nn = &(*nn)->right; }
+ }
+ if (!candidate || str_lt((*candidate)->k, (*candidate)->kn, k, kn))
+ return (0);
+
+ n = *candidate; l = n->left; r = n->right;
+ for (;;) {
+ if (l && (!r || l->wt > r->wt)) { nn = &l->right; l = l->right; }
+ else if (r) { nn = &r->left; r = r->left; }
+ else break;
+ }
+ *nn = 0;
+ free(n->k);
+ return (n);
+}
+
+void treap_start_iter(struct treap *t, struct treap_iter *i)
+{
+ struct treap_node *n = t->root;
+ unsigned sp = 0;
+
+ while (n) {
+ assert(sp < TREAP_PATHMAX);
+ i->stack[sp++] = n; n = n->left;
+ }
+ i->sp = sp;
+}
+
+void *treap_next(struct treap_iter *i)
+{
+ struct treap_node *n, *o;
+ unsigned sp = i->sp;
+
+ if (!sp) return (0);
+ n = i->stack[--sp];
+ o = n->right;
+ while (o) {
+ assert(sp < TREAP_PATHMAX);
+ i->stack[sp++] = o; o = o->left;
+ }
+ i->sp = sp;
+ return (n);
+}
+
+static void check_node(struct treap_node *n, unsigned maxwt,
+ const char *klo, const char *khi)
+{
+ assert(n->wt <= maxwt);
+ if (klo) assert(STRCMP(n->k, >, klo));
+ if (khi) assert(STRCMP(n->k, <, khi));
+ if (n->left) check_node(n->left, n->wt, klo, n->k);
+ if (n->right) check_node(n->right, n->wt, n->k, khi);
+}
+
+void treap_check(struct treap *t)
+ { if (t->root) check_node(t->root, t->root->wt, 0, 0); }
+
+static void dump_node(struct treap_node *n, int ind)
+{
+ if (n->left) dump_node(n->left, ind + 1);
+ printf(";;%*s [%10u] `%s'\n", 2*ind, "", n->wt, n->k);
+ if (n->right) dump_node(n->right, ind + 1);
+}
+
+void treap_dump(struct treap *t) { if (t->root) dump_node(t->root, 0); }
+
+/*----- Configuration file parsing ----------------------------------------*/
+
+#ifndef DECL_ENVIRON
+ extern char **environ;
+#endif
+
+void config_init(struct config *conf)
+ { treap_init(&conf->sections); }
+
+struct config_section *config_find_section(struct config *conf, unsigned f,
+ const char *name)
+ { return (config_find_section_n(conf, f, name, strlen(name))); }
+
+struct config_section *config_find_section_n(struct config *conf, unsigned f,
+ const char *name, size_t sz)
+{
+ struct config_section *sect;
+ struct treap_path path;
+
+ if (!(f&CF_CREAT))
+ sect = treap_lookup(&conf->sections, name, sz);
+ else {
+ sect = treap_probe(&conf->sections, name, sz, &path);
+ if (!sect) {
+ sect = xmalloc(sizeof(*sect));
+ if (!conf->head) conf->tail = &conf->head;
+ sect->next = 0; *conf->tail = sect; conf->tail = §->next;
+ sect->parents = 0; sect->nparents = SIZE_MAX;
+ treap_init(§->vars); treap_init(§->cache);
+ treap_insert(&conf->sections, &path, §->_node, name, sz);
+ config_set_var_n(conf, sect, CF_LITERAL, "@NAME", 5, name, sz);
+ }
+ }
+ return (sect);
+}
+
+void config_set_fallback(struct config *conf, struct config_section *sect)
+{
+ if (sect->nparents == SIZE_MAX) sect->nparents = 0;
+ conf->fallback = sect;
+}
+
+void config_set_parent(struct config_section *sect,
+ struct config_section *parent)
+{
+ if (!parent)
+ sect->nparents = 0;
+ else {
+ sect->parents = xmalloc(sizeof(*sect->parents));
+ sect->parents[0] = parent; sect->nparents = 1;
+ }
+}
+
+void config_start_section_iter(struct config *conf,
+ struct config_section_iter *i)
+ { i->sect = conf->head; }
+
+struct config_section *config_next_section(struct config_section_iter *i)
+{
+ struct config_section *sect;
+
+ sect = i->sect;
+ if (sect) i->sect = sect->next;
+ return (sect);
+}
+
+static void set_config_section_parents(struct config *conf,
+ struct config_section *sect)
+{
+ struct config_section *parent;
+ struct config_var *var;
+ struct argv av = ARGV_INIT;
+ size_t i, n;
+ char *p, *q;
+
+ if (sect->nparents != SIZE_MAX) return;
+
+ var = treap_lookup(§->vars, "@PARENTS", 8);
+ if (!var) {
+ if (!conf->fallback)
+ sect->nparents = 0;
+ else {
+ sect->parents = xmalloc(sizeof(*sect->parents));
+ sect->nparents = 1;
+ sect->parents[0] = conf->fallback;
+ }
+ } else {
+ p = var->val;
+ for (;;) {
+ while (ISSPACE(*p)) p++;
+ if (!*p) break;
+ q = p; while (*q && *q != ',' && !ISSPACE(*q)) q++;
+ argv_append(&av, p); argv_append(&av, q);
+ p = q; if (*p == ',') p++;
+ }
+ sect->nparents = av.n/2;
+ sect->parents = xmalloc(sect->nparents*sizeof(sect->parents));
+ for (i = 0; i < av.n; i += 2) {
+ n = av.v[i + 1] - av.v[i];
+ parent = config_find_section_n(conf, 0, av.v[i], n);
+ if (!parent)
+ lose("%s:%u: unknown parent section `%.*s'",
+ var->file, var->line, (int)n, av.v[i]);
+ sect->parents[i/2] = parent;
+ }
+ argv_release(&av);
+ }
+}
+
+struct config_var *search_recursive(struct config *conf,
+ struct config_section *sect,
+ const char *name, size_t sz)
+{
+ struct config_cache_entry *cache;
+ struct treap_path path;
+ struct config_var *var, *v;
+ size_t i, j = j;
+
+ cache = treap_probe(§->cache, name, sz, &path);
+ if (!cache) {
+ cache = xmalloc(sizeof(*cache)); cache->f = CF_OPEN;
+ treap_insert(§->cache, &path, &cache->_node, name, sz);
+ } else if (cache->f&CF_OPEN)
+ lose("inheritance cycle through section `%s'",
+ CONFIG_SECTION_NAME(sect));
+ else
+ return (cache->var);
+
+ set_config_section_parents(conf, sect);
+
+ var = treap_lookup(§->vars, name, sz);
+ if (!var) {
+ for (i = 0; i < sect->nparents; i++) {
+ v = search_recursive(conf, sect->parents[i], name, sz);
+ if (!v);
+ else if (!var) { var = v; j = i; }
+ else if (var != v)
+ lose("section `%s' inherits variable `%s' ambiguously "
+ "via `%s' and `%s'",
+ CONFIG_SECTION_NAME(sect), CONFIG_VAR_NAME(var),
+ CONFIG_SECTION_NAME(sect->parents[j]),
+ CONFIG_SECTION_NAME(sect->parents[i]));
+ }
+ }
+
+ cache->var = var; cache->f &= ~CF_OPEN;
+ return (var);
+}
+
+struct config_var *config_find_var(struct config *conf,
+ struct config_section *sect,
+ unsigned f, const char *name)
+ { return (config_find_var_n(conf, sect, f, name, strlen(name))); }
+
+struct config_var *config_find_var_n(struct config *conf,
+ struct config_section *sect,
+ unsigned f, const char *name, size_t sz)
+{
+ struct config_var *var;
+ struct treap_path path;
+
+ if (f&CF_INHERIT)
+ var = search_recursive(conf, sect, name, sz);
+ else if (!(f&CF_CREAT))
+ var = treap_lookup(§->vars, name, sz);
+ else {
+ var = treap_probe(§->vars, name, sz, &path);
+ if (!var) {
+ var = xmalloc(sizeof(*var));
+ var->val = 0; var->file = 0; var->f = 0; var->line = 1;
+ treap_insert(§->vars, &path, &var->_node, name, sz);
+ }
+ }
+ return (var);
+}
+
+void config_start_var_iter(struct config_section *sect,
+ struct config_var_iter *i)
+ { treap_start_iter(§->vars, &i->i); }
+
+struct config_var *config_next_var(struct config_var_iter *i)
+ { return (treap_next(&i->i)); }
+
+void config_set_var(struct config *conf, struct config_section *sect,
+ unsigned f,
+ const char *name, const char *value)
+{
+ config_set_var_n(conf, sect, f,
+ name, strlen(name),
+ value, strlen(value));
+}
+
+void config_set_var_n(struct config *conf, struct config_section *sect,
+ unsigned f,
+ const char *name, size_t namelen,
+ const char *value, size_t valuelen)
+{
+ struct config_var *var =
+ config_find_var_n(conf, sect, CF_CREAT, name, namelen);
+
+ if (var->f&~f&CF_OVERRIDE) return;
+ free(var->val); var->val = xstrndup(value, valuelen); var->n = valuelen;
+ var->f = f;
+}
+
+int config_read_file(struct config *conf, const char *file, unsigned f)
+{
+ struct config_section *sect;
+ struct config_var *var;
+ struct dstr d = DSTR_INIT, dd = DSTR_INIT;
+ unsigned line = 0;
+ char *p, *q;
+ FILE *fp;
+
+ fp = fopen(file, "r");
+ if (!fp) {
+ if ((f&CF_NOENTOK) && errno == ENOENT) return (-1);
+ lose("failed to open configuration file `%s': %s",
+ file, strerror(errno));
+ }
+
+ sect = config_find_section(conf, CF_CREAT, "@CONFIG"); var = 0;
+
+ for (;;) {
+ dstr_reset(&d); if (dstr_readline(&d, fp)) break;
+ line++;
+
+ if (d.p[0] && !ISSPACE(d.p[0])) {
+ if (var) {
+ if (!(var->f&CF_OVERRIDE))
+ { var->val = xstrndup(dd.p, dd.len); var->n = dd.len; }
+ var = 0;
+ }
+ if (d.p[0] == ';')
+ ;
+ else if (d.p[0] == '[') {
+ p = d.p + 1; q = strchr(p, ']');
+ if (!q) lose("%s:%u: missing `]' in section header", file, line);
+ sect = config_find_section_n(conf, CF_CREAT, p, q - p);
+ q++; while (ISSPACE(*q)) q++;
+ if (*q) lose("%s:%u: trailing junk after `]' in section header",
+ file, line);
+ } else {
+ p = d.p;
+ while (*p && !ISSPACE(*p) && *p != '{' && *p != '}' && *p != '=')
+ p++;
+ var = config_find_var_n(conf, sect, CF_CREAT, d.p, p - d.p);
+ while (ISSPACE(*p)) p++;
+ if (*p != '=') lose("%s:%u: missing `=' in assignment", file, line);
+ p++; while (ISSPACE(*p)) p++;
+ if (!(var->f&CF_OVERRIDE)) {
+ free(var->val); var->val = 0; var->f = 0;
+ free(var->file); var->file = xstrdup(file); var->line = line;
+ }
+ dstr_reset(&dd); dstr_puts(&dd, p);
+ }
+ } else {
+ p = d.p; while (ISSPACE(*p)) p++;
+ if (*p) {
+ if (!var)
+ lose("%s:%u: continuation line, but no variable", file, line);
+ if (dd.len) dstr_putc(&dd, ' ');
+ dstr_puts(&dd, p);
+ }
+ }
+ }
+
+ if (var && !(var->f&CF_OVERRIDE))
+ { var->val = xstrndup(dd.p, dd.len); var->n = dd.len; }
+
+ dstr_release(&d); dstr_release(&dd);
+ if (fclose(fp))
+ lose("error reading configuration file `%s': %s", file, strerror(errno));
+ return (0);
+}
+
+void config_read_env(struct config *conf, struct config_section *sect)
+{
+ const char *p, *v;
+ size_t i;
+
+ for (i = 0; (p = environ[i]) != 0; i++) {
+ v = strchr(p, '='); if (!v) continue;
+ config_set_var_n(conf, sect, CF_LITERAL, p, v - p, v + 1, strlen(v + 1));
+ }
+}
+
+/*----- Substitution and quoting ------------------------------------------*/
+
+struct subst {
+ struct config *config;
+ struct config_section *home, *fallback;
+ struct argv *av;
+ struct dstr *d;
+};
+
+static const char *scan_name(const char *p, const char *l)
+{
+ while (p < l &&
+ (ISALNUM(*p) || *p == '-' || *p == '_' || *p == '.' || *p == '/' ||
+ *p == '*' || *p == '+' || *p == '%' || *p == '@'))
+ p++;
+ return (p);
+}
+
+static void filter_string(const char *p, const char *l, struct subst *sb,
+ unsigned qfilt)
+{
+ size_t r, n;
+
+ if (!qfilt)
+ dstr_putm(sb->d, p, l - p);
+ else for (;;) {
+ r = l - p; n = strcspn(p, "\"\\");
+ if (n > r) n = r;
+ dstr_putm(sb->d, p, n);
+ if (n >= r) break;
+ dstr_putcn(sb->d, '\\', qfilt); dstr_putc(sb->d, p[n]);
+ p += n + 1;
+ }
+}
+
+static const char *retrieve_varspec(const char *p, const char *l,
+ struct subst *sb,
+ struct config_var **var_out)
+{
+ struct config_section *sect = sb->home;
+ const char *t;
+
+ t = scan_name(p, l);
+ if (t < l && *t == ':') {
+ sect = config_find_section_n(sb->config, 0, p, t - p);
+ p = t + 1; t = scan_name(p, l);
+ }
+
+ if (!sect) *var_out = 0;
+ else *var_out = config_find_var_n(sb->config, sect, CF_INHERIT, p, t - p);
+ return (t);
+}
+
+#define SF_SPLIT 0x0001u
+#define SF_QUOT 0x0002u
+#define SF_SUBST 0x0004u
+#define SF_SUBEXPR 0x0008u
+#define SF_SPANMASK 0x00ffu
+#define SF_WORD 0x0100u
+#define SF_SKIP 0x0200u
+#define SF_LITERAL 0x0400u
+
+static const char *subst(const char *p, const char *l, struct subst *sb,
+ const char *file, unsigned line,
+ unsigned qfilt, unsigned f)
+{
+ struct config_var *var;
+ const char *q0, *q1, *t;
+ unsigned subqfilt, ff;
+ size_t n;
+
+#define ESCAPE "\\"
+#define SUBST "$"
+#define WORDSEP " \f\r\n\t\v'\""
+#define QUOT "\""
+#define DELIM "|}"
+
+ static const char *const delimtab[] =
+ { ESCAPE,
+ ESCAPE WORDSEP,
+ 0,
+ ESCAPE QUOT,
+ ESCAPE SUBST,
+ ESCAPE SUBST WORDSEP,
+ 0,
+ ESCAPE SUBST QUOT,
+ ESCAPE DELIM,
+ ESCAPE DELIM WORDSEP,
+ 0,
+ ESCAPE DELIM QUOT,
+ ESCAPE DELIM SUBST,
+ ESCAPE DELIM SUBST WORDSEP,
+ 0,
+ ESCAPE DELIM SUBST QUOT };
+
+#undef COMMON
+#undef WORDSEP
+#undef SQUOT
+#undef DELIM
+
+ if (!file) file = "<internal>";
+
+ if (f&SF_LITERAL) {
+ filter_string(p, l, sb, qfilt);
+ f |= SF_WORD;
+ goto done;
+ }
+
+ while (p < l) {
+
+ if ((f&(SF_SPLIT | SF_QUOT)) == SF_SPLIT && ISSPACE(*p)) {
+ if (f&SF_WORD) {
+ if (!(f&SF_SKIP)) {
+ argv_append(sb->av, xstrndup(sb->d->p, sb->d->len));
+ dstr_reset(sb->d);
+ }
+ f &= ~SF_WORD;
+ }
+ do p++; while (p < l && ISSPACE(*p));
+
+ } else if (*p == '\\') {
+ p++;
+ if (p >= l) lose("%s:%u: unfinished `\\' escape", file, line);
+ if (!(f&SF_SKIP)) {
+ if (qfilt && (*p == '"' || *p == '\\'))
+ dstr_putcn(sb->d, '\\', qfilt);
+ dstr_putc(sb->d, *p);
+ }
+ p++;
+
+ } else if ((f&SF_SPLIT) && *p == '"') {
+ f ^= SF_QUOT; f |= SF_WORD; p++;
+
+ } else if ((f&(SF_SPLIT | SF_QUOT)) == SF_SPLIT && *p == '\'') {
+ t = strchr(p, '\''); if (!t) lose("%s:%u: missing `''", file, line);
+ if (!(f&SF_SKIP)) filter_string(p, t, sb, qfilt);
+ p = t + 1; f |= SF_WORD;
+
+ } else if ((f&SF_SUBEXPR) && (*p == '|' || *p == '}')) {
+ break;
+
+ } else if ((f&SF_SUBST) && *p == '$') {
+ p++; if (p >= l) lose("%s:%u: incomplete substitution", file, line);
+ ff = f&~(SF_QUOT | (f&SF_WORD ? SF_SPLIT : 0));
+ switch (*p) {
+
+ case '?':
+ p = retrieve_varspec(p + 1, l, sb, &var);
+ if (p > l || *p != '{') lose("%s:%u: expected `{'", file, line);
+ p++;
+ ff |= SF_SUBEXPR;
+ p = subst(p, l, sb, file, line, qfilt,
+ ff | (var ? 0 : SF_SKIP));
+ if (p < l && *p == '|')
+ p = subst(p + 1, l, sb, file, line, qfilt,
+ ff | (var ? SF_SKIP : 0));
+ if (p >= l || *p != '}') lose("%s:%u: missing `}'", file, line);
+ p++;
+ break;
+
+ case '{':
+ q0 = p + 1; p = retrieve_varspec(q0, l, sb, &var); q1 = p;
+ subqfilt = qfilt;
+ while (p < l) {
+ if (*p != '|') break;
+ p++; t = scan_name(p, l);
+ if (t - p == 1 && *p == 'q') subqfilt = 2*subqfilt + 1;
+ else
+ lose("%s:%u: unknown filter `%.*s'",
+ file, line, (int)(t - p), p);
+ p = t;
+ }
+ if (!(f&SF_SKIP) && var) {
+ if (var->f&CF_EXPAND)
+ lose("%s:%u: recursive expansion of variable `%.*s'",
+ file, line, (int)(q1 - q0), q0);
+ var->f |= CF_EXPAND;
+ subst(var->val, var->val + var->n, sb,
+ var->file, var->line, subqfilt,
+ ff | (var->f&CF_LITERAL ? SF_LITERAL : 0));
+ var->f &= ~CF_EXPAND;
+ }
+ if (p < l && *p == '?')
+ p = subst(p + 1, l, sb, file, line, subqfilt,
+ ff | SF_SUBEXPR | (var ? SF_SKIP : 0));
+ else if (!var && !(f&SF_SKIP))
+ lose("%s:%u: unknown variable `%.*s'",
+ file, line, (int)(q1 - q0), q0);
+ if (p >= l || *p != '}') lose("%s:%u: missing `}'", file, line);
+ p++;
+ break;
+
+ default:
+ lose("%s:%u: unexpected substitution `%c'", file, line, *p);
+ }
+ if (p < l && !(~f&~(SF_WORD | SF_SPLIT)) && !ISSPACE(*p) &&
+ !((f&SF_SUBEXPR) && (*p == '|' || *p == '}')))
+ lose("%s:%u: surprising word boundary "
+ "after splicing substitution",
+ file, line);
+ }
+
+ else {
+ n = strcspn(p, delimtab[f&SF_SPANMASK]);
+ if (n > l - p) n = l - p;
+ if (!(f&SF_SKIP)) filter_string(p, p + n, sb, qfilt);
+ p += n; f |= SF_WORD;
+ }
+ }
+
+done:
+ if (f&SF_QUOT) lose("%s:%u: missing `\"'", file, line);
+ if ((f&(SF_WORD | SF_SPLIT | SF_SKIP)) == (SF_SPLIT | SF_WORD)) {
+ argv_append(sb->av, xstrndup(sb->d->p, sb->d->len));
+ dstr_reset(sb->d);
+ }
+
+ return (p);
+}
+
+void config_subst_string(struct config *config, struct config_section *home,
+ const char *what, const char *p, struct dstr *d)
+{
+ struct subst sb;
+
+ sb.config = config; sb.home = home; sb.d = d;
+ subst(p, p + strlen(p), &sb, what, 0, 0, SF_SUBST);
+ dstr_putz(d);
+}
+
+char *config_subst_string_alloc(struct config *config,
+ struct config_section *home,
+ const char *what, const char *p)
+{
+ struct dstr d = DSTR_INIT;
+ char *q;
+
+ config_subst_string(config, home, what, p, &d);
+ q = xstrndup(d.p, d.len); dstr_release(&d); return (q);
+}
+
+void config_subst_var(struct config *config, struct config_section *home,
+ struct config_var *var, struct dstr *d)
+{
+ struct subst sb;
+
+ sb.config = config; sb.home = home; sb.d = d;
+ var->f |= CF_EXPAND;
+ subst(var->val, var->val + var->n, &sb, var->file, var->line, 0,
+ SF_SUBST | (var->f&CF_LITERAL ? SF_LITERAL : 0));
+ var->f &= ~CF_EXPAND;
+ dstr_putz(d);
+}
+
+char *config_subst_var_alloc(struct config *config,
+ struct config_section *home,
+ struct config_var *var)
+{
+ struct dstr d = DSTR_INIT;
+ char *q;
+
+ config_subst_var(config, home, var, &d);
+ q = xstrndup(d.p, d.len); dstr_release(&d); return (q);
+}
+
+void config_subst_split_var(struct config *config,
+ struct config_section *home,
+ struct config_var *var, struct argv *av)
+{
+ struct dstr d = DSTR_INIT;
+ struct subst sb;
+
+ sb.config = config; sb.home = home; sb.av = av; sb.d = &d;
+ var->f |= CF_EXPAND;
+ subst(var->val, var->val + var->n, &sb, var->file, var->line, 0,
+ SF_SUBST | SF_SPLIT | (var->f&CF_LITERAL ? SF_LITERAL : 0));
+ var->f &= ~CF_EXPAND;
+ dstr_release(&d);
+}
+
+/*----- That's all, folks -------------------------------------------------*/
--- /dev/null
+/* -*-c-*-
+ *
+ * Common definitions for `runlisp'
+ *
+ * (c) 2020 Mark Wooding
+ */
+
+/*----- Licensing notice --------------------------------------------------*
+ *
+ * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
+ *
+ * Runlisp is free software: you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License as published by the
+ * Free Software Foundation; either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Runlisp is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ * for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with Runlisp. If not, see <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef LIB_H
+#define LIB_H
+
+#ifdef __cplusplus
+ extern "C" {
+#endif
+
+/*----- Header files ------------------------------------------------------*/
+
+#include <limits.h>
+#include <stdarg.h>
+#include <stddef.h>
+#include <stdio.h>
+
+/*----- Handy macros ------------------------------------------------------*/
+
+#define N(v) (sizeof(v)/sizeof((v)[0]))
+
+#if defined(__GNUC__)
+# define GCC_VERSION_P(maj, min) \
+ (__GNUC__ > (maj) || (__GNUC__ == (maj) && __GNUC_MINOR__ >= (min)))
+#else
+# define GCC_VERSION_P(maj, min) 0
+#endif
+
+#ifdef __clang__
+# define CLANG_VERSION_P(maj, min) \
+ (__clang_major__ > (maj) || (__clang_major__ == (maj) && \
+ __clang_minor__ >= (min)))
+#else
+# define CLANG_VERSION_P(maj, min) 0
+#endif
+
+#if GCC_VERSION_P(2, 5) || CLANG_VERSION_P(3, 3)
+# define NORETURN __attribute__((__noreturn__))
+# define PRINTF_LIKE(fix, aix) __attribute__((__format__(printf, fix, aix)))
+#endif
+
+#if GCC_VERSION_P(4, 0) || CLANG_VERSION_P(3, 3)
+# define EXECL_LIKE(ntrail) __attribute__((__sentinel__(ntrail)))
+#endif
+
+#define CTYPE_HACK(func, ch) (func((unsigned char)(ch)))
+#define ISSPACE(ch) CTYPE_HACK(isspace, ch)
+#define ISALNUM(ch) CTYPE_HACK(isalnum, ch)
+
+#define MEMCMP(x, op, y, n) (memcmp((x), (y), (n)) op 0)
+#define STRCMP(x, op, y) (strcmp((x), (y)) op 0)
+#define STRNCMP(x, op, y, n) (strncmp((x), (y), (n)) op 0)
+
+#define DISCARD(x) do if (x); while (0)
+
+#define END ((const char *)0)
+
+#ifndef SIZE_MAX
+# define SIZE_MAX (-(size_t)1)
+#endif
+
+/*----- Miscellany --------------------------------------------------------*/
+
+extern int str_lt(const char */*a*/, size_t /*an*/,
+ const char */*b*/, size_t /*bn*/);
+
+/*----- Diagnostic utilities ----------------------------------------------*/
+
+extern const char *progname;
+
+extern void set_progname(const char */*prog*/);
+extern void vmoan(const char */*msg*/, va_list /*ap*/);
+extern PRINTF_LIKE(1, 2) void moan(const char */*msg*/, ...);
+extern NORETURN PRINTF_LIKE(1, 2) void lose(const char */*msg*/, ...);
+
+/*----- Memory allocation -------------------------------------------------*/
+
+extern void *xmalloc(size_t /*n*/);
+extern void *xrealloc(void */*p*/, size_t /*n*/);
+extern char *xstrndup(const char */*p*/, size_t /*n*/);
+extern char *xstrdup(const char */*p*/);
+
+/*----- Dynamic strings ---------------------------------------------------*/
+
+struct dstr {
+ char *p;
+ size_t len, sz;
+};
+#define DSTR_INIT { 0, 0, 0 }
+
+extern void dstr_init(struct dstr */*d*/);
+extern void dstr_reset(struct dstr */*d*/);
+extern void dstr_ensure(struct dstr */*d*/, size_t /*n*/);
+extern void dstr_release(struct dstr */*d*/);
+extern void dstr_putm(struct dstr */*d*/, const void */*p*/, size_t /*n*/);
+extern void dstr_puts(struct dstr */*d*/, const char */*p*/);
+extern void dstr_putc(struct dstr */*d*/, int /*ch*/);
+extern void dstr_putz(struct dstr */*d*/);
+extern void dstr_vputf(struct dstr */*d*/,
+ const char */*p*/, va_list /*ap*/);
+extern PRINTF_LIKE(2, 3)
+ void dstr_putf(struct dstr */*d*/, const char */*p*/, ...);
+extern int dstr_readline(struct dstr */*d*/, FILE */*fp*/);
+
+/*----- Dynamic vectors of strings ----------------------------------------*/
+
+struct argv {
+ const char **v;
+ size_t o, n, sz;
+};
+#define ARGV_INIT { 0, 0, 0, 0 }
+
+extern void argv_init(struct argv */*a*/v);
+extern void argv_reset(struct argv */*av*/);
+extern void argv_ensure(struct argv */*av*/, size_t /*n*/);
+extern void argv_ensure_offset(struct argv */*av*/, size_t /*n*/);
+extern void argv_release(struct argv */*av*/);
+extern void argv_append(struct argv */*av*/, const char */*p*/);
+extern void argv_appendz(struct argv */*av*/);
+extern void argv_appendn(struct argv */*av*/,
+ const char *const */*v*/, size_t /*n*/);
+extern void argv_appendav(struct argv */*av*/, const struct argv */*bv*/);
+extern void argv_appendv(struct argv */*av*/, va_list /*ap*/);
+extern EXECL_LIKE(0) void argv_appendl(struct argv */*av*/, ...);
+extern void argv_prepend(struct argv */*av*/, const char */*p*/);
+extern void argv_prependn(struct argv */*av*/,
+ const char *const */*v*/, size_t /*n*/);
+extern void argv_prependav(struct argv */*av*/, const struct argv */*bv*/);
+extern void argv_prependv(struct argv */*av*/, va_list /*ap*/);
+extern EXECL_LIKE(0) void argv_prependl(struct argv */*av*/, ...);
+
+/*----- Treaps ------------------------------------------------------------*/
+
+struct treap {
+ struct treap_node *root;
+};
+#define TREAP_INIT { 0 }
+
+struct treap_node {
+ unsigned wt;
+ struct treap_node *left, *right;
+ char *k; size_t kn;
+};
+#define TREAP_NODE_KEY(n) (((const struct treap_node *)(n))->k + 0)
+#define TREAP_NODE_KEYLEN(n) (((const struct treap_node *)(n))->kn + 0)
+
+#define TREAP_PATHMAX 64
+struct treap_path {
+ struct treap_node **path[TREAP_PATHMAX];
+ unsigned nsteps;
+};
+
+struct treap_iter {
+ struct treap_node *stack[TREAP_PATHMAX];
+ unsigned sp;
+};
+
+extern void treap_init(struct treap */*t*/);
+extern void *treap_lookup(const struct treap */*t*/,
+ const char */*k*/, size_t /*kn*/);
+extern void *treap_probe(struct treap */*t*/,
+ const char */*k*/, size_t /*kn*/,
+ struct treap_path */*p*/);
+extern void treap_insert(struct treap */*t*/, const struct treap_path */*p*/,
+ struct treap_node */*n*/,
+ const char */*k*/, size_t /*kn*/);
+extern void *treap_remove(struct treap */*t*/,
+ const char */*k*/, size_t /*kn*/);
+extern void treap_start_iter(struct treap */*t*/, struct treap_iter */*i*/);
+extern void *treap_next(struct treap_iter */*i*/);
+extern void treap_check(struct treap */*t*/);
+extern void treap_dump(struct treap */*t*/);
+
+/*----- Configuration file parsing ----------------------------------------*/
+
+struct config {
+ struct treap sections;
+ struct config_section *head, **tail;
+ struct config_section *fallback;
+};
+#define CONFIG_INIT { TREAP_INIT, 0, 0 }
+
+struct config_section {
+ struct treap_node _node;
+ struct config_section *next;
+ struct config_section **parents; size_t nparents;
+ struct treap vars;
+ struct treap cache;
+};
+#define CONFIG_SECTION_NAME(sect) TREAP_NODE_KEY(sect)
+#define CONFIG_SECTION_NAMELEN(sect) TREAP_NODE_KEYLEN(sect)
+
+struct config_cache_entry {
+ struct treap_node _node;
+ unsigned f;
+#define CF_OPEN 1u
+ struct config_var *var;
+};
+
+struct config_var {
+ struct treap_node _node;
+ char *file; unsigned line;
+ char *val; size_t n;
+ unsigned f;
+};
+#define CONFIG_VAR_NAME(var) TREAP_NODE_KEY(var)
+#define CONFIG_VAR_NAMELEN(var) TREAP_NODE_KEYLEN(var)
+#define CF_LITERAL 1u
+#define CF_EXPAND 2u
+#define CF_OVERRIDE 4u
+
+struct config_section_iter {
+ struct config_section *sect;
+};
+
+struct config_var_iter {
+ struct treap_iter i;
+};
+
+extern void config_init(struct config */*conf*/);
+
+extern struct config_section *config_find_section(struct config */*conf*/,
+ unsigned /*f*/,
+ const char */*name*/);
+extern struct config_section *config_find_section_n(struct config */*conf*/,
+ unsigned /*f*/,
+ const char */*name*/,
+ size_t /*sz*/);
+#define CF_CREAT 1u
+
+extern void config_set_fallback(struct config */*conf*/,
+ struct config_section */*sect*/);
+extern void config_set_parent(struct config_section */*sect*/,
+ struct config_section */*parent*/);
+
+extern void config_start_section_iter(struct config */*conf*/,
+ struct config_section_iter */*i*/);
+extern struct config_section *config_next_section
+ (struct config_section_iter */*i*/);
+
+extern struct config_var *config_find_var(struct config */*conf*/,
+ struct config_section */*sect*/,
+ unsigned /*f*/,
+ const char */*name*/);
+extern struct config_var *config_find_var_n(struct config */*conf*/,
+ struct config_section */*sect*/,
+ unsigned /*f*/,
+ const char */*name*/,
+ size_t /*sz*/);
+#define CF_INHERIT 2u
+
+extern void config_set_var(struct config */*conf*/,
+ struct config_section */*sect*/, unsigned /*f*/,
+ const char */*name*/, const char */*value*/);
+extern void config_set_var_n(struct config */*conf*/,
+ struct config_section */*sect*/, unsigned /*f*/,
+ const char */*name*/, size_t /*namelen*/,
+ const char */*value*/, size_t /*valuelen*/);
+extern void config_start_var_iter(struct config_section */*sect*/,
+ struct config_var_iter */*i*/);
+extern struct config_var *config_next_var(struct config_var_iter */*i*/);
+
+extern int config_read_file(struct config */*conf*/, const char */*file*/,
+ unsigned /*f*/);
+extern int config_read_dir(struct config */*conf*/,
+ const char */*dir*/, unsigned /*f*/);
+extern void config_read_env(struct config */*conf*/,
+ struct config_section */*sect*/);
+#define CF_NOENTOK 1u
+
+extern void config_subst_string(struct config */*config*/,
+ struct config_section */*home*/,
+ const char */*what*/,
+ const char */*p*/, struct dstr */*d*/);
+extern char *config_subst_string_alloc(struct config */*config*/,
+ struct config_section */*home*/,
+ const char */*what*/,
+ const char */*p*/);
+extern void config_subst_var(struct config */*config*/,
+ struct config_section */*home*/,
+ struct config_var */*var*/,
+ struct dstr */*d*/);
+extern char *config_subst_var_alloc(struct config */*config*/,
+ struct config_section */*home*/,
+ struct config_var */*var*/);
+extern void config_subst_split_var(struct config */*config*/,
+ struct config_section */*home*/,
+ struct config_var */*var*/,
+ struct argv */*av*/);
+
+/*----- That's all, folks -------------------------------------------------*/
+
+#ifdef __cplusplus
+ }
+#endif
+
+#endif
+++ /dev/null
-../.ext/cfd/m4/mdw-dir-texmf.m4
\ No newline at end of file
+++ /dev/null
-../.ext/cfd/m4/mdw-libtool-version-info.m4
\ No newline at end of file
+++ /dev/null
-../.ext/cfd/m4/mdw-manext.m4
\ No newline at end of file
--- /dev/null
+.ext/cfd/src/mdwopt.c
\ No newline at end of file
--- /dev/null
+.ext/cfd/src/mdwopt.h
\ No newline at end of file
--- /dev/null
+/* -*-c-*-
+ *
+ * Invoke a Lisp script
+ *
+ * (c) 2020 Mark Wooding
+ */
+
+/*----- Licensing notice --------------------------------------------------*
+ *
+ * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
+ *
+ * Runlisp is free software: you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License as published by the
+ * Free Software Foundation; either version 3 of the License, or (at your
+ * option) any later version.
+ *
+ * Runlisp is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ * for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with Runlisp. If not, see <https://www.gnu.org/licenses/>.
+ */
+
+/*----- Header files ------------------------------------------------------*/
+
+#include "config.h"
+
+#include <assert.h>
+#include <ctype.h>
+#include <errno.h>
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <unistd.h>
+#include <sys/stat.h>
+
+#include <pwd.h>
+
+#include "lib.h"
+
+/*----- Common Lisp runes -------------------------------------------------*/
+
+/* A common preamble rune to do the necessary things.
+ *
+ * We need to ensure that `asdf' (and therefore `uiop') is loaded. And we
+ * should arrange for `:runlisp-script' to find its way into the `*features*'
+ * list so that scripts can notice that they're being invoked from the
+ * command line rather than loaded into a resident session, and actually do
+ * something useful.
+ */
+#define COMMON_PRELUDE_RUNE \
+ "(progn " \
+ "(setf *load-verbose* nil *compile-verbose* nil) " \
+ "(require \"asdf\") " \
+ "(funcall (intern \"REGISTER-IMMUTABLE-SYSTEM\" " \
+ "(find-package \"ASDF\")) " \
+ "\"asdf\") " \
+ "(set-dispatch-macro-character " \
+ "#\\# #\\! " \
+ "(lambda (#1=#:stream #2=#:char #3=#:arg) " \
+ "(declare (ignore #2# #3#)) " \
+ "(values (read-line #1#)))) " \
+ "(pushnew :runlisp-script *features*))"
+
+/* Get `uiop' to re-check the command-line arguments following an image
+ * restore.
+ */
+#define IMAGE_RESTORE_RUNE \
+ "(uiop:call-image-restore-hook)"
+
+/* Some Lisps leave crud in the `COMMON-LISP-USER' package. Clear it out. */
+#define CLEAR_CL_USER_RUNE \
+ "(let ((#4=#:pkg (find-package \"COMMON-LISP-USER\"))) " \
+ "(with-package-iterator (#5=#:next #4# :internal) " \
+ "(loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how) " \
+ "(#5#) " \
+ "(declare (ignore #8#)) " \
+ "(unless #6# (return)) " \
+ "(unintern #7# #4#)))))"
+
+/*----- The Lisp implementation table -------------------------------------*/
+
+/* The systems, in decreasing order of (not quite my personal) preference.
+ * This list is used to initialize various tables and constants.
+ */
+#define LISP_SYSTEMS(_) \
+ _(sbcl) \
+ _(ccl) \
+ _(clisp) \
+ _(ecl) \
+ _(cmucl) \
+ _(abcl)
+
+enum {
+#define DEFSYS(sys) sys##_INDEX,
+ LISP_SYSTEMS(DEFSYS)
+#undef DEFSYS
+ NSYS
+};
+
+enum {
+#define DEFFLAG(sys) sys##_FLAG = 1 << sys##_INDEX,
+ LISP_SYSTEMS(DEFFLAG)
+#undef DEFFLAG
+ ALL_SYSTEMS = 0
+#define SETFLAG(sys) | sys##_FLAG
+ LISP_SYSTEMS(SETFLAG)
+#undef SETFLAG
+};
+
+struct argstate;
+struct argv;
+
+#define DECLENTRY(sys) \
+static void run_##sys(struct argstate *, const char *);
+ LISP_SYSTEMS(DECLENTRY)
+#undef DECLENTRY
+
+static const struct systab {
+ const char *name;
+ unsigned f;
+ void (*run)(struct argstate *, const char *);
+} systab[] = {
+#define SYSENTRY(sys) { #sys, sys##_FLAG, run_##sys },
+ LISP_SYSTEMS(SYSENTRY)
+#undef SYSENTRY
+};
+
+static const struct systab *find_system(const char *name)
+{
+ const struct systab *sys;
+ size_t i;
+
+ for (i = 0; i < NSYS; i++) {
+ sys = &systab[i];
+ if (STRCMP(name, ==, sys->name)) return (sys);
+ }
+ lose("unknown Lisp system `%s'", name);
+}
+
+static void lisp_quote_string(struct dstr *d, const char *p)
+{
+ size_t n;
+
+ for (;;) {
+ n = strcspn(p, "\"\\");
+ if (n) { dstr_putm(d, p, n); p += n; }
+ if (!*p) break;
+ dstr_putc(d, '\\'); dstr_putc(d, *p++);
+ }
+ dstr_putz(d);
+}
+
+static const char *expand_rune(struct dstr *d, const char *rune, ...)
+{
+ const struct argv *av;
+ va_list ap;
+ size_t i, n;
+
+ va_start(ap, rune);
+ for (;;) {
+ n = strcspn(rune, "%");
+ if (n) { dstr_putm(d, rune, n); rune += n; }
+ if (!*rune) break;
+ switch (*++rune) {
+ case '%': dstr_putc(d, '%'); break;
+ case 'e': lisp_quote_string(d, va_arg(ap, const char *)); break;
+ case 'E':
+ av = va_arg(ap, const struct argv *);
+ for (i = 0; i < av->n; i++) {
+ if (i) dstr_putc(d, ' ');
+ dstr_putc(d, '"');
+ lisp_quote_string(d, av->v[i]);
+ dstr_putc(d, '"');
+ }
+ break;
+ default: lose("*** BUG unknown expansion `%%%c'", *rune);
+ }
+ rune++;
+ }
+ dstr_putz(d);
+ return (d->p);
+}
+
+/*----- Argument processing -----------------------------------------------*/
+
+struct syslist {
+ const struct systab *sys[NSYS];
+ size_t n;
+ unsigned f;
+};
+#define SYSLIST_INIT { { 0 }, 0, 0 }
+
+struct argstate {
+ unsigned f;
+#define F_BOGUS 1u
+#define F_NOEMBED 2u
+#define F_NOACT 4u
+#define F_NODUMP 8u
+#define F_AUX 16u
+ int verbose;
+ char *imagedir;
+ struct syslist allow, pref;
+ struct argv av;
+};
+#define ARGSTATE_INIT { 0, 1, 0, SYSLIST_INIT, SYSLIST_INIT, ARGV_INIT }
+
+/*----- Running programs --------------------------------------------------*/
+
+#define FEF_EXEC 1u
+static int file_exists_p(const struct argstate *arg, const char *path,
+ unsigned f)
+{
+ struct stat st;
+
+ if (stat(path, &st)) {
+ if (arg && arg->verbose > 2) moan("file `%s' not found", path);
+ return (0);
+ } else if (!(S_ISREG(st.st_mode))) {
+ if (arg && arg->verbose > 2) moan("`%s' is not a regular file", path);
+ return (0);
+ } else if ((f&FEF_EXEC) && access(path, X_OK)) {
+ if (arg && arg->verbose > 2) moan("file `%s' is not executable", path);
+ return (0);
+ } else {
+ if (arg && arg->verbose > 2) moan("found file `%s'", path);
+ return (1);
+ }
+}
+
+static int found_in_path_p(const struct argstate *arg, const char *prog)
+{
+ struct dstr p = DSTR_INIT, d = DSTR_INIT;
+ const char *path;
+ char *q;
+ size_t n, avail, proglen;
+ int i;
+
+ if (strchr(prog, '/')) return (file_exists_p(arg, prog, 0));
+ path = getenv("PATH");
+ if (path)
+ dstr_puts(&p, path);
+ else {
+ dstr_puts(&p, ".:");
+ i = 0;
+ again:
+ avail = p.sz - p.len;
+ n = confstr(_CS_PATH, p.p + p.len, avail);
+ if (avail > n) { i++; assert(i < 2); dstr_ensure(&p, n); goto again; }
+ }
+
+ q = p.p; proglen = strlen(prog);
+ for (;;) {
+ n = strcspn(q, ":");
+ dstr_reset(&d);
+ if (q[n]) dstr_putm(&d, q, n);
+ else dstr_putc(&d, '.');
+ dstr_putc(&d, '/');
+ dstr_putm(&d, prog, proglen);
+ dstr_putz(&d);
+ if (file_exists_p(arg, d.p, FEF_EXEC)) {
+ if (arg->verbose == 2) moan("found program `%s'", d.p);
+ return (1);
+ }
+ q += n; if (!*q) break; else q++;
+ }
+ return (0);
+}
+
+static void try_exec(const struct argstate *arg, struct argv *av)
+{
+ struct dstr d = DSTR_INIT;
+ size_t i;
+
+ assert(av->n); argv_appendz(av);
+ if (arg->verbose > 1) {
+ for (i = 0; i < av->n; i++) {
+ if (i) { dstr_putc(&d, ','); dstr_putc(&d, ' '); }
+ dstr_putc(&d, '"');
+ lisp_quote_string(&d, av->v[i]);
+ dstr_putc(&d, '"');
+ }
+ dstr_putz(&d);
+ moan("trying %s...", d.p);
+ }
+ if (arg->f&F_NOACT)
+ { if (found_in_path_p(arg, av->v[0])) exit(0); }
+ else {
+ execvp(av->v[0], (/*unconst*/ char **)av->v);
+ if (errno != ENOENT)
+ lose("failed to exec `%s': %s", av->v[0], strerror(errno));
+ }
+ if (arg->verbose > 1) moan("`%s' not found", av->v[0]);
+ dstr_release(&d);
+}
+
+static const char *getenv_or_default(const char *var, const char *dflt)
+ { const char *p = getenv(var); return (p ? p : dflt); }
+
+/*----- Invoking Lisp systems ---------------------------------------------*/
+
+/* Steel Bank Common Lisp. */
+
+static void run_sbcl(struct argstate *arg, const char *script)
+{
+ struct dstr d = DSTR_INIT;
+
+ argv_prependl(&arg->av, "--script", script, END);
+
+ dstr_puts(&d, arg->imagedir);
+ dstr_putc(&d, '/');
+ dstr_puts(&d, "sbcl+asdf.core");
+ if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
+ argv_prependl(&arg->av,
+ "--core", d.p,
+ "--eval", IMAGE_RESTORE_RUNE,
+ END);
+ else
+ argv_prependl(&arg->av, "--eval", COMMON_PRELUDE_RUNE, END);
+
+ argv_prependl(&arg->av, getenv_or_default("SBCL", "sbcl"),
+ "--noinform",
+ END);
+ try_exec(arg, &arg->av);
+ dstr_release(&d);
+}
+
+/* Clozure Common Lisp. */
+
+#define CCL_QUIT_RUNE \
+ "(ccl:quit)"
+
+static void run_ccl(struct argstate *arg, const char *script)
+{
+ struct dstr d = DSTR_INIT;
+
+ argv_prependl(&arg->av, "-b", "-n", "-Q",
+ "-l", script,
+ "-e", CCL_QUIT_RUNE,
+ "--",
+ END);
+
+ dstr_puts(&d, arg->imagedir);
+ dstr_putc(&d, '/');
+ dstr_puts(&d, "ccl+asdf.image");
+ if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
+ argv_prependl(&arg->av, "-I", d.p, "-e", IMAGE_RESTORE_RUNE, END);
+ else
+ argv_prependl(&arg->av, "-e", COMMON_PRELUDE_RUNE, END);
+
+ argv_prepend(&arg->av, getenv_or_default("CCL", "ccl"));
+ try_exec(arg, &arg->av);
+ dstr_release(&d);
+}
+
+/* GNU CLisp.
+ *
+ * CLisp causes much sadness. Superficially, it's the most sensible of all
+ * of the systems supported here: you just run `clisp SCRIPT -- ARGS ...' and
+ * it works.
+ *
+ * The problems come when you want to do some preparatory work (e.g., load
+ * `asdf') and then run the script. There's a `-x' option to evaluate some
+ * Lisp code, but it has three major deficiencies.
+ *
+ * * It insists on printing the values of the forms it evaluates. It
+ * prints a blank line even if the form goes out of its way to produce no
+ * values at all. So the whole thing has to be a single top-level form
+ * which quits the Lisp rather than returning.
+ *
+ * * For some idiotic reason, you can have /either/ `-x' forms /or/ a
+ * script, but not both. So we have to include the `load' here
+ * explicitly. I suppose that was inevitable because we have to inhibit
+ * printing of the result forms, but it's still a separate source of
+ * annoyance.
+ *
+ * * The icing on the cake: the `-x' forms are collectively concatenated --
+ * without spaces! -- and used to build a string stream, which is then
+ * assigned over the top of `*standard-input*', making the original stdin
+ * somewhat fiddly to track down.
+ *
+ * There's an `-i' option which will load a file without any of this
+ * stupidity, but nothing analogous for immediate expressions.
+ */
+
+#define CLISP_COMMON_STARTUP_RUNES \
+ "(setf *standard-input* (ext:make-stream :input)) " \
+ "(load \"%e\" :verbose nil :print nil) " \
+ "(ext:quit)"
+
+#define CLISP_STARTUP_RUNE \
+ "(progn " \
+ COMMON_PRELUDE_RUNE " " \
+ CLISP_COMMON_STARTUP_RUNES ")"
+
+#define CLISP_STARTUP_IMAGE_RUNE \
+ "(progn " \
+ IMAGE_RESTORE_RUNE " " \
+ CLISP_COMMON_STARTUP_RUNES ")"
+
+static void run_clisp(struct argstate *arg, const char *script)
+{
+ struct dstr d = DSTR_INIT, dd = DSTR_INIT;
+
+ dstr_puts(&d, arg->imagedir);
+ dstr_putc(&d, '/');
+ dstr_puts(&d, "clisp+asdf.mem");
+ if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
+ argv_prependl(&arg->av, "-M", d.p, "-q",
+ "-x", expand_rune(&dd, CLISP_STARTUP_IMAGE_RUNE, script),
+ "--",
+ END);
+ else
+ argv_prependl(&arg->av, "-norc", "-q",
+ "-x", expand_rune(&dd, CLISP_STARTUP_RUNE, script),
+ "--",
+ END);
+
+ argv_prepend(&arg->av, getenv_or_default("CLISP", "clisp"));
+ try_exec(arg, &arg->av);
+ dstr_release(&d);
+ dstr_release(&dd);
+
+#undef f
+}
+
+/* Embeddable Common Lisp. *
+ *
+ * ECL is changing its command-line option syntax in version 16. I have no
+ * idea why they think the result can ever be worth the pain of a transition.
+ */
+
+#if ECL_OPTIONS_GNU
+# define ECLOPT "--"
+#else
+# define ECLOPT "-"
+#endif
+
+#define ECL_STARTUP_RUNE \
+ "(progn " \
+ COMMON_PRELUDE_RUNE " " \
+ CLEAR_CL_USER_RUNE ")"
+
+static void run_ecl(struct argstate *arg, const char *script)
+{
+ struct dstr d = DSTR_INIT;
+
+ dstr_puts(&d, arg->imagedir);
+ dstr_putc(&d, '/');
+ dstr_puts(&d, "ecl+asdf");
+ if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, FEF_EXEC)) {
+ argv_prependl(&arg->av, "-s", script, "--", END);
+ argv_prependl(&arg->av, d.p, END);
+ } else {
+ argv_prependl(&arg->av, ECLOPT "shell", script, "--", END);
+ argv_prependl(&arg->av, getenv_or_default("ECL", "ecl"), ECLOPT "norc",
+ ECLOPT "eval", ECL_STARTUP_RUNE,
+ END);
+ }
+ try_exec(arg, &arg->av);
+}
+
+/* Carnegie--Mellon University Common Lisp. */
+
+#define CMUCL_STARTUP_RUNE \
+ "(progn " \
+ "(setf ext:*require-verbose* nil) " \
+ COMMON_PRELUDE_RUNE ")"
+#define CMUCL_QUIT_RUNE \
+ "(ext:quit)"
+
+static void run_cmucl(struct argstate *arg, const char *script)
+{
+ struct dstr d = DSTR_INIT;
+
+ argv_prependl(&arg->av,
+ "-load", script,
+ "-eval", CMUCL_QUIT_RUNE,
+ "--",
+ END);
+
+ dstr_puts(&d, arg->imagedir);
+ dstr_putc(&d, '/');
+ dstr_puts(&d, "cmucl+asdf.core");
+ if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
+ argv_prependl(&arg->av, "-core", d.p, "-eval", IMAGE_RESTORE_RUNE, END);
+ else
+ argv_prependl(&arg->av, "-batch", "-noinit", "-nositeinit", "-quiet",
+ "-eval", CMUCL_STARTUP_RUNE,
+ END);
+
+ argv_prepend(&arg->av, getenv_or_default("CMUCL", "cmucl"));
+ try_exec(arg, &arg->av);
+ dstr_release(&d);
+}
+
+/* Armed Bear Common Lisp. *
+ *
+ * CLisp made a worthy effort, but ABCL still manages to take the price.
+ *
+ * * ABCL manages to avoid touching the `stderr' stream at all, ever. Its
+ * startup machinery finds `stdout' (as `java.lang.System.out'), wraps it
+ * up in a Lisp stream, and uses the result as `*standard-output*' and
+ * `*error-output*' (and a goodly number of other things too). So we
+ * must manufacture a working `stderr' the hard way.
+ *
+ * * There doesn't appear to be any easy way to prevent toplevel errors
+ * from invoking the interactive debugger. For extra fun, the debugger
+ * reads from `stdin' by default, so an input file which somehow manages
+ * to break the script can then take over its brain by providing Lisp
+ * forms for the debugger to evaluate.
+ */
+
+#define ABCL_STARTUP_RUNE \
+ "(let ((#9=#:script \"%e\")) " \
+ COMMON_PRELUDE_RUNE " " \
+ CLEAR_CL_USER_RUNE " " \
+ \
+ /* Replace the broken `*error-output*' stream with a working \
+ * copy of `stderr'. \
+ */ \
+ "(setf *error-output* " \
+ "(java:jnew \"org.armedbear.lisp.Stream\" " \
+ "'sys::system-stream " \
+ "(java:jfield \"java.lang.System\" \"err\") " \
+ "'character " \
+ "java:+true+)) " \
+ \
+ /* Trap errors signalled by the script and arrange for them \
+ * to actually kill the process rather than ending up in the \
+ * interactive debugger. \
+ */ \
+ "(handler-case (load #9# :verbose nil :print nil) " \
+ "(error (error) " \
+ "(format *error-output* \"~A (unhandled error): ~A~%%\" " \
+ "#9# error) " \
+ "(ext:quit :status 255))))"
+
+static void run_abcl(struct argstate *arg, const char *script)
+{
+ struct dstr d = DSTR_INIT;
+
+ argv_prependl(&arg->av, getenv_or_default("ABCL", "abcl"),
+ "--batch", "--noinform", "--noinit", "--nosystem",
+ "--eval", expand_rune(&d, ABCL_STARTUP_RUNE, script),
+ "--",
+ END);
+ try_exec(arg, &arg->av);
+ dstr_release(&d);
+}
+
+/*----- Main code ---------------------------------------------------------*/
+
+static void version(FILE *fp)
+ { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); }
+
+static void usage(FILE *fp)
+{
+ fprintf(fp, "usage: %s [-CDEnqv] [-I IMAGEDIR] "
+ "[-L SYS,SYS,...] [-P SYS,SYS,...]\n"
+ "\t[--] SCRIPT [ARGUMENTS ...] |\n"
+ "\t[-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n",
+ progname);
+}
+
+static void help(FILE *fp)
+{
+ version(fp); fputc('\n', fp); usage(fp);
+ fputs("\n\
+Options:\n\
+ --help Show this help text and exit successfully.\n\
+ --version Show the version number and exit successfully.\n\
+ -C Clear the list of preferred Lisp systems.\n\
+ -D Run system Lisp images, rather than custom images.\n\
+ -E Don't read embedded options from the script.\n\
+ -I IMAGEDIR Look for custom images in IMAGEDIR rather than\n\
+ `" IMAGEDIR "'.\n\
+ -L SYS,SYS,... Only use the listed Lisp systems.the script.\n\
+ -P SYS,SYS,... Prefer the listed Lisp systems.\n\
+ -e EXPR Evaluate EXPR (can be repeated).\n\
+ -l FILE Load FILE (can be repeated).\n\
+ -n Don't actually run the script (useful with `-v')\n\
+ -p EXPR Print (`prin1') EXPR (can be repeated).\n\
+ -q Don't print warning messages.\n\
+ -v Print informational messages (repeat for even more).\n",
+ fp);
+}
+
+static void push_eval_op(struct argstate *arg, char op, const char *val)
+{
+ char *p;
+ size_t n;
+
+ if (arg->f&F_AUX) {
+ moan("must use `-e', `-p', or `-l' on command line");
+ arg->f |= F_BOGUS;
+ return;
+ }
+
+ n = strlen(val) + 1;
+ p = xmalloc(n + 1);
+ p[0] = op; memcpy(p + 1, val, n);
+ argv_append(&arg->av, p);
+}
+
+/* Parse a comma-separated list of system names SPEC, and add the named
+ * systems to LIST.
+ */
+static void parse_syslist(const char *spec, const struct argstate *arg,
+ struct syslist *list, const char *what)
+{
+ char *copy = xstrdup(spec), *p = copy, *q;
+ const struct systab *sys;
+ size_t n;
+
+ for (;;) {
+ n = strcspn(p, ",");
+ if (p[n]) q = p + n + 1;
+ else q = 0;
+ p[n] = 0; sys = find_system(p);
+ if (list->f&sys->f) {
+ if (arg->verbose > 0)
+ moan("ignoring duplicate system `%s' in %s list", p, what);
+ } else {
+ list->sys[list->n++] = sys;
+ list->f |= sys->f;
+ }
+ if (!q) break;
+ p = q;
+ }
+ free(copy);
+}
+
+/* Parse a vector ARGS of command-line arguments. Update ARG with the
+ * results. NARG is the number of arguments, and *I_INOUT is the current
+ * index into the vector, to be updated on exit to identify the first
+ * non-option argument (or the end of the vector).
+ */
+static void parse_arguments(struct argstate *arg, const char *const *args,
+ size_t nargs, size_t *i_inout)
+{
+ const char *o, *a;
+ char opt;
+
+ for (;;) {
+ if (*i_inout >= nargs) break;
+ o = args[*i_inout];
+ if (STRCMP(o, ==, "--help")) { help(stdout); exit(0); }
+ else if (STRCMP(o, ==, "--version")) { version(stdout); exit(0); }
+ if (!*o || *o != '-' || !o[1]) break;
+ (*i_inout)++;
+ if (STRCMP(o, ==, "--")) break;
+ o++;
+ while (o && *o) {
+ opt = *o++;
+ switch (opt) {
+
+#define GETARG do { \
+ if (*o) \
+ { a = o; o = 0; } \
+ else { \
+ if (*i_inout >= nargs) goto noarg; \
+ a = args[(*i_inout)++]; \
+ } \
+} while (0)
+
+ case 'C': arg->pref.n = 0; arg->pref.f = 0; break;
+ case 'D': arg->f |= F_NODUMP; break;
+ case 'E': arg->f |= F_NOEMBED; break;
+ case 'e': GETARG; push_eval_op(arg, '!', a); break;
+ case 'p': GETARG; push_eval_op(arg, '?', a); break;
+ case 'l': GETARG; push_eval_op(arg, '<', a); break;
+ case 'n': arg->f |= F_NOACT; break;
+ case 'q': if (arg->verbose) arg->verbose--; break;
+ case 'v': arg->verbose++; break;
+
+ case 'I':
+ free(arg->imagedir);
+ GETARG; arg->imagedir = xstrdup(a);
+ break;
+
+ case 'L':
+ GETARG;
+ parse_syslist(a, arg, &arg->allow, "allowed");
+ break;
+
+ case 'P':
+ GETARG;
+ parse_syslist(a, arg, &arg->pref, "preferred");
+ break;
+
+ default:
+ moan("unknown option `%c'", opt);
+ arg->f |= F_BOGUS;
+ break;
+
+#undef GETARG
+
+ }
+ }
+ }
+ goto end;
+
+noarg:
+ moan("missing argument for `-%c'", opt);
+ arg->f |= F_BOGUS;
+end:
+ return;
+}
+
+/* Parse a string P into words (destructively), and process them as
+ * command-line options, updating ARG. Non-option arguments are not
+ * permitted. If `SOSF_EMACS' is set in FLAGS, then ignore `-*- ... -*-'
+ * editor turds. If `SOSF_ENDOK' is set, then accept `--' and ignore
+ * whatever comes after; otherwise, reject all positional arguments.
+ */
+#define SOSF_EMACS 1u
+#define SOSF_ENDOK 2u
+static void scan_options_from_string(char *p, struct argstate *arg,
+ unsigned flags,
+ const char *what, const char *file)
+{
+ struct argv av = ARGV_INIT;
+ char *q;
+ size_t i;
+ int st = 0;
+ unsigned f = 0;
+#define f_escape 1u
+
+ for (;;) {
+ while (ISSPACE(*p)) p++;
+ if (!*p) break;
+ if ((flags&SOSF_EMACS) && p[0] == '-' && p[1] == '*' && p[2] == '-') {
+ p = strstr(p + 3, "-*-");
+ if (!p) lose("unfinished local-variables list in %s `%s'", what, file);
+ p += 3; continue;
+ }
+ if ((flags&SOSF_ENDOK) &&
+ p[0] == '-' && p[1] == '-' && (!p[2] || ISSPACE(p[2])))
+ break;
+ argv_append(&av, p); q = p;
+ for (;;) {
+ if (!*p) break;
+ else if (f&f_escape) { *q++ = *p; f &= ~f_escape; }
+ else if (st && *p == st) st = 0;
+ else if (st != '\'' && *p == '\\') f |= f_escape;
+ else if (!st && (*p == '"' || *p == '\'')) st = *p;
+ else if (!st && ISSPACE(*p)) break;
+ else *q++ = *p;
+ p++;
+ }
+
+ if (*p) p++;
+ *q = 0;
+ if (f&f_escape) lose("unfinished escape in %s `%s'", what, file);
+ if (st) lose("unfinished `%c' string in %s `%s'", st, what, file);
+ }
+
+ i = 0; parse_arguments(arg, av.v, av.n, &i);
+ if (i < av.n)
+ lose("positional argument `%s' in %s `%s'", av.v[i], what, file);
+ argv_release(&av);
+
+#undef f_escape
+}
+
+/* Read SCRIPT, and check for a `@RUNLISP:' marker in the second line. If
+ * there is one, parse options from it, and update ARG.
+ */
+static void check_for_embedded_args(const char *script, struct argstate *arg)
+{
+ struct dstr d = DSTR_INIT;
+ char *p;
+ FILE *fp = 0;
+
+ fp = fopen(script, "r");
+ if (!fp) lose("can't read script `%s': %s", script, strerror(errno));
+
+ if (dstr_readline(&d, fp)) goto end;
+ dstr_reset(&d); if (dstr_readline(&d, fp)) goto end;
+
+ p = strstr(d.p, "@RUNLISP:");
+ if (p)
+ scan_options_from_string(p + 9, arg, SOSF_EMACS | SOSF_ENDOK,
+ "embedded options in script", script);
+
+end:
+ if (fp) {
+ if (ferror(fp))
+ lose("error reading script `%s': %s", script, strerror(errno));
+ fclose(fp);
+ }
+ dstr_release(&d);
+}
+
+/* Read the file PATH (if it exists) and update ARG with the arguments parsed
+ * from it. Ignore blank lines and (Unix- or Lisp-style) comments.
+ */
+static void read_config_file(const char *path, struct argstate *arg)
+{
+ FILE *fp = 0;
+ struct dstr d = DSTR_INIT;
+ char *p;
+
+ fp = fopen(path, "r");
+ if (!fp) {
+ if (errno == ENOENT) {
+ if (arg->verbose > 2)
+ moan("ignoring nonexistent configuration file `%s'", path);
+ goto end;
+ }
+ lose("failed to open configuration file `%s': %s",
+ path, strerror(errno));
+ }
+ if (arg->verbose > 1)
+ moan("reading configuration file `%s'", path);
+ for (;;) {
+ dstr_reset(&d);
+ if (dstr_readline(&d, fp)) break;
+ p = d.p;
+ while (ISSPACE(*p)) p++;
+ if (!*p || *p == ';' || *p == '#') continue;
+ scan_options_from_string(p, arg, 0, "configuration file `%s'", path);
+ }
+ if (arg->f&F_BOGUS)
+ lose("invalid options in configuration file `%s'", path);
+
+end:
+ if (fp) {
+ if (ferror(fp))
+ lose("error reading configuration file `%s': %s",
+ path, strerror(errno));
+ fclose(fp);
+ }
+ dstr_release(&d);
+}
+
+int main(int argc, char *argv[])
+{
+ struct dstr d = DSTR_INIT;
+ const char *script, *p;
+ const char *home;
+ struct passwd *pw;
+ char *t;
+ size_t i, n;
+ struct argstate arg = ARGSTATE_INIT;
+
+ /* Scan the command line. This gets low priority, since it's probably
+ * from the script shebang.
+ */
+ set_progname(argv[0]); i = 1;
+ parse_arguments(&arg, (const char *const *)argv, argc, &i);
+ arg.f |= F_AUX;
+ if ((i >= argc && !arg.av.n) || (arg.f&F_BOGUS))
+ { usage(stderr); exit(255); }
+
+ /* Prepare the argument vector. Keep track of the number of arguments
+ * here: we'll need to refer to this later.
+ */
+ if (!arg.av.n) {
+ script = argv[i++];
+ if (!(arg.f&F_NOEMBED)) check_for_embedded_args(script, &arg);
+ if (arg.f&F_BOGUS)
+ lose("invalid options in `%s' embedded option list", script);
+ } else {
+ script = getenv("RUNLISP_EVAL");
+ if (!script) script = DATADIR "/eval.lisp";
+ argv_append(&arg.av, "--");
+ }
+ argv_appendn(&arg.av, (const char *const *)argv + i, argc - i);
+ n = arg.av.n;
+
+ /* Find the user's home directory. (Believe them if they set something
+ * strange.)
+ */
+ home = getenv("HOME");
+ if (!home) {
+ pw = getpwuid(getuid());
+ if (!pw) lose("can't find user in password database");
+ home = pw->pw_dir;
+ }
+
+ /* Check user configuration file `~/.runlisprc'. */
+ dstr_reset(&d);
+ dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".runlisprc");
+ read_config_file(d.p, &arg);
+
+ /* Check user configuration file `~/.config/runlisprc'. */
+ dstr_reset(&d);
+ p = getenv("XDG_CONFIG_HOME");
+ if (p)
+ dstr_puts(&d, p);
+ else
+ { dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".config"); }
+ dstr_putc(&d, '/'); dstr_puts(&d, "runlisprc");
+ read_config_file(d.p, &arg);
+
+ /* Finally, check the environment variables. */
+ p = getenv("RUNLISP_OPTIONS");
+ if (p) {
+ t = xstrdup(p);
+ scan_options_from_string(t, &arg, 0,
+ "environment variable", "RUNLISP_OPTIONS");
+ free(t);
+ }
+ if (arg.f&F_BOGUS)
+ lose("invalid options in environment variable `RUNLISP_OPTIONS'");
+ if (!arg.imagedir) {
+ arg.imagedir = getenv("RUNLISP_IMAGEDIR");
+ if (!arg.imagedir) arg.imagedir = IMAGEDIR;
+ }
+
+ /* If no systems are listed as acceptable, try them all. */
+ if (!arg.allow.n) {
+ if (arg.verbose > 1)
+ moan("no explicitly allowed implementations: allowing all");
+ for (i = 0; i < NSYS; i++) arg.allow.sys[i] = &systab[i];
+ arg.allow.n = NSYS; arg.allow.f = (1u << NSYS) - 1;
+ }
+
+ /* Print what we're going to do. */
+ if (arg.verbose > 2) {
+ dstr_reset(&d); p = "";
+ for (i = 0; i < arg.allow.n; i++)
+ { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); }
+ dstr_putz(&d); moan("permitted Lisps: %s", d.p);
+
+ dstr_reset(&d); p = "";
+ for (i = 0; i < arg.pref.n; i++)
+ { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); }
+ dstr_putz(&d); moan("preferred Lisps: %s", d.p);
+
+ dstr_reset(&d); p = "";
+ for (i = 0; i < arg.pref.n; i++)
+ if (arg.pref.sys[i]->f&arg.allow.f)
+ { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); }
+ for (i = 0; i < arg.allow.n; i++)
+ if (!(arg.allow.sys[i]->f&arg.pref.f))
+ { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); }
+ moan("overall preference order: %s", d.p);
+ }
+
+ /* Inform `uiop' of the script name.
+ *
+ * As an aside, this is a terrible interface. It's too easy to forget to
+ * set it. (To illustrate this, `cl-launch -x' indeed forgets to set it.)
+ * If you're lucky, the script just thinks that its argument is `nil', in
+ * which case maybe it can use `*load-pathname*' as a fallback. If you're
+ * unlucky, your script was invoked (possibly indirectly) by another
+ * script, and now you've accidentally inherited the calling script's name.
+ *
+ * It would have been far better simply to repeat the script name as the
+ * first user argument, if nothing else had come readily to mind.
+ */
+ if (setenv("__CL_ARGV0", script, 1))
+ lose("failed to set script-name environment variable");
+
+ /* Work through the list of preferred Lisp systems, trying the ones which
+ * are allowed.
+ */
+ for (i = 0; i < arg.pref.n; i++)
+ if (arg.pref.sys[i]->f&arg.allow.f) {
+ arg.av.o += arg.av.n - n; arg.av.v += arg.av.n - n; arg.av.n = n;
+ arg.pref.sys[i]->run(&arg, script);
+ }
+
+ /* That didn't work. Try the remaining allowed systems, in the given
+ * order.
+ */
+ for (i = 0; i < arg.allow.n; i++)
+ if (!(arg.allow.sys[i]->f&arg.pref.f)) {
+ arg.av.o += arg.av.n - n; arg.av.v += arg.av.n - n; arg.av.n = n;
+ arg.allow.sys[i]->run(&arg, script);
+ }
+
+ /* No joy. Give up. */
+ argv_release(&arg.av);
+ lose("no supported Lisp systems found");
+}
+
+/*----- That's all, folks -------------------------------------------------*/
/* -*-c-*-
*
- * Invoke a Lisp script
+ * Invoke Lisp scripts and implementations
*
* (c) 2020 Mark Wooding
*/
#include "config.h"
-#include <assert.h>
#include <ctype.h>
#include <errno.h>
-#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
-#include <unistd.h>
-#include <sys/stat.h>
+#include "common.h"
+#include "lib.h"
+#include "mdwopt.h"
-#include <pwd.h>
+/*----- Static data -------------------------------------------------------*/
-/*----- Common Lisp runes -------------------------------------------------*/
-
-/* A common preamble rune to do the necessary things.
- *
- * We need to ensure that `asdf' (and therefore `uiop') is loaded. And we
- * should arrange for `:runlisp-script' to find its way into the `*features*'
- * list so that scripts can notice that they're being invoked from the
- * command line rather than loaded into a resident session, and actually do
- * something useful.
- */
-#define COMMON_PRELUDE_RUNE \
- "(progn " \
- "(setf *load-verbose* nil *compile-verbose* nil) " \
- "(require \"asdf\") " \
- "(funcall (intern \"REGISTER-IMMUTABLE-SYSTEM\" " \
- "(find-package \"ASDF\")) " \
- "\"asdf\") " \
- "(set-dispatch-macro-character " \
- "#\\# #\\! " \
- "(lambda (#1=#:stream #2=#:char #3=#:arg) " \
- "(declare (ignore #2# #3#)) " \
- "(values (read-line #1#)))) " \
- "(pushnew :runlisp-script *features*))"
-
-/* Get `uiop' to re-check the command-line arguments following an image
- * restore.
- */
-#define IMAGE_RESTORE_RUNE \
- "(uiop:call-image-restore-hook)"
-
-/* Some Lisps leave crud in the `COMMON-LISP-USER' package. Clear it out. */
-#define CLEAR_CL_USER_RUNE \
- "(let ((#4=#:pkg (find-package \"COMMON-LISP-USER\"))) " \
- "(with-package-iterator (#5=#:next #4# :internal) " \
- "(loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how) " \
- "(#5#) " \
- "(declare (ignore #8#)) " \
- "(unless #6# (return)) " \
- "(unintern #7# #4#)))))"
-
-/*----- Handy macros ------------------------------------------------------*/
-
-#define N(v) (sizeof(v)/sizeof((v)[0]))
-
-#if defined(__GNUC__)
-# define GCC_VERSION_P(maj, min) \
- (__GNUC__ > (maj) || (__GNUC__ == (maj) && __GNUC_MINOR__ >= (min)))
-#else
-# define GCC_VERSION_P(maj, min) 0
-#endif
-
-#ifdef __clang__
-# define CLANG_VERSION_P(maj, min) \
- (__clang_major__ > (maj) || (__clang_major__ == (maj) && \
- __clang_minor__ >= (min)))
-#else
-# define CLANG_VERSION_P(maj, min) 0
-#endif
-
-#if GCC_VERSION_P(2, 5) || CLANG_VERSION_P(3, 3)
-# define NORETURN __attribute__((__noreturn__))
-# define PRINTF_LIKE(fix, aix) __attribute__((__format__(printf, fix, aix)))
-#endif
-
-#if GCC_VERSION_P(4, 0) || CLANG_VERSION_P(3, 3)
-# define EXECL_LIKE(ntrail) __attribute__((__sentinel__(ntrail)))
-#endif
-
-#define CTYPE_HACK(func, ch) (func((unsigned char)(ch)))
-#define ISSPACE(ch) CTYPE_HACK(isspace, ch)
-
-#define MEMCMP(x, op, y, n) (memcmp((x), (y), (n)) op 0)
-#define STRCMP(x, op, y) (strcmp((x), (y)) op 0)
-#define STRNCMP(x, op, y, n) (strncmp((x), (y), (n)) op 0)
-
-#define END ((const char *)0)
-
-/*----- The Lisp implementation table -------------------------------------*/
-
-/* The systems, in decreasing order of (not quite my personal) preference.
- * This list is used to initialize various tables and constants.
- */
-#define LISP_SYSTEMS(_) \
- _(sbcl) \
- _(ccl) \
- _(clisp) \
- _(ecl) \
- _(cmucl) \
- _(abcl)
-
-enum {
-#define DEFSYS(sys) sys##_INDEX,
- LISP_SYSTEMS(DEFSYS)
-#undef DEFSYS
- NSYS
-};
-
-enum {
-#define DEFFLAG(sys) sys##_FLAG = 1 << sys##_INDEX,
- LISP_SYSTEMS(DEFFLAG)
-#undef DEFFLAG
- ALL_SYSTEMS = 0
-#define SETFLAG(sys) | sys##_FLAG
- LISP_SYSTEMS(SETFLAG)
-#undef SETFLAG
-};
-
-struct argstate;
-struct argv;
-
-#define DECLENTRY(sys) \
-static void run_##sys(struct argstate *, const char *);
- LISP_SYSTEMS(DECLENTRY)
-#undef DECLENTRY
-
-static const struct systab {
- const char *name;
+struct lispsys {
+ struct treap_node _node;
+ struct lispsys *next_lisp, *next_accept, *next_prefer, *next_order;
unsigned f;
- void (*run)(struct argstate *, const char *);
-} systab[] = {
-#define SYSENTRY(sys) { #sys, sys##_FLAG, run_##sys },
- LISP_SYSTEMS(SYSENTRY)
-#undef SYSENTRY
+#define LF_KNOWN 1u
+#define LF_ACCEPT 2u
+#define LF_PREFER 4u
+ struct config_section *sect;
+ struct config_var *var;
};
+#define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp)
+#define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp)
-/*----- Diagnostic utilities ----------------------------------------------*/
-
-static const char *progname = "runlisp";
-
-static void set_progname(const char *prog)
-{
- const char *p;
-
- p = strrchr(prog, '/');
- progname = p ? p + 1 : progname;
-}
-
-static void vmoan(const char *msg, va_list ap)
-{
- fprintf(stderr, "%s: ", progname);
- vfprintf(stderr, msg, ap);
- fputc('\n', stderr);
-}
-
-static PRINTF_LIKE(1, 2) void moan(const char *msg, ...)
- { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); }
-
-static NORETURN PRINTF_LIKE(1, 2) void lose(const char *msg, ...)
- { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); exit(127); }
-
-/*----- Memory allocation -------------------------------------------------*/
-
-static void *xmalloc(size_t n)
-{
- void *p;
-
- if (!n) return (0);
- p = malloc(n); if (!p) lose("failed to allocate memory");
- return (p);
-}
-
-static void *xrealloc(void *p, size_t n)
-{
- if (!n) { free(p); return (0); }
- else if (!p) return (xmalloc(n));
- p = realloc(p, n); if (!p) lose("failed to allocate memory");
- return (p);
-}
-
-static char *xstrdup(const char *p)
-{
- size_t n = strlen(p) + 1;
- char *q = xmalloc(n);
-
- memcpy(q, p, n);
- return (q);
-}
-
-/*----- Dynamic strings ---------------------------------------------------*/
-
-struct dstr {
- char *p;
- size_t len, sz;
+struct lispsys_list {
+ struct lispsys *head, **tail;
};
-#define DSTR_INIT { 0, 0, 0 }
-
-/*
-static void dstr_init(struct dstr *d) { d->p = 0; d->len = d->sz = 0; }
-*/
-
-static void dstr_reset(struct dstr *d) { d->len = 0; }
-
-static void dstr_ensure(struct dstr *d, size_t n)
-{
- size_t need = d->len + n, newsz;
-
- if (need <= d->sz) return;
- newsz = d->sz ? 2*d->sz : 16;
- while (newsz < need) newsz *= 2;
- d->p = xrealloc(d->p, newsz); d->sz = newsz;
-}
-
-static void dstr_release(struct dstr *d) { free(d->p); }
-
-static void dstr_putm(struct dstr *d, const void *p, size_t n)
- { dstr_ensure(d, n); memcpy(d->p + d->len, p, n); d->len += n; }
-
-static void dstr_puts(struct dstr *d, const char *p)
-{
- size_t n = strlen(p);
- dstr_ensure(d, n + 1);
- memcpy(d->p + d->len, p, n + 1);
- d->len += n;
-}
-
-static void dstr_putc(struct dstr *d, int ch)
- { dstr_ensure(d, 1); d->p[d->len++] = ch; }
-
-static void dstr_putz(struct dstr *d)
- { dstr_ensure(d, 1); d->p[d->len] = 0; }
-
-static int dstr_readline(struct dstr *d, FILE *fp)
-{
- size_t n;
- int any = 0;
-
- for (;;) {
- dstr_ensure(d, 2);
- if (!fgets(d->p + d->len, d->sz - d->len, fp)) break;
- n = strlen(d->p + d->len); assert(n > 0); any = 1;
- d->len += n;
- if (d->p[d->len - 1] == '\n') { d->p[--d->len] = 0; break; }
- }
-
- if (!any) return (-1);
- else return (0);
-}
-/*----- Dynamic vectors of strings ----------------------------------------*/
-
-struct argv {
- const char **v;
- size_t o, n, sz;
-};
-#define ARGV_INIT { 0, 0, 0, 0 }
-
-/*
-static void argv_init(struct argv *av)
- { av->v = 0; av->o = av->n = av->sz = 0; }
-*/
-
-/*
-static void argv_reset(struct argv *av) { av->o = av->n = 0; }
-*/
-
-static void argv_ensure(struct argv *av, size_t n)
-{
- size_t need = av->n + av->o + n, newsz;
-
- if (need <= av->sz) return;
- newsz = av->sz ? 2*av->sz : 8;
- while (newsz < need) newsz *= 2;
- av->v = xrealloc(av->v, newsz*sizeof(const char *)); av->sz = newsz;
-}
+static struct argv argv_tail = ARGV_INIT;
+const char *script = 0;
+
+static unsigned flags = 0;
+#define AF_CMDLINE 0x0000u
+#define AF_EMBED 0x0001u
+#define AF_ENV 0x0002u
+#define AF_CONF 0x0003u
+#define AF_STATEMASK 0x000fu
+#define AF_BOGUS 0x0010u
+#define AF_SETCONF 0x0020u
+#define AF_NOEMBED 0x0040u
+#define AF_DRYRUN 0x0080u
+#define AF_VANILLA 0x0100u
+
+struct treap lispsys = TREAP_INIT;
+static struct lispsys_list
+ lisps = { 0, &lisps.head },
+ accept = { 0, &accept.head },
+ prefer = { 0, &prefer.head };
-static void argv_ensure_offset(struct argv *av, size_t n)
-{
- size_t newoff;
-
- /* Stupid version. We won't, in practice, be prepending lots of stuff, so
- * avoid the extra bookkeeping involved in trying to make a double-ended
- * extendable array asymptotically efficient.
- */
- if (av->o >= n) return;
- newoff = 16;
- while (newoff < n) newoff *= 2;
- argv_ensure(av, newoff - av->o);
- memmove(av->v + newoff, av->v + av->o, av->n*sizeof(const char *));
- av->o = newoff;
-}
-
-static void argv_release(struct argv *av) { free(av->v); }
-
-static void argv_append(struct argv *av, const char *p)
- { argv_ensure(av, 1); av->v[av->n++ + av->o] = p; }
+/*----- Main code ---------------------------------------------------------*/
-static void argv_appendz(struct argv *av)
- { argv_ensure(av, 1); av->v[av->n + av->o] = 0; }
+static void version(FILE *fp)
+ { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); }
-static void argv_appendn(struct argv *av, const char *const *v, size_t n)
+static void usage(FILE *fp)
{
- argv_ensure(av, n);
- memcpy(av->v + av->n + av->o, v, n*sizeof(const char *));
- av->n += n;
+ fprintf(fp, "\
+usage:\n\
+ %s [OPTIONS] [--] SCRIPT [ARGUMENTS ...]\n\
+ %s [OPTIONS] [-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n\
+OPTIONS:\n\
+ [-CDEnqv] [+DEn] [-L SYS,SYS,...] [-c CONF] [-o [SECT:]VAR=VAL]\n",
+ progname, progname);
}
-/*
-static void argv_appendav(struct argv *av, const struct argv *bv)
- { argv_appendn(av, bv->v + bv->o, bv->n); }
-*/
-
-/*
-static void argv_appendv(struct argv *av, va_list ap)
+static void help(FILE *fp)
{
- const char *p;
-
- for (;;)
- { p = va_arg(ap, const char *); if (!p) break; argv_append(av, p); }
+ version(fp); fputc('\n', fp); usage(fp);
+ fputs("\n\
+Help options:\n\
+ -h, --help Show this help text and exit successfully.\n\
+ -V, --version Show version number and exit successfully.\n\
+\n\
+Diagnostics:\n\
+ -n, --dry-run Don't run run anything (useful with `-v').\n\
+ -q, --quiet Don't print warning messages.\n\
+ -v, --verbose Print informational messages (repeatable).\n\
+\n\
+Configuration:\n\
+ -E, --command-line-only Don't read embedded options from script.\n\
+ -c, --config-file=CONF Read configuration from CONF (repeatable).\n\
+ -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
+\n\
+Lisp implementation selection:\n\
+ -D, --vanilla-image Run vanilla Lisp images, not custom ones.\n\
+ -L, --accept-lisp=SYS,SYS,... Only use the listed Lisp systems.\n\
+\n\
+Evaluation mode:\n\
+ -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\
+ -l, --load-file=FILE Load FILE (repeatable).\n\
+ -p, --print-expression=EXPR Print (`prin1') EXPR (repeatable).\n",
+ fp);
}
-*/
-/*
-static EXECL_LIKE(0) void argv_appendl(struct argv *av, ...)
- { va_list ap; va_start(ap, av); argv_appendv(av, ap); va_end(ap); }
-*/
-
-static void argv_prepend(struct argv *av, const char *p)
- { argv_ensure_offset(av, 1); av->v[--av->o] = p; av->n++; }
-
-/*
-static void argv_prependn(struct argv *av, const char *const *v, size_t n)
+static struct lispsys *ensure_lispsys(const char *name, size_t n)
{
- argv_ensure_offset(av, 1);
- av->o -= n; av->n += n;
- memcpy(av->v + av->o, v, n*sizeof(const char *));
-}
-*/
+ struct lispsys *lisp;
+ struct treap_path path;
-/*
-static void argv_prependav(struct argv *av, const struct argv *bv)
- { argv_prependn(av, bv->v + bv->o, bv->n); }
-*/
-
-static void argv_prependv(struct argv *av, va_list ap)
-{
- const char *p, **v;
- size_t n = 0;
-
- for (;;) {
- p = va_arg(ap, const char *); if (!p) break;
- argv_prepend(av, p); n++;
- }
- v = av->v + av->o;
- while (n >= 2) {
- p = v[0]; v[0] = v[n - 1]; v[n - 1] = p;
- v++; n -= 2;
+ lisp = treap_probe(&lispsys, name, n, &path);
+ if (!lisp) {
+ lisp = xmalloc(sizeof(*lisp));
+ lisp->f = 0; lisp->sect = 0;
+ treap_insert(&lispsys, &path, &lisp->_node, name, n);
}
+ return (lisp);
}
-static EXECL_LIKE(0) void argv_prependl(struct argv *av, ...)
- { va_list ap; va_start(ap, av); argv_prependv(av, ap); va_end(ap); }
-
-/*----- Lisp system table (redux) -----------------------------------------*/
-
-static const struct systab *find_system(const char *name)
-{
- const struct systab *sys;
- size_t i;
+#define LISP_LINK(lisp, linkoff) \
+ ((struct lispsys **)((unsigned char *)(lisp) + (linkoff)))
- for (i = 0; i < NSYS; i++) {
- sys = &systab[i];
- if (STRCMP(name, ==, sys->name)) return (sys);
- }
- lose("unknown Lisp system `%s'", name);
-}
-
-static void lisp_quote_string(struct dstr *d, const char *p)
+static void add_lispsys(const char *p, const char *what,
+ struct lispsys_list *list,
+ unsigned flag, size_t linkoff)
{
- size_t n;
+ struct lispsys *lisp, **link;
+ const char *q;
+ if (!*p) return;
for (;;) {
- n = strcspn(p, "\"\\");
- if (n) { dstr_putm(d, p, n); p += n; }
if (!*p) break;
- dstr_putc(d, '\\'); dstr_putc(d, *p++);
- }
- dstr_putz(d);
-}
-
-static const char *expand_rune(struct dstr *d, const char *rune, ...)
-{
- const struct argv *av;
- va_list ap;
- size_t i, n;
-
- va_start(ap, rune);
- for (;;) {
- n = strcspn(rune, "%");
- if (n) { dstr_putm(d, rune, n); rune += n; }
- if (!*rune) break;
- switch (*++rune) {
- case '%': dstr_putc(d, '%'); break;
- case 'e': lisp_quote_string(d, va_arg(ap, const char *)); break;
- case 'E':
- av = va_arg(ap, const struct argv *);
- for (i = 0; i < av->n; i++) {
- if (i) dstr_putc(d, ' ');
- dstr_putc(d, '"');
- lisp_quote_string(d, av->v[i]);
- dstr_putc(d, '"');
- }
- break;
- default: lose("*** BUG unknown expansion `%%%c'", *rune);
+ q = p; while (*p && *p != ',') p++;
+ lisp = ensure_lispsys(q, p - q);
+ if (lisp->f&flag) {
+ if (verbose >= 1)
+ moan("ignoring duplicate %s Lisp `%.*s'", what, (int)(p - q), q);
+ } else {
+ link = LISP_LINK(lisp, linkoff);
+ lisp->f |= flag; *link = 0;
+ *list->tail = lisp; list->tail = link;
}
- rune++;
- }
- dstr_putz(d);
- return (d->p);
-}
-
-/*----- Argument processing -----------------------------------------------*/
-
-struct syslist {
- const struct systab *sys[NSYS];
- size_t n;
- unsigned f;
-};
-#define SYSLIST_INIT { { 0 }, 0, 0 }
-
-struct argstate {
- unsigned f;
-#define F_BOGUS 1u
-#define F_NOEMBED 2u
-#define F_NOACT 4u
-#define F_NODUMP 8u
-#define F_AUX 16u
- int verbose;
- char *imagedir;
- struct syslist allow, pref;
- struct argv av;
-};
-#define ARGSTATE_INIT { 0, 1, 0, SYSLIST_INIT, SYSLIST_INIT, ARGV_INIT }
-
-/*----- Running programs --------------------------------------------------*/
-
-#define FEF_EXEC 1u
-static int file_exists_p(const struct argstate *arg, const char *path,
- unsigned f)
-{
- struct stat st;
-
- if (stat(path, &st)) {
- if (arg && arg->verbose > 2) moan("file `%s' not found", path);
- return (0);
- } else if (!(S_ISREG(st.st_mode))) {
- if (arg && arg->verbose > 2) moan("`%s' is not a regular file", path);
- return (0);
- } else if ((f&FEF_EXEC) && access(path, X_OK)) {
- if (arg && arg->verbose > 2) moan("file `%s' is not executable", path);
- return (0);
- } else {
- if (arg && arg->verbose > 2) moan("found file `%s'", path);
- return (1);
+ if (!*p) break;
+ p++;
}
}
-static int found_in_path_p(const struct argstate *arg, const char *prog)
+static void check_lisps(const char *what,
+ struct lispsys_list *list, size_t linkoff)
{
- struct dstr p = DSTR_INIT, d = DSTR_INIT;
- const char *path;
- char *q;
- size_t n, avail, proglen;
- int i;
+ struct lispsys *lisp;
- if (strchr(prog, '/')) return (file_exists_p(arg, prog, 0));
- path = getenv("PATH");
- if (path)
- dstr_puts(&p, path);
- else {
- dstr_puts(&p, ".:");
- i = 0;
- again:
- avail = p.sz - p.len;
- n = confstr(_CS_PATH, p.p + p.len, avail);
- if (avail > n) { i++; assert(i < 2); dstr_ensure(&p, n); goto again; }
- }
-
- q = p.p; proglen = strlen(prog);
- for (;;) {
- n = strcspn(q, ":");
- dstr_reset(&d);
- if (q[n]) dstr_putm(&d, q, n);
- else dstr_putc(&d, '.');
- dstr_putc(&d, '/');
- dstr_putm(&d, prog, proglen);
- dstr_putz(&d);
- if (file_exists_p(arg, d.p, FEF_EXEC)) {
- if (arg->verbose == 2) moan("found program `%s'", d.p);
- return (1);
- }
- q += n; if (!*q) break; else q++;
- }
- return (0);
+ for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff))
+ if (!(lisp->f&LF_KNOWN))
+ lose("unknown Lisp implementation `%s'", LISPSYS_NAME(lisp));
}
-static void try_exec(const struct argstate *arg, struct argv *av)
+static void dump_lisps(const char *what,
+ struct lispsys_list *list, size_t linkoff)
{
struct dstr d = DSTR_INIT;
- size_t i;
-
- assert(av->n); argv_appendz(av);
- if (arg->verbose > 1) {
- for (i = 0; i < av->n; i++) {
- if (i) { dstr_putc(&d, ','); dstr_putc(&d, ' '); }
- dstr_putc(&d, '"');
- lisp_quote_string(&d, av->v[av->o + i]);
- dstr_putc(&d, '"');
- }
- dstr_putz(&d);
- moan("trying %s...", d.p);
- }
- if (arg->f&F_NOACT)
- { if (found_in_path_p(arg, av->v[av->o])) exit(0); }
- else {
- execvp(av->v[av->o], (/*unconst*/ char **)av->v + av->o);
- if (errno != ENOENT)
- lose("failed to exec `%s': %s", av->v[av->o], strerror(errno));
+ struct lispsys *lisp;
+ int first;
+
+ first = 1;
+ for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff)) {
+ if (first) first = 0;
+ else dstr_puts(&d, ", ");
+ dstr_putf(&d, "`%s'", LISPSYS_NAME(lisp));
}
- if (arg->verbose > 1) moan("`%s' not found", av->v[av->o]);
+ if (first) dstr_puts(&d, "(none)");
+ dstr_putz(&d);
+ moan("%s: %s", what, d.p);
dstr_release(&d);
}
-static const char *getenv_or_default(const char *var, const char *dflt)
- { const char *p = getenv(var); return (p ? p : dflt); }
-
-/*----- Invoking Lisp systems ---------------------------------------------*/
-
-/* Steel Bank Common Lisp. */
-
-static void run_sbcl(struct argstate *arg, const char *script)
-{
- struct dstr d = DSTR_INIT;
-
- argv_prependl(&arg->av, "--script", script, END);
-
- dstr_puts(&d, arg->imagedir);
- dstr_putc(&d, '/');
- dstr_puts(&d, "sbcl+asdf.core");
- if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
- argv_prependl(&arg->av,
- "--core", d.p,
- "--eval", IMAGE_RESTORE_RUNE,
- END);
- else
- argv_prependl(&arg->av, "--eval", COMMON_PRELUDE_RUNE, END);
-
- argv_prependl(&arg->av, getenv_or_default("SBCL", "sbcl"),
- "--noinform",
- END);
- try_exec(arg, &arg->av);
- dstr_release(&d);
-}
-
-/* Clozure Common Lisp. */
-
-#define CCL_QUIT_RUNE \
- "(ccl:quit)"
-
-static void run_ccl(struct argstate *arg, const char *script)
-{
- struct dstr d = DSTR_INIT;
-
- argv_prependl(&arg->av, "-b", "-n", "-Q",
- "-l", script,
- "-e", CCL_QUIT_RUNE,
- "--",
- END);
-
- dstr_puts(&d, arg->imagedir);
- dstr_putc(&d, '/');
- dstr_puts(&d, "ccl+asdf.image");
- if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
- argv_prependl(&arg->av, "-I", d.p, "-e", IMAGE_RESTORE_RUNE, END);
- else
- argv_prependl(&arg->av, "-e", COMMON_PRELUDE_RUNE, END);
-
- argv_prepend(&arg->av, getenv_or_default("CCL", "ccl"));
- try_exec(arg, &arg->av);
- dstr_release(&d);
-}
-
-/* GNU CLisp.
- *
- * CLisp causes much sadness. Superficially, it's the most sensible of all
- * of the systems supported here: you just run `clisp SCRIPT -- ARGS ...' and
- * it works.
- *
- * The problems come when you want to do some preparatory work (e.g., load
- * `asdf') and then run the script. There's a `-x' option to evaluate some
- * Lisp code, but it has three major deficiencies.
- *
- * * It insists on printing the values of the forms it evaluates. It
- * prints a blank line even if the form goes out of its way to produce no
- * values at all. So the whole thing has to be a single top-level form
- * which quits the Lisp rather than returning.
- *
- * * For some idiotic reason, you can have /either/ `-x' forms /or/ a
- * script, but not both. So we have to include the `load' here
- * explicitly. I suppose that was inevitable because we have to inhibit
- * printing of the result forms, but it's still a separate source of
- * annoyance.
- *
- * * The icing on the cake: the `-x' forms are collectively concatenated --
- * without spaces! -- and used to build a string stream, which is then
- * assigned over the top of `*standard-input*', making the original stdin
- * somewhat fiddly to track down.
- *
- * There's an `-i' option which will load a file without any of this
- * stupidity, but nothing analogous for immediate expressions.
- */
-
-#define CLISP_COMMON_STARTUP_RUNES \
- "(setf *standard-input* (ext:make-stream :input)) " \
- "(load \"%e\" :verbose nil :print nil) " \
- "(ext:quit)"
-
-#define CLISP_STARTUP_RUNE \
- "(progn " \
- COMMON_PRELUDE_RUNE " " \
- CLISP_COMMON_STARTUP_RUNES ")"
-
-#define CLISP_STARTUP_IMAGE_RUNE \
- "(progn " \
- IMAGE_RESTORE_RUNE " " \
- CLISP_COMMON_STARTUP_RUNES ")"
-
-static void run_clisp(struct argstate *arg, const char *script)
-{
- struct dstr d = DSTR_INIT, dd = DSTR_INIT;
-
- dstr_puts(&d, arg->imagedir);
- dstr_putc(&d, '/');
- dstr_puts(&d, "clisp+asdf.mem");
- if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
- argv_prependl(&arg->av, "-M", d.p, "-q",
- "-x", expand_rune(&dd, CLISP_STARTUP_IMAGE_RUNE, script),
- "--",
- END);
- else
- argv_prependl(&arg->av, "-norc", "-q",
- "-x", expand_rune(&dd, CLISP_STARTUP_RUNE, script),
- "--",
- END);
-
- argv_prepend(&arg->av, getenv_or_default("CLISP", "clisp"));
- try_exec(arg, &arg->av);
- dstr_release(&d);
- dstr_release(&dd);
-
-#undef f
-}
-
-/* Embeddable Common Lisp. *
- *
- * ECL is changing its command-line option syntax in version 16. I have no
- * idea why they think the result can ever be worth the pain of a transition.
- */
-
-#if ECL_OPTIONS_GNU
-# define ECLOPT "--"
-#else
-# define ECLOPT "-"
-#endif
-
-#define ECL_STARTUP_RUNE \
- "(progn " \
- COMMON_PRELUDE_RUNE " " \
- CLEAR_CL_USER_RUNE ")"
-
-static void run_ecl(struct argstate *arg, const char *script)
-{
- struct dstr d = DSTR_INIT;
-
- dstr_puts(&d, arg->imagedir);
- dstr_putc(&d, '/');
- dstr_puts(&d, "ecl+asdf");
- if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, FEF_EXEC)) {
- argv_prependl(&arg->av, "-s", script, "--", END);
- argv_prependl(&arg->av, d.p, END);
- } else {
- argv_prependl(&arg->av, ECLOPT "shell", script, "--", END);
- argv_prependl(&arg->av, getenv_or_default("ECL", "ecl"), ECLOPT "norc",
- ECLOPT "eval", ECL_STARTUP_RUNE,
- END);
- }
- try_exec(arg, &arg->av);
-}
-
-/* Carnegie--Mellon University Common Lisp. */
-
-#define CMUCL_STARTUP_RUNE \
- "(progn " \
- "(setf ext:*require-verbose* nil) " \
- COMMON_PRELUDE_RUNE ")"
-#define CMUCL_QUIT_RUNE \
- "(ext:quit)"
-
-static void run_cmucl(struct argstate *arg, const char *script)
-{
- struct dstr d = DSTR_INIT;
-
- argv_prependl(&arg->av,
- "-load", script,
- "-eval", CMUCL_QUIT_RUNE,
- "--",
- END);
-
- dstr_puts(&d, arg->imagedir);
- dstr_putc(&d, '/');
- dstr_puts(&d, "cmucl+asdf.core");
- if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
- argv_prependl(&arg->av, "-core", d.p, "-eval", IMAGE_RESTORE_RUNE, END);
- else
- argv_prependl(&arg->av, "-batch", "-noinit", "-nositeinit", "-quiet",
- "-eval", CMUCL_STARTUP_RUNE,
- END);
-
- argv_prepend(&arg->av, getenv_or_default("CMUCL", "cmucl"));
- try_exec(arg, &arg->av);
- dstr_release(&d);
-}
-
-/* Armed Bear Common Lisp. *
- *
- * CLisp made a worthy effort, but ABCL still manages to take the price.
- *
- * * ABCL manages to avoid touching the `stderr' stream at all, ever. Its
- * startup machinery finds `stdout' (as `java.lang.System.out'), wraps it
- * up in a Lisp stream, and uses the result as `*standard-output*' and
- * `*error-output*' (and a goodly number of other things too). So we
- * must manufacture a working `stderr' the hard way.
- *
- * * There doesn't appear to be any easy way to prevent toplevel errors
- * from invoking the interactive debugger. For extra fun, the debugger
- * reads from `stdin' by default, so an input file which somehow manages
- * to break the script can then take over its brain by providing Lisp
- * forms for the debugger to evaluate.
- */
-
-#define ABCL_STARTUP_RUNE \
- "(let ((#9=#:script \"%e\")) " \
- COMMON_PRELUDE_RUNE " " \
- CLEAR_CL_USER_RUNE " " \
- \
- /* Replace the broken `*error-output*' stream with a working \
- * copy of `stderr'. \
- */ \
- "(setf *error-output* " \
- "(java:jnew \"org.armedbear.lisp.Stream\" " \
- "'sys::system-stream " \
- "(java:jfield \"java.lang.System\" \"err\") " \
- "'character " \
- "java:+true+)) " \
- \
- /* Trap errors signalled by the script and arrange for them \
- * to actually kill the process rather than ending up in the \
- * interactive debugger. \
- */ \
- "(handler-case (load #9# :verbose nil :print nil) " \
- "(error (error) " \
- "(format *error-output* \"~A (unhandled error): ~A~%%\" " \
- "#9# error) " \
- "(ext:quit :status 255))))"
-
-static void run_abcl(struct argstate *arg, const char *script)
-{
- struct dstr d = DSTR_INIT;
-
- argv_prependl(&arg->av, getenv_or_default("ABCL", "abcl"),
- "--batch", "--noinform", "--noinit", "--nosystem",
- "--eval", expand_rune(&d, ABCL_STARTUP_RUNE, script),
- "--",
- END);
- try_exec(arg, &arg->av);
- dstr_release(&d);
-}
-
-/*----- Main code ---------------------------------------------------------*/
-
-static void version(FILE *fp)
- { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); }
-
-static void usage(FILE *fp)
-{
- fprintf(fp, "usage: %s [-CDEnqv] [-I IMAGEDIR] "
- "[-L SYS,SYS,...] [-P SYS,SYS,...]\n"
- "\t[--] SCRIPT [ARGUMENTS ...] |\n"
- "\t[-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n",
- progname);
-}
-
-static void help(FILE *fp)
-{
- version(fp); fputc('\n', fp); usage(fp);
- fputs("\n\
-Options:\n\
- --help Show this help text and exit successfully.\n\
- --version Show the version number and exit successfully.\n\
- -C Clear the list of preferred Lisp systems.\n\
- -D Run system Lisp images, rather than custom images.\n\
- -E Don't read embedded options from the script.\n\
- -I IMAGEDIR Look for custom images in IMAGEDIR rather than\n\
- `" IMAGEDIR "'.\n\
- -L SYS,SYS,... Only use the listed Lisp systems.the script.\n\
- -P SYS,SYS,... Prefer the listed Lisp systems.\n\
- -e EXPR Evaluate EXPR (can be repeated).\n\
- -l FILE Load FILE (can be repeated).\n\
- -n Don't actually run the script (useful with `-v')\n\
- -p EXPR Print (`prin1') EXPR (can be repeated).\n\
- -q Don't print warning messages.\n\
- -v Print informational messages (repeat for even more).\n",
- fp);
-}
-
-/* Parse a comma-separated list of system names SPEC, and add the named
- * systems to LIST.
- */
-static void parse_syslist(const char *spec, const struct argstate *arg,
- struct syslist *list, const char *what)
-{
- char *copy = xstrdup(spec), *p = copy, *q;
- const struct systab *sys;
- size_t n;
-
- for (;;) {
- n = strcspn(p, ",");
- if (p[n]) q = p + n + 1;
- else q = 0;
- p[n] = 0; sys = find_system(p);
- if (list->f&sys->f) {
- if (arg->verbose > 0)
- moan("ignoring duplicate system `%s' in %s list", p, what);
- } else {
- list->sys[list->n++] = sys;
- list->f |= sys->f;
- }
- if (!q) break;
- p = q;
- }
- free(copy);
-}
-
-static void push_eval_op(struct argstate *arg, char op, const char *val)
+static void push_eval_op(char op, const char *val)
{
char *p;
size_t n;
- if (arg->f&F_AUX) {
+ if ((flags&AF_STATEMASK) != AF_CMDLINE) {
moan("must use `-e', `-p', or `-l' on command line");
- arg->f |= F_BOGUS;
+ flags |= AF_BOGUS;
return;
}
n = strlen(val) + 1;
p = xmalloc(n + 1);
p[0] = op; memcpy(p + 1, val, n);
- argv_append(&arg->av, p);
+ argv_append(&argv_tail, p);
}
-/* Parse a vector ARGS of command-line arguments. Update ARG with the
- * results. NARG is the number of arguments, and *I_INOUT is the current
- * index into the vector, to be updated on exit to identify the first
- * non-option argument (or the end of the vector).
- */
-static void parse_arguments(struct argstate *arg, const char *const *args,
- size_t nargs, size_t *i_inout)
+static void parse_options(int argc, char *argv[])
{
- const char *o, *a;
- char opt;
-
- for (;;) {
- if (*i_inout >= nargs) break;
- o = args[*i_inout];
- if (STRCMP(o, ==, "--help")) { help(stdout); exit(0); }
- else if (STRCMP(o, ==, "--version")) { version(stdout); exit(0); }
- if (!*o || *o != '-' || !o[1]) break;
- (*i_inout)++;
- if (STRCMP(o, ==, "--")) break;
- o++;
- while (o && *o) {
- opt = *o++;
- switch (opt) {
-
-#define GETARG do { \
- if (*o) \
- { a = o; o = 0; } \
- else { \
- if (*i_inout >= nargs) goto noarg; \
- a = args[(*i_inout)++]; \
- } \
-} while (0)
-
- case 'C': arg->pref.n = 0; arg->pref.f = 0; break;
- case 'D': arg->f |= F_NODUMP; break;
- case 'E': arg->f |= F_NOEMBED; break;
- case 'e': GETARG; push_eval_op(arg, '!', a); break;
- case 'p': GETARG; push_eval_op(arg, '?', a); break;
- case 'l': GETARG; push_eval_op(arg, '<', a); break;
- case 'n': arg->f |= F_NOACT; break;
- case 'q': if (arg->verbose) arg->verbose--; break;
- case 'v': arg->verbose++; break;
-
- case 'I':
- free(arg->imagedir);
- GETARG; arg->imagedir = xstrdup(a);
- break;
-
- case 'L':
- GETARG;
- parse_syslist(a, arg, &arg->allow, "allowed");
- break;
-
- case 'P':
- GETARG;
- parse_syslist(a, arg, &arg->pref, "preferred");
- break;
-
- default:
- moan("unknown option `%c'", opt);
- arg->f |= F_BOGUS;
- break;
-
-#undef GETARG
-
- }
- }
- }
- goto end;
-
-noarg:
- moan("missing argument for `-%c'", opt);
- arg->f |= F_BOGUS;
-end:
- return;
-}
-
-/* Parse a string P into words (destructively), and process them as
- * command-line options, updating ARG. Non-option arguments are not
- * permitted. If `SOSF_EMACS' is set in FLAGS, then ignore `-*- ... -*-'
- * editor turds. If `SOSF_ENDOK' is set, then accept `--' and ignore
- * whatever comes after; otherwise, reject all positional arguments.
- */
-#define SOSF_EMACS 1u
-#define SOSF_ENDOK 2u
-static void scan_options_from_string(char *p, struct argstate *arg,
- unsigned flags,
- const char *what, const char *file)
-{
- struct argv av = ARGV_INIT;
- char *q;
- size_t i;
- int st = 0;
- unsigned f = 0;
-#define f_escape 1u
+ int i;
+ static const struct option opts[] = {
+ { "help", 0, 0, 'h' },
+ { "version", 0, 0, 'V' },
+ { "vanilla-image", OPTF_NEGATE, 0, 'D' },
+ { "command-line-only", OPTF_NEGATE, 0, 'E' },
+ { "accept-lisp", OPTF_ARGREQ, 0, 'L' },
+ { "config-file", OPTF_ARGREQ, 0, 'c' },
+ { "evaluate-expression", OPTF_ARGREQ, 0, 'e' },
+ { "load-file", OPTF_ARGREQ, 0, 'l' },
+ { "dry-run", OPTF_NEGATE, 0, 'n' },
+ { "set-option", OPTF_ARGREQ, 0, 'o' },
+ { "print-expression", OPTF_ARGREQ, 0, 'p' },
+ { "quiet", 0, 0, 'q' },
+ { "verbose", 0, 0, 'v' },
+ { 0, 0, 0, 0 }
+ };
+
+ optarg = 0; optind = 0; optprog = (/*unconst*/ char *)progname;
for (;;) {
- while (ISSPACE(*p)) p++;
- if (!*p) break;
- if ((flags&SOSF_EMACS) && p[0] == '-' && p[1] == '*' && p[2] == '-') {
- p = strstr(p + 3, "-*-");
- if (!p) lose("unfinished local-variables list in %s `%s'", what, file);
- p += 3; continue;
- }
- if ((flags&SOSF_ENDOK) &&
- p[0] == '-' && p[1] == '-' && (!p[2] || ISSPACE(p[2])))
- break;
- argv_append(&av, p); q = p;
- for (;;) {
- if (!*p) break;
- else if (f&f_escape) { *q++ = *p; f &= ~f_escape; }
- else if (st && *p == st) st = 0;
- else if (st != '\'' && *p == '\\') f |= f_escape;
- else if (!st && (*p == '"' || *p == '\'')) st = *p;
- else if (!st && ISSPACE(*p)) break;
- else *q++ = *p;
- p++;
+ i = mdwopt(argc, argv, "+hVD+E+L:c:e:l:n+o:p:qv", opts, 0, 0,
+ OPTF_NEGATION | OPTF_NOPROGNAME);
+ if (i < 0) break;
+ switch (i) {
+ case 'h': help(stdout); exit(0);
+ case 'V': version(stdout); exit(0);
+ case 'D': flags |= AF_VANILLA; break;
+ case 'D' | OPTF_NEGATED: flags &= ~AF_VANILLA; break;
+ case 'E': flags |= AF_NOEMBED; break;
+ case 'E' | OPTF_NEGATED: flags &= ~AF_NOEMBED; break;
+ case 'L':
+ add_lispsys(optarg, "acceptable", &accept, LF_ACCEPT,
+ offsetof(struct lispsys, next_accept));
+ break;
+ case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break;
+ case 'e': push_eval_op('!', optarg); break;
+ case 'l': push_eval_op('<', optarg); break;
+ case 'n': flags |= AF_DRYRUN; break;
+ case 'n' | OPTF_NEGATED: flags &= ~AF_DRYRUN; break;
+ case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break;
+ case 'p': push_eval_op('?', optarg); break;
+ case 'q': if (verbose) verbose--; break;
+ case 'v': verbose++; break;
+ default: flags |= AF_BOGUS; break;
}
- if (*p) p++;
- *q = 0;
- if (f&f_escape) lose("unfinished escape in %s `%s'", what, file);
- if (st) lose("unfinished `%c' string in %s `%s'", st, what, file);
}
-
- i = 0; parse_arguments(arg, av.v, av.n, &i);
- if (i < av.n)
- lose("positional argument `%s' in %s `%s'", av.v[i], what, file);
- argv_release(&av);
-
-#undef f_escape
}
-/* Read SCRIPT, and check for a `@RUNLISP:' marker in the second line. If
- * there is one, parse options from it, and update ARG.
- */
-static void check_for_embedded_args(const char *script, struct argstate *arg)
+static void handle_embedded_args(const char *script)
{
struct dstr d = DSTR_INIT;
- char *p;
+ struct argv av = ARGV_INIT;
+ char *p, *q, *r; const char *l;
+ size_t n;
+ int qstate = 0;
FILE *fp = 0;
fp = fopen(script, "r");
if (dstr_readline(&d, fp)) goto end;
dstr_reset(&d); if (dstr_readline(&d, fp)) goto end;
- p = strstr(d.p, "@RUNLISP:");
- if (p)
- scan_options_from_string(p + 9, arg, SOSF_EMACS | SOSF_ENDOK,
- "embedded options in script", script);
-
-end:
- if (fp) {
- if (ferror(fp))
- lose("error reading script `%s': %s", script, strerror(errno));
- fclose(fp);
- }
- dstr_release(&d);
-}
-
-/* Read the file PATH (if it exists) and update ARG with the arguments parsed
- * from it. Ignore blank lines and (Unix- or Lisp-style) comments.
- */
-static void read_config_file(const char *path, struct argstate *arg)
-{
- FILE *fp = 0;
- struct dstr d = DSTR_INIT;
- char *p;
+ p = strstr(d.p, "@RUNLISP:"); if (!p) goto end;
+ p += 9; q = p; l = d.p + d.len;
+ for (;;) {
+ while (p < l && ISSPACE(*p)) p++;
+ if (p >= l) break;
+ if (l - p >= 3 && p[0] == '-' && p[1] == '*' && p[2] == '-') {
+ p = strstr(p + 3, "-*-");
+ if (!p || p + 3 > l)
+ lose("%s:2: unfinished local-variables list", script);
+ p += 3;
+ continue;
+ }
+ if (l - p >= 2 && p[0] == '-' && p[1] == '-' &&
+ (l == p + 2 || ISSPACE(p[2])))
+ break;
- fp = fopen(path, "r");
- if (!fp) {
- if (errno == ENOENT) {
- if (arg->verbose > 2)
- moan("ignoring nonexistent configuration file `%s'", path);
- goto end;
+ argv_append(&av, q);
+ while (p < l && (qstate || !ISSPACE(*p))) {
+ if (*p == '"') { p++; qstate = !qstate; }
+ else if (*p == '\\') {
+ p++; if (p >= l) lose("%s:2: unfinished `\\' escape", script);
+ *q++ = *p++;
+ } else if (*p == '\'') {
+ p++; r = strchr(p, '\'');
+ if (!r || r > l) lose("%s:2: missing `''", script);
+ n = r - p; memmove(q, p, n); q += n; p = r + 1;
+ } else {
+ n = strcspn(p, qstate ? "\"\\" : "\"'\\ \f\n\r\t\v");
+ if (n > l - p) n = l - p;
+ memmove(q, p, n); q += n; p += n;
+ }
}
- lose("failed to open configuration file `%s': %s",
- path, strerror(errno));
- }
- if (arg->verbose > 1)
- moan("reading configuration file `%s'", path);
- for (;;) {
- dstr_reset(&d);
- if (dstr_readline(&d, fp)) break;
- p = d.p;
- while (ISSPACE(*p)) p++;
- if (!*p || *p == ';' || *p == '#') continue;
- scan_options_from_string(p, arg, 0, "configuration file `%s'", path);
+ if (qstate) lose("%s:2: missing `\"'", script);
+ if (p < l) p++;
+ *q++ = 0;
}
- if (arg->f&F_BOGUS)
- lose("invalid options in configuration file `%s'", path);
+
+ flags = (flags&~AF_STATEMASK) | AF_EMBED;
+ parse_options(av.n, (char * /*unconst*/*)av.v);
+ if (optind < av.n)
+ lose("%s:2: positional argument `%s' not permitted here",
+ script, av.v[optind]);
end:
if (fp) {
if (ferror(fp))
- lose("error reading configuration file `%s': %s",
- path, strerror(errno));
+ lose("error reading script `%s': %s", script, strerror(errno));
fclose(fp);
}
- dstr_release(&d);
+ dstr_release(&d); argv_release(&av);
}
int main(int argc, char *argv[])
{
+ struct config_section_iter si;
+ struct config_section *sect;
+ struct config_var *var;
+ struct lispsys_list order;
+ struct lispsys *lisp, **tail;
struct dstr d = DSTR_INIT;
- const char *script, *p;
- const char *home;
- struct passwd *pw;
- char *t;
- size_t i, n;
- struct argstate arg = ARGSTATE_INIT;
-
- /* Scan the command line. This gets low priority, since it's probably
- * from the script shebang.
- */
- set_progname(argv[0]); i = 1;
- parse_arguments(&arg, (const char *const *)argv, argc, &i);
- arg.f |= F_AUX;
- if ((i >= argc && !arg.av.n) || (arg.f&F_BOGUS))
- { usage(stderr); exit(255); }
-
- /* Prepare the argument vector. Keep track of the number of arguments
- * here: we'll need to refer to this later.
- */
- if (!arg.av.n) {
- script = argv[i++];
- if (!(arg.f&F_NOEMBED)) check_for_embedded_args(script, &arg);
- if (arg.f&F_BOGUS)
- lose("invalid options in `%s' embedded option list", script);
- } else {
- script = getenv("RUNLISP_EVAL");
- if (!script) script = DATADIR "/eval.lisp";
- argv_append(&arg.av, "--");
- }
- argv_appendn(&arg.av, (const char *const *)argv + i, argc - i);
- n = arg.av.n;
+ struct argv av = ARGV_INIT;
- /* Find the user's home directory. (Believe them if they set something
- * strange.)
- */
- home = getenv("HOME");
- if (!home) {
- pw = getpwuid(getuid());
- if (!pw) lose("can't find user in password database");
- home = pw->pw_dir;
- }
+ set_progname(argv[0]);
- /* Check user configuration file `~/.runlisprc'. */
- dstr_reset(&d);
- dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".runlisprc");
- read_config_file(d.p, &arg);
+ init_config();
+ config_set_var(&config, toplevel, 0, "prefer", "${@ENV:RUNLISP_PREFER?}");
- /* Check user configuration file `~/.config/runlisprc'. */
- dstr_reset(&d);
- p = getenv("XDG_CONFIG_HOME");
- if (p)
- dstr_puts(&d, p);
- else
- { dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".config"); }
- dstr_putc(&d, '/'); dstr_puts(&d, "runlisprc");
- read_config_file(d.p, &arg);
+ flags = (flags&~AF_STATEMASK) | AF_CMDLINE;
+ parse_options(argc - 1, argv + 1); optind++;
- /* Finally, check the environment variables. */
- p = getenv("RUNLISP_OPTIONS");
- if (p) {
- t = xstrdup(p);
- scan_options_from_string(t, &arg, 0,
- "environment variable", "RUNLISP_OPTIONS");
- free(t);
- }
- if (arg.f&F_BOGUS)
- lose("invalid options in environment variable `RUNLISP_OPTIONS'");
- if (!arg.imagedir) {
- arg.imagedir = getenv("RUNLISP_IMAGEDIR");
- if (!arg.imagedir) arg.imagedir = IMAGEDIR;
+ if (argv_tail.n)
+ flags |= AF_NOEMBED;
+ else if (!script && !argv_tail.n) {
+ if (optind < argc) script = argv[optind]++;
+ else flags |= AF_BOGUS;
}
- /* If no systems are listed as acceptable, try them all. */
- if (!arg.allow.n) {
- if (arg.verbose > 1)
- moan("no explicitly allowed implementations: allowing all");
- for (i = 0; i < NSYS; i++) arg.allow.sys[i] = &systab[i];
- arg.allow.n = NSYS; arg.allow.f = (1u << NSYS) - 1;
+ argc -= optind; argv += optind;
+ if (argv_tail.n) {
+ argv_append(&argv_tail, "--");
+ argv_appendn(&argv_tail, (const char *const *)argv, argc);
+ argc = argv_tail.n; argv = (/*unconst*/ char */*unconst*/ *)argv_tail.v;
}
- /* Print what we're going to do. */
- if (arg.verbose > 2) {
- dstr_reset(&d); p = "";
- for (i = 0; i < arg.allow.n; i++)
- { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); }
- moan("permitted Lisps: %s", d.p);
+ if (flags&AF_BOGUS) { usage(stderr); exit(2); }
+ if (!(flags&AF_NOEMBED)) handle_embedded_args(script);
+ if (!(flags&AF_SETCONF)) load_default_config();
+ if (verbose >= 5) dump_config();
- dstr_reset(&d); p = "";
- for (i = 0; i < arg.pref.n; i++)
- { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); }
- moan("preferred Lisps: %s", d.p);
+ dstr_reset(&d);
+ var = config_find_var(&config, toplevel, CF_INHERIT, "prefer");
+ config_subst_var(&config, toplevel, var, &d);
+ add_lispsys(d.p, "preferred", &prefer, LF_PREFER,
+ offsetof(struct lispsys, next_prefer));
- dstr_reset(&d); p = "";
- for (i = 0; i < arg.pref.n; i++)
- if (arg.pref.sys[i]->f&arg.allow.f)
- { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); }
- for (i = 0; i < arg.allow.n; i++)
- if (!(arg.allow.sys[i]->f&arg.pref.f))
- { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); }
- moan("overall preference order: %s", d.p);
- }
+ if (!script)
+ script = config_subst_string_alloc
+ (&config, common, "<internal>",
+ "${@ENV:RUNLISP_EVAL?${@CONFIG:data-dir}/eval.lisp}");
- /* Inform `uiop' of the script name.
- *
- * As an aside, this is a terrible interface. It's too easy to forget to
- * set it. (To illustrate this, `cl-launch -x' indeed forgets to set it.)
- * If you're lucky, the script just thinks that its argument is `nil', in
- * which case maybe it can use `*load-pathname*' as a fallback. If you're
- * unlucky, your script was invoked (possibly indirectly) by another
- * script, and now you've accidentally inherited the calling script's name.
- *
- * It would have been far better simply to repeat the script name as the
- * first user argument, if nothing else had come readily to mind.
- */
if (setenv("__CL_ARGV0", script, 1))
lose("failed to set script-name environment variable");
+ config_set_var(&config, builtin, CF_LITERAL, "@SCRIPT", script);
+
+ tail = lisps.tail;
+ for (config_start_section_iter(&config, &si);
+ (sect = config_next_section(&si)); ) {
+ var = config_find_var(&config, sect, CF_INHERIT, "run-script");
+ if (!var) continue;
+ lisp = ensure_lispsys(CONFIG_SECTION_NAME(sect),
+ CONFIG_SECTION_NAMELEN(sect));
+ lisp->f |= LF_KNOWN; lisp->sect = sect; lisp->var = var;
+ *tail = lisp; tail = &lisp->next_lisp;
+ }
+ *tail = 0; lisps.tail = tail;
+
+ check_lisps("acceptable", &accept, offsetof(struct lispsys, next_accept));
+ check_lisps("preferred", &prefer, offsetof(struct lispsys, next_prefer));
+
+ if (!accept.head) {
+ if (verbose >= 2)
+ moan("no explicitly acceptable implementations: allowing all");
+ tail = accept.tail;
+ for (lisp = lisps.head; lisp; lisp = lisp->next_lisp)
+ { lisp->f |= LF_ACCEPT; *tail = lisp; tail = &lisp->next_accept; }
+ *tail = 0; accept.tail = tail;
+ }
- /* Work through the list of preferred Lisp systems, trying the ones which
- * are allowed.
- */
- for (i = 0; i < arg.pref.n; i++)
- if (arg.pref.sys[i]->f&arg.allow.f) {
- arg.av.o += arg.av.n - n; arg.av.n = n;
- arg.pref.sys[i]->run(&arg, script);
- }
+ tail = &order.head;
+ for (lisp = prefer.head; lisp; lisp = lisp->next_prefer)
+ if (lisp->f&LF_ACCEPT) { *tail = lisp; tail = &lisp->next_order; }
+ for (lisp = accept.head; lisp; lisp = lisp->next_accept)
+ if (!(lisp->f&LF_PREFER)) { *tail = lisp; tail = &lisp->next_order; }
+ *tail = 0;
+
+ if (verbose >= 4)
+ dump_lisps("known Lisps", &lisps, offsetof(struct lispsys, next_lisp));
+ if (verbose >= 3) {
+ dump_lisps("acceptable Lisps", &accept,
+ offsetof(struct lispsys, next_accept));
+ dump_lisps("preferred Lisps", &prefer,
+ offsetof(struct lispsys, next_prefer));
+ dump_lisps("overall preference order", &order,
+ offsetof(struct lispsys, next_order));
+ }
- /* That didn't work. Try the remaining allowed systems, in the given
- * order.
- */
- for (i = 0; i < arg.allow.n; i++)
- if (!(arg.allow.sys[i]->f&arg.pref.f)) {
- arg.av.o += arg.av.n - n; arg.av.n = n;
- arg.allow.sys[i]->run(&arg, script);
+ for (lisp = order.head; lisp; lisp = lisp->next_order) {
+ if (config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) {
+ var = config_find_var(&config, lisp->sect, CF_INHERIT, "image-path");
+ dstr_reset(&d); config_subst_var(&config, lisp->sect, var, &d);
+ if (file_exists_p(d.p, verbose >= 2 ? FEF_VERBOSE : 0))
+ config_set_var(&config, lisp->sect, CF_LITERAL, "@IMAGE", "t");
}
+ argv_reset(&av);
+ config_subst_split_var(&config, lisp->sect, lisp->var, &av);
+ if (!av.n) {
+ moan("empty command for Lisp implementation `%s'", LISPSYS_NAME(lisp));
+ continue;
+ }
+ argv_appendn(&av, (const char *const *)argv, argc);
+ if (!try_exec(&av,
+ (flags&AF_DRYRUN ? TEF_DRYRUN : 0) |
+ (verbose >= 2 ? TEF_VERBOSE : 0)))
+ return (0);
+ }
- /* No joy. Give up. */
- argv_release(&arg.av);
- lose("no supported Lisp systems found");
+ lose("no acceptable Lisp systems found");
}
/*----- That's all, folks -------------------------------------------------*/
--- /dev/null
+;;; -*-conf-windows-*-
+
+;; Summary of syntax.
+;;
+;; Sections are started with a line `[NAME]', starting in the leftmost
+;; column. Empty lines and lines starting with `;' -- /without/ preceding
+;; whitespace -- are ignored. Assignments have the form `VAR = VALUE'; the
+;; VALUE may be continued across multiple lines, if they begin with
+;; whitespace. All of the lines are stripped of initial and final whitespace
+;; and concatenated with spaces.
+;;
+;; Values may contain substitutions:
+;;
+;; * ${[SECTION:]VAR[?ALT]} -- replace with the value of VAR in SECTION; if
+;; not found, use ALT instead. (If ALT isn't provided, it's an error.)
+;;
+;; * $?[SECTION:]VAR{YES[|NO]} -- look up VAR in SECTION (or in the
+;; (original) current section, and `@COMMON'); if found, use YES,
+;; otherwise use NO.
+;;
+;; Variables are looked up starting in the home (or explicitly specified)
+;; section, then proceeding to the parents assigned to `@PARENTS'.
+;; (`@PARENTS' usually defaults to `@COMMON'; the parent of `@COMMON' is
+;; `@BUILTIN'; `@BUILTIN' and `@CONFIG' have no parents.)
+;;
+;; At top-level, the text is split into words at whitespace, unless prevented
+;; by double- and single-quote, or escaped by `\'. Within single quotes, all
+;; characters are treated literally. Within double quotes, `\' and `$' still
+;; works. A variable reference within quotes, or within a word, suppresses
+;; word-splitting and quoting, within the variable value -- but `$'
+;; expansions still work.
+
+;;;--------------------------------------------------------------------------
+[@COMMON]
+
+;; Turn `#!' into a comment-to-end-of-line. This is used in all Lisp
+;; invocations, even though some of them don't apparently need it. For
+;; example, SBCL ignores an initial line beginning `#!' as a special feature
+;; of its `--script' option. Other Lisps won't do this, so a countermeasure
+;; like the following is necessary in their case. For the sake of a
+;; consistent environment, we ignore `#!' lines everywhere, even in Lisps
+;; which have their own, more specific, solution to this problem.
+ignore-shebang =
+ (set-dispatch-macro-character
+ #\\# #\\!
+ (lambda (#1=#:stream #2=#:char #3=#:arg)
+ (declare (ignore #2# #3#))
+ (values (read-line #1#))))
+
+;; Clear all present symbols from the `COMMON-LISP-USER' package. Some Lisps
+;; leave débris in `COMMON-LISP-USER' -- for example, ECL leaves some
+;; allegedly useful symbols lying around, while ABCL has a straight-up bug in
+;; its `adjoin.lisp' file.
+clear-cl-user =
+ (let ((#4=#:pkg (find-package "COMMON-LISP-USER")))
+ (with-package-iterator (#5=#:next #4# :internal)
+ (loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how)
+ (#5#)
+ (declare (ignore #8#))
+ (unless #6# (return))
+ (unintern #7# #4#)))))
+
+;; Add `:runlisp-script' to `*features*' so that scripts can tell whether
+;; they're supposed to sit quietly and be debugged in a Lisp session or run
+;; as a script.
+set-script-feature =
+ (pushnew :runlisp-script *features*)
+
+;; Load the system's ASDF.
+require-asdf =
+ (require "asdf")
+
+;; Prevent ASDF from upgrading itself. Otherwise it will do this
+;; automatically if a script invokes `asdf:load-system', but that will have a
+;; bad effect on startup time, and risks spamming the output streams with
+;; drivel.
+inhibit-asdf-upgrade =
+ (funcall (intern "REGISTER-IMMUTABLE-SYSTEM"
+ (find-package "ASDF"))
+ "asdf")
+
+;; Upgrade ASDF from the source registry.
+upgrade-asdf =
+ (funcall (intern "UPGRADE-ASDF" (find-package "ASDF")))
+
+;; Common actions when resuming a custom image.
+image-restore =
+ (uiop:call-image-restore-hook)
+
+;; Common prelude for script startup in vanilla images. Most of this is
+;; already done in custom images.
+run-script-prelude =
+ (progn
+ (setf *load-verbose* nil *compile-verbose* nil)
+ ${require-asdf}
+ ${inhibit-asdf-upgrade}
+ ${ignore-shebang}
+ ${set-script-feature})
+
+;; Common prelude for dumping images.
+dump-image-prelude =
+ (progn
+ ${require-asdf}
+ ${upgrade-asdf}
+ ${inhibit-asdf-upgrade}
+ ${ignore-shebang}
+ ${set-script-feature})
+
+image-path = ${@CONFIG:image-dir}/${image-file}
+
+;;;--------------------------------------------------------------------------
+[sbcl]
+
+command = ${@ENV:SBCL?sbcl}
+image-file = sbcl+asdf.core
+
+run-script =
+ ${command} --noinform
+ $?@IMAGE{--core "${image-path}" --eval "${image-restore}" |
+ --eval "${run-script-prelude}"}
+ --script ${@SCRIPT}
+
+dump-image =
+ ${command} --noinform --no-userinit --no-sysinit --disable-debugger
+ --eval "${dump-image-prelude}"
+ --eval "(sb-ext:save-lisp-and-die \"${@IMAGE|q}\")"
+
+
+;;;--------------------------------------------------------------------------
+[ccl]
+
+command = ${@ENV:CCL?ccl}
+image-file = ccl+asdf.image
+
+run-script =
+ ${command} -b -n -Q
+ $?@IMAGE{-I "${image-path}" -e "${image-restore}" |
+ -e "${run-script-prelude}"}
+ -l ${@SCRIPT} -e "(ccl:quit)" --
+
+;; A snaglet occurs here. CCL wants to use the image name as a clue to where
+;; the rest of its installation is; but in fact the image is nowhere near its
+;; installation. So we must hack...
+dump-image =
+ ${command} -b -n -Q
+ -e "${dump-image-prelude}"
+ -e "(ccl::in-development-mode
+ (let ((#1=#:real-ccl-dir (ccl::ccl-directory)))
+ (defun ccl::ccl-directory ()
+ (let* ((#2=#:dirpath
+ (ccl:getenv \"CCL_DEFAULT_DIRECTORY\")))
+ (if (and #2# (plusp (length (namestring #2#))))
+ (ccl::native-to-directory-pathname #2#)
+ #1#))))
+ (compile 'ccl::ccl-directory))"
+ -e "(ccl:save-application \"${@IMAGE|q}\"
+ :init-file nil
+ :error-handler :quit)"
+
+;;;--------------------------------------------------------------------------
+[clisp]
+
+;; CLisp causes much sadness. Superficially, it's the most sensible of all
+;; of the systems supported here: you just run `clisp SCRIPT -- ARGS ...' and
+;; it works.
+;;
+;; The problems come when you want to do some preparatory work (e.g., load
+;; `asdf') and then run the script. There's a `-x' option to evaluate some
+;; Lisp code, but it has three major deficiencies.
+;;
+;; * It insists on printing the values of the forms it evaluates. It
+;; prints a blank line even if the form goes out of its way to produce no
+;; values at all. So the whole thing has to be a single top-level form
+;; which quits the Lisp rather than returning.
+;;
+;; * For some idiotic reason, you can have /either/ `-x' forms /or/ a
+;; script, but not both. So we have to include the `load' here
+;; explicitly. I suppose that was inevitable because we have to inhibit
+;; printing of the result forms, but it's still a separate source of
+;; annoyance.
+;;
+;; * The icing on the cake: the `-x' forms are collectively concatenated --
+;; without spaces! -- and used to build a string stream, which is then
+;; assigned over the top of `*standard-input*', making the original stdin
+;; somewhat fiddly to track down.
+;;
+;; There's a `-i' option which will load a file without any of this
+;; stupidity, but nothing analogous for immediate expressions.
+
+clisp-common-startup =
+ (setf *standard-input* (ext:make-stream :input))
+ (load "${@SCRIPT|q}" :verbose nil :print nil)
+ (ext:quit)
+
+command = ${@ENV:CLISP?clisp}
+image-file = clisp+asdf.mem
+
+run-script =
+ ${command}
+ $?@IMAGE{-M "${image-path}" -q
+ -x "(progn
+ ${image-restore}
+ ${clisp-common-startup})" |
+ -norc -q
+ -x "(progn
+ ${run-script-prelude}
+ ${clisp-common-startup})"}
+ --
+
+dump-image =
+ ${command} -norc -q -q
+ -x "${dump-image-prelude}"
+ -x "(ext:saveinitmem \"${@IMAGE|q}\" :norc t :script t)"
+
+;;;--------------------------------------------------------------------------
+[ecl]
+
+command = ${@ENV:ECL?ecl}
+image-file = ecl+asdf
+
+run-script =
+ $?@IMAGE{"${image-path}" -s ${@SCRIPT} |
+ ${@ENV:ECL?ecl} "${@ECLOPT}norc"
+ "${@ECLOPT}eval" "(progn
+ ${run-script-prelude}
+ ${clear-cl-user})"
+ "${@ECLOPT}shell" ${@SCRIPT}}
+ --
+
+dump-image =
+ "${@CONFIG:data-dir}/dump-ecl"
+ "${@IMAGE}" "${command}" "${@ECLOPT}" "${@TMPDIR}"
+
+;;;--------------------------------------------------------------------------
+[cmucl]
+
+command = ${@ENV:CMUCL?cmucl}
+image-file = cmucl+asdf.core
+
+run-script =
+ ${command}
+ $?@IMAGE{-core "${image-path}" -eval "${image-restore}" |
+ -batch -noinit -nositeinit -quiet
+ -eval "(progn
+ (setf ext:*require-verbose* nil)
+ ${run-script-prelude})"}
+ -load ${@SCRIPT} -eval "(ext:quit)" --
+
+dump-image =
+ ${command} -batch -noinit -nositeinit -quiet
+ -eval "${dump-image-prelude}"
+ -eval "(ext:save-lisp \"${@IMAGE|q}\"
+ :batch-mode t :print-herald nil
+ :site-init nil :load-init-file nil)"
+
+;;;--------------------------------------------------------------------------
+[abcl]
+
+;; CLisp made a worthy effort, but ABCL still manages to take the prize.
+;;
+;; * ABCL manages to avoid touching the `stderr' stream at all, ever. Its
+;; startup machinery finds `stdout' (as `java.lang.System.out'), wraps it
+;; up in a Lisp stream, and uses the result as `*standard-output*' and
+;; `*error-output*' (and a goodly number of other things too). So we
+;; must manufacture a working `stderr' the hard way.
+;;
+;; * There doesn't appear to be any easy way to prevent toplevel errors
+;; from invoking the interactive debugger. For extra fun, the debugger
+;; reads from `stdin' by default, so an input file which somehow manages
+;; to break the script can then take over its brain by providing Lisp
+;; forms for the debugger to evaluate.
+;;
+;; * And, just to really top everything off, ABCL's `adjoin.lisp' is
+;; missing an `(in-package ...)' form at the top, so it leaks symbols
+;; into the `COMMON-LISP-USER' package.
+
+command = ${@ENV:ABCL?abcl}
+
+abcl-startup =
+ (let ((#9=#:script "${@SCRIPT|q}"))
+ ${run-script-prelude}
+ ${clear-cl-user}
+ (setf *error-output*
+ (java:jnew "org.armedbear.lisp.Stream"
+ \'sys::system-stream
+ (java:jfield "java.lang.System" "err")
+ \'character
+ java:+true+))
+ (handler-case (load #9# :verbose nil :print nil)
+ (error (error)
+ (format *error-output* "~A (unhandled error): ~A~%" #9# error)
+ (ext:quit :status 255))))
+
+run-script =
+ ${command} --batch --noinform --noinit --nosystem
+ --eval "${abcl-startup}"
+ --
+
+;;;----- That's all, folks --------------------------------------------------