runlisp.c, etc.: Rename `-p' to `-d'. COMPAT

[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 -------------------------------------------------------*/

/* The state we need for a Lisp system. */
struct lispsys {
  struct treap_node _node;		/* treap intrusion */
  struct lispsys *next_lisp,		/* link in all-Lisps list */
    *next_accept,			/* link acceptable-Lisps list */
    *next_prefer,			/* link in preferred-Lisps list */
    *next_order;			/* link in overall-order list */
  unsigned f;				/* flags */
#define LF_KNOWN 1u			/*   this is actually a Lisp */
#define LF_ACCEPT 2u			/*   this is an acceptable Lisp */
#define LF_PREFER 4u			/*   this is a preferred Lisp */
  struct config_section *sect;		/* configuration section */
  struct config_var *var;		/* `run-script variable */
};
#define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp)
#define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp)

/* Pick out a link from a `struct lispsys' object given its offset. */
#define LISP_LINK(lisp, linkoff)					\
	((struct lispsys **)((unsigned char *)(lisp) + (linkoff)))

/* A list of Lisp systems. */
struct lispsys_list {
  struct lispsys *head, **tail;		/* list head and tail */
};

static struct argv argv_tail = ARGV_INIT; /* accumulates eval-mode args */
struct treap lispsys = TREAP_INIT;	/* track duplicate Lisp systems */
static struct lispsys_list		/* lists of Lisp systems */
  lisps = { 0, &lisps.head },		/*   all known */
  accept = { 0, &accept.head },		/*   acceptable */
  prefer = { 0, &prefer.head };		/*   preferred */

static unsigned flags = 0;		/* flags for the application */
#define AF_CMDLINE 0x0000u		/*   options are from command-line */
#define AF_EMBED 0x0001u		/*   reading embedded options */
#define AF_STATEMASK 0x000fu		/*   mask of option origin codes */
#define AF_BOGUS 0x0010u		/*   invalid command-line syntax */
#define AF_SETCONF 0x0020u		/*   explicit configuration */
#define AF_NOEMBED 0x0040u		/*   don't read embedded options */
#define AF_DRYRUN 0x0080u		/*   don't actually do it */
#define AF_VANILLA 0x0100u		/*   don't use custom images */

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

/* Return the `struct lispsys' entry for the given N-byte NAME. */
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);
}

/* Add Lisp systems from the comma- or space-sparated list P to LIST.
 *
 * WHAT is an adjective describing the list flavour; FLAG is a bit to set in
 * the node's flags word; LINKOFF is the offset of the list's link member.
 */
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 (;;) {
    while (ISSPACE(*p)) p++;
    if (!*p) break;
    q = p; while (*p && !ISSPACE(*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;
    }
    while (ISSPACE(*p)) p++;
    if (!*p) break;
    if (*p == ',') p++;
  }
}

/* Check that the Lisp systems on LIST (linked through LINKOFF) are real.
 *
 * That is, `LF_KNOWN' is set in their flags.
 */
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));
}

/* Dump the names of the Lisp systems on LIST (linked through LINKOFF).
 *
 * WHAT is an adjective describing the list.
 */
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_puts(&d, LISPSYS_NAME(lisp));
  }
  if (first) dstr_puts(&d, "(none)");
  dstr_putz(&d);
  moan("%s: %s", what, d.p);
  dstr_release(&d);
}

/* Add an eval-mode operation to the `argv_tail' vector.
 *
 * OP is the operation character (see `eval.lisp' for these) and `val' is the
 * argument (filename or expression).
 */
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);
}

/* Help and related functions. */
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] [-d 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\
  -d, --dump-expression=EXPR	Print (`prin1') EXPR (repeatable).\n\
  -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\
  -l, --load-file=FILE		Load FILE (repeatable).\n",
	fp);
}

/* Complain about options which aren't permitted as embedded options. */
static void check_command_line(int ch)
{
  if ((flags&AF_STATEMASK) != AF_CMDLINE) {
    moan("`%c%c' is not permitted as embedded option",
	 ch&OPTF_NEGATED ? '+' : '-',
	 ch&~OPTF_NEGATED);
    flags |= AF_BOGUS;
  }
}

/* Parse the options in the argument vector. */
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' },
    { "dump-expression",	OPTF_ARGREQ,	0,	'd' },
    { "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 }
  };

#define FLAGOPT(ch, f, extra)						\
  case ch:								\
    extra								\
    flags |= f;								\
    break;								\
  case ch | OPTF_NEGATED:						\
    extra								\
    flags &= ~f;							\
    break
#define CMDL do { check_command_line(i); } while (0)

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

#undef FLAGOPT
#undef CMDL
}

/* Extract and process the embedded options from a SCRIPT. */
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;

  /* Open the script.  If this doesn't work, then we have no hope. */
  fp = fopen(script, "r");
  if (!fp) lose("can't read script `%s': %s", script, strerror(errno));

  /* Read the second line. */
  if (dstr_readline(&d, fp)) goto end;
  dstr_reset(&d); if (dstr_readline(&d, fp)) goto end;

  /* Check to find the magic marker. */
  p = strstr(d.p, "@RUNLISP:"); if (!p) goto end;
  p += 9; q = p; l = d.p + d.len;

  /* Split the line into words.
   *
   * Do this by hand because we have strange things to support, such as Emacs
   * turds and the early `--' exit.
   *
   * We work in place: `p' is the input cursor and advances through the
   * string as we parse, until it meets the limit pointer `l'; `q' is the
   * output cursor which will always be no further forward than `p'.
   */
  for (;;) {
    /* Iterate over the words. */

    /* Skip spaces. */
    while (p < l && ISSPACE(*p)) p++;

    /* If we've reached the end then we're done. */
    if (p >= l) break;

    /* Check for an Emacs local-variables `-*-' turd.
     *
     * If we find one, find the matching end marker and move past it.
     */
    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 we find a `--' marker then stop immediately. */
    if (l - p >= 2 && p[0] == '-' && p[1] == '-' &&
	(l == p + 2 || ISSPACE(p[2])))
      break;

    /* Push the output cursor position onto the output, because this is where
     * the next word will start.
     */
    argv_append(&av, q);

    /* Collect characters until we find an unquoted space. */
    while (p < l && (qstate || !ISSPACE(*p))) {

      if (*p == '"')
	/* A quote.  Skip past, and toggle quotedness. */

	{ p++; qstate = !qstate; }

      else if (*p == '\\') {
	/* A backslash.  Just emit the following character. */

	p++; if (p >= l) lose("%s:2: unfinished `\\' escape", script);
	*q++ = *p++;

      } else if (*p == '\'') {
	/* A single quote.  Find its matching end quote, and emit everything
	 * in between.
	 */

	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 {
	/* An ordinary constituent.  Gather a bunch of these up and emit them
	 * all.
	 */
	n = strcspn(p, qstate ? "\"\\" : "\"'\\ \f\n\r\t\v");
	if (n > l - p) n = l - p;
	memmove(q, p, n); q += n; p += n;
      }
    }

    /* Check that we're not still inside quotes. */
    if (qstate) lose("%s:2: missing `\"'", script);

    /* Finish off this word and prepare to start the next. */
    *q++ = 0; if (p < l) p++;
  }

  /* Parse the arguments we've collected as options.  Object if we find
   * positional arguments.
   */
  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:
  /* Tidy up. */
  if (fp) {
    if (ferror(fp))
      lose("error reading script `%s': %s", script, strerror(errno));
    fclose(fp);
  }
  dstr_release(&d); argv_release(&av);
}

/* Main program. */
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;
  const char *p;
  const char *script;
  struct dstr d = DSTR_INIT;
  struct argv av = ARGV_INIT;

  /* initial setup. */
  set_progname(argv[0]);
  init_config();

  /* Parse the command-line options. */
  flags = (flags&~AF_STATEMASK) | AF_CMDLINE;
  parse_options(argc - 1, argv + 1); optind++;

  /* We now know enough to decide whether we're in eval or script mode.  In
   * the former case, don't check for embedded options (it won't work because
   * we don't know where the `eval.lisp' script is yet, and besides, there
   * aren't any).  In the latter case, pick out the script name, leaving the
   * remaining positional arguments for later.
   */
  if (argv_tail.n) { flags |= AF_NOEMBED; script = 0; }
  else if (optind < argc) script = argv[optind++];
  else flags |= AF_BOGUS;

  /* Check that everything worked. */
  if (flags&AF_BOGUS) { usage(stderr); exit(127); }

  /* Reestablish ARGC/ARGV to refer to the tail of positional arguments to be
   * passed onto the eventual script.  For eval mode, that includes the
   * operations already queued up, so we'll have to accumulate everything in
   * `argv_tail'.
   */
  argc -= optind; argv += optind;
  if (argv_tail.n) {
    argv_append(&argv_tail, "--");
    argv_appendn(&argv_tail, argv, argc);
    argc = argv_tail.n; argv = argv_tail.v;
  }

  /* Fetch embedded options. */
  if (!(flags&AF_NOEMBED)) handle_embedded_args(script);

  /* Load default configuration if no explicit files were requested. */
  if (!(flags&AF_SETCONF)) load_default_config();

  /* Determine the preferred Lisp systems.  Check the environment first;
   * otherwise use the configuration file.
   */
  p = my_getenv("RUNLISP_PREFER", 0);
  if (!p) {
    var = config_find_var(&config, toplevel, CF_INHERIT, "prefer");
    if (var) {
      dstr_reset(&d);
      config_subst_var(&config, toplevel, var, &d); p = d.p;
    }
  }
  if (p)
    add_lispsys(p, "preferred", &prefer, LF_PREFER,
		offsetof(struct lispsys, next_prefer));

  /* If we're in eval mode, then find the `eval.lisp' script. */
  if (!script)
    script = config_subst_string_alloc(&config, common, "<internal>",
				       "${@ENV:RUNLISP_EVAL?"
					 "${@CONFIG:eval-script?"
					   "${@data-dir}/eval.lisp}}");

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

  /* And publish it in the configuration for the `run-script' commands. */
  config_set_var(&config, builtin, CF_LITERAL, "@script", script);

  /* Dump the final configuration if we're being very verbose. */
  if (verbose >= 5) dump_config();

  /* Identify the configuration sections which correspond to actual Lisp
   * system definitions, and gather them into the `known' list.
   */
  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;

  /* Make sure that the acceptable and preferred Lisps actually exist. */
  check_lisps("acceptable", &accept, offsetof(struct lispsys, next_accept));
  check_lisps("preferred", &prefer, offsetof(struct lispsys, next_prefer));

  /* If there are no acceptable Lisps, then we'll take all of them. */
  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;
  }

  /* Build the final list of Lisp systems in the order in which we'll try
   * them: first, preferred Lisps which are acceptable, and then acceptable
   * Lisps which aren't preferred.
   */
  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;

  /* Maybe dump out the various lists of Lisp systems we've collected. */
  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));
  }

  /* Try to actually run the script. */
  for (lisp = order.head; lisp; lisp = lisp->next_order) {
    /* Try each of the selected systems in turn. */

    /* See whether there's a custom image file.  If so, set `@image' in the
     * system's configuration section.
     */
    if (!(flags&AF_VANILLA) &&
	config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) {
      var = config_find_var(&config, lisp->sect, CF_INHERIT, "image-path");
      if (!var)
	lose("variable `image-path' not defined for Lisp `%s'",
	     LISPSYS_NAME(lisp));
      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");
    }

    /* Build the command line from `run-script'. */
    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;
    }

    /* Append our additional positional arguments. */
    argv_appendn(&av, argv, argc);

    /* Try to run the Lisp system. */
    if (!try_exec(&av,
		  (flags&AF_DRYRUN ? TEF_DRYRUN : 0) |
		    (verbose >= 2 ? TEF_VERBOSE : 0)))
      return (0);
  }

  /* No.  Much errors.  So failure.  Very sadness. */
  lose("no acceptable Lisp systems found");
}

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