/*----- Static data -------------------------------------------------------*/
+/* The state we need for a Lisp system. */
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;
+ 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;
+ struct lispsys *head, **tail; /* list head and 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 };
+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 ---------------------------------------------------------*/
-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);
-}
-
+/* 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;
return (lisp);
}
-#define LISP_LINK(lisp, linkoff) \
- ((struct lispsys **)((unsigned char *)(lisp) + (linkoff)))
-
+/* 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)
if (!*p) return;
for (;;) {
+ while (ISSPACE(*p)) p++;
if (!*p) break;
- q = p; while (*p && *p != ',') p++;
+ q = p; while (*p && !ISSPACE(*p) && *p != ',') p++;
lisp = ensure_lispsys(q, p - q);
if (lisp->f&flag) {
if (verbose >= 1)
lisp->f |= flag; *link = 0;
*list->tail = lisp; list->tail = link;
}
+ while (ISSPACE(*p)) p++;
if (!*p) break;
- p++;
+ 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)
{
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)
{
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));
+ dstr_puts(&d, LISPSYS_NAME(lisp));
}
if (first) dstr_puts(&d, "(none)");
dstr_putz(&d);
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;
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] [-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);
+}
+
+/* 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;
{ 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: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 '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': 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;
+ case 'c': CMDL; read_config_path(optarg, 0); flags |= AF_SETCONF; 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 'p': CMDL; push_eval_op('?', optarg); break;
+ case 'q': CMDL; if (verbose) verbose--; break;
+ case 'v': CMDL; verbose++; break;
default: flags |= AF_BOGUS; break;
}
}
}
+/* Extract and process the embedded options from a SCRIPT. */
static void handle_embedded_args(const char *script)
{
struct dstr d = DSTR_INIT;
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)
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 == '"') { p++; qstate = !qstate; }
+
+ 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);
- if (p < l) p++;
- *q++ = 0;
+
+ /* 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)
script, av.v[optind]);
end:
+ /* Tidy up. */
if (fp) {
if (ferror(fp))
lose("error reading script `%s': %s", script, strerror(errno));
dstr_release(&d); argv_release(&av);
}
+/* Main program. */
int main(int argc, char *argv[])
{
struct config_section_iter si;
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();
- config_set_var(&config, toplevel, 0, "prefer", "${@ENV:RUNLISP_PREFER?}");
+ /* Parse the command-line options. */
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;
- }
-
+ /* 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, (const char *const *)argv, argc);
- argc = argv_tail.n; argv = (/*unconst*/ char */*unconst*/ *)argv_tail.v;
+ argv_appendn(&argv_tail, argv, argc);
+ argc = argv_tail.n; argv = argv_tail.v;
}
- if (flags&AF_BOGUS) { usage(stderr); exit(2); }
+ /* 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();
- 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));
+ /* 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:data-dir}/eval.lisp}");
-
+ 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");
- config_set_var(&config, builtin, CF_LITERAL, "@SCRIPT", script);
+ /* 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)); ) {
}
*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 = 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; }
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) {
offsetof(struct lispsys, next_order));
}
+ /* Try to actually run the script. */
for (lisp = order.head; lisp; lisp = lisp->next_order) {
- if (config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) {
+ /* 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");
+ 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;
}
- argv_appendn(&av, (const char *const *)argv, argc);
+
+ /* 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");
}
~mdw / runlisp / blobdiff