--- /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 -------------------------------------------------*/
~mdw / runlisp / blobdiff