X-Git-Url: https://git.distorted.org.uk/~mdw/runlisp/blobdiff_plain/e29834b853038e8c90dcfe8377f02431cad42fc5..e41cbc79e39d62f0343a48efc4d832ed99c83aaf:/runlisp.c diff --git a/runlisp.c b/runlisp.c index 300c8ed..65741ad 100644 --- a/runlisp.c +++ b/runlisp.c @@ -1,6 +1,6 @@ /* -*-c-*- * - * Invoke a Lisp script + * Invoke Lisp scripts and implementations * * (c) 2020 Mark Wooding */ @@ -27,1187 +27,480 @@ #include "config.h" -#include #include #include -#include #include #include #include -#include -#include - -#include - -/*----- 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 +#include "common.h" +#include "lib.h" +#include "mdwopt.h" + +/*----- Static data -------------------------------------------------------*/ + +/* The state we need for a Lisp system. */ +struct lispsys { + struct treap_node _node; /* treap intrusion */ + struct lispsys *next_lisp, /* link in all-Lisps list */ + *next_accept, /* link acceptable-Lisps list */ + *next_prefer, /* link in preferred-Lisps list */ + *next_order; /* link in overall-order list */ + unsigned f; /* flags */ +#define LF_KNOWN 1u /* this is actually a Lisp */ +#define LF_ACCEPT 2u /* this is an acceptable Lisp */ +#define LF_PREFER 4u /* this is a preferred Lisp */ + struct config_section *sect; /* configuration section */ + struct config_var *var; /* `run-script variable */ }; +#define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp) +#define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp) -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 -}; - -/*----- 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); -} +/* Pick out a link from a `struct lispsys' object given its offset. */ +#define LISP_LINK(lisp, linkoff) \ + ((struct lispsys **)((unsigned char *)(lisp) + (linkoff))) -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; +/* A list of Lisp systems. */ +struct lispsys_list { + struct lispsys *head, **tail; /* list head and tail */ }; -#define DSTR_INIT { 0, 0, 0 } -/* -static void dstr_init(struct dstr *d) { d->p = 0; d->len = d->sz = 0; } -*/ +static struct argv argv_tail = ARGV_INIT; /* accumulates eval-mode args */ +struct treap lispsys = TREAP_INIT; /* track duplicate Lisp systems */ +static struct lispsys_list /* lists of Lisp systems */ + lisps = { 0, &lisps.head }, /* all known */ + accept = { 0, &accept.head }, /* acceptable */ + prefer = { 0, &prefer.head }; /* preferred */ + +static unsigned flags = 0; /* flags for the application */ +#define AF_CMDLINE 0x0000u /* options are from command-line */ +#define AF_EMBED 0x0001u /* reading embedded options */ +#define AF_STATEMASK 0x000fu /* mask of option origin codes */ +#define AF_BOGUS 0x0010u /* invalid command-line syntax */ +#define AF_SETCONF 0x0020u /* explicit configuration */ +#define AF_NOEMBED 0x0040u /* don't read embedded options */ +#define AF_DRYRUN 0x0080u /* don't actually do it */ +#define AF_VANILLA 0x0100u /* don't use custom images */ -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 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; } - -static void argv_appendz(struct argv *av) - { argv_ensure(av, 1); av->v[av->n + av->o] = 0; } - -static void argv_appendn(struct argv *av, const char *const *v, size_t n) -{ - argv_ensure(av, n); - memcpy(av->v + av->n + av->o, v, n*sizeof(const char *)); - av->n += n; -} - -/* -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) -{ - const char *p; - - for (;;) - { p = va_arg(ap, const char *); if (!p) break; argv_append(av, p); } -} -*/ - -/* -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) -{ - argv_ensure_offset(av, 1); - av->o -= n; av->n += n; - memcpy(av->v + av->o, v, n*sizeof(const char *)); -} -*/ - -/* -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; - } -} - -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) -----------------------------------------*/ +/*----- Main code ---------------------------------------------------------*/ -static const struct systab *find_system(const char *name) +/* Return the `struct lispsys' entry for the given N-byte NAME. */ +static struct lispsys *ensure_lispsys(const char *name, size_t n) { - const struct systab *sys; - size_t i; + struct lispsys *lisp; + struct treap_path path; - for (i = 0; i < NSYS; i++) { - sys = &systab[i]; - if (STRCMP(name, ==, sys->name)) return (sys); + 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); } - lose("unknown Lisp system `%s'", name); + return (lisp); } -static void lisp_quote_string(struct dstr *d, const char *p) +/* Add Lisp systems from the comma- or space-sparated list P to LIST. + * + * WHAT is an adjective describing the list flavour; FLAG is a bit to set in + * the node's flags word; LINKOFF is the offset of the list's link member. + */ +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; } + while (ISSPACE(*p)) p++; 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[av->o + i]); - dstr_putc(&d, '"'); + q = p; while (*p && !ISSPACE(*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; } - 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)); + while (ISSPACE(*p)) p++; + if (!*p) break; + if (*p == ',') p++; } - if (arg->verbose > 1) moan("`%s' not found", av->v[av->o]); - 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. +/* Check that the Lisp systems on LIST (linked through LINKOFF) are real. * - * * 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. + * That is, `LF_KNOWN' is set in their flags. */ - -#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) +static void check_lisps(const char *what, + struct lispsys_list *list, size_t linkoff) { - 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); + struct lispsys *lisp; -#undef f + for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff)) + if (!(lisp->f&LF_KNOWN)) + lose("unknown Lisp implementation `%s'", LISPSYS_NAME(lisp)); } -/* Embeddable Common Lisp. * +/* Dump the names of the Lisp systems on LIST (linked through LINKOFF). * - * 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. + * WHAT is an adjective describing the list. */ - -#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) +static void dump_lisps(const char *what, + struct lispsys_list *list, size_t linkoff) { 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); + 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_puts(&d, LISPSYS_NAME(lisp)); } - 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); + if (first) dstr_puts(&d, "(none)"); + dstr_putz(&d); + moan("%s: %s", what, d.p); dstr_release(&d); } -/* Armed Bear Common Lisp. * - * - * CLisp made a worthy effort, but ABCL still manages to take the price. +/* Add an eval-mode operation to the `argv_tail' vector. * - * * 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. + * OP is the operation character (see `eval.lisp' for these) and `val' is the + * argument (filename or expression). */ - -#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) +static void push_eval_op(char op, const char *val) { - struct dstr d = DSTR_INIT; + char *p; + size_t n; - 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); -} + if ((flags&AF_STATEMASK) != AF_CMDLINE) { + moan("must use `-e', `-p', or `-l' on command line"); + flags |= AF_BOGUS; + return; + } -/*----- Main code ---------------------------------------------------------*/ + n = strlen(val) + 1; + p = xmalloc(n + 1); + p[0] = op; memcpy(p + 1, val, n); + argv_append(&argv_tail, p); +} +/* Help and related functions. */ 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); + 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 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", +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); } -/* 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) +/* Complain about options which aren't permitted as embedded options. */ +static void check_command_line(int ch) { - char *copy = xstrdup(spec), *p = copy, *q; - const struct systab *sys; - size_t n; + if ((flags&AF_STATEMASK) != AF_CMDLINE) { + moan("`%c%c' is not permitted as embedded option", + ch&OPTF_NEGATED ? '+' : '-', + ch&~OPTF_NEGATED); + flags |= AF_BOGUS; + } +} +/* Parse the options in the argument vector. */ +static void parse_options(int argc, char *argv[]) +{ + 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 } + }; + +#define FLAGOPT(ch, f, extra) \ + case ch: \ + extra \ + flags |= f; \ + break; \ + case ch | OPTF_NEGATED: \ + extra \ + flags &= ~f; \ + break +#define CMDL do { check_command_line(i); } while (0) + + optarg = 0; optind = 0; optprog = (/*unconst*/ char *)progname; 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; + 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': CMDL; help(stdout); exit(0); + case 'V': CMDL; version(stdout); exit(0); + FLAGOPT('D', AF_VANILLA, ; ); + FLAGOPT('E', AF_NOEMBED, { CMDL; }); + case 'L': + add_lispsys(optarg, "acceptable", &accept, LF_ACCEPT, + offsetof(struct lispsys, next_accept)); + break; + case 'c': CMDL; read_config_path(optarg, 0); flags |= AF_SETCONF; break; + case 'e': CMDL; push_eval_op('!', optarg); break; + case 'l': CMDL; push_eval_op('<', optarg); break; + FLAGOPT('n', AF_DRYRUN, { CMDL; }); + case 'o': CMDL; if (set_config_var(optarg)) flags |= AF_BOGUS; break; + case 'p': CMDL; push_eval_op('?', optarg); break; + case 'q': CMDL; if (verbose) verbose--; break; + case 'v': CMDL; verbose++; break; + default: flags |= AF_BOGUS; break; } - if (!q) break; - p = q; } - free(copy); } -static void push_eval_op(struct argstate *arg, char op, const char *val) +/* Extract and process the embedded options from a SCRIPT. */ +static void handle_embedded_args(const char *script) { - char *p; + struct dstr d = DSTR_INIT; + struct argv av = ARGV_INIT; + char *p, *q, *r; const char *l; size_t n; + int qstate = 0; + FILE *fp = 0; - if (arg->f&F_AUX) { - moan("must use `-e', `-p', or `-l' on command line"); - arg->f |= F_BOGUS; - return; - } + /* Open the script. If this doesn't work, then we have no hope. */ + fp = fopen(script, "r"); + if (!fp) lose("can't read script `%s': %s", script, strerror(errno)); - n = strlen(val) + 1; - p = xmalloc(n + 1); - p[0] = op; memcpy(p + 1, val, n); - argv_append(&arg->av, p); -} + /* Read the second line. */ + if (dstr_readline(&d, fp)) goto end; + dstr_reset(&d); if (dstr_readline(&d, fp)) goto end; -/* 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; + /* Check to find the magic marker. */ + p = strstr(d.p, "@RUNLISP:"); if (!p) goto end; + p += 9; q = p; l = d.p + d.len; + /* Split the line into words. + * + * Do this by hand because we have strange things to support, such as Emacs + * turds and the early `--' exit. + * + * We work in place: `p' is the input cursor and advances through the + * string as we parse, until it meets the limit pointer `l'; `q' is the + * output cursor which will always be no further forward than `p'. + */ 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 + /* Iterate over the words. */ - } - } - } - goto end; + /* Skip spaces. */ + while (p < l && ISSPACE(*p)) p++; -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 + /* If we've reached the end then we're done. */ + if (p >= l) break; - for (;;) { - while (ISSPACE(*p)) p++; - if (!*p) break; - if ((flags&SOSF_EMACS) && p[0] == '-' && p[1] == '*' && p[2] == '-') { + /* Check for an Emacs local-variables `-*-' turd. + * + * If we find one, find the matching end marker and move past it. + */ + if (l - p >= 3 && 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 (!p || p + 3 > l) + lose("%s:2: unfinished local-variables list", script); + p += 3; + continue; } - if ((flags&SOSF_ENDOK) && - p[0] == '-' && p[1] == '-' && (!p[2] || ISSPACE(p[2]))) + + /* If we find a `--' marker then stop immediately. */ + if (l - p >= 2 && p[0] == '-' && p[1] == '-' && + (l == 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); + /* Push the output cursor position onto the output, because this is where + * the next word will start. + */ + argv_append(&av, q); -#undef f_escape -} + /* Collect characters until we find an unquoted space. */ + while (p < l && (qstate || !ISSPACE(*p))) { -/* 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; + if (*p == '"') + /* A quote. Skip past, and toggle quotedness. */ - fp = fopen(script, "r"); - if (!fp) lose("can't read script `%s': %s", script, strerror(errno)); + { p++; qstate = !qstate; } - if (dstr_readline(&d, fp)) goto end; - dstr_reset(&d); if (dstr_readline(&d, fp)) goto end; + else if (*p == '\\') { + /* A backslash. Just emit the following character. */ - p = strstr(d.p, "@RUNLISP:"); - if (p) - scan_options_from_string(p + 9, arg, SOSF_EMACS | SOSF_ENDOK, - "embedded options in script", script); + p++; if (p >= l) lose("%s:2: unfinished `\\' escape", script); + *q++ = *p++; -end: - if (fp) { - if (ferror(fp)) - lose("error reading script `%s': %s", script, strerror(errno)); - fclose(fp); - } - dstr_release(&d); -} + } else if (*p == '\'') { + /* A single quote. Find its matching end quote, and emit everything + * in between. + */ -/* 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++; r = strchr(p, '\''); + if (!r || r > l) lose("%s:2: missing `''", script); + n = r - p; memmove(q, p, n); q += n; p = r + 1; - fp = fopen(path, "r"); - if (!fp) { - if (errno == ENOENT) { - if (arg->verbose > 2) - moan("ignoring nonexistent configuration file `%s'", path); - goto end; + } else { + /* An ordinary constituent. Gather a bunch of these up and emit them + * all. + */ + 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); + + /* Check that we're not still inside quotes. */ + if (qstate) lose("%s:2: missing `\"'", script); + + /* Finish off this word and prepare to start the next. */ + *q++ = 0; if (p < l) p++; } - if (arg->f&F_BOGUS) - lose("invalid options in configuration file `%s'", path); + + /* Parse the arguments we've collected as options. Object if we find + * positional arguments. + */ + 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: + /* Tidy up. */ 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); } +/* Main program. */ 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; + const char *p; + const char *script; 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. + struct argv av = ARGV_INIT; + + /* initial setup. */ + set_progname(argv[0]); + init_config(); + + /* Parse the command-line options. */ + flags = (flags&~AF_STATEMASK) | AF_CMDLINE; + parse_options(argc - 1, argv + 1); optind++; + + /* We now know enough to decide whether we're in eval or script mode. In + * the former case, don't check for embedded options (it won't work because + * we don't know where the `eval.lisp' script is yet, and besides, there + * aren't any). In the latter case, pick out the script name, leaving the + * remaining positional arguments for 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; + if (argv_tail.n) { flags |= AF_NOEMBED; script = 0; } + else if (optind < argc) script = argv[optind++]; + else flags |= AF_BOGUS; - /* Find the user's home directory. (Believe them if they set something - * strange.) + /* Check that everything worked. */ + if (flags&AF_BOGUS) { usage(stderr); exit(127); } + + /* Reestablish ARGC/ARGV to refer to the tail of positional arguments to be + * passed onto the eventual script. For eval mode, that includes the + * operations already queued up, so we'll have to accumulate everything in + * `argv_tail'. */ - home = getenv("HOME"); - if (!home) { - pw = getpwuid(getuid()); - if (!pw) lose("can't find user in password database"); - home = pw->pw_dir; + argc -= optind; argv += optind; + if (argv_tail.n) { + argv_append(&argv_tail, "--"); + argv_appendn(&argv_tail, argv, argc); + argc = argv_tail.n; argv = argv_tail.v; } - /* 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); + /* Fetch embedded options. */ + if (!(flags&AF_NOEMBED)) handle_embedded_args(script); - /* 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; - } + /* Load default configuration if no explicit files were requested. */ + if (!(flags&AF_SETCONF)) load_default_config(); - /* 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; + /* Determine the preferred Lisp systems. Check the environment first; + * otherwise use the configuration file. + */ + p = my_getenv("RUNLISP_PREFER", 0); + if (!p) { + var = config_find_var(&config, toplevel, CF_INHERIT, "prefer"); + if (var) { + dstr_reset(&d); + config_subst_var(&config, toplevel, var, &d); p = d.p; + } } + if (p) + add_lispsys(p, "preferred", &prefer, LF_PREFER, + offsetof(struct lispsys, next_prefer)); - /* 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); - - 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); 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 we're in eval mode, then find the `eval.lisp' script. */ + if (!script) + script = config_subst_string_alloc(&config, common, "", + "${@ENV:RUNLISP_EVAL?" + "${@CONFIG:eval-script?" + "${@data-dir}/eval.lisp}}"); - /* Inform `uiop' of the script name. + /* We now have the script name, so publish it for `uiop'. * * 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.) @@ -1222,27 +515,102 @@ int main(int argc, char *argv[]) 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. + /* And publish it in the configuration for the `run-script' commands. */ + config_set_var(&config, builtin, CF_LITERAL, "@script", script); + + /* Dump the final configuration if we're being very verbose. */ + if (verbose >= 5) dump_config(); + + /* Identify the configuration sections which correspond to actual Lisp + * system definitions, and gather them into the `known' list. */ - 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 = 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; + + /* Make sure that the acceptable and preferred Lisps actually exist. */ + check_lisps("acceptable", &accept, offsetof(struct lispsys, next_accept)); + check_lisps("preferred", &prefer, offsetof(struct lispsys, next_prefer)); + + /* If there are no acceptable Lisps, then we'll take all of them. */ + 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; + } - /* That didn't work. Try the remaining allowed systems, in the given - * order. + /* Build the final list of Lisp systems in the order in which we'll try + * them: first, preferred Lisps which are acceptable, and then acceptable + * Lisps which aren't preferred. */ - 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); + 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; + + /* Maybe dump out the various lists of Lisp systems we've collected. */ + 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)); + } + + /* Try to actually run the script. */ + for (lisp = order.head; lisp; lisp = lisp->next_order) { + /* Try each of the selected systems in turn. */ + + /* See whether there's a custom image file. If so, set `@image' in the + * system's configuration section. + */ + if (!(flags&AF_VANILLA) && + config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) { + var = config_find_var(&config, lisp->sect, CF_INHERIT, "image-path"); + if (!var) + lose("variable `image-path' not defined for Lisp `%s'", + LISPSYS_NAME(lisp)); + 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"); } - /* No joy. Give up. */ - argv_release(&arg.av); - lose("no supported Lisp systems found"); + /* Build the command line from `run-script'. */ + 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; + } + + /* Append our additional positional arguments. */ + argv_appendn(&av, argv, argc); + + /* Try to run the Lisp system. */ + if (!try_exec(&av, + (flags&AF_DRYRUN ? TEF_DRYRUN : 0) | + (verbose >= 2 ? TEF_VERBOSE : 0))) + return (0); + } + + /* No. Much errors. So failure. Very sadness. */ + lose("no acceptable Lisp systems found"); } /*----- That's all, folks -------------------------------------------------*/