@@@ work in progress

[runlisp] / runlisp.c

/* -*-c-*-
 *
 * Invoke Lisp scripts and implementations
 *
 * (c) 2020 Mark Wooding
 */

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

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

#include "config.h"

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

#include "common.h"
#include "lib.h"
#include "mdwopt.h"

/*----- Static data -------------------------------------------------------*/

struct lispsys {
  struct treap_node _node;
  struct lispsys *next_lisp, *next_accept, *next_prefer, *next_order;
  unsigned f;
#define LF_KNOWN 1u
#define LF_ACCEPT 2u
#define LF_PREFER 4u
  struct config_section *sect;
  struct config_var *var;
};
#define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp)
#define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp)

struct lispsys_list {
  struct lispsys *head, **tail;
};

static struct argv argv_tail = ARGV_INIT;
const char *script = 0;

static unsigned flags = 0;
#define AF_CMDLINE 0x0000u
#define AF_EMBED 0x0001u
#define AF_ENV 0x0002u
#define AF_CONF 0x0003u
#define AF_STATEMASK 0x000fu
#define AF_BOGUS 0x0010u
#define AF_SETCONF 0x0020u
#define AF_NOEMBED 0x0040u
#define AF_DRYRUN 0x0080u
#define AF_VANILLA 0x0100u

struct treap lispsys = TREAP_INIT;
static struct lispsys_list
  lisps = { 0, &lisps.head },
  accept = { 0, &accept.head },
  prefer = { 0, &prefer.head };

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

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

static void usage(FILE *fp)
{
  fprintf(fp, "\
usage:\n\
	%s [OPTIONS] [--] SCRIPT [ARGUMENTS ...]\n\
	%s [OPTIONS] [-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n\
OPTIONS:\n\
	[-CDEnqv] [+DEn] [-L SYS,SYS,...] [-c CONF] [-o [SECT:]VAR=VAL]\n",
	  progname, progname);
}

static void help(FILE *fp)
{
  version(fp); fputc('\n', fp); usage(fp);
  fputs("\n\
Help options:\n\
  -h, --help			Show this help text and exit successfully.\n\
  -V, --version			Show version number and exit successfully.\n\
\n\
Diagnostics:\n\
  -n, --dry-run			Don't run run anything (useful with `-v').\n\
  -q, --quiet			Don't print warning messages.\n\
  -v, --verbose			Print informational messages (repeatable).\n\
\n\
Configuration:\n\
  -E, --command-line-only	Don't read embedded options from script.\n\
  -c, --config-file=CONF	Read configuration from CONF (repeatable).\n\
  -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
\n\
Lisp implementation selection:\n\
  -D, --vanilla-image		Run vanilla Lisp images, not custom ones.\n\
  -L, --accept-lisp=SYS,SYS,...	Only use the listed Lisp systems.\n\
\n\
Evaluation mode:\n\
  -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\
  -l, --load-file=FILE		Load FILE (repeatable).\n\
  -p, --print-expression=EXPR	Print (`prin1') EXPR (repeatable).\n",
	fp);
}

static struct lispsys *ensure_lispsys(const char *name, size_t n)
{
  struct lispsys *lisp;
  struct treap_path path;

  lisp = treap_probe(&lispsys, name, n, &path);
  if (!lisp) {
    lisp = xmalloc(sizeof(*lisp));
    lisp->f = 0; lisp->sect = 0;
    treap_insert(&lispsys, &path, &lisp->_node, name, n);
  }
  return (lisp);
}

#define LISP_LINK(lisp, linkoff)					\
	((struct lispsys **)((unsigned char *)(lisp) + (linkoff)))

static void add_lispsys(const char *p, const char *what,
			struct lispsys_list *list,
			unsigned flag, size_t linkoff)
{
  struct lispsys *lisp, **link;
  const char *q;

  if (!*p) return;
  for (;;) {
    if (!*p) break;
    q = p; while (*p && *p != ',') p++;
    lisp = ensure_lispsys(q, p - q);
    if (lisp->f&flag) {
      if (verbose >= 1)
	moan("ignoring duplicate %s Lisp `%.*s'", what, (int)(p - q), q);
    } else {
      link = LISP_LINK(lisp, linkoff);
      lisp->f |= flag; *link = 0;
      *list->tail = lisp; list->tail = link;
    }
    if (!*p) break;
    p++;
  }
}

static void check_lisps(const char *what,
			struct lispsys_list *list, size_t linkoff)
{
  struct lispsys *lisp;

  for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff))
    if (!(lisp->f&LF_KNOWN))
      lose("unknown Lisp implementation `%s'", LISPSYS_NAME(lisp));
}

static void dump_lisps(const char *what,
		       struct lispsys_list *list, size_t linkoff)
{
  struct dstr d = DSTR_INIT;
  struct lispsys *lisp;
  int first;

  first = 1;
  for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff)) {
    if (first) first = 0;
    else dstr_puts(&d, ", ");
    dstr_putf(&d, "`%s'", LISPSYS_NAME(lisp));
  }
  if (first) dstr_puts(&d, "(none)");
  dstr_putz(&d);
  moan("%s: %s", what, d.p);
  dstr_release(&d);
}

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

  if ((flags&AF_STATEMASK) != AF_CMDLINE) {
    moan("must use `-e', `-p', or `-l' on command line");
    flags |= AF_BOGUS;
    return;
  }

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

static void parse_options(int argc, char *argv[])
{
  int i;

  static const struct option opts[] = {
    { "help",			0,		0,	'h' },
    { "version",		0,		0,	'V' },
    { "vanilla-image",		OPTF_NEGATE,	0,	'D' },
    { "command-line-only",	OPTF_NEGATE,	0,	'E' },
    { "accept-lisp",		OPTF_ARGREQ,	0,	'L' },
    { "config-file",		OPTF_ARGREQ,	0,	'c' },
    { "evaluate-expression",	OPTF_ARGREQ,	0,	'e' },
    { "load-file",		OPTF_ARGREQ,	0,	'l' },
    { "dry-run",		OPTF_NEGATE,	0,	'n' },
    { "set-option",		OPTF_ARGREQ,	0,	'o' },
    { "print-expression",	OPTF_ARGREQ,	0,	'p' },
    { "quiet",			0,		0,	'q' },
    { "verbose",		0,		0,	'v' },
    { 0,			0,		0,	0 }
  };

  optarg = 0; optind = 0; optprog = (/*unconst*/ char *)progname;
  for (;;) {
    i = mdwopt(argc, argv, "+hVD+E+L:c:e:l:n+o:p:qv", opts, 0, 0,
	       OPTF_NEGATION | OPTF_NOPROGNAME);
    if (i < 0) break;
    switch (i) {
      case 'h': help(stdout); exit(0);
      case 'V': version(stdout); exit(0);
      case 'D': flags |= AF_VANILLA; break;
      case 'D' | OPTF_NEGATED: flags &= ~AF_VANILLA; break;
      case 'E': flags |= AF_NOEMBED; break;
      case 'E' | OPTF_NEGATED: flags &= ~AF_NOEMBED; break;
      case 'L':
	add_lispsys(optarg, "acceptable", &accept, LF_ACCEPT,
		    offsetof(struct lispsys, next_accept));
	break;
      case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break;
      case 'e': push_eval_op('!', optarg); break;
      case 'l': push_eval_op('<', optarg); break;
      case 'n': flags |= AF_DRYRUN; break;
      case 'n' | OPTF_NEGATED: flags &= ~AF_DRYRUN; break;
      case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break;
      case 'p': push_eval_op('?', optarg); break;
      case 'q': if (verbose) verbose--; break;
      case 'v': verbose++; break;
      default: flags |= AF_BOGUS; break;
    }
  }
}

static void handle_embedded_args(const char *script)
{
  struct dstr d = DSTR_INIT;
  struct argv av = ARGV_INIT;
  char *p, *q, *r; const char *l;
  size_t n;
  int qstate = 0;
  FILE *fp = 0;

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

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

  p = strstr(d.p, "@RUNLISP:"); if (!p) goto end;
  p += 9; q = p; l = d.p + d.len;
  for (;;) {
    while (p < l && ISSPACE(*p)) p++;
    if (p >= l) break;
    if (l - p >= 3 && p[0] == '-' && p[1] == '*' && p[2] == '-') {
      p = strstr(p + 3, "-*-");
      if (!p || p + 3 > l)
	lose("%s:2: unfinished local-variables list", script);
      p += 3;
      continue;
    }
    if (l - p >= 2 && p[0] == '-' && p[1] == '-' &&
	(l == p + 2 || ISSPACE(p[2])))
      break;

    argv_append(&av, q);
    while (p < l && (qstate || !ISSPACE(*p))) {
      if (*p == '"') { p++; qstate = !qstate; }
      else if (*p == '\\') {
	p++; if (p >= l) lose("%s:2: unfinished `\\' escape", script);
	*q++ = *p++;
      } else if (*p == '\'') {
	p++; r = strchr(p, '\'');
	if (!r || r > l) lose("%s:2: missing `''", script);
	n = r - p; memmove(q, p, n); q += n; p = r + 1;
      } else {
	n = strcspn(p, qstate ? "\"\\" : "\"'\\ \f\n\r\t\v");
	if (n > l - p) n = l - p;
	memmove(q, p, n); q += n; p += n;
      }
    }
    if (qstate) lose("%s:2: missing `\"'", script);
    if (p < l) p++;
    *q++ = 0;
  }

  flags = (flags&~AF_STATEMASK) | AF_EMBED;
  parse_options(av.n, (char * /*unconst*/*)av.v);
  if (optind < av.n)
    lose("%s:2: positional argument `%s' not permitted here",
	 script, av.v[optind]);

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

int main(int argc, char *argv[])
{
  struct config_section_iter si;
  struct config_section *sect;
  struct config_var *var;
  struct lispsys_list order;
  struct lispsys *lisp, **tail;
  struct dstr d = DSTR_INIT;
  struct argv av = ARGV_INIT;

  set_progname(argv[0]);

  init_config();
  config_set_var(&config, toplevel, 0, "prefer", "${@ENV:RUNLISP_PREFER?}");

  flags = (flags&~AF_STATEMASK) | AF_CMDLINE;
  parse_options(argc - 1, argv + 1); optind++;

  if (argv_tail.n)
    flags |= AF_NOEMBED;
  else if (!script && !argv_tail.n) {
    if (optind < argc) script = argv[optind]++;
    else flags |= AF_BOGUS;
  }

  argc -= optind; argv += optind;
  if (argv_tail.n) {
    argv_append(&argv_tail, "--");
    argv_appendn(&argv_tail, (const char *const *)argv, argc);
    argc = argv_tail.n; argv = (/*unconst*/ char */*unconst*/ *)argv_tail.v;
  }

  if (flags&AF_BOGUS) { usage(stderr); exit(2); }
  if (!(flags&AF_NOEMBED)) handle_embedded_args(script);
  if (!(flags&AF_SETCONF)) load_default_config();
  if (verbose >= 5) dump_config();

  dstr_reset(&d);
  var = config_find_var(&config, toplevel, CF_INHERIT, "prefer");
  config_subst_var(&config, toplevel, var, &d);
  add_lispsys(d.p, "preferred", &prefer, LF_PREFER,
	      offsetof(struct lispsys, next_prefer));

  if (!script)
    script = config_subst_string_alloc
      (&config, common, "<internal>",
       "${@ENV:RUNLISP_EVAL?${@CONFIG:data-dir}/eval.lisp}");

  if (setenv("__CL_ARGV0", script, 1))
    lose("failed to set script-name environment variable");
  config_set_var(&config, builtin, CF_LITERAL, "@SCRIPT", script);

  tail = lisps.tail;
  for (config_start_section_iter(&config, &si);
       (sect = config_next_section(&si)); ) {
    var = config_find_var(&config, sect, CF_INHERIT, "run-script");
    if (!var) continue;
    lisp = ensure_lispsys(CONFIG_SECTION_NAME(sect),
			  CONFIG_SECTION_NAMELEN(sect));
    lisp->f |= LF_KNOWN; lisp->sect = sect; lisp->var = var;
    *tail = lisp; tail = &lisp->next_lisp;
  }
  *tail = 0; lisps.tail = tail;

  check_lisps("acceptable", &accept, offsetof(struct lispsys, next_accept));
  check_lisps("preferred", &prefer, offsetof(struct lispsys, next_prefer));

  if (!accept.head) {
    if (verbose >= 2)
      moan("no explicitly acceptable implementations: allowing all");
    tail = accept.tail;
    for (lisp = lisps.head; lisp; lisp = lisp->next_lisp)
      { lisp->f |= LF_ACCEPT; *tail = lisp; tail = &lisp->next_accept; }
    *tail = 0; accept.tail = tail;
  }

  tail = &order.head;
  for (lisp = prefer.head; lisp; lisp = lisp->next_prefer)
    if (lisp->f&LF_ACCEPT) { *tail = lisp; tail = &lisp->next_order; }
  for (lisp = accept.head; lisp; lisp = lisp->next_accept)
    if (!(lisp->f&LF_PREFER)) { *tail = lisp; tail = &lisp->next_order; }
  *tail = 0;

  if (verbose >= 4)
    dump_lisps("known Lisps", &lisps, offsetof(struct lispsys, next_lisp));
  if (verbose >= 3) {
    dump_lisps("acceptable Lisps", &accept,
	       offsetof(struct lispsys, next_accept));
    dump_lisps("preferred Lisps", &prefer,
	       offsetof(struct lispsys, next_prefer));
    dump_lisps("overall preference order", &order,
	       offsetof(struct lispsys, next_order));
  }

  for (lisp = order.head; lisp; lisp = lisp->next_order) {
    if (config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) {
      var = config_find_var(&config, lisp->sect, CF_INHERIT, "image-path");
      dstr_reset(&d); config_subst_var(&config, lisp->sect, var, &d);
      if (file_exists_p(d.p, verbose >= 2 ? FEF_VERBOSE : 0))
	config_set_var(&config, lisp->sect, CF_LITERAL, "@IMAGE", "t");
    }
    argv_reset(&av);
    config_subst_split_var(&config, lisp->sect, lisp->var, &av);
    if (!av.n) {
      moan("empty command for Lisp implementation `%s'", LISPSYS_NAME(lisp));
      continue;
    }
    argv_appendn(&av, (const char *const *)argv, argc);
    if (!try_exec(&av,
		  (flags&AF_DRYRUN ? TEF_DRYRUN : 0) |
		    (verbose >= 2 ? TEF_VERBOSE : 0)))
      return (0);
  }

  lose("no acceptable Lisp systems found");
}

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