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

   1 /* -*-c-*-
   2  *
   3  * Invoke Lisp scripts and implementations
   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 <ctype.h>
  31 #include <errno.h>
  32 #include <stdio.h>
  33 #include <stdlib.h>
  34 #include <string.h>
  35
  36 #include "common.h"
  37 #include "lib.h"
  38 #include "mdwopt.h"
  39
  40 /*----- Static data -------------------------------------------------------*/
  41
  42 struct lispsys {
  43   struct treap_node _node;
  44   struct lispsys *next_lisp, *next_accept, *next_prefer, *next_order;
  45   unsigned f;
  46 #define LF_KNOWN 1u
  47 #define LF_ACCEPT 2u
  48 #define LF_PREFER 4u
  49   struct config_section *sect;
  50   struct config_var *var;
  51 };
  52 #define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp)
  53 #define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp)
  54
  55 struct lispsys_list {
  56   struct lispsys *head, **tail;
  57 };
  58
  59 static struct argv argv_tail = ARGV_INIT;
  60 const char *script = 0;
  61
  62 static unsigned flags = 0;
  63 #define AF_CMDLINE 0x0000u
  64 #define AF_EMBED 0x0001u
  65 #define AF_ENV 0x0002u
  66 #define AF_CONF 0x0003u
  67 #define AF_STATEMASK 0x000fu
  68 #define AF_BOGUS 0x0010u
  69 #define AF_SETCONF 0x0020u
  70 #define AF_NOEMBED 0x0040u
  71 #define AF_DRYRUN 0x0080u
  72 #define AF_VANILLA 0x0100u
  73
  74 struct treap lispsys = TREAP_INIT;
  75 static struct lispsys_list
  76   lisps = { 0, &lisps.head },
  77   accept = { 0, &accept.head },
  78   prefer = { 0, &prefer.head };
  79
  80 /*----- Main code ---------------------------------------------------------*/
  81
  82 static void version(FILE *fp)
  83   { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); }
  84
  85 static void usage(FILE *fp)
  86 {
  87   fprintf(fp, "\
  88 usage:\n\
  89         %s [OPTIONS] [--] SCRIPT [ARGUMENTS ...]\n\
  90         %s [OPTIONS] [-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n\
  91 OPTIONS:\n\
  92         [-CDEnqv] [+DEn] [-L SYS,SYS,...] [-c CONF] [-o [SECT:]VAR=VAL]\n",
  93           progname, progname);
  94 }
  95
  96 static void help(FILE *fp)
  97 {
  98   version(fp); fputc('\n', fp); usage(fp);
  99   fputs("\n\
 100 Help options:\n\
 101   -h, --help                    Show this help text and exit successfully.\n\
 102   -V, --version                 Show version number and exit successfully.\n\
 103 \n\
 104 Diagnostics:\n\
 105   -n, --dry-run                 Don't run run anything (useful with `-v').\n\
 106   -q, --quiet                   Don't print warning messages.\n\
 107   -v, --verbose                 Print informational messages (repeatable).\n\
 108 \n\
 109 Configuration:\n\
 110   -E, --command-line-only       Don't read embedded options from script.\n\
 111   -c, --config-file=CONF        Read configuration from CONF (repeatable).\n\
 112   -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
 113 \n\
 114 Lisp implementation selection:\n\
 115   -D, --vanilla-image           Run vanilla Lisp images, not custom ones.\n\
 116   -L, --accept-lisp=SYS,SYS,... Only use the listed Lisp systems.\n\
 117 \n\
 118 Evaluation mode:\n\
 119   -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\
 120   -l, --load-file=FILE          Load FILE (repeatable).\n\
 121   -p, --print-expression=EXPR   Print (`prin1') EXPR (repeatable).\n",
 122         fp);
 123 }
 124
 125 static struct lispsys *ensure_lispsys(const char *name, size_t n)
 126 {
 127   struct lispsys *lisp;
 128   struct treap_path path;
 129
 130   lisp = treap_probe(&lispsys, name, n, &path);
 131   if (!lisp) {
 132     lisp = xmalloc(sizeof(*lisp));
 133     lisp->f = 0; lisp->sect = 0;
 134     treap_insert(&lispsys, &path, &lisp->_node, name, n);
 135   }
 136   return (lisp);
 137 }
 138
 139 #define LISP_LINK(lisp, linkoff)                                        \
 140         ((struct lispsys **)((unsigned char *)(lisp) + (linkoff)))
 141
 142 static void add_lispsys(const char *p, const char *what,
 143                         struct lispsys_list *list,
 144                         unsigned flag, size_t linkoff)
 145 {
 146   struct lispsys *lisp, **link;
 147   const char *q;
 148
 149   if (!*p) return;
 150   for (;;) {
 151     if (!*p) break;
 152     q = p; while (*p && *p != ',') p++;
 153     lisp = ensure_lispsys(q, p - q);
 154     if (lisp->f&flag) {
 155       if (verbose >= 1)
 156         moan("ignoring duplicate %s Lisp `%.*s'", what, (int)(p - q), q);
 157     } else {
 158       link = LISP_LINK(lisp, linkoff);
 159       lisp->f |= flag; *link = 0;
 160       *list->tail = lisp; list->tail = link;
 161     }
 162     if (!*p) break;
 163     p++;
 164   }
 165 }
 166
 167 static void check_lisps(const char *what,
 168                         struct lispsys_list *list, size_t linkoff)
 169 {
 170   struct lispsys *lisp;
 171
 172   for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff))
 173     if (!(lisp->f&LF_KNOWN))
 174       lose("unknown Lisp implementation `%s'", LISPSYS_NAME(lisp));
 175 }
 176
 177 static void dump_lisps(const char *what,
 178                        struct lispsys_list *list, size_t linkoff)
 179 {
 180   struct dstr d = DSTR_INIT;
 181   struct lispsys *lisp;
 182   int first;
 183
 184   first = 1;
 185   for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff)) {
 186     if (first) first = 0;
 187     else dstr_puts(&d, ", ");
 188     dstr_putf(&d, "`%s'", LISPSYS_NAME(lisp));
 189   }
 190   if (first) dstr_puts(&d, "(none)");
 191   dstr_putz(&d);
 192   moan("%s: %s", what, d.p);
 193   dstr_release(&d);
 194 }
 195
 196 static void push_eval_op(char op, const char *val)
 197 {
 198   char *p;
 199   size_t n;
 200
 201   if ((flags&AF_STATEMASK) != AF_CMDLINE) {
 202     moan("must use `-e', `-p', or `-l' on command line");
 203     flags |= AF_BOGUS;
 204     return;
 205   }
 206
 207   n = strlen(val) + 1;
 208   p = xmalloc(n + 1);
 209   p[0] = op; memcpy(p + 1, val, n);
 210   argv_append(&argv_tail, p);
 211 }
 212
 213 static void parse_options(int argc, char *argv[])
 214 {
 215   int i;
 216
 217   static const struct option opts[] = {
 218     { "help",                   0,              0,      'h' },
 219     { "version",                0,              0,      'V' },
 220     { "vanilla-image",          OPTF_NEGATE,    0,      'D' },
 221     { "command-line-only",      OPTF_NEGATE,    0,      'E' },
 222     { "accept-lisp",            OPTF_ARGREQ,    0,      'L' },
 223     { "config-file",            OPTF_ARGREQ,    0,      'c' },
 224     { "evaluate-expression",    OPTF_ARGREQ,    0,      'e' },
 225     { "load-file",              OPTF_ARGREQ,    0,      'l' },
 226     { "dry-run",                OPTF_NEGATE,    0,      'n' },
 227     { "set-option",             OPTF_ARGREQ,    0,      'o' },
 228     { "print-expression",       OPTF_ARGREQ,    0,      'p' },
 229     { "quiet",                  0,              0,      'q' },
 230     { "verbose",                0,              0,      'v' },
 231     { 0,                        0,              0,      0 }
 232   };
 233
 234   optarg = 0; optind = 0; optprog = (/*unconst*/ char *)progname;
 235   for (;;) {
 236     i = mdwopt(argc, argv, "+hVD+E+L:c:e:l:n+o:p:qv", opts, 0, 0,
 237                OPTF_NEGATION | OPTF_NOPROGNAME);
 238     if (i < 0) break;
 239     switch (i) {
 240       case 'h': help(stdout); exit(0);
 241       case 'V': version(stdout); exit(0);
 242       case 'D': flags |= AF_VANILLA; break;
 243       case 'D' | OPTF_NEGATED: flags &= ~AF_VANILLA; break;
 244       case 'E': flags |= AF_NOEMBED; break;
 245       case 'E' | OPTF_NEGATED: flags &= ~AF_NOEMBED; break;
 246       case 'L':
 247         add_lispsys(optarg, "acceptable", &accept, LF_ACCEPT,
 248                     offsetof(struct lispsys, next_accept));
 249         break;
 250       case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break;
 251       case 'e': push_eval_op('!', optarg); break;
 252       case 'l': push_eval_op('<', optarg); break;
 253       case 'n': flags |= AF_DRYRUN; break;
 254       case 'n' | OPTF_NEGATED: flags &= ~AF_DRYRUN; break;
 255       case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break;
 256       case 'p': push_eval_op('?', optarg); break;
 257       case 'q': if (verbose) verbose--; break;
 258       case 'v': verbose++; break;
 259       default: flags |= AF_BOGUS; break;
 260     }
 261   }
 262 }
 263
 264 static void handle_embedded_args(const char *script)
 265 {
 266   struct dstr d = DSTR_INIT;
 267   struct argv av = ARGV_INIT;
 268   char *p, *q, *r; const char *l;
 269   size_t n;
 270   int qstate = 0;
 271   FILE *fp = 0;
 272
 273   fp = fopen(script, "r");
 274   if (!fp) lose("can't read script `%s': %s", script, strerror(errno));
 275
 276   if (dstr_readline(&d, fp)) goto end;
 277   dstr_reset(&d); if (dstr_readline(&d, fp)) goto end;
 278
 279   p = strstr(d.p, "@RUNLISP:"); if (!p) goto end;
 280   p += 9; q = p; l = d.p + d.len;
 281   for (;;) {
 282     while (p < l && ISSPACE(*p)) p++;
 283     if (p >= l) break;
 284     if (l - p >= 3 && p[0] == '-' && p[1] == '*' && p[2] == '-') {
 285       p = strstr(p + 3, "-*-");
 286       if (!p || p + 3 > l)
 287         lose("%s:2: unfinished local-variables list", script);
 288       p += 3;
 289       continue;
 290     }
 291     if (l - p >= 2 && p[0] == '-' && p[1] == '-' &&
 292         (l == p + 2 || ISSPACE(p[2])))
 293       break;
 294
 295     argv_append(&av, q);
 296     while (p < l && (qstate || !ISSPACE(*p))) {
 297       if (*p == '"') { p++; qstate = !qstate; }
 298       else if (*p == '\\') {
 299         p++; if (p >= l) lose("%s:2: unfinished `\\' escape", script);
 300         *q++ = *p++;
 301       } else if (*p == '\'') {
 302         p++; r = strchr(p, '\'');
 303         if (!r || r > l) lose("%s:2: missing `''", script);
 304         n = r - p; memmove(q, p, n); q += n; p = r + 1;
 305       } else {
 306         n = strcspn(p, qstate ? "\"\\" : "\"'\\ \f\n\r\t\v");
 307         if (n > l - p) n = l - p;
 308         memmove(q, p, n); q += n; p += n;
 309       }
 310     }
 311     if (qstate) lose("%s:2: missing `\"'", script);
 312     if (p < l) p++;
 313     *q++ = 0;
 314   }
 315
 316   flags = (flags&~AF_STATEMASK) | AF_EMBED;
 317   parse_options(av.n, (char * /*unconst*/*)av.v);
 318   if (optind < av.n)
 319     lose("%s:2: positional argument `%s' not permitted here",
 320          script, av.v[optind]);
 321
 322 end:
 323   if (fp) {
 324     if (ferror(fp))
 325       lose("error reading script `%s': %s", script, strerror(errno));
 326     fclose(fp);
 327   }
 328   dstr_release(&d); argv_release(&av);
 329 }
 330
 331 int main(int argc, char *argv[])
 332 {
 333   struct config_section_iter si;
 334   struct config_section *sect;
 335   struct config_var *var;
 336   struct lispsys_list order;
 337   struct lispsys *lisp, **tail;
 338   struct dstr d = DSTR_INIT;
 339   struct argv av = ARGV_INIT;
 340
 341   set_progname(argv[0]);
 342
 343   init_config();
 344   config_set_var(&config, toplevel, 0, "prefer", "${@ENV:RUNLISP_PREFER?}");
 345
 346   flags = (flags&~AF_STATEMASK) | AF_CMDLINE;
 347   parse_options(argc - 1, argv + 1); optind++;
 348
 349   if (argv_tail.n)
 350     flags |= AF_NOEMBED;
 351   else if (!script && !argv_tail.n) {
 352     if (optind < argc) script = argv[optind]++;
 353     else flags |= AF_BOGUS;
 354   }
 355
 356   argc -= optind; argv += optind;
 357   if (argv_tail.n) {
 358     argv_append(&argv_tail, "--");
 359     argv_appendn(&argv_tail, (const char *const *)argv, argc);
 360     argc = argv_tail.n; argv = (/*unconst*/ char */*unconst*/ *)argv_tail.v;
 361   }
 362
 363   if (flags&AF_BOGUS) { usage(stderr); exit(2); }
 364   if (!(flags&AF_NOEMBED)) handle_embedded_args(script);
 365   if (!(flags&AF_SETCONF)) load_default_config();
 366   if (verbose >= 5) dump_config();
 367
 368   dstr_reset(&d);
 369   var = config_find_var(&config, toplevel, CF_INHERIT, "prefer");
 370   config_subst_var(&config, toplevel, var, &d);
 371   add_lispsys(d.p, "preferred", &prefer, LF_PREFER,
 372               offsetof(struct lispsys, next_prefer));
 373
 374   if (!script)
 375     script = config_subst_string_alloc
 376       (&config, common, "<internal>",
 377        "${@ENV:RUNLISP_EVAL?${@CONFIG:data-dir}/eval.lisp}");
 378
 379   if (setenv("__CL_ARGV0", script, 1))
 380     lose("failed to set script-name environment variable");
 381   config_set_var(&config, builtin, CF_LITERAL, "@SCRIPT", script);
 382
 383   tail = lisps.tail;
 384   for (config_start_section_iter(&config, &si);
 385        (sect = config_next_section(&si)); ) {
 386     var = config_find_var(&config, sect, CF_INHERIT, "run-script");
 387     if (!var) continue;
 388     lisp = ensure_lispsys(CONFIG_SECTION_NAME(sect),
 389                           CONFIG_SECTION_NAMELEN(sect));
 390     lisp->f |= LF_KNOWN; lisp->sect = sect; lisp->var = var;
 391     *tail = lisp; tail = &lisp->next_lisp;
 392   }
 393   *tail = 0; lisps.tail = tail;
 394
 395   check_lisps("acceptable", &accept, offsetof(struct lispsys, next_accept));
 396   check_lisps("preferred", &prefer, offsetof(struct lispsys, next_prefer));
 397
 398   if (!accept.head) {
 399     if (verbose >= 2)
 400       moan("no explicitly acceptable implementations: allowing all");
 401     tail = accept.tail;
 402     for (lisp = lisps.head; lisp; lisp = lisp->next_lisp)
 403       { lisp->f |= LF_ACCEPT; *tail = lisp; tail = &lisp->next_accept; }
 404     *tail = 0; accept.tail = tail;
 405   }
 406
 407   tail = &order.head;
 408   for (lisp = prefer.head; lisp; lisp = lisp->next_prefer)
 409     if (lisp->f&LF_ACCEPT) { *tail = lisp; tail = &lisp->next_order; }
 410   for (lisp = accept.head; lisp; lisp = lisp->next_accept)
 411     if (!(lisp->f&LF_PREFER)) { *tail = lisp; tail = &lisp->next_order; }
 412   *tail = 0;
 413
 414   if (verbose >= 4)
 415     dump_lisps("known Lisps", &lisps, offsetof(struct lispsys, next_lisp));
 416   if (verbose >= 3) {
 417     dump_lisps("acceptable Lisps", &accept,
 418                offsetof(struct lispsys, next_accept));
 419     dump_lisps("preferred Lisps", &prefer,
 420                offsetof(struct lispsys, next_prefer));
 421     dump_lisps("overall preference order", &order,
 422                offsetof(struct lispsys, next_order));
 423   }
 424
 425   for (lisp = order.head; lisp; lisp = lisp->next_order) {
 426     if (config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) {
 427       var = config_find_var(&config, lisp->sect, CF_INHERIT, "image-path");
 428       dstr_reset(&d); config_subst_var(&config, lisp->sect, var, &d);
 429       if (file_exists_p(d.p, verbose >= 2 ? FEF_VERBOSE : 0))
 430         config_set_var(&config, lisp->sect, CF_LITERAL, "@IMAGE", "t");
 431     }
 432     argv_reset(&av);
 433     config_subst_split_var(&config, lisp->sect, lisp->var, &av);
 434     if (!av.n) {
 435       moan("empty command for Lisp implementation `%s'", LISPSYS_NAME(lisp));
 436       continue;
 437     }
 438     argv_appendn(&av, (const char *const *)argv, argc);
 439     if (!try_exec(&av,
 440                   (flags&AF_DRYRUN ? TEF_DRYRUN : 0) |
 441                     (verbose >= 2 ? TEF_VERBOSE : 0)))
 442       return (0);
 443   }
 444
 445   lose("no acceptable Lisp systems found");
 446 }
 447
 448 /*----- That's all, folks -------------------------------------------------*/