[runlisp] / runlisp.c

/* -*-c-*-
 *
 * Invoke a Lisp script
 *
 * (c) 2020 Mark Wooding
 */

/*----- Licensing notice --------------------------------------------------*
 *
 * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
 *
 * Runlisp is free software: you can redistribute it and/or modify it
 * under the terms of the GNU General Public License as published by the
 * Free Software Foundation; either version 3 of the License, or (at your
 * option) any later version.
 *
 * Runlisp is distributed in the hope that it will be useful, but WITHOUT
 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 * for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.
 */

/*----- Header files ------------------------------------------------------*/

#include "config.h"

#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#include <unistd.h>
#include <sys/stat.h>

#include <pwd.h>

/*----- Common Lisp runes -------------------------------------------------*/

/* A common preamble rune to do the necessary things.
 *
 * We need to ensure that `asdf' (and therefore `uiop') is loaded.  And we
 * should arrange for `:runlisp-script' to find its way into the `*features*'
 * list so that scripts can notice that they're being invoked from the
 * command line rather than loaded into a resident session, and actually do
 * something useful.
 */
#define COMMON_PRELUDE_RUNE                                             \
        "(progn "                                                       \
          "(setf *load-verbose* nil *compile-verbose* nil) "            \
          "(require \"asdf\") "                                         \
          "(funcall (intern \"REGISTER-IMMUTABLE-SYSTEM\" "             \
                           "(find-package \"ASDF\")) "                  \
                   "\"asdf\") "                                         \
          "(set-dispatch-macro-character "                              \
           "#\\# #\\! "                                                 \
           "(lambda (#1=#:stream #2=#:char #3=#:arg) "                  \
             "(declare (ignore #2# #3#)) "                              \
             "(values (read-line #1#)))) "                              \
          "(pushnew :runlisp-script *features*))"

/* Get `uiop' to re-check the command-line arguments following an image
 * restore.
 */
#define IMAGE_RESTORE_RUNE                                              \
        "(uiop:call-image-restore-hook)"

/* Some Lisps leave crud in the `COMMON-LISP-USER' package.  Clear it out. */
#define CLEAR_CL_USER_RUNE                                              \
        "(let ((#4=#:pkg (find-package \"COMMON-LISP-USER\"))) "        \
          "(with-package-iterator (#5=#:next #4# :internal) "           \
            "(loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how) " \
                      "(#5#) "                                          \
                    "(declare (ignore #8#)) "                           \
                    "(unless #6# (return)) "                            \
                    "(unintern #7# #4#)))))"

/*----- Handy macros ------------------------------------------------------*/

#define N(v) (sizeof(v)/sizeof((v)[0]))

#if defined(__GNUC__)
#  define GCC_VERSION_P(maj, min)                                       \
        (__GNUC__ > (maj) || (__GNUC__ == (maj) && __GNUC_MINOR__ >= (min)))
#else
#  define GCC_VERSION_P(maj, min) 0
#endif

#ifdef __clang__
#  define CLANG_VERSION_P(maj, min)                                     \
        (__clang_major__ > (maj) || (__clang_major__ == (maj) &&        \
                                     __clang_minor__ >= (min)))
#else
#  define CLANG_VERSION_P(maj, min) 0
#endif

#if GCC_VERSION_P(2, 5) || CLANG_VERSION_P(3, 3)
#  define NORETURN __attribute__((__noreturn__))
#  define PRINTF_LIKE(fix, aix) __attribute__((__format__(printf, fix, aix)))
#endif

#if GCC_VERSION_P(4, 0) || CLANG_VERSION_P(3, 3)
#  define EXECL_LIKE(ntrail) __attribute__((__sentinel__(ntrail)))
#endif

#define CTYPE_HACK(func, ch) (func((unsigned char)(ch)))
#define ISSPACE(ch) CTYPE_HACK(isspace, ch)

#define MEMCMP(x, op, y, n) (memcmp((x), (y), (n)) op 0)
#define STRCMP(x, op, y) (strcmp((x), (y)) op 0)
#define STRNCMP(x, op, y, n) (strncmp((x), (y), (n)) op 0)

#define END ((const char *)0)

/*----- The Lisp implementation table -------------------------------------*/

/* The systems, in decreasing order of (not quite my personal) preference.
 * This list is used to initialize various tables and constants.
 */
#define LISP_SYSTEMS(_)                                                 \
        _(sbcl)                                                         \
        _(ccl)                                                          \
        _(clisp)                                                        \
        _(ecl)                                                          \
        _(cmucl)                                                        \
        _(abcl)

enum {
#define DEFSYS(sys) sys##_INDEX,
  LISP_SYSTEMS(DEFSYS)
#undef DEFSYS
  NSYS
};

enum {
#define DEFFLAG(sys) sys##_FLAG = 1 << sys##_INDEX,
  LISP_SYSTEMS(DEFFLAG)
#undef DEFFLAG
  ALL_SYSTEMS = 0
#define SETFLAG(sys) | sys##_FLAG
  LISP_SYSTEMS(SETFLAG)
#undef SETFLAG
};

struct argstate;
struct argv;

#define DECLENTRY(sys) \
static void run_##sys(struct argstate *, const char *);
  LISP_SYSTEMS(DECLENTRY)
#undef DECLENTRY

static const struct systab {
  const char *name;
  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);
}

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;
};
#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); }

/*----- Lisp system table (redux) -----------------------------------------*/

static const struct systab *find_system(const char *name)
{
  const struct systab *sys;
  size_t i;

  for (i = 0; i < NSYS; i++) {
    sys = &systab[i];
    if (STRCMP(name, ==, sys->name)) return (sys);
  }
  lose("unknown Lisp system `%s'", name);
}

static void lisp_quote_string(struct dstr *d, const char *p)
{
  size_t n;

  for (;;) {
    n = strcspn(p, "\"\\");
    if (n) { dstr_putm(d, p, n); p += n; }
    if (!*p) break;
    dstr_putc(d, '\\'); dstr_putc(d, *p++);
  }
  dstr_putz(d);
}

static const char *expand_rune(struct dstr *d, const char *rune, ...)
{
  const struct argv *av;
  va_list ap;
  size_t i, n;

  va_start(ap, rune);
  for (;;) {
    n = strcspn(rune, "%");
    if (n) { dstr_putm(d, rune, n); rune += n; }
    if (!*rune) break;
    switch (*++rune) {
      case '%': dstr_putc(d, '%'); break;
      case 'e': lisp_quote_string(d, va_arg(ap, const char *)); break;
      case 'E':
        av = va_arg(ap, const struct argv *);
        for (i = 0; i < av->n; i++) {
          if (i) dstr_putc(d, ' ');
          dstr_putc(d, '"');
          lisp_quote_string(d, av->v[i]);
          dstr_putc(d, '"');
        }
        break;
      default: lose("*** BUG unknown expansion `%%%c'", *rune);
    }
    rune++;
  }
  dstr_putz(d);
  return (d->p);
}

/*----- Argument processing -----------------------------------------------*/

struct syslist {
  const struct systab *sys[NSYS];
  size_t n;
  unsigned f;
};
#define SYSLIST_INIT { { 0 }, 0, 0 }

struct argstate {
  unsigned f;
#define F_BOGUS 1u
#define F_NOEMBED 2u
#define F_NOACT 4u
#define F_NODUMP 8u
#define F_AUX 16u
  int verbose;
  char *imagedir;
  struct syslist allow, pref;
  struct argv av;
};
#define ARGSTATE_INIT { 0, 1, 0, SYSLIST_INIT, SYSLIST_INIT, ARGV_INIT }

/*----- Running programs --------------------------------------------------*/

#define FEF_EXEC 1u
static int file_exists_p(const struct argstate *arg, const char *path,
                         unsigned f)
{
  struct stat st;

  if (stat(path, &st)) {
    if (arg && arg->verbose > 2) moan("file `%s' not found", path);
    return (0);
  } else if (!(S_ISREG(st.st_mode))) {
    if (arg && arg->verbose > 2) moan("`%s' is not a regular file", path);
    return (0);
  } else if ((f&FEF_EXEC) && access(path, X_OK)) {
    if (arg && arg->verbose > 2) moan("file `%s' is not executable", path);
    return (0);
  } else {
    if (arg && arg->verbose > 2) moan("found file `%s'", path);
    return (1);
  }
}

static int found_in_path_p(const struct argstate *arg, const char *prog)
{
  struct dstr p = DSTR_INIT, d = DSTR_INIT;
  const char *path;
  char *q;
  size_t n, avail, proglen;
  int i;

  if (strchr(prog, '/')) return (file_exists_p(arg, prog, 0));
  path = getenv("PATH");
  if (path)
    dstr_puts(&p, path);
  else {
    dstr_puts(&p, ".:");
    i = 0;
  again:
    avail = p.sz - p.len;
    n = confstr(_CS_PATH, p.p + p.len, avail);
    if (avail > n) { i++; assert(i < 2); dstr_ensure(&p, n); goto again; }
  }

  q = p.p; proglen = strlen(prog);
  for (;;) {
    n = strcspn(q, ":");
    dstr_reset(&d);
    if (q[n]) dstr_putm(&d, q, n);
    else dstr_putc(&d, '.');
    dstr_putc(&d, '/');
    dstr_putm(&d, prog, proglen);
    dstr_putz(&d);
    if (file_exists_p(arg, d.p, FEF_EXEC)) {
      if (arg->verbose == 2) moan("found program `%s'", d.p);
      return (1);
    }
    q += n; if (!*q) break; else q++;
  }
  return (0);
}

static void try_exec(const struct argstate *arg, struct argv *av)
{
  struct dstr d = DSTR_INIT;
  size_t i;

  assert(av->n); argv_appendz(av);
  if (arg->verbose > 1) {
    for (i = 0; i < av->n; i++) {
      if (i) { dstr_putc(&d, ','); dstr_putc(&d, ' '); }
      dstr_putc(&d, '"');
      lisp_quote_string(&d, av->v[av->o + i]);
      dstr_putc(&d, '"');
    }
    dstr_putz(&d);
    moan("trying %s...", d.p);
  }
  if (arg->f&F_NOACT)
    { if (found_in_path_p(arg, av->v[av->o])) exit(0); }
  else {
    execvp(av->v[av->o], (/*unconst*/ char **)av->v + av->o);
    if (errno != ENOENT)
      lose("failed to exec `%s': %s", av->v[av->o], strerror(errno));
  }
  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.
 *
 *   * The icing on the cake: the `-x' forms are collectively concatenated --
 *     without spaces! -- and used to build a string stream, which is then
 *     assigned over the top of `*standard-input*', making the original stdin
 *     somewhat fiddly to track down.
 *
 * There's an `-i' option which will load a file without any of this
 * stupidity, but nothing analogous for immediate expressions.
 */

#define CLISP_COMMON_STARTUP_RUNES                                      \
        "(setf *standard-input* (ext:make-stream :input)) "             \
        "(load \"%e\" :verbose nil :print nil) "                        \
        "(ext:quit)"

#define CLISP_STARTUP_RUNE                                              \
        "(progn "                                                       \
           COMMON_PRELUDE_RUNE " "                                      \
           CLISP_COMMON_STARTUP_RUNES ")"

#define CLISP_STARTUP_IMAGE_RUNE                                        \
        "(progn "                                                       \
           IMAGE_RESTORE_RUNE " "                                       \
           CLISP_COMMON_STARTUP_RUNES ")"

static void run_clisp(struct argstate *arg, const char *script)
{
  struct dstr d = DSTR_INIT, dd = DSTR_INIT;

  dstr_puts(&d, arg->imagedir);
  dstr_putc(&d, '/');
  dstr_puts(&d, "clisp+asdf.mem");
  if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
    argv_prependl(&arg->av, "-M", d.p, "-q",
                  "-x", expand_rune(&dd, CLISP_STARTUP_IMAGE_RUNE, script),
                  "--",
                  END);
  else
    argv_prependl(&arg->av, "-norc", "-q",
                  "-x", expand_rune(&dd, CLISP_STARTUP_RUNE, script),
                  "--",
                  END);

  argv_prepend(&arg->av, getenv_or_default("CLISP", "clisp"));
  try_exec(arg, &arg->av);
  dstr_release(&d);
  dstr_release(&dd);

#undef f
}

/* Embeddable Common Lisp. *
 *
 * ECL is changing its command-line option syntax in version 16.  I have no
 * idea why they think the result can ever be worth the pain of a transition.
 */

#if ECL_OPTIONS_GNU
#  define ECLOPT "--"
#else
#  define ECLOPT "-"
#endif

#define ECL_STARTUP_RUNE                                                \
        "(progn "                                                       \
           COMMON_PRELUDE_RUNE " "                                      \
           CLEAR_CL_USER_RUNE ")"

static void run_ecl(struct argstate *arg, const char *script)
{
  struct dstr d = DSTR_INIT;

  dstr_puts(&d, arg->imagedir);
  dstr_putc(&d, '/');
  dstr_puts(&d, "ecl+asdf");
  if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, FEF_EXEC)) {
    argv_prependl(&arg->av, "-s", script, "--", END);
    argv_prependl(&arg->av, d.p, END);
  } else {
    argv_prependl(&arg->av, ECLOPT "shell", script, "--", END);
    argv_prependl(&arg->av, getenv_or_default("ECL", "ecl"), ECLOPT "norc",
                  ECLOPT "eval", ECL_STARTUP_RUNE,
                  END);
  }
  try_exec(arg, &arg->av);
}

/* Carnegie--Mellon University Common Lisp. */

#define CMUCL_STARTUP_RUNE                                              \
        "(progn "                                                       \
          "(setf ext:*require-verbose* nil) "                           \
          COMMON_PRELUDE_RUNE ")"
#define CMUCL_QUIT_RUNE                                                 \
        "(ext:quit)"

static void run_cmucl(struct argstate *arg, const char *script)
{
  struct dstr d = DSTR_INIT;

  argv_prependl(&arg->av,
                "-load", script,
                "-eval", CMUCL_QUIT_RUNE,
                "--",
                END);

  dstr_puts(&d, arg->imagedir);
  dstr_putc(&d, '/');
  dstr_puts(&d, "cmucl+asdf.core");
  if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
    argv_prependl(&arg->av, "-core", d.p, "-eval", IMAGE_RESTORE_RUNE, END);
  else
    argv_prependl(&arg->av, "-batch", "-noinit", "-nositeinit", "-quiet",
                  "-eval", CMUCL_STARTUP_RUNE,
                  END);

  argv_prepend(&arg->av, getenv_or_default("CMUCL", "cmucl"));
  try_exec(arg, &arg->av);
  dstr_release(&d);
}

/* Armed Bear Common Lisp. *
 *
 * CLisp made a worthy effort, but ABCL still manages to take the price.
 *
 *   * ABCL manages to avoid touching the `stderr' stream at all, ever.  Its
 *     startup machinery finds `stdout' (as `java.lang.System.out'), wraps it
 *     up in a Lisp stream, and uses the result as `*standard-output*' and
 *     `*error-output*' (and a goodly number of other things too).  So we
 *     must manufacture a working `stderr' the hard way.
 *
 *   * There doesn't appear to be any easy way to prevent toplevel errors
 *     from invoking the interactive debugger.  For extra fun, the debugger
 *     reads from `stdin' by default, so an input file which somehow manages
 *     to break the script can then take over its brain by providing Lisp
 *     forms for the debugger to evaluate.
 */

#define ABCL_STARTUP_RUNE                                               \
        "(let ((#9=#:script \"%e\")) "                                  \
           COMMON_PRELUDE_RUNE " "                                      \
           CLEAR_CL_USER_RUNE " "                                       \
                                                                        \
           /* Replace the broken `*error-output*' stream with a working \
            * copy of `stderr'.                                         \
            */                                                          \
          "(setf *error-output* "                                       \
                  "(java:jnew \"org.armedbear.lisp.Stream\" "           \
                             "'sys::system-stream "                     \
                             "(java:jfield \"java.lang.System\" \"err\") " \
                             "'character "                              \
                             "java:+true+)) "                           \
                                                                        \
           /* Trap errors signalled by the script and arrange for them  \
            * to actually kill the process rather than ending up in the \
            * interactive debugger.                                     \
            */                                                          \
          "(handler-case (load #9# :verbose nil :print nil) "           \
            "(error (error) "                                           \
              "(format *error-output* \"~A (unhandled error): ~A~%%\" " \
                      "#9# error) "                                     \
            "(ext:quit :status 255))))"

static void run_abcl(struct argstate *arg, const char *script)
{
  struct dstr d = DSTR_INIT;

  argv_prependl(&arg->av, getenv_or_default("ABCL", "abcl"),
                "--batch", "--noinform", "--noinit", "--nosystem",
                "--eval", expand_rune(&d, ABCL_STARTUP_RUNE, script),
                "--",
                END);
  try_exec(arg, &arg->av);
  dstr_release(&d);
}

/*----- Main code ---------------------------------------------------------*/

static void version(FILE *fp)
  { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); }

static void usage(FILE *fp)
{
  fprintf(fp, "usage: %s [-CDEnqv] [-I IMAGEDIR] "
              "[-L SYS,SYS,...] [-P SYS,SYS,...]\n"
              "\t[--] SCRIPT [ARGUMENTS ...] |\n"
              "\t[-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n",
          progname);
}

static void help(FILE *fp)
{
  version(fp); fputc('\n', fp); usage(fp);
  fputs("\n\
Options:\n\
  --help                Show this help text and exit successfully.\n\
  --version             Show the version number and exit successfully.\n\
  -C                    Clear the list of preferred Lisp systems.\n\
  -D                    Run system Lisp images, rather than custom images.\n\
  -E                    Don't read embedded options from the script.\n\
  -I IMAGEDIR           Look for custom images in IMAGEDIR rather than\n\
                          `" IMAGEDIR "'.\n\
  -L SYS,SYS,...        Only use the listed Lisp systems.the script.\n\
  -P SYS,SYS,...        Prefer the listed Lisp systems.\n\
  -e EXPR               Evaluate EXPR (can be repeated).\n\
  -l FILE               Load FILE (can be repeated).\n\
  -n                    Don't actually run the script (useful with `-v')\n\
  -p EXPR               Print (`prin1') EXPR (can be repeated).\n\
  -q                    Don't print warning messages.\n\
  -v                    Print informational messages (repeat for even more).\n",
        fp);
}

/* Parse a comma-separated list of system names SPEC, and add the named
 * systems to LIST.
 */
static void parse_syslist(const char *spec, const struct argstate *arg,
                          struct syslist *list, const char *what)
{
  char *copy = xstrdup(spec), *p = copy, *q;
  const struct systab *sys;
  size_t n;

  for (;;) {
    n = strcspn(p, ",");
    if (p[n]) q = p + n + 1;
    else q = 0;
    p[n] = 0; sys = find_system(p);
    if (list->f&sys->f) {
      if (arg->verbose > 0)
        moan("ignoring duplicate system `%s' in %s list", p, what);
    } else {
      list->sys[list->n++] = sys;
      list->f |= sys->f;
    }
    if (!q) break;
    p = q;
  }
  free(copy);
}

static void push_eval_op(struct argstate *arg, char op, const char *val)
{
  char *p;
  size_t n;

  if (arg->f&F_AUX) {
    moan("must use `-e', `-p', or `-l' on command line");
    arg->f |= F_BOGUS;
    return;
  }

  n = strlen(val) + 1;
  p = xmalloc(n + 1);
  p[0] = op; memcpy(p + 1, val, n);
  argv_append(&arg->av, p);
}

/* Parse a vector ARGS of command-line arguments.  Update ARG with the
 * results.  NARG is the number of arguments, and *I_INOUT is the current
 * index into the vector, to be updated on exit to identify the first
 * non-option argument (or the end of the vector).
 */
static void parse_arguments(struct argstate *arg, const char *const *args,
                            size_t nargs, size_t *i_inout)
{
  const char *o, *a;
  char opt;

  for (;;) {
    if (*i_inout >= nargs) break;
    o = args[*i_inout];
    if (STRCMP(o, ==, "--help")) { help(stdout); exit(0); }
    else if (STRCMP(o, ==, "--version")) { version(stdout); exit(0); }
    if (!*o || *o != '-' || !o[1]) break;
    (*i_inout)++;
    if (STRCMP(o, ==, "--")) break;
    o++;
    while (o && *o) {
      opt = *o++;
      switch (opt) {

#define GETARG do {                                                     \
  if (*o)                                                               \
    { a = o; o = 0; }                                                   \
  else {                                                                \
    if (*i_inout >= nargs) goto noarg;                                  \
    a = args[(*i_inout)++];                                             \
  }                                                                     \
} while (0)

        case 'C': arg->pref.n = 0; arg->pref.f = 0; break;
        case 'D': arg->f |= F_NODUMP; break;
        case 'E': arg->f |= F_NOEMBED; break;
        case 'e': GETARG; push_eval_op(arg, '!', a); break;
        case 'p': GETARG; push_eval_op(arg, '?', a); break;
        case 'l': GETARG; push_eval_op(arg, '<', a); break;
        case 'n': arg->f |= F_NOACT; break;
        case 'q': if (arg->verbose) arg->verbose--; break;
        case 'v': arg->verbose++; break;

        case 'I':
          free(arg->imagedir);
          GETARG; arg->imagedir = xstrdup(a);
          break;

        case 'L':
          GETARG;
          parse_syslist(a, arg, &arg->allow, "allowed");
          break;

        case 'P':
          GETARG;
          parse_syslist(a, arg, &arg->pref, "preferred");
          break;

        default:
          moan("unknown option `%c'", opt);
          arg->f |= F_BOGUS;
          break;

#undef GETARG

      }
    }
  }
  goto end;

noarg:
  moan("missing argument for `-%c'", opt);
  arg->f |= F_BOGUS;
end:
  return;
}

/* Parse a string P into words (destructively), and process them as
 * command-line options, updating ARG.  Non-option arguments are not
 * permitted.  If `SOSF_EMACS' is set in FLAGS, then ignore `-*- ... -*-'
 * editor turds.  If `SOSF_ENDOK' is set, then accept `--' and ignore
 * whatever comes after; otherwise, reject all positional arguments.
 */
#define SOSF_EMACS 1u
#define SOSF_ENDOK 2u
static void scan_options_from_string(char *p, struct argstate *arg,
                                     unsigned flags,
                                     const char *what, const char *file)
{
  struct argv av = ARGV_INIT;
  char *q;
  size_t i;
  int st = 0;
  unsigned f = 0;
#define f_escape 1u

  for (;;) {
    while (ISSPACE(*p)) p++;
    if (!*p) break;
    if ((flags&SOSF_EMACS) && p[0] == '-' && p[1] == '*' && p[2] == '-') {
      p = strstr(p + 3, "-*-");
      if (!p) lose("unfinished local-variables list in %s `%s'", what, file);
      p += 3; continue;
    }
    if ((flags&SOSF_ENDOK) &&
        p[0] == '-' && p[1] == '-' && (!p[2] || ISSPACE(p[2])))
      break;
    argv_append(&av, p); q = p;
    for (;;) {
      if (!*p) break;
      else if (f&f_escape) { *q++ = *p; f &= ~f_escape; }
      else if (st && *p == st) st = 0;
      else if (st != '\'' && *p == '\\') f |= f_escape;
      else if (!st && (*p == '"' || *p == '\'')) st = *p;
      else if (!st && ISSPACE(*p)) break;
      else *q++ = *p;
      p++;
    }
    if (*p) p++;
    *q = 0;
    if (f&f_escape) lose("unfinished escape in %s `%s'", what, file);
    if (st) lose("unfinished `%c' string in %s `%s'", st, what, file);
  }

  i = 0; parse_arguments(arg, av.v, av.n, &i);
  if (i < av.n)
    lose("positional argument `%s' in %s `%s'", av.v[i], what, file);
  argv_release(&av);

#undef f_escape
}

/* Read SCRIPT, and check for a `@RUNLISP:' marker in the second line.  If
 * there is one, parse options from it, and update ARG.
 */
static void check_for_embedded_args(const char *script, struct argstate *arg)
{
  struct dstr d = DSTR_INIT;
  char *p;
  FILE *fp = 0;

  fp = fopen(script, "r");
  if (!fp) lose("can't read script `%s': %s", script, strerror(errno));

  if (dstr_readline(&d, fp)) goto end;
  dstr_reset(&d); if (dstr_readline(&d, fp)) goto end;

  p = strstr(d.p, "@RUNLISP:");
  if (p)
    scan_options_from_string(p + 9, arg, SOSF_EMACS | SOSF_ENDOK,
                             "embedded options in script", script);

end:
  if (fp) {
    if (ferror(fp))
      lose("error reading script `%s': %s", script, strerror(errno));
    fclose(fp);
  }
  dstr_release(&d);
}

/* Read the file PATH (if it exists) and update ARG with the arguments parsed
 * from it.  Ignore blank lines and (Unix- or Lisp-style) comments.
 */
static void read_config_file(const char *path, struct argstate *arg)
{
  FILE *fp = 0;
  struct dstr d = DSTR_INIT;
  char *p;

  fp = fopen(path, "r");
  if (!fp) {
    if (errno == ENOENT) {
      if (arg->verbose > 2)
        moan("ignoring nonexistent configuration file `%s'", path);
      goto end;
    }
    lose("failed to open configuration file `%s': %s",
         path, strerror(errno));
  }
  if (arg->verbose > 1)
    moan("reading configuration file `%s'", path);
  for (;;) {
    dstr_reset(&d);
    if (dstr_readline(&d, fp)) break;
    p = d.p;
    while (ISSPACE(*p)) p++;
    if (!*p || *p == ';' || *p == '#') continue;
    scan_options_from_string(p, arg, 0, "configuration file `%s'", path);
  }
  if (arg->f&F_BOGUS)
    lose("invalid options in configuration file `%s'", path);

end:
  if (fp) {
    if (ferror(fp))
      lose("error reading configuration file `%s': %s",
           path, strerror(errno));
    fclose(fp);
  }
  dstr_release(&d);
}

int main(int argc, char *argv[])
{
  struct dstr d = DSTR_INIT;
  const char *script, *p;
  const char *home;
  struct passwd *pw;
  char *t;
  size_t i, n;
  struct argstate arg = ARGSTATE_INIT;

  /* Scan the command line.  This gets low priority, since it's probably
   * from the script shebang.
   */
  set_progname(argv[0]); i = 1;
  parse_arguments(&arg, (const char *const *)argv, argc, &i);
  arg.f |= F_AUX;
  if ((i >= argc && !arg.av.n) || (arg.f&F_BOGUS))
    { usage(stderr); exit(255); }

  /* Prepare the argument vector.  Keep track of the number of arguments
   * here: we'll need to refer to this later.
   */
  if (!arg.av.n) {
    script = argv[i++];
    if (!(arg.f&F_NOEMBED)) check_for_embedded_args(script, &arg);
    if (arg.f&F_BOGUS)
      lose("invalid options in `%s' embedded option list", script);
  } else {
    script = getenv("RUNLISP_EVAL");
    if (!script) script = DATADIR "/eval.lisp";
    argv_append(&arg.av, "--");
  }
  argv_appendn(&arg.av, (const char *const *)argv + i, argc - i);
  n = arg.av.n;

  /* Find the user's home directory.  (Believe them if they set something
   * strange.)
   */
  home = getenv("HOME");
  if (!home) {
    pw = getpwuid(getuid());
    if (!pw) lose("can't find user in password database");
    home = pw->pw_dir;
  }

  /* Check user configuration file `~/.runlisprc'. */
  dstr_reset(&d);
  dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".runlisprc");
  read_config_file(d.p, &arg);

  /* Check user configuration file `~/.config/runlisprc'. */
  dstr_reset(&d);
  p = getenv("XDG_CONFIG_HOME");
  if (p)
    dstr_puts(&d, p);
  else
    { dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".config"); }
  dstr_putc(&d, '/'); dstr_puts(&d, "runlisprc");
  read_config_file(d.p, &arg);

  /* Finally, check the environment variables. */
  p = getenv("RUNLISP_OPTIONS");
  if (p) {
    t = xstrdup(p);
    scan_options_from_string(t, &arg, 0,
                             "environment variable", "RUNLISP_OPTIONS");
    free(t);
  }
  if (arg.f&F_BOGUS)
    lose("invalid options in environment variable `RUNLISP_OPTIONS'");
  if (!arg.imagedir) {
    arg.imagedir = getenv("RUNLISP_IMAGEDIR");
    if (!arg.imagedir) arg.imagedir = IMAGEDIR;
  }

  /* If no systems are listed as acceptable, try them all. */
  if (!arg.allow.n) {
    if (arg.verbose > 1)
      moan("no explicitly allowed implementations: allowing all");
    for (i = 0; i < NSYS; i++) arg.allow.sys[i] = &systab[i];
    arg.allow.n = NSYS; arg.allow.f = (1u << NSYS) - 1;
  }

  /* Print what we're going to do. */
  if (arg.verbose > 2) {
    dstr_reset(&d); p = "";
    for (i = 0; i < arg.allow.n; i++)
      { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); }
    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);
  }

  /* Inform `uiop' of the script name.
   *
   * As an aside, this is a terrible interface.  It's too easy to forget to
   * set it.  (To illustrate this, `cl-launch -x' indeed forgets to set it.)
   * If you're lucky, the script just thinks that its argument is `nil', in
   * which case maybe it can use `*load-pathname*' as a fallback.  If you're
   * unlucky, your script was invoked (possibly indirectly) by another
   * script, and now you've accidentally inherited the calling script's name.
   *
   * It would have been far better simply to repeat the script name as the
   * first user argument, if nothing else had come readily to mind.
   */
  if (setenv("__CL_ARGV0", script, 1))
    lose("failed to set script-name environment variable");

  /* Work through the list of preferred Lisp systems, trying the ones which
   * are allowed.
   */
  for (i = 0; i < arg.pref.n; i++)
    if (arg.pref.sys[i]->f&arg.allow.f) {
      arg.av.o += arg.av.n - n; arg.av.n = n;
      arg.pref.sys[i]->run(&arg, script);
    }

  /* That didn't work.  Try the remaining allowed systems, in the given
   * order.
   */
  for (i = 0; i < arg.allow.n; i++)
    if (!(arg.allow.sys[i]->f&arg.pref.f)) {
      arg.av.o += arg.av.n - n; arg.av.n = n;
      arg.allow.sys[i]->run(&arg, script);
    }

  /* No joy.  Give up. */
  argv_release(&arg.av);
  lose("no supported Lisp systems found");
}

/*----- That's all, folks -------------------------------------------------*/