chiark - git - mdw - runlisp/blob - runlisp.c

   1 /* -*-c-*-
   2  *
   3  * Invoke a Lisp script
   4  *
   5  * (c) 2020 Mark Wooding
   6  */
   7
   8 /*----- Licensing notice --------------------------------------------------*
   9  *
  10  * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
  11  *
  12  * Runlisp is free software: you can redistribute it and/or modify it
  13  * under the terms of the GNU General Public License as published by the
  14  * Free Software Foundation; either version 3 of the License, or (at your
  15  * option) any later version.
  16  *
  17  * Runlisp is distributed in the hope that it will be useful, but WITHOUT
  18  * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  19  * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  20  * for more details.
  21  *
  22  * You should have received a copy of the GNU General Public License
  23  * along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.
  24  */
  25
  26 /*----- Header files ------------------------------------------------------*/
  27
  28 #include "config.h"
  29
  30 #include <assert.h>
  31 #include <ctype.h>
  32 #include <errno.h>
  33 #include <stdarg.h>
  34 #include <stdio.h>
  35 #include <stdlib.h>
  36 #include <string.h>
  37
  38 #include <unistd.h>
  39 #include <sys/stat.h>
  40
  41 #include <pwd.h>
  42
  43 /*----- Common Lisp runes -------------------------------------------------*/
  44
  45 /* A common preamble rune to do the necessary things.
  46  *
  47  * We need to ensure that `asdf' (and therefore `uiop') is loaded.  And we
  48  * should arrange for `:runlisp-script' to find its way into the `*features*'
  49  * list so that scripts can notice that they're being invoked from the
  50  * command line rather than loaded into a resident session, and actually do
  51  * something useful.
  52  */
  53 #define COMMON_PRELUDE_RUNE                                             \
  54         "(progn "                                                       \
  55           "(setf *load-verbose* nil *compile-verbose* nil) "            \
  56           "(require \"asdf\") "                                         \
  57           "(funcall (intern \"REGISTER-IMMUTABLE-SYSTEM\" "             \
  58                            "(find-package \"ASDF\")) "                  \
  59                    "\"asdf\") "                                         \
  60           "(set-dispatch-macro-character "                              \
  61            "#\\# #\\! "                                                 \
  62            "(lambda (#1=#:stream #2=#:char #3=#:arg) "                  \
  63              "(declare (ignore #2# #3#)) "                              \
  64              "(values (read-line #1#)))) "                              \
  65           "(pushnew :runlisp-script *features*))"
  66
  67 /* Get `uiop' to re-check the command-line arguments following an image
  68  * restore.
  69  */
  70 #define IMAGE_RESTORE_RUNE                                              \
  71         "(uiop:call-image-restore-hook)"
  72
  73 /* Some Lisps leave crud in the `COMMON-LISP-USER' package.  Clear it out. */
  74 #define CLEAR_CL_USER_RUNE                                              \
  75         "(let ((#4=#:pkg (find-package \"COMMON-LISP-USER\"))) "        \
  76           "(with-package-iterator (#5=#:next #4# :internal) "           \
  77             "(loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how) " \
  78                       "(#5#) "                                          \
  79                     "(declare (ignore #8#)) "                           \
  80                     "(unless #6# (return)) "                            \
  81                     "(unintern #7# #4#)))))"
  82
  83 /*----- Handy macros ------------------------------------------------------*/
  84
  85 #define N(v) (sizeof(v)/sizeof((v)[0]))
  86
  87 #if defined(__GNUC__)
  88 #  define GCC_VERSION_P(maj, min)                                       \
  89         (__GNUC__ > (maj) || (__GNUC__ == (maj) && __GNUC_MINOR__ >= (min)))
  90 #else
  91 #  define GCC_VERSION_P(maj, min) 0
  92 #endif
  93
  94 #ifdef __clang__
  95 #  define CLANG_VERSION_P(maj, min)                                     \
  96         (__clang_major__ > (maj) || (__clang_major__ == (maj) &&        \
  97                                      __clang_minor__ >= (min)))
  98 #else
  99 #  define CLANG_VERSION_P(maj, min) 0
 100 #endif
 101
 102 #if GCC_VERSION_P(2, 5) || CLANG_VERSION_P(3, 3)
 103 #  define NORETURN __attribute__((__noreturn__))
 104 #  define PRINTF_LIKE(fix, aix) __attribute__((__format__(printf, fix, aix)))
 105 #endif
 106
 107 #if GCC_VERSION_P(4, 0) || CLANG_VERSION_P(3, 3)
 108 #  define EXECL_LIKE(ntrail) __attribute__((__sentinel__(ntrail)))
 109 #endif
 110
 111 #define CTYPE_HACK(func, ch) (func((unsigned char)(ch)))
 112 #define ISSPACE(ch) CTYPE_HACK(isspace, ch)
 113
 114 #define MEMCMP(x, op, y, n) (memcmp((x), (y), (n)) op 0)
 115 #define STRCMP(x, op, y) (strcmp((x), (y)) op 0)
 116 #define STRNCMP(x, op, y, n) (strncmp((x), (y), (n)) op 0)
 117
 118 #define END ((const char *)0)
 119
 120 /*----- The Lisp implementation table -------------------------------------*/
 121
 122 /* The systems, in decreasing order of (not quite my personal) preference.
 123  * This list is used to initialize various tables and constants.
 124  */
 125 #define LISP_SYSTEMS(_)                                                 \
 126         _(sbcl)                                                         \
 127         _(ccl)                                                          \
 128         _(clisp)                                                        \
 129         _(ecl)                                                          \
 130         _(cmucl)                                                        \
 131         _(abcl)
 132
 133 enum {
 134 #define DEFSYS(sys) sys##_INDEX,
 135   LISP_SYSTEMS(DEFSYS)
 136 #undef DEFSYS
 137   NSYS
 138 };
 139
 140 enum {
 141 #define DEFFLAG(sys) sys##_FLAG = 1 << sys##_INDEX,
 142   LISP_SYSTEMS(DEFFLAG)
 143 #undef DEFFLAG
 144   ALL_SYSTEMS = 0
 145 #define SETFLAG(sys) | sys##_FLAG
 146   LISP_SYSTEMS(SETFLAG)
 147 #undef SETFLAG
 148 };
 149
 150 struct argstate;
 151 struct argv;
 152
 153 #define DECLENTRY(sys) \
 154 static void run_##sys(struct argstate *, const char *);
 155   LISP_SYSTEMS(DECLENTRY)
 156 #undef DECLENTRY
 157
 158 static const struct systab {
 159   const char *name;
 160   unsigned f;
 161   void (*run)(struct argstate *, const char *);
 162 } systab[] = {
 163 #define SYSENTRY(sys) { #sys, sys##_FLAG, run_##sys },
 164   LISP_SYSTEMS(SYSENTRY)
 165 #undef SYSENTRY
 166 };
 167
 168 /*----- Diagnostic utilities ----------------------------------------------*/
 169
 170 static const char *progname = "runlisp";
 171
 172 static void set_progname(const char *prog)
 173 {
 174   const char *p;
 175
 176   p = strrchr(prog, '/');
 177   progname = p ? p + 1 : progname;
 178 }
 179
 180 static void vmoan(const char *msg, va_list ap)
 181 {
 182   fprintf(stderr, "%s: ", progname);
 183   vfprintf(stderr, msg, ap);
 184   fputc('\n', stderr);
 185 }
 186
 187 static PRINTF_LIKE(1, 2) void moan(const char *msg, ...)
 188   { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); }
 189
 190 static NORETURN PRINTF_LIKE(1, 2) void lose(const char *msg, ...)
 191   { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); exit(127); }
 192
 193 /*----- Memory allocation -------------------------------------------------*/
 194
 195 static void *xmalloc(size_t n)
 196 {
 197   void *p;
 198
 199   if (!n) return (0);
 200   p = malloc(n); if (!p) lose("failed to allocate memory");
 201   return (p);
 202 }
 203
 204 static void *xrealloc(void *p, size_t n)
 205 {
 206   if (!n) { free(p); return (0); }
 207   else if (!p) return (xmalloc(n));
 208   p = realloc(p, n); if (!p) lose("failed to allocate memory");
 209   return (p);
 210 }
 211
 212 static char *xstrdup(const char *p)
 213 {
 214   size_t n = strlen(p) + 1;
 215   char *q = xmalloc(n);
 216
 217   memcpy(q, p, n);
 218   return (q);
 219 }
 220
 221 /*----- Dynamic strings ---------------------------------------------------*/
 222
 223 struct dstr {
 224   char *p;
 225   size_t len, sz;
 226 };
 227 #define DSTR_INIT { 0, 0, 0 }
 228
 229 /*
 230 static void dstr_init(struct dstr *d) { d->p = 0; d->len = d->sz = 0; }
 231 */
 232
 233 static void dstr_reset(struct dstr *d) { d->len = 0; }
 234
 235 static void dstr_ensure(struct dstr *d, size_t n)
 236 {
 237   size_t need = d->len + n, newsz;
 238
 239   if (need <= d->sz) return;
 240   newsz = d->sz ? 2*d->sz : 16;
 241   while (newsz < need) newsz *= 2;
 242   d->p = xrealloc(d->p, newsz); d->sz = newsz;
 243 }
 244
 245 static void dstr_release(struct dstr *d) { free(d->p); }
 246
 247 static void dstr_putm(struct dstr *d, const void *p, size_t n)
 248   { dstr_ensure(d, n); memcpy(d->p + d->len, p, n); d->len += n; }
 249
 250 static void dstr_puts(struct dstr *d, const char *p)
 251 {
 252   size_t n = strlen(p);
 253
 254   dstr_ensure(d, n + 1);
 255   memcpy(d->p + d->len, p, n + 1);
 256   d->len += n;
 257 }
 258
 259 static void dstr_putc(struct dstr *d, int ch)
 260   { dstr_ensure(d, 1); d->p[d->len++] = ch; }
 261
 262 static void dstr_putz(struct dstr *d)
 263   { dstr_ensure(d, 1); d->p[d->len] = 0; }
 264
 265 static int dstr_readline(struct dstr *d, FILE *fp)
 266 {
 267   size_t n;
 268   int any = 0;
 269
 270   for (;;) {
 271     dstr_ensure(d, 2);
 272     if (!fgets(d->p + d->len, d->sz - d->len, fp)) break;
 273     n = strlen(d->p + d->len); assert(n > 0); any = 1;
 274     d->len += n;
 275     if (d->p[d->len - 1] == '\n') { d->p[--d->len] = 0; break; }
 276   }
 277
 278   if (!any) return (-1);
 279   else return (0);
 280 }
 281 /*----- Dynamic vectors of strings ----------------------------------------*/
 282
 283 struct argv {
 284   const char **v;
 285   size_t o, n, sz;
 286 };
 287 #define ARGV_INIT { 0, 0, 0, 0 }
 288
 289 /*
 290 static void argv_init(struct argv *av)
 291   { av->v = 0; av->o = av->n = av->sz = 0; }
 292 */
 293
 294 /*
 295 static void argv_reset(struct argv *av) { av->o = av->n = 0; }
 296 */
 297
 298 static void argv_ensure(struct argv *av, size_t n)
 299 {
 300   size_t need = av->n + av->o + n, newsz;
 301
 302   if (need <= av->sz) return;
 303   newsz = av->sz ? 2*av->sz : 8;
 304   while (newsz < need) newsz *= 2;
 305   av->v = xrealloc(av->v, newsz*sizeof(const char *)); av->sz = newsz;
 306 }
 307
 308 static void argv_ensure_offset(struct argv *av, size_t n)
 309 {
 310   size_t newoff;
 311
 312   /* Stupid version.  We won't, in practice, be prepending lots of stuff, so
 313    * avoid the extra bookkeeping involved in trying to make a double-ended
 314    * extendable array asymptotically efficient.
 315    */
 316   if (av->o >= n) return;
 317   newoff = 16;
 318   while (newoff < n) newoff *= 2;
 319   argv_ensure(av, newoff - av->o);
 320   memmove(av->v + newoff, av->v + av->o, av->n*sizeof(const char *));
 321   av->o = newoff;
 322 }
 323
 324 static void argv_release(struct argv *av) { free(av->v); }
 325
 326 static void argv_append(struct argv *av, const char *p)
 327   { argv_ensure(av, 1); av->v[av->n++ + av->o] = p; }
 328
 329 static void argv_appendz(struct argv *av)
 330   { argv_ensure(av, 1); av->v[av->n + av->o] = 0; }
 331
 332 static void argv_appendn(struct argv *av, const char *const *v, size_t n)
 333 {
 334   argv_ensure(av, n);
 335   memcpy(av->v + av->n + av->o, v, n*sizeof(const char *));
 336   av->n += n;
 337 }
 338
 339 /*
 340 static void argv_appendav(struct argv *av, const struct argv *bv)
 341   { argv_appendn(av, bv->v + bv->o, bv->n); }
 342 */
 343
 344 /*
 345 static void argv_appendv(struct argv *av, va_list ap)
 346 {
 347   const char *p;
 348
 349   for (;;)
 350     { p = va_arg(ap, const char *); if (!p) break; argv_append(av, p); }
 351 }
 352 */
 353
 354 /*
 355 static EXECL_LIKE(0) void argv_appendl(struct argv *av, ...)
 356   { va_list ap; va_start(ap, av); argv_appendv(av, ap); va_end(ap); }
 357 */
 358
 359 static void argv_prepend(struct argv *av, const char *p)
 360   { argv_ensure_offset(av, 1); av->v[--av->o] = p; av->n++; }
 361
 362 /*
 363 static void argv_prependn(struct argv *av, const char *const *v, size_t n)
 364 {
 365   argv_ensure_offset(av, 1);
 366   av->o -= n; av->n += n;
 367   memcpy(av->v + av->o, v, n*sizeof(const char *));
 368 }
 369 */
 370
 371 /*
 372 static void argv_prependav(struct argv *av, const struct argv *bv)
 373   { argv_prependn(av, bv->v + bv->o, bv->n); }
 374 */
 375
 376 static void argv_prependv(struct argv *av, va_list ap)
 377 {
 378   const char *p, **v;
 379   size_t n = 0;
 380
 381   for (;;) {
 382     p = va_arg(ap, const char *); if (!p) break;
 383     argv_prepend(av, p); n++;
 384   }
 385   v = av->v + av->o;
 386   while (n >= 2) {
 387     p = v[0]; v[0] = v[n - 1]; v[n - 1] = p;
 388     v++; n -= 2;
 389   }
 390 }
 391
 392 static EXECL_LIKE(0) void argv_prependl(struct argv *av, ...)
 393   { va_list ap; va_start(ap, av); argv_prependv(av, ap); va_end(ap); }
 394
 395 /*----- Lisp system table (redux) -----------------------------------------*/
 396
 397 static const struct systab *find_system(const char *name)
 398 {
 399   const struct systab *sys;
 400   size_t i;
 401
 402   for (i = 0; i < NSYS; i++) {
 403     sys = &systab[i];
 404     if (STRCMP(name, ==, sys->name)) return (sys);
 405   }
 406   lose("unknown Lisp system `%s'", name);
 407 }
 408
 409 static void lisp_quote_string(struct dstr *d, const char *p)
 410 {
 411   size_t n;
 412
 413   for (;;) {
 414     n = strcspn(p, "\"\\");
 415     if (n) { dstr_putm(d, p, n); p += n; }
 416     if (!*p) break;
 417     dstr_putc(d, '\\'); dstr_putc(d, *p++);
 418   }
 419   dstr_putz(d);
 420 }
 421
 422 static const char *expand_rune(struct dstr *d, const char *rune, ...)
 423 {
 424   const struct argv *av;
 425   va_list ap;
 426   size_t i, n;
 427
 428   va_start(ap, rune);
 429   for (;;) {
 430     n = strcspn(rune, "%");
 431     if (n) { dstr_putm(d, rune, n); rune += n; }
 432     if (!*rune) break;
 433     switch (*++rune) {
 434       case '%': dstr_putc(d, '%'); break;
 435       case 'e': lisp_quote_string(d, va_arg(ap, const char *)); break;
 436       case 'E':
 437         av = va_arg(ap, const struct argv *);
 438         for (i = 0; i < av->n; i++) {
 439           if (i) dstr_putc(d, ' ');
 440           dstr_putc(d, '"');
 441           lisp_quote_string(d, av->v[i]);
 442           dstr_putc(d, '"');
 443         }
 444         break;
 445       default: lose("*** BUG unknown expansion `%%%c'", *rune);
 446     }
 447     rune++;
 448   }
 449   dstr_putz(d);
 450   return (d->p);
 451 }
 452
 453 /*----- Argument processing -----------------------------------------------*/
 454
 455 struct syslist {
 456   const struct systab *sys[NSYS];
 457   size_t n;
 458   unsigned f;
 459 };
 460 #define SYSLIST_INIT { { 0 }, 0, 0 }
 461
 462 struct argstate {
 463   unsigned f;
 464 #define F_BOGUS 1u
 465 #define F_NOEMBED 2u
 466 #define F_NOACT 4u
 467 #define F_NODUMP 8u
 468 #define F_AUX 16u
 469   int verbose;
 470   char *imagedir;
 471   struct syslist allow, pref;
 472   struct argv av;
 473 };
 474 #define ARGSTATE_INIT { 0, 1, 0, SYSLIST_INIT, SYSLIST_INIT, ARGV_INIT }
 475
 476 /*----- Running programs --------------------------------------------------*/
 477
 478 #define FEF_EXEC 1u
 479 static int file_exists_p(const struct argstate *arg, const char *path,
 480                          unsigned f)
 481 {
 482   struct stat st;
 483
 484   if (stat(path, &st)) {
 485     if (arg && arg->verbose > 2) moan("file `%s' not found", path);
 486     return (0);
 487   } else if (!(S_ISREG(st.st_mode))) {
 488     if (arg && arg->verbose > 2) moan("`%s' is not a regular file", path);
 489     return (0);
 490   } else if ((f&FEF_EXEC) && access(path, X_OK)) {
 491     if (arg && arg->verbose > 2) moan("file `%s' is not executable", path);
 492     return (0);
 493   } else {
 494     if (arg && arg->verbose > 2) moan("found file `%s'", path);
 495     return (1);
 496   }
 497 }
 498
 499 static int found_in_path_p(const struct argstate *arg, const char *prog)
 500 {
 501   struct dstr p = DSTR_INIT, d = DSTR_INIT;
 502   const char *path;
 503   char *q;
 504   size_t n, avail, proglen;
 505   int i;
 506
 507   if (strchr(prog, '/')) return (file_exists_p(arg, prog, 0));
 508   path = getenv("PATH");
 509   if (path)
 510     dstr_puts(&p, path);
 511   else {
 512     dstr_puts(&p, ".:");
 513     i = 0;
 514   again:
 515     avail = p.sz - p.len;
 516     n = confstr(_CS_PATH, p.p + p.len, avail);
 517     if (avail > n) { i++; assert(i < 2); dstr_ensure(&p, n); goto again; }
 518   }
 519
 520   q = p.p; proglen = strlen(prog);
 521   for (;;) {
 522     n = strcspn(q, ":");
 523     dstr_reset(&d);
 524     if (q[n]) dstr_putm(&d, q, n);
 525     else dstr_putc(&d, '.');
 526     dstr_putc(&d, '/');
 527     dstr_putm(&d, prog, proglen);
 528     dstr_putz(&d);
 529     if (file_exists_p(arg, d.p, FEF_EXEC)) {
 530       if (arg->verbose == 2) moan("found program `%s'", d.p);
 531       return (1);
 532     }
 533     q += n; if (!*q) break; else q++;
 534   }
 535   return (0);
 536 }
 537
 538 static void try_exec(const struct argstate *arg, struct argv *av)
 539 {
 540   struct dstr d = DSTR_INIT;
 541   size_t i;
 542
 543   assert(av->n); argv_appendz(av);
 544   if (arg->verbose > 1) {
 545     for (i = 0; i < av->n; i++) {
 546       if (i) { dstr_putc(&d, ','); dstr_putc(&d, ' '); }
 547       dstr_putc(&d, '"');
 548       lisp_quote_string(&d, av->v[av->o + i]);
 549       dstr_putc(&d, '"');
 550     }
 551     dstr_putz(&d);
 552     moan("trying %s...", d.p);
 553   }
 554   if (arg->f&F_NOACT)
 555     { if (found_in_path_p(arg, av->v[av->o])) exit(0); }
 556   else {
 557     execvp(av->v[av->o], (/*unconst*/ char **)av->v + av->o);
 558     if (errno != ENOENT)
 559       lose("failed to exec `%s': %s", av->v[av->o], strerror(errno));
 560   }
 561   if (arg->verbose > 1) moan("`%s' not found", av->v[av->o]);
 562   dstr_release(&d);
 563 }
 564
 565 static const char *getenv_or_default(const char *var, const char *dflt)
 566   { const char *p = getenv(var); return (p ? p : dflt); }
 567
 568 /*----- Invoking Lisp systems ---------------------------------------------*/
 569
 570 /* Steel Bank Common Lisp. */
 571
 572 static void run_sbcl(struct argstate *arg, const char *script)
 573 {
 574   struct dstr d = DSTR_INIT;
 575
 576   argv_prependl(&arg->av, "--script", script, END);
 577
 578   dstr_puts(&d, arg->imagedir);
 579   dstr_putc(&d, '/');
 580   dstr_puts(&d, "sbcl+asdf.core");
 581   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
 582     argv_prependl(&arg->av,
 583                   "--core", d.p,
 584                   "--eval", IMAGE_RESTORE_RUNE,
 585                   END);
 586   else
 587     argv_prependl(&arg->av, "--eval", COMMON_PRELUDE_RUNE, END);
 588
 589   argv_prependl(&arg->av, getenv_or_default("SBCL", "sbcl"),
 590                 "--noinform",
 591                 END);
 592   try_exec(arg, &arg->av);
 593   dstr_release(&d);
 594 }
 595
 596 /* Clozure Common Lisp. */
 597
 598 #define CCL_QUIT_RUNE                                                   \
 599         "(ccl:quit)"
 600
 601 static void run_ccl(struct argstate *arg, const char *script)
 602 {
 603   struct dstr d = DSTR_INIT;
 604
 605   argv_prependl(&arg->av, "-b", "-n", "-Q",
 606                 "-l", script,
 607                 "-e", CCL_QUIT_RUNE,
 608                 "--",
 609                 END);
 610
 611   dstr_puts(&d, arg->imagedir);
 612   dstr_putc(&d, '/');
 613   dstr_puts(&d, "ccl+asdf.image");
 614   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
 615     argv_prependl(&arg->av, "-I", d.p, "-e", IMAGE_RESTORE_RUNE, END);
 616   else
 617     argv_prependl(&arg->av, "-e", COMMON_PRELUDE_RUNE, END);
 618
 619   argv_prepend(&arg->av, getenv_or_default("CCL", "ccl"));
 620   try_exec(arg, &arg->av);
 621   dstr_release(&d);
 622 }
 623
 624 /* GNU CLisp.
 625  *
 626  * CLisp causes much sadness.  Superficially, it's the most sensible of all
 627  * of the systems supported here: you just run `clisp SCRIPT -- ARGS ...' and
 628  * it works.
 629  *
 630  * The problems come when you want to do some preparatory work (e.g., load
 631  * `asdf') and then run the script.  There's a `-x' option to evaluate some
 632  * Lisp code, but it has three major deficiencies.
 633  *
 634  *   * It insists on printing the values of the forms it evaluates.  It
 635  *     prints a blank line even if the form goes out of its way to produce no
 636  *     values at all.  So the whole thing has to be a single top-level form
 637  *     which quits the Lisp rather than returning.
 638  *
 639  *   * For some idiotic reason, you can have /either/ `-x' forms /or/ a
 640  *     script, but not both.  So we have to include the `load' here
 641  *     explicitly.  I suppose that was inevitable because we have to inhibit
 642  *     printing of the result forms, but it's still a separate source of
 643  *     annoyance.
 644  *
 645  *   * The icing on the cake: the `-x' forms are collectively concatenated --
 646  *     without spaces! -- and used to build a string stream, which is then
 647  *     assigned over the top of `*standard-input*', making the original stdin
 648  *     somewhat fiddly to track down.
 649  *
 650  * There's an `-i' option which will load a file without any of this
 651  * stupidity, but nothing analogous for immediate expressions.
 652  */
 653
 654 #define CLISP_COMMON_STARTUP_RUNES                                      \
 655         "(setf *standard-input* (ext:make-stream :input)) "             \
 656         "(load \"%e\" :verbose nil :print nil) "                        \
 657         "(ext:quit)"
 658
 659 #define CLISP_STARTUP_RUNE                                              \
 660         "(progn "                                                       \
 661            COMMON_PRELUDE_RUNE " "                                      \
 662            CLISP_COMMON_STARTUP_RUNES ")"
 663
 664 #define CLISP_STARTUP_IMAGE_RUNE                                        \
 665         "(progn "                                                       \
 666            IMAGE_RESTORE_RUNE " "                                       \
 667            CLISP_COMMON_STARTUP_RUNES ")"
 668
 669 static void run_clisp(struct argstate *arg, const char *script)
 670 {
 671   struct dstr d = DSTR_INIT, dd = DSTR_INIT;
 672
 673   dstr_puts(&d, arg->imagedir);
 674   dstr_putc(&d, '/');
 675   dstr_puts(&d, "clisp+asdf.mem");
 676   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
 677     argv_prependl(&arg->av, "-M", d.p, "-q",
 678                   "-x", expand_rune(&dd, CLISP_STARTUP_IMAGE_RUNE, script),
 679                   "--",
 680                   END);
 681   else
 682     argv_prependl(&arg->av, "-norc", "-q",
 683                   "-x", expand_rune(&dd, CLISP_STARTUP_RUNE, script),
 684                   "--",
 685                   END);
 686
 687   argv_prepend(&arg->av, getenv_or_default("CLISP", "clisp"));
 688   try_exec(arg, &arg->av);
 689   dstr_release(&d);
 690   dstr_release(&dd);
 691
 692 #undef f
 693 }
 694
 695 /* Embeddable Common Lisp. *
 696  *
 697  * ECL is changing its command-line option syntax in version 16.  I have no
 698  * idea why they think the result can ever be worth the pain of a transition.
 699  */
 700
 701 #if ECL_OPTIONS_GNU
 702 #  define ECLOPT "--"
 703 #else
 704 #  define ECLOPT "-"
 705 #endif
 706
 707 #define ECL_STARTUP_RUNE                                                \
 708         "(progn "                                                       \
 709            COMMON_PRELUDE_RUNE " "                                      \
 710            CLEAR_CL_USER_RUNE ")"
 711
 712 static void run_ecl(struct argstate *arg, const char *script)
 713 {
 714   struct dstr d = DSTR_INIT;
 715
 716   dstr_puts(&d, arg->imagedir);
 717   dstr_putc(&d, '/');
 718   dstr_puts(&d, "ecl+asdf");
 719   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, FEF_EXEC)) {
 720     argv_prependl(&arg->av, "-s", script, "--", END);
 721     argv_prependl(&arg->av, d.p, END);
 722   } else {
 723     argv_prependl(&arg->av, ECLOPT "shell", script, "--", END);
 724     argv_prependl(&arg->av, getenv_or_default("ECL", "ecl"), ECLOPT "norc",
 725                   ECLOPT "eval", ECL_STARTUP_RUNE,
 726                   END);
 727   }
 728   try_exec(arg, &arg->av);
 729 }
 730
 731 /* Carnegie--Mellon University Common Lisp. */
 732
 733 #define CMUCL_STARTUP_RUNE                                              \
 734         "(progn "                                                       \
 735           "(setf ext:*require-verbose* nil) "                           \
 736           COMMON_PRELUDE_RUNE ")"
 737 #define CMUCL_QUIT_RUNE                                                 \
 738         "(ext:quit)"
 739
 740 static void run_cmucl(struct argstate *arg, const char *script)
 741 {
 742   struct dstr d = DSTR_INIT;
 743
 744   argv_prependl(&arg->av,
 745                 "-load", script,
 746                 "-eval", CMUCL_QUIT_RUNE,
 747                 "--",
 748                 END);
 749
 750   dstr_puts(&d, arg->imagedir);
 751   dstr_putc(&d, '/');
 752   dstr_puts(&d, "cmucl+asdf.core");
 753   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
 754     argv_prependl(&arg->av, "-core", d.p, "-eval", IMAGE_RESTORE_RUNE, END);
 755   else
 756     argv_prependl(&arg->av, "-batch", "-noinit", "-nositeinit", "-quiet",
 757                   "-eval", CMUCL_STARTUP_RUNE,
 758                   END);
 759
 760   argv_prepend(&arg->av, getenv_or_default("CMUCL", "cmucl"));
 761   try_exec(arg, &arg->av);
 762   dstr_release(&d);
 763 }
 764
 765 /* Armed Bear Common Lisp. *
 766  *
 767  * CLisp made a worthy effort, but ABCL still manages to take the price.
 768  *
 769  *   * ABCL manages to avoid touching the `stderr' stream at all, ever.  Its
 770  *     startup machinery finds `stdout' (as `java.lang.System.out'), wraps it
 771  *     up in a Lisp stream, and uses the result as `*standard-output*' and
 772  *     `*error-output*' (and a goodly number of other things too).  So we
 773  *     must manufacture a working `stderr' the hard way.
 774  *
 775  *   * There doesn't appear to be any easy way to prevent toplevel errors
 776  *     from invoking the interactive debugger.  For extra fun, the debugger
 777  *     reads from `stdin' by default, so an input file which somehow manages
 778  *     to break the script can then take over its brain by providing Lisp
 779  *     forms for the debugger to evaluate.
 780  */
 781
 782 #define ABCL_STARTUP_RUNE                                               \
 783         "(let ((#9=#:script \"%e\")) "                                  \
 784            COMMON_PRELUDE_RUNE " "                                      \
 785            CLEAR_CL_USER_RUNE " "                                       \
 786                                                                         \
 787            /* Replace the broken `*error-output*' stream with a working \
 788             * copy of `stderr'.                                         \
 789             */                                                          \
 790           "(setf *error-output* "                                       \
 791                   "(java:jnew \"org.armedbear.lisp.Stream\" "           \
 792                              "'sys::system-stream "                     \
 793                              "(java:jfield \"java.lang.System\" \"err\") " \
 794                              "'character "                              \
 795                              "java:+true+)) "                           \
 796                                                                         \
 797            /* Trap errors signalled by the script and arrange for them  \
 798             * to actually kill the process rather than ending up in the \
 799             * interactive debugger.                                     \
 800             */                                                          \
 801           "(handler-case (load #9# :verbose nil :print nil) "           \
 802             "(error (error) "                                           \
 803               "(format *error-output* \"~A (unhandled error): ~A~%%\" " \
 804                       "#9# error) "                                     \
 805             "(ext:quit :status 255))))"
 806
 807 static void run_abcl(struct argstate *arg, const char *script)
 808 {
 809   struct dstr d = DSTR_INIT;
 810
 811   argv_prependl(&arg->av, getenv_or_default("ABCL", "abcl"),
 812                 "--batch", "--noinform", "--noinit", "--nosystem",
 813                 "--eval", expand_rune(&d, ABCL_STARTUP_RUNE, script),
 814                 "--",
 815                 END);
 816   try_exec(arg, &arg->av);
 817   dstr_release(&d);
 818 }
 819
 820 /*----- Main code ---------------------------------------------------------*/
 821
 822 static void version(FILE *fp)
 823   { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); }
 824
 825 static void usage(FILE *fp)
 826 {
 827   fprintf(fp, "usage: %s [-CDEnqv] [-I IMAGEDIR] "
 828               "[-L SYS,SYS,...] [-P SYS,SYS,...]\n"
 829               "\t[--] SCRIPT [ARGUMENTS ...] |\n"
 830               "\t[-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n",
 831           progname);
 832 }
 833
 834 static void help(FILE *fp)
 835 {
 836   version(fp); fputc('\n', fp); usage(fp);
 837   fputs("\n\
 838 Options:\n\
 839   --help                Show this help text and exit successfully.\n\
 840   --version             Show the version number and exit successfully.\n\
 841   -C                    Clear the list of preferred Lisp systems.\n\
 842   -D                    Run system Lisp images, rather than custom images.\n\
 843   -E                    Don't read embedded options from the script.\n\
 844   -I IMAGEDIR           Look for custom images in IMAGEDIR rather than\n\
 845                           `" IMAGEDIR "'.\n\
 846   -L SYS,SYS,...        Only use the listed Lisp systems.the script.\n\
 847   -P SYS,SYS,...        Prefer the listed Lisp systems.\n\
 848   -e EXPR               Evaluate EXPR (can be repeated).\n\
 849   -l FILE               Load FILE (can be repeated).\n\
 850   -n                    Don't actually run the script (useful with `-v')\n\
 851   -p EXPR               Print (`prin1') EXPR (can be repeated).\n\
 852   -q                    Don't print warning messages.\n\
 853   -v                    Print informational messages (repeat for even more).\n",
 854         fp);
 855 }
 856
 857 /* Parse a comma-separated list of system names SPEC, and add the named
 858  * systems to LIST.
 859  */
 860 static void parse_syslist(const char *spec, const struct argstate *arg,
 861                           struct syslist *list, const char *what)
 862 {
 863   char *copy = xstrdup(spec), *p = copy, *q;
 864   const struct systab *sys;
 865   size_t n;
 866
 867   for (;;) {
 868     n = strcspn(p, ",");
 869     if (p[n]) q = p + n + 1;
 870     else q = 0;
 871     p[n] = 0; sys = find_system(p);
 872     if (list->f&sys->f) {
 873       if (arg->verbose > 0)
 874         moan("ignoring duplicate system `%s' in %s list", p, what);
 875     } else {
 876       list->sys[list->n++] = sys;
 877       list->f |= sys->f;
 878     }
 879     if (!q) break;
 880     p = q;
 881   }
 882   free(copy);
 883 }
 884
 885 static void push_eval_op(struct argstate *arg, char op, const char *val)
 886 {
 887   char *p;
 888   size_t n;
 889
 890   if (arg->f&F_AUX) {
 891     moan("must use `-e', `-p', or `-l' on command line");
 892     arg->f |= F_BOGUS;
 893     return;
 894   }
 895
 896   n = strlen(val) + 1;
 897   p = xmalloc(n + 1);
 898   p[0] = op; memcpy(p + 1, val, n);
 899   argv_append(&arg->av, p);
 900 }
 901
 902 /* Parse a vector ARGS of command-line arguments.  Update ARG with the
 903  * results.  NARG is the number of arguments, and *I_INOUT is the current
 904  * index into the vector, to be updated on exit to identify the first
 905  * non-option argument (or the end of the vector).
 906  */
 907 static void parse_arguments(struct argstate *arg, const char *const *args,
 908                             size_t nargs, size_t *i_inout)
 909 {
 910   const char *o, *a;
 911   char opt;
 912
 913   for (;;) {
 914     if (*i_inout >= nargs) break;
 915     o = args[*i_inout];
 916     if (STRCMP(o, ==, "--help")) { help(stdout); exit(0); }
 917     else if (STRCMP(o, ==, "--version")) { version(stdout); exit(0); }
 918     if (!*o || *o != '-' || !o[1]) break;
 919     (*i_inout)++;
 920     if (STRCMP(o, ==, "--")) break;
 921     o++;
 922     while (o && *o) {
 923       opt = *o++;
 924       switch (opt) {
 925
 926 #define GETARG do {                                                     \
 927   if (*o)                                                               \
 928     { a = o; o = 0; }                                                   \
 929   else {                                                                \
 930     if (*i_inout >= nargs) goto noarg;                                  \
 931     a = args[(*i_inout)++];                                             \
 932   }                                                                     \
 933 } while (0)
 934
 935         case 'C': arg->pref.n = 0; arg->pref.f = 0; break;
 936         case 'D': arg->f |= F_NODUMP; break;
 937         case 'E': arg->f |= F_NOEMBED; break;
 938         case 'e': GETARG; push_eval_op(arg, '!', a); break;
 939         case 'p': GETARG; push_eval_op(arg, '?', a); break;
 940         case 'l': GETARG; push_eval_op(arg, '<', a); break;
 941         case 'n': arg->f |= F_NOACT; break;
 942         case 'q': if (arg->verbose) arg->verbose--; break;
 943         case 'v': arg->verbose++; break;
 944
 945         case 'I':
 946           free(arg->imagedir);
 947           GETARG; arg->imagedir = xstrdup(a);
 948           break;
 949
 950         case 'L':
 951           GETARG;
 952           parse_syslist(a, arg, &arg->allow, "allowed");
 953           break;
 954
 955         case 'P':
 956           GETARG;
 957           parse_syslist(a, arg, &arg->pref, "preferred");
 958           break;
 959
 960         default:
 961           moan("unknown option `%c'", opt);
 962           arg->f |= F_BOGUS;
 963           break;
 964
 965 #undef GETARG
 966
 967       }
 968     }
 969   }
 970   goto end;
 971
 972 noarg:
 973   moan("missing argument for `-%c'", opt);
 974   arg->f |= F_BOGUS;
 975 end:
 976   return;
 977 }
 978
 979 /* Parse a string P into words (destructively), and process them as
 980  * command-line options, updating ARG.  Non-option arguments are not
 981  * permitted.  If `SOSF_EMACS' is set in FLAGS, then ignore `-*- ... -*-'
 982  * editor turds.  If `SOSF_ENDOK' is set, then accept `--' and ignore
 983  * whatever comes after; otherwise, reject all positional arguments.
 984  */
 985 #define SOSF_EMACS 1u
 986 #define SOSF_ENDOK 2u
 987 static void scan_options_from_string(char *p, struct argstate *arg,
 988                                      unsigned flags,
 989                                      const char *what, const char *file)
 990 {
 991   struct argv av = ARGV_INIT;
 992   char *q;
 993   size_t i;
 994   int st = 0;
 995   unsigned f = 0;
 996 #define f_escape 1u
 997
 998   for (;;) {
 999     while (ISSPACE(*p)) p++;
1000     if (!*p) break;
1001     if ((flags&SOSF_EMACS) && p[0] == '-' && p[1] == '*' && p[2] == '-') {
1002       p = strstr(p + 3, "-*-");
1003       if (!p) lose("unfinished local-variables list in %s `%s'", what, file);
1004       p += 3; continue;
1005     }
1006     if ((flags&SOSF_ENDOK) &&
1007         p[0] == '-' && p[1] == '-' && (!p[2] || ISSPACE(p[2])))
1008       break;
1009     argv_append(&av, p); q = p;
1010     for (;;) {
1011       if (!*p) break;
1012       else if (f&f_escape) { *q++ = *p; f &= ~f_escape; }
1013       else if (st && *p == st) st = 0;
1014       else if (st != '\'' && *p == '\\') f |= f_escape;
1015       else if (!st && (*p == '"' || *p == '\'')) st = *p;
1016       else if (!st && ISSPACE(*p)) break;
1017       else *q++ = *p;
1018       p++;
1019     }
1020     if (*p) p++;
1021     *q = 0;
1022     if (f&f_escape) lose("unfinished escape in %s `%s'", what, file);
1023     if (st) lose("unfinished `%c' string in %s `%s'", st, what, file);
1024   }
1025
1026   i = 0; parse_arguments(arg, av.v, av.n, &i);
1027   if (i < av.n)
1028     lose("positional argument `%s' in %s `%s'", av.v[i], what, file);
1029   argv_release(&av);
1030
1031 #undef f_escape
1032 }
1033
1034 /* Read SCRIPT, and check for a `@RUNLISP:' marker in the second line.  If
1035  * there is one, parse options from it, and update ARG.
1036  */
1037 static void check_for_embedded_args(const char *script, struct argstate *arg)
1038 {
1039   struct dstr d = DSTR_INIT;
1040   char *p;
1041   FILE *fp = 0;
1042
1043   fp = fopen(script, "r");
1044   if (!fp) lose("can't read script `%s': %s", script, strerror(errno));
1045
1046   if (dstr_readline(&d, fp)) goto end;
1047   dstr_reset(&d); if (dstr_readline(&d, fp)) goto end;
1048
1049   p = strstr(d.p, "@RUNLISP:");
1050   if (p)
1051     scan_options_from_string(p + 9, arg, SOSF_EMACS | SOSF_ENDOK,
1052                              "embedded options in script", script);
1053
1054 end:
1055   if (fp) {
1056     if (ferror(fp))
1057       lose("error reading script `%s': %s", script, strerror(errno));
1058     fclose(fp);
1059   }
1060   dstr_release(&d);
1061 }
1062
1063 /* Read the file PATH (if it exists) and update ARG with the arguments parsed
1064  * from it.  Ignore blank lines and (Unix- or Lisp-style) comments.
1065  */
1066 static void read_config_file(const char *path, struct argstate *arg)
1067 {
1068   FILE *fp = 0;
1069   struct dstr d = DSTR_INIT;
1070   char *p;
1071
1072   fp = fopen(path, "r");
1073   if (!fp) {
1074     if (errno == ENOENT) {
1075       if (arg->verbose > 2)
1076         moan("ignoring nonexistent configuration file `%s'", path);
1077       goto end;
1078     }
1079     lose("failed to open configuration file `%s': %s",
1080          path, strerror(errno));
1081   }
1082   if (arg->verbose > 1)
1083     moan("reading configuration file `%s'", path);
1084   for (;;) {
1085     dstr_reset(&d);
1086     if (dstr_readline(&d, fp)) break;
1087     p = d.p;
1088     while (ISSPACE(*p)) p++;
1089     if (!*p || *p == ';' || *p == '#') continue;
1090     scan_options_from_string(p, arg, 0, "configuration file `%s'", path);
1091   }
1092   if (arg->f&F_BOGUS)
1093     lose("invalid options in configuration file `%s'", path);
1094
1095 end:
1096   if (fp) {
1097     if (ferror(fp))
1098       lose("error reading configuration file `%s': %s",
1099            path, strerror(errno));
1100     fclose(fp);
1101   }
1102   dstr_release(&d);
1103 }
1104
1105 int main(int argc, char *argv[])
1106 {
1107   struct dstr d = DSTR_INIT;
1108   const char *script, *p;
1109   const char *home;
1110   struct passwd *pw;
1111   char *t;
1112   size_t i, n;
1113   struct argstate arg = ARGSTATE_INIT;
1114
1115   /* Scan the command line.  This gets low priority, since it's probably
1116    * from the script shebang.
1117    */
1118   set_progname(argv[0]); i = 1;
1119   parse_arguments(&arg, (const char *const *)argv, argc, &i);
1120   arg.f |= F_AUX;
1121   if ((i >= argc && !arg.av.n) || (arg.f&F_BOGUS))
1122     { usage(stderr); exit(255); }
1123
1124   /* Prepare the argument vector.  Keep track of the number of arguments
1125    * here: we'll need to refer to this later.
1126    */
1127   if (!arg.av.n) {
1128     script = argv[i++];
1129     if (!(arg.f&F_NOEMBED)) check_for_embedded_args(script, &arg);
1130     if (arg.f&F_BOGUS)
1131       lose("invalid options in `%s' embedded option list", script);
1132   } else {
1133     script = getenv("RUNLISP_EVAL");
1134     if (!script) script = DATADIR "/eval.lisp";
1135     argv_append(&arg.av, "--");
1136   }
1137   argv_appendn(&arg.av, (const char *const *)argv + i, argc - i);
1138   n = arg.av.n;
1139
1140   /* Find the user's home directory.  (Believe them if they set something
1141    * strange.)
1142    */
1143   home = getenv("HOME");
1144   if (!home) {
1145     pw = getpwuid(getuid());
1146     if (!pw) lose("can't find user in password database");
1147     home = pw->pw_dir;
1148   }
1149
1150   /* Check user configuration file `~/.runlisprc'. */
1151   dstr_reset(&d);
1152   dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".runlisprc");
1153   read_config_file(d.p, &arg);
1154
1155   /* Check user configuration file `~/.config/runlisprc'. */
1156   dstr_reset(&d);
1157   p = getenv("XDG_CONFIG_HOME");
1158   if (p)
1159     dstr_puts(&d, p);
1160   else
1161     { dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".config"); }
1162   dstr_putc(&d, '/'); dstr_puts(&d, "runlisprc");
1163   read_config_file(d.p, &arg);
1164
1165   /* Finally, check the environment variables. */
1166   p = getenv("RUNLISP_OPTIONS");
1167   if (p) {
1168     t = xstrdup(p);
1169     scan_options_from_string(t, &arg, 0,
1170                              "environment variable", "RUNLISP_OPTIONS");
1171     free(t);
1172   }
1173   if (arg.f&F_BOGUS)
1174     lose("invalid options in environment variable `RUNLISP_OPTIONS'");
1175   if (!arg.imagedir) {
1176     arg.imagedir = getenv("RUNLISP_IMAGEDIR");
1177     if (!arg.imagedir) arg.imagedir = IMAGEDIR;
1178   }
1179
1180   /* If no systems are listed as acceptable, try them all. */
1181   if (!arg.allow.n) {
1182     if (arg.verbose > 1)
1183       moan("no explicitly allowed implementations: allowing all");
1184     for (i = 0; i < NSYS; i++) arg.allow.sys[i] = &systab[i];
1185     arg.allow.n = NSYS; arg.allow.f = (1u << NSYS) - 1;
1186   }
1187
1188   /* Print what we're going to do. */
1189   if (arg.verbose > 2) {
1190     dstr_reset(&d); p = "";
1191     for (i = 0; i < arg.allow.n; i++)
1192       { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); }
1193     moan("permitted Lisps: %s", d.p);
1194
1195     dstr_reset(&d); p = "";
1196     for (i = 0; i < arg.pref.n; i++)
1197       { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); }
1198     moan("preferred Lisps: %s", d.p);
1199
1200     dstr_reset(&d); p = "";
1201     for (i = 0; i < arg.pref.n; i++)
1202       if (arg.pref.sys[i]->f&arg.allow.f)
1203         { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); }
1204     for (i = 0; i < arg.allow.n; i++)
1205       if (!(arg.allow.sys[i]->f&arg.pref.f))
1206         { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); }
1207     moan("overall preference order: %s", d.p);
1208   }
1209
1210   /* Inform `uiop' of the script name.
1211    *
1212    * As an aside, this is a terrible interface.  It's too easy to forget to
1213    * set it.  (To illustrate this, `cl-launch -x' indeed forgets to set it.)
1214    * If you're lucky, the script just thinks that its argument is `nil', in
1215    * which case maybe it can use `*load-pathname*' as a fallback.  If you're
1216    * unlucky, your script was invoked (possibly indirectly) by another
1217    * script, and now you've accidentally inherited the calling script's name.
1218    *
1219    * It would have been far better simply to repeat the script name as the
1220    * first user argument, if nothing else had come readily to mind.
1221    */
1222   if (setenv("__CL_ARGV0", script, 1))
1223     lose("failed to set script-name environment variable");
1224
1225   /* Work through the list of preferred Lisp systems, trying the ones which
1226    * are allowed.
1227    */
1228   for (i = 0; i < arg.pref.n; i++)
1229     if (arg.pref.sys[i]->f&arg.allow.f) {
1230       arg.av.o += arg.av.n - n; arg.av.n = n;
1231       arg.pref.sys[i]->run(&arg, script);
1232     }
1233
1234   /* That didn't work.  Try the remaining allowed systems, in the given
1235    * order.
1236    */
1237   for (i = 0; i < arg.allow.n; i++)
1238     if (!(arg.allow.sys[i]->f&arg.pref.f)) {
1239       arg.av.o += arg.av.n - n; arg.av.n = n;
1240       arg.allow.sys[i]->run(&arg, script);
1241     }
1242
1243   /* No joy.  Give up. */
1244   argv_release(&arg.av);
1245   lose("no supported Lisp systems found");
1246 }
1247
1248 /*----- That's all, folks -------------------------------------------------*/