/* -*-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 <pwd.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#)))))"
-
-/*----- 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 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); }
+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 */
-/*----- 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.
- *
- * * 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.
+/* Check that the Lisp systems on LIST (linked through LINKOFF) are real.
*
- * * 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.
- *
- * * 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.
+/* Add an eval-mode operation to the `argv_tail' vector.
*
- * * 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] [-d EXPR] [-p EXPR] [-l FILE]\n\
+ [--] [ARGUMENTS ...]\n\
+OPTIONS:\n\
+ [-DEnqv] [+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\
+ -d, --dump-expression=EXPR Print (`prin1') EXPR (repeatable).\n\
+ -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\
+ -l, --load-file=FILE Load FILE (repeatable).\n\
+ -p, --print-expression=EXPR Print (`princ') 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' },
+ { "dump-expression", OPTF_ARGREQ, 0, 'd' },
+ { "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:d: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 'd': CMDL; push_eval_op('?', optarg); 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);
+
+#undef FLAGOPT
+#undef CMDL
}
-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, "<internal>",
+ "${@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.)
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 preferred Lisps actually exist. */
+ 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 are known but not 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_KNOWN) && !(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 -------------------------------------------------*/
~mdw / runlisp / blobdiff