chiark - git - mdw - runlisp/blob - old-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 #include "lib.h"
  44
  45 /*----- Common Lisp runes -------------------------------------------------*/
  46
  47 /* A common preamble rune to do the necessary things.
  48  *
  49  * We need to ensure that `asdf' (and therefore `uiop') is loaded.  And we
  50  * should arrange for `:runlisp-script' to find its way into the `*features*'
  51  * list so that scripts can notice that they're being invoked from the
  52  * command line rather than loaded into a resident session, and actually do
  53  * something useful.
  54  */
  55 #define COMMON_PRELUDE_RUNE                                             \
  56         "(progn "                                                       \
  57           "(setf *load-verbose* nil *compile-verbose* nil) "            \
  58           "(require \"asdf\") "                                         \
  59           "(funcall (intern \"REGISTER-IMMUTABLE-SYSTEM\" "             \
  60                            "(find-package \"ASDF\")) "                  \
  61                    "\"asdf\") "                                         \
  62           "(set-dispatch-macro-character "                              \
  63            "#\\# #\\! "                                                 \
  64            "(lambda (#1=#:stream #2=#:char #3=#:arg) "                  \
  65              "(declare (ignore #2# #3#)) "                              \
  66              "(values (read-line #1#)))) "                              \
  67           "(pushnew :runlisp-script *features*))"
  68
  69 /* Get `uiop' to re-check the command-line arguments following an image
  70  * restore.
  71  */
  72 #define IMAGE_RESTORE_RUNE                                              \
  73         "(uiop:call-image-restore-hook)"
  74
  75 /* Some Lisps leave crud in the `COMMON-LISP-USER' package.  Clear it out. */
  76 #define CLEAR_CL_USER_RUNE                                              \
  77         "(let ((#4=#:pkg (find-package \"COMMON-LISP-USER\"))) "        \
  78           "(with-package-iterator (#5=#:next #4# :internal) "           \
  79             "(loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how) " \
  80                       "(#5#) "                                          \
  81                     "(declare (ignore #8#)) "                           \
  82                     "(unless #6# (return)) "                            \
  83                     "(unintern #7# #4#)))))"
  84
  85 /*----- The Lisp implementation table -------------------------------------*/
  86
  87 /* The systems, in decreasing order of (not quite my personal) preference.
  88  * This list is used to initialize various tables and constants.
  89  */
  90 #define LISP_SYSTEMS(_)                                                 \
  91         _(sbcl)                                                         \
  92         _(ccl)                                                          \
  93         _(clisp)                                                        \
  94         _(ecl)                                                          \
  95         _(cmucl)                                                        \
  96         _(abcl)
  97
  98 enum {
  99 #define DEFSYS(sys) sys##_INDEX,
 100   LISP_SYSTEMS(DEFSYS)
 101 #undef DEFSYS
 102   NSYS
 103 };
 104
 105 enum {
 106 #define DEFFLAG(sys) sys##_FLAG = 1 << sys##_INDEX,
 107   LISP_SYSTEMS(DEFFLAG)
 108 #undef DEFFLAG
 109   ALL_SYSTEMS = 0
 110 #define SETFLAG(sys) | sys##_FLAG
 111   LISP_SYSTEMS(SETFLAG)
 112 #undef SETFLAG
 113 };
 114
 115 struct argstate;
 116 struct argv;
 117
 118 #define DECLENTRY(sys) \
 119 static void run_##sys(struct argstate *, const char *);
 120   LISP_SYSTEMS(DECLENTRY)
 121 #undef DECLENTRY
 122
 123 static const struct systab {
 124   const char *name;
 125   unsigned f;
 126   void (*run)(struct argstate *, const char *);
 127 } systab[] = {
 128 #define SYSENTRY(sys) { #sys, sys##_FLAG, run_##sys },
 129   LISP_SYSTEMS(SYSENTRY)
 130 #undef SYSENTRY
 131 };
 132
 133 static const struct systab *find_system(const char *name)
 134 {
 135   const struct systab *sys;
 136   size_t i;
 137
 138   for (i = 0; i < NSYS; i++) {
 139     sys = &systab[i];
 140     if (STRCMP(name, ==, sys->name)) return (sys);
 141   }
 142   lose("unknown Lisp system `%s'", name);
 143 }
 144
 145 static void lisp_quote_string(struct dstr *d, const char *p)
 146 {
 147   size_t n;
 148
 149   for (;;) {
 150     n = strcspn(p, "\"\\");
 151     if (n) { dstr_putm(d, p, n); p += n; }
 152     if (!*p) break;
 153     dstr_putc(d, '\\'); dstr_putc(d, *p++);
 154   }
 155   dstr_putz(d);
 156 }
 157
 158 static const char *expand_rune(struct dstr *d, const char *rune, ...)
 159 {
 160   const struct argv *av;
 161   va_list ap;
 162   size_t i, n;
 163
 164   va_start(ap, rune);
 165   for (;;) {
 166     n = strcspn(rune, "%");
 167     if (n) { dstr_putm(d, rune, n); rune += n; }
 168     if (!*rune) break;
 169     switch (*++rune) {
 170       case '%': dstr_putc(d, '%'); break;
 171       case 'e': lisp_quote_string(d, va_arg(ap, const char *)); break;
 172       case 'E':
 173         av = va_arg(ap, const struct argv *);
 174         for (i = 0; i < av->n; i++) {
 175           if (i) dstr_putc(d, ' ');
 176           dstr_putc(d, '"');
 177           lisp_quote_string(d, av->v[i]);
 178           dstr_putc(d, '"');
 179         }
 180         break;
 181       default: lose("*** BUG unknown expansion `%%%c'", *rune);
 182     }
 183     rune++;
 184   }
 185   dstr_putz(d);
 186   return (d->p);
 187 }
 188
 189 /*----- Argument processing -----------------------------------------------*/
 190
 191 struct syslist {
 192   const struct systab *sys[NSYS];
 193   size_t n;
 194   unsigned f;
 195 };
 196 #define SYSLIST_INIT { { 0 }, 0, 0 }
 197
 198 struct argstate {
 199   unsigned f;
 200 #define F_BOGUS 1u
 201 #define F_NOEMBED 2u
 202 #define F_NOACT 4u
 203 #define F_NODUMP 8u
 204 #define F_AUX 16u
 205   int verbose;
 206   char *imagedir;
 207   struct syslist allow, pref;
 208   struct argv av;
 209 };
 210 #define ARGSTATE_INIT { 0, 1, 0, SYSLIST_INIT, SYSLIST_INIT, ARGV_INIT }
 211
 212 /*----- Running programs --------------------------------------------------*/
 213
 214 #define FEF_EXEC 1u
 215 static int file_exists_p(const struct argstate *arg, const char *path,
 216                          unsigned f)
 217 {
 218   struct stat st;
 219
 220   if (stat(path, &st)) {
 221     if (arg && arg->verbose > 2) moan("file `%s' not found", path);
 222     return (0);
 223   } else if (!(S_ISREG(st.st_mode))) {
 224     if (arg && arg->verbose > 2) moan("`%s' is not a regular file", path);
 225     return (0);
 226   } else if ((f&FEF_EXEC) && access(path, X_OK)) {
 227     if (arg && arg->verbose > 2) moan("file `%s' is not executable", path);
 228     return (0);
 229   } else {
 230     if (arg && arg->verbose > 2) moan("found file `%s'", path);
 231     return (1);
 232   }
 233 }
 234
 235 static int found_in_path_p(const struct argstate *arg, const char *prog)
 236 {
 237   struct dstr p = DSTR_INIT, d = DSTR_INIT;
 238   const char *path;
 239   char *q;
 240   size_t n, avail, proglen;
 241   int i;
 242
 243   if (strchr(prog, '/')) return (file_exists_p(arg, prog, 0));
 244   path = getenv("PATH");
 245   if (path)
 246     dstr_puts(&p, path);
 247   else {
 248     dstr_puts(&p, ".:");
 249     i = 0;
 250   again:
 251     avail = p.sz - p.len;
 252     n = confstr(_CS_PATH, p.p + p.len, avail);
 253     if (avail > n) { i++; assert(i < 2); dstr_ensure(&p, n); goto again; }
 254   }
 255
 256   q = p.p; proglen = strlen(prog);
 257   for (;;) {
 258     n = strcspn(q, ":");
 259     dstr_reset(&d);
 260     if (q[n]) dstr_putm(&d, q, n);
 261     else dstr_putc(&d, '.');
 262     dstr_putc(&d, '/');
 263     dstr_putm(&d, prog, proglen);
 264     dstr_putz(&d);
 265     if (file_exists_p(arg, d.p, FEF_EXEC)) {
 266       if (arg->verbose == 2) moan("found program `%s'", d.p);
 267       return (1);
 268     }
 269     q += n; if (!*q) break; else q++;
 270   }
 271   return (0);
 272 }
 273
 274 static void try_exec(const struct argstate *arg, struct argv *av)
 275 {
 276   struct dstr d = DSTR_INIT;
 277   size_t i;
 278
 279   assert(av->n); argv_appendz(av);
 280   if (arg->verbose > 1) {
 281     for (i = 0; i < av->n; i++) {
 282       if (i) { dstr_putc(&d, ','); dstr_putc(&d, ' '); }
 283       dstr_putc(&d, '"');
 284       lisp_quote_string(&d, av->v[i]);
 285       dstr_putc(&d, '"');
 286     }
 287     dstr_putz(&d);
 288     moan("trying %s...", d.p);
 289   }
 290   if (arg->f&F_NOACT)
 291     { if (found_in_path_p(arg, av->v[0])) exit(0); }
 292   else {
 293     execvp(av->v[0], (/*unconst*/ char **)av->v);
 294     if (errno != ENOENT)
 295       lose("failed to exec `%s': %s", av->v[0], strerror(errno));
 296   }
 297   if (arg->verbose > 1) moan("`%s' not found", av->v[0]);
 298   dstr_release(&d);
 299 }
 300
 301 static const char *getenv_or_default(const char *var, const char *dflt)
 302   { const char *p = getenv(var); return (p ? p : dflt); }
 303
 304 /*----- Invoking Lisp systems ---------------------------------------------*/
 305
 306 /* Steel Bank Common Lisp. */
 307
 308 static void run_sbcl(struct argstate *arg, const char *script)
 309 {
 310   struct dstr d = DSTR_INIT;
 311
 312   argv_prependl(&arg->av, "--script", script, END);
 313
 314   dstr_puts(&d, arg->imagedir);
 315   dstr_putc(&d, '/');
 316   dstr_puts(&d, "sbcl+asdf.core");
 317   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
 318     argv_prependl(&arg->av,
 319                   "--core", d.p,
 320                   "--eval", IMAGE_RESTORE_RUNE,
 321                   END);
 322   else
 323     argv_prependl(&arg->av, "--eval", COMMON_PRELUDE_RUNE, END);
 324
 325   argv_prependl(&arg->av, getenv_or_default("SBCL", "sbcl"),
 326                 "--noinform",
 327                 END);
 328   try_exec(arg, &arg->av);
 329   dstr_release(&d);
 330 }
 331
 332 /* Clozure Common Lisp. */
 333
 334 #define CCL_QUIT_RUNE                                                   \
 335         "(ccl:quit)"
 336
 337 static void run_ccl(struct argstate *arg, const char *script)
 338 {
 339   struct dstr d = DSTR_INIT;
 340
 341   argv_prependl(&arg->av, "-b", "-n", "-Q",
 342                 "-l", script,
 343                 "-e", CCL_QUIT_RUNE,
 344                 "--",
 345                 END);
 346
 347   dstr_puts(&d, arg->imagedir);
 348   dstr_putc(&d, '/');
 349   dstr_puts(&d, "ccl+asdf.image");
 350   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
 351     argv_prependl(&arg->av, "-I", d.p, "-e", IMAGE_RESTORE_RUNE, END);
 352   else
 353     argv_prependl(&arg->av, "-e", COMMON_PRELUDE_RUNE, END);
 354
 355   argv_prepend(&arg->av, getenv_or_default("CCL", "ccl"));
 356   try_exec(arg, &arg->av);
 357   dstr_release(&d);
 358 }
 359
 360 /* GNU CLisp.
 361  *
 362  * CLisp causes much sadness.  Superficially, it's the most sensible of all
 363  * of the systems supported here: you just run `clisp SCRIPT -- ARGS ...' and
 364  * it works.
 365  *
 366  * The problems come when you want to do some preparatory work (e.g., load
 367  * `asdf') and then run the script.  There's a `-x' option to evaluate some
 368  * Lisp code, but it has three major deficiencies.
 369  *
 370  *   * It insists on printing the values of the forms it evaluates.  It
 371  *     prints a blank line even if the form goes out of its way to produce no
 372  *     values at all.  So the whole thing has to be a single top-level form
 373  *     which quits the Lisp rather than returning.
 374  *
 375  *   * For some idiotic reason, you can have /either/ `-x' forms /or/ a
 376  *     script, but not both.  So we have to include the `load' here
 377  *     explicitly.  I suppose that was inevitable because we have to inhibit
 378  *     printing of the result forms, but it's still a separate source of
 379  *     annoyance.
 380  *
 381  *   * The icing on the cake: the `-x' forms are collectively concatenated --
 382  *     without spaces! -- and used to build a string stream, which is then
 383  *     assigned over the top of `*standard-input*', making the original stdin
 384  *     somewhat fiddly to track down.
 385  *
 386  * There's an `-i' option which will load a file without any of this
 387  * stupidity, but nothing analogous for immediate expressions.
 388  */
 389
 390 #define CLISP_COMMON_STARTUP_RUNES                                      \
 391         "(setf *standard-input* (ext:make-stream :input)) "             \
 392         "(load \"%e\" :verbose nil :print nil) "                        \
 393         "(ext:quit)"
 394
 395 #define CLISP_STARTUP_RUNE                                              \
 396         "(progn "                                                       \
 397            COMMON_PRELUDE_RUNE " "                                      \
 398            CLISP_COMMON_STARTUP_RUNES ")"
 399
 400 #define CLISP_STARTUP_IMAGE_RUNE                                        \
 401         "(progn "                                                       \
 402            IMAGE_RESTORE_RUNE " "                                       \
 403            CLISP_COMMON_STARTUP_RUNES ")"
 404
 405 static void run_clisp(struct argstate *arg, const char *script)
 406 {
 407   struct dstr d = DSTR_INIT, dd = DSTR_INIT;
 408
 409   dstr_puts(&d, arg->imagedir);
 410   dstr_putc(&d, '/');
 411   dstr_puts(&d, "clisp+asdf.mem");
 412   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
 413     argv_prependl(&arg->av, "-M", d.p, "-q",
 414                   "-x", expand_rune(&dd, CLISP_STARTUP_IMAGE_RUNE, script),
 415                   "--",
 416                   END);
 417   else
 418     argv_prependl(&arg->av, "-norc", "-q",
 419                   "-x", expand_rune(&dd, CLISP_STARTUP_RUNE, script),
 420                   "--",
 421                   END);
 422
 423   argv_prepend(&arg->av, getenv_or_default("CLISP", "clisp"));
 424   try_exec(arg, &arg->av);
 425   dstr_release(&d);
 426   dstr_release(&dd);
 427
 428 #undef f
 429 }
 430
 431 /* Embeddable Common Lisp. *
 432  *
 433  * ECL is changing its command-line option syntax in version 16.  I have no
 434  * idea why they think the result can ever be worth the pain of a transition.
 435  */
 436
 437 #if ECL_OPTIONS_GNU
 438 #  define ECLOPT "--"
 439 #else
 440 #  define ECLOPT "-"
 441 #endif
 442
 443 #define ECL_STARTUP_RUNE                                                \
 444         "(progn "                                                       \
 445            COMMON_PRELUDE_RUNE " "                                      \
 446            CLEAR_CL_USER_RUNE ")"
 447
 448 static void run_ecl(struct argstate *arg, const char *script)
 449 {
 450   struct dstr d = DSTR_INIT;
 451
 452   dstr_puts(&d, arg->imagedir);
 453   dstr_putc(&d, '/');
 454   dstr_puts(&d, "ecl+asdf");
 455   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, FEF_EXEC)) {
 456     argv_prependl(&arg->av, "-s", script, "--", END);
 457     argv_prependl(&arg->av, d.p, END);
 458   } else {
 459     argv_prependl(&arg->av, ECLOPT "shell", script, "--", END);
 460     argv_prependl(&arg->av, getenv_or_default("ECL", "ecl"), ECLOPT "norc",
 461                   ECLOPT "eval", ECL_STARTUP_RUNE,
 462                   END);
 463   }
 464   try_exec(arg, &arg->av);
 465 }
 466
 467 /* Carnegie--Mellon University Common Lisp. */
 468
 469 #define CMUCL_STARTUP_RUNE                                              \
 470         "(progn "                                                       \
 471           "(setf ext:*require-verbose* nil) "                           \
 472           COMMON_PRELUDE_RUNE ")"
 473 #define CMUCL_QUIT_RUNE                                                 \
 474         "(ext:quit)"
 475
 476 static void run_cmucl(struct argstate *arg, const char *script)
 477 {
 478   struct dstr d = DSTR_INIT;
 479
 480   argv_prependl(&arg->av,
 481                 "-load", script,
 482                 "-eval", CMUCL_QUIT_RUNE,
 483                 "--",
 484                 END);
 485
 486   dstr_puts(&d, arg->imagedir);
 487   dstr_putc(&d, '/');
 488   dstr_puts(&d, "cmucl+asdf.core");
 489   if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0))
 490     argv_prependl(&arg->av, "-core", d.p, "-eval", IMAGE_RESTORE_RUNE, END);
 491   else
 492     argv_prependl(&arg->av, "-batch", "-noinit", "-nositeinit", "-quiet",
 493                   "-eval", CMUCL_STARTUP_RUNE,
 494                   END);
 495
 496   argv_prepend(&arg->av, getenv_or_default("CMUCL", "cmucl"));
 497   try_exec(arg, &arg->av);
 498   dstr_release(&d);
 499 }
 500
 501 /* Armed Bear Common Lisp. *
 502  *
 503  * CLisp made a worthy effort, but ABCL still manages to take the price.
 504  *
 505  *   * ABCL manages to avoid touching the `stderr' stream at all, ever.  Its
 506  *     startup machinery finds `stdout' (as `java.lang.System.out'), wraps it
 507  *     up in a Lisp stream, and uses the result as `*standard-output*' and
 508  *     `*error-output*' (and a goodly number of other things too).  So we
 509  *     must manufacture a working `stderr' the hard way.
 510  *
 511  *   * There doesn't appear to be any easy way to prevent toplevel errors
 512  *     from invoking the interactive debugger.  For extra fun, the debugger
 513  *     reads from `stdin' by default, so an input file which somehow manages
 514  *     to break the script can then take over its brain by providing Lisp
 515  *     forms for the debugger to evaluate.
 516  */
 517
 518 #define ABCL_STARTUP_RUNE                                               \
 519         "(let ((#9=#:script \"%e\")) "                                  \
 520            COMMON_PRELUDE_RUNE " "                                      \
 521            CLEAR_CL_USER_RUNE " "                                       \
 522                                                                         \
 523            /* Replace the broken `*error-output*' stream with a working \
 524             * copy of `stderr'.                                         \
 525             */                                                          \
 526           "(setf *error-output* "                                       \
 527                   "(java:jnew \"org.armedbear.lisp.Stream\" "           \
 528                              "'sys::system-stream "                     \
 529                              "(java:jfield \"java.lang.System\" \"err\") " \
 530                              "'character "                              \
 531                              "java:+true+)) "                           \
 532                                                                         \
 533            /* Trap errors signalled by the script and arrange for them  \
 534             * to actually kill the process rather than ending up in the \
 535             * interactive debugger.                                     \
 536             */                                                          \
 537           "(handler-case (load #9# :verbose nil :print nil) "           \
 538             "(error (error) "                                           \
 539               "(format *error-output* \"~A (unhandled error): ~A~%%\" " \
 540                       "#9# error) "                                     \
 541             "(ext:quit :status 255))))"
 542
 543 static void run_abcl(struct argstate *arg, const char *script)
 544 {
 545   struct dstr d = DSTR_INIT;
 546
 547   argv_prependl(&arg->av, getenv_or_default("ABCL", "abcl"),
 548                 "--batch", "--noinform", "--noinit", "--nosystem",
 549                 "--eval", expand_rune(&d, ABCL_STARTUP_RUNE, script),
 550                 "--",
 551                 END);
 552   try_exec(arg, &arg->av);
 553   dstr_release(&d);
 554 }
 555
 556 /*----- Main code ---------------------------------------------------------*/
 557
 558 static void version(FILE *fp)
 559   { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); }
 560
 561 static void usage(FILE *fp)
 562 {
 563   fprintf(fp, "usage: %s [-CDEnqv] [-I IMAGEDIR] "
 564               "[-L SYS,SYS,...] [-P SYS,SYS,...]\n"
 565               "\t[--] SCRIPT [ARGUMENTS ...] |\n"
 566               "\t[-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n",
 567           progname);
 568 }
 569
 570 static void help(FILE *fp)
 571 {
 572   version(fp); fputc('\n', fp); usage(fp);
 573   fputs("\n\
 574 Options:\n\
 575   --help                Show this help text and exit successfully.\n\
 576   --version             Show the version number and exit successfully.\n\
 577   -C                    Clear the list of preferred Lisp systems.\n\
 578   -D                    Run system Lisp images, rather than custom images.\n\
 579   -E                    Don't read embedded options from the script.\n\
 580   -I IMAGEDIR           Look for custom images in IMAGEDIR rather than\n\
 581                           `" IMAGEDIR "'.\n\
 582   -L SYS,SYS,...        Only use the listed Lisp systems.the script.\n\
 583   -P SYS,SYS,...        Prefer the listed Lisp systems.\n\
 584   -e EXPR               Evaluate EXPR (can be repeated).\n\
 585   -l FILE               Load FILE (can be repeated).\n\
 586   -n                    Don't actually run the script (useful with `-v')\n\
 587   -p EXPR               Print (`prin1') EXPR (can be repeated).\n\
 588   -q                    Don't print warning messages.\n\
 589   -v                    Print informational messages (repeat for even more).\n",
 590         fp);
 591 }
 592
 593 static void push_eval_op(struct argstate *arg, char op, const char *val)
 594 {
 595   char *p;
 596   size_t n;
 597
 598   if (arg->f&F_AUX) {
 599     moan("must use `-e', `-p', or `-l' on command line");
 600     arg->f |= F_BOGUS;
 601     return;
 602   }
 603
 604   n = strlen(val) + 1;
 605   p = xmalloc(n + 1);
 606   p[0] = op; memcpy(p + 1, val, n);
 607   argv_append(&arg->av, p);
 608 }
 609
 610 /* Parse a comma-separated list of system names SPEC, and add the named
 611  * systems to LIST.
 612  */
 613 static void parse_syslist(const char *spec, const struct argstate *arg,
 614                           struct syslist *list, const char *what)
 615 {
 616   char *copy = xstrdup(spec), *p = copy, *q;
 617   const struct systab *sys;
 618   size_t n;
 619
 620   for (;;) {
 621     n = strcspn(p, ",");
 622     if (p[n]) q = p + n + 1;
 623     else q = 0;
 624     p[n] = 0; sys = find_system(p);
 625     if (list->f&sys->f) {
 626       if (arg->verbose > 0)
 627         moan("ignoring duplicate system `%s' in %s list", p, what);
 628     } else {
 629       list->sys[list->n++] = sys;
 630       list->f |= sys->f;
 631     }
 632     if (!q) break;
 633     p = q;
 634   }
 635   free(copy);
 636 }
 637
 638 /* Parse a vector ARGS of command-line arguments.  Update ARG with the
 639  * results.  NARG is the number of arguments, and *I_INOUT is the current
 640  * index into the vector, to be updated on exit to identify the first
 641  * non-option argument (or the end of the vector).
 642  */
 643 static void parse_arguments(struct argstate *arg, const char *const *args,
 644                             size_t nargs, size_t *i_inout)
 645 {
 646   const char *o, *a;
 647   char opt;
 648
 649   for (;;) {
 650     if (*i_inout >= nargs) break;
 651     o = args[*i_inout];
 652     if (STRCMP(o, ==, "--help")) { help(stdout); exit(0); }
 653     else if (STRCMP(o, ==, "--version")) { version(stdout); exit(0); }
 654     if (!*o || *o != '-' || !o[1]) break;
 655     (*i_inout)++;
 656     if (STRCMP(o, ==, "--")) break;
 657     o++;
 658     while (o && *o) {
 659       opt = *o++;
 660       switch (opt) {
 661
 662 #define GETARG do {                                                     \
 663   if (*o)                                                               \
 664     { a = o; o = 0; }                                                   \
 665   else {                                                                \
 666     if (*i_inout >= nargs) goto noarg;                                  \
 667     a = args[(*i_inout)++];                                             \
 668   }                                                                     \
 669 } while (0)
 670
 671         case 'C': arg->pref.n = 0; arg->pref.f = 0; break;
 672         case 'D': arg->f |= F_NODUMP; break;
 673         case 'E': arg->f |= F_NOEMBED; break;
 674         case 'e': GETARG; push_eval_op(arg, '!', a); break;
 675         case 'p': GETARG; push_eval_op(arg, '?', a); break;
 676         case 'l': GETARG; push_eval_op(arg, '<', a); break;
 677         case 'n': arg->f |= F_NOACT; break;
 678         case 'q': if (arg->verbose) arg->verbose--; break;
 679         case 'v': arg->verbose++; break;
 680
 681         case 'I':
 682           free(arg->imagedir);
 683           GETARG; arg->imagedir = xstrdup(a);
 684           break;
 685
 686         case 'L':
 687           GETARG;
 688           parse_syslist(a, arg, &arg->allow, "allowed");
 689           break;
 690
 691         case 'P':
 692           GETARG;
 693           parse_syslist(a, arg, &arg->pref, "preferred");
 694           break;
 695
 696         default:
 697           moan("unknown option `%c'", opt);
 698           arg->f |= F_BOGUS;
 699           break;
 700
 701 #undef GETARG
 702
 703       }
 704     }
 705   }
 706   goto end;
 707
 708 noarg:
 709   moan("missing argument for `-%c'", opt);
 710   arg->f |= F_BOGUS;
 711 end:
 712   return;
 713 }
 714
 715 /* Parse a string P into words (destructively), and process them as
 716  * command-line options, updating ARG.  Non-option arguments are not
 717  * permitted.  If `SOSF_EMACS' is set in FLAGS, then ignore `-*- ... -*-'
 718  * editor turds.  If `SOSF_ENDOK' is set, then accept `--' and ignore
 719  * whatever comes after; otherwise, reject all positional arguments.
 720  */
 721 #define SOSF_EMACS 1u
 722 #define SOSF_ENDOK 2u
 723 static void scan_options_from_string(char *p, struct argstate *arg,
 724                                      unsigned flags,
 725                                      const char *what, const char *file)
 726 {
 727   struct argv av = ARGV_INIT;
 728   char *q;
 729   size_t i;
 730   int st = 0;
 731   unsigned f = 0;
 732 #define f_escape 1u
 733
 734   for (;;) {
 735     while (ISSPACE(*p)) p++;
 736     if (!*p) break;
 737     if ((flags&SOSF_EMACS) && p[0] == '-' && p[1] == '*' && p[2] == '-') {
 738       p = strstr(p + 3, "-*-");
 739       if (!p) lose("unfinished local-variables list in %s `%s'", what, file);
 740       p += 3; continue;
 741     }
 742     if ((flags&SOSF_ENDOK) &&
 743         p[0] == '-' && p[1] == '-' && (!p[2] || ISSPACE(p[2])))
 744       break;
 745     argv_append(&av, p); q = p;
 746     for (;;) {
 747       if (!*p) break;
 748       else if (f&f_escape) { *q++ = *p; f &= ~f_escape; }
 749       else if (st && *p == st) st = 0;
 750       else if (st != '\'' && *p == '\\') f |= f_escape;
 751       else if (!st && (*p == '"' || *p == '\'')) st = *p;
 752       else if (!st && ISSPACE(*p)) break;
 753       else *q++ = *p;
 754       p++;
 755     }
 756
 757     if (*p) p++;
 758     *q = 0;
 759     if (f&f_escape) lose("unfinished escape in %s `%s'", what, file);
 760     if (st) lose("unfinished `%c' string in %s `%s'", st, what, file);
 761   }
 762
 763   i = 0; parse_arguments(arg, av.v, av.n, &i);
 764   if (i < av.n)
 765     lose("positional argument `%s' in %s `%s'", av.v[i], what, file);
 766   argv_release(&av);
 767
 768 #undef f_escape
 769 }
 770
 771 /* Read SCRIPT, and check for a `@RUNLISP:' marker in the second line.  If
 772  * there is one, parse options from it, and update ARG.
 773  */
 774 static void check_for_embedded_args(const char *script, struct argstate *arg)
 775 {
 776   struct dstr d = DSTR_INIT;
 777   char *p;
 778   FILE *fp = 0;
 779
 780   fp = fopen(script, "r");
 781   if (!fp) lose("can't read script `%s': %s", script, strerror(errno));
 782
 783   if (dstr_readline(&d, fp)) goto end;
 784   dstr_reset(&d); if (dstr_readline(&d, fp)) goto end;
 785
 786   p = strstr(d.p, "@RUNLISP:");
 787   if (p)
 788     scan_options_from_string(p + 9, arg, SOSF_EMACS | SOSF_ENDOK,
 789                              "embedded options in script", script);
 790
 791 end:
 792   if (fp) {
 793     if (ferror(fp))
 794       lose("error reading script `%s': %s", script, strerror(errno));
 795     fclose(fp);
 796   }
 797   dstr_release(&d);
 798 }
 799
 800 /* Read the file PATH (if it exists) and update ARG with the arguments parsed
 801  * from it.  Ignore blank lines and (Unix- or Lisp-style) comments.
 802  */
 803 static void read_config_file(const char *path, struct argstate *arg)
 804 {
 805   FILE *fp = 0;
 806   struct dstr d = DSTR_INIT;
 807   char *p;
 808
 809   fp = fopen(path, "r");
 810   if (!fp) {
 811     if (errno == ENOENT) {
 812       if (arg->verbose > 2)
 813         moan("ignoring nonexistent configuration file `%s'", path);
 814       goto end;
 815     }
 816     lose("failed to open configuration file `%s': %s",
 817          path, strerror(errno));
 818   }
 819   if (arg->verbose > 1)
 820     moan("reading configuration file `%s'", path);
 821   for (;;) {
 822     dstr_reset(&d);
 823     if (dstr_readline(&d, fp)) break;
 824     p = d.p;
 825     while (ISSPACE(*p)) p++;
 826     if (!*p || *p == ';' || *p == '#') continue;
 827     scan_options_from_string(p, arg, 0, "configuration file `%s'", path);
 828   }
 829   if (arg->f&F_BOGUS)
 830     lose("invalid options in configuration file `%s'", path);
 831
 832 end:
 833   if (fp) {
 834     if (ferror(fp))
 835       lose("error reading configuration file `%s': %s",
 836            path, strerror(errno));
 837     fclose(fp);
 838   }
 839   dstr_release(&d);
 840 }
 841
 842 int main(int argc, char *argv[])
 843 {
 844   struct dstr d = DSTR_INIT;
 845   const char *script, *p;
 846   const char *home;
 847   struct passwd *pw;
 848   char *t;
 849   size_t i, n;
 850   struct argstate arg = ARGSTATE_INIT;
 851
 852   /* Scan the command line.  This gets low priority, since it's probably
 853    * from the script shebang.
 854    */
 855   set_progname(argv[0]); i = 1;
 856   parse_arguments(&arg, (const char *const *)argv, argc, &i);
 857   arg.f |= F_AUX;
 858   if ((i >= argc && !arg.av.n) || (arg.f&F_BOGUS))
 859     { usage(stderr); exit(255); }
 860
 861   /* Prepare the argument vector.  Keep track of the number of arguments
 862    * here: we'll need to refer to this later.
 863    */
 864   if (!arg.av.n) {
 865     script = argv[i++];
 866     if (!(arg.f&F_NOEMBED)) check_for_embedded_args(script, &arg);
 867     if (arg.f&F_BOGUS)
 868       lose("invalid options in `%s' embedded option list", script);
 869   } else {
 870     script = getenv("RUNLISP_EVAL");
 871     if (!script) script = DATADIR "/eval.lisp";
 872     argv_append(&arg.av, "--");
 873   }
 874   argv_appendn(&arg.av, (const char *const *)argv + i, argc - i);
 875   n = arg.av.n;
 876
 877   /* Find the user's home directory.  (Believe them if they set something
 878    * strange.)
 879    */
 880   home = getenv("HOME");
 881   if (!home) {
 882     pw = getpwuid(getuid());
 883     if (!pw) lose("can't find user in password database");
 884     home = pw->pw_dir;
 885   }
 886
 887   /* Check user configuration file `~/.runlisprc'. */
 888   dstr_reset(&d);
 889   dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".runlisprc");
 890   read_config_file(d.p, &arg);
 891
 892   /* Check user configuration file `~/.config/runlisprc'. */
 893   dstr_reset(&d);
 894   p = getenv("XDG_CONFIG_HOME");
 895   if (p)
 896     dstr_puts(&d, p);
 897   else
 898     { dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".config"); }
 899   dstr_putc(&d, '/'); dstr_puts(&d, "runlisprc");
 900   read_config_file(d.p, &arg);
 901
 902   /* Finally, check the environment variables. */
 903   p = getenv("RUNLISP_OPTIONS");
 904   if (p) {
 905     t = xstrdup(p);
 906     scan_options_from_string(t, &arg, 0,
 907                              "environment variable", "RUNLISP_OPTIONS");
 908     free(t);
 909   }
 910   if (arg.f&F_BOGUS)
 911     lose("invalid options in environment variable `RUNLISP_OPTIONS'");
 912   if (!arg.imagedir) {
 913     arg.imagedir = getenv("RUNLISP_IMAGEDIR");
 914     if (!arg.imagedir) arg.imagedir = IMAGEDIR;
 915   }
 916
 917   /* If no systems are listed as acceptable, try them all. */
 918   if (!arg.allow.n) {
 919     if (arg.verbose > 1)
 920       moan("no explicitly allowed implementations: allowing all");
 921     for (i = 0; i < NSYS; i++) arg.allow.sys[i] = &systab[i];
 922     arg.allow.n = NSYS; arg.allow.f = (1u << NSYS) - 1;
 923   }
 924
 925   /* Print what we're going to do. */
 926   if (arg.verbose > 2) {
 927     dstr_reset(&d); p = "";
 928     for (i = 0; i < arg.allow.n; i++)
 929       { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); }
 930     dstr_putz(&d); moan("permitted Lisps: %s", d.p);
 931
 932     dstr_reset(&d); p = "";
 933     for (i = 0; i < arg.pref.n; i++)
 934       { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); }
 935     dstr_putz(&d); moan("preferred Lisps: %s", d.p);
 936
 937     dstr_reset(&d); p = "";
 938     for (i = 0; i < arg.pref.n; i++)
 939       if (arg.pref.sys[i]->f&arg.allow.f)
 940         { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); }
 941     for (i = 0; i < arg.allow.n; i++)
 942       if (!(arg.allow.sys[i]->f&arg.pref.f))
 943         { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); }
 944     moan("overall preference order: %s", d.p);
 945   }
 946
 947   /* Inform `uiop' of the script name.
 948    *
 949    * As an aside, this is a terrible interface.  It's too easy to forget to
 950    * set it.  (To illustrate this, `cl-launch -x' indeed forgets to set it.)
 951    * If you're lucky, the script just thinks that its argument is `nil', in
 952    * which case maybe it can use `*load-pathname*' as a fallback.  If you're
 953    * unlucky, your script was invoked (possibly indirectly) by another
 954    * script, and now you've accidentally inherited the calling script's name.
 955    *
 956    * It would have been far better simply to repeat the script name as the
 957    * first user argument, if nothing else had come readily to mind.
 958    */
 959   if (setenv("__CL_ARGV0", script, 1))
 960     lose("failed to set script-name environment variable");
 961
 962   /* Work through the list of preferred Lisp systems, trying the ones which
 963    * are allowed.
 964    */
 965   for (i = 0; i < arg.pref.n; i++)
 966     if (arg.pref.sys[i]->f&arg.allow.f) {
 967       arg.av.o += arg.av.n - n; arg.av.v += arg.av.n - n; arg.av.n = n;
 968       arg.pref.sys[i]->run(&arg, script);
 969     }
 970
 971   /* That didn't work.  Try the remaining allowed systems, in the given
 972    * order.
 973    */
 974   for (i = 0; i < arg.allow.n; i++)
 975     if (!(arg.allow.sys[i]->f&arg.pref.f)) {
 976       arg.av.o += arg.av.n - n; arg.av.v += arg.av.n - n; arg.av.n = n;
 977       arg.allow.sys[i]->run(&arg, script);
 978     }
 979
 980   /* No joy.  Give up. */
 981   argv_release(&arg.av);
 982   lose("no supported Lisp systems found");
 983 }
 984
 985 /*----- That's all, folks -------------------------------------------------*/