3 * Invoke Lisp scripts and implementations
5 * (c) 2020 Mark Wooding
8 /*----- Licensing notice --------------------------------------------------*
10 * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
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.
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
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/>.
26 /*----- Header files ------------------------------------------------------*/
40 /*----- Static data -------------------------------------------------------*/
42 /* The state we need for a Lisp system. */
44 struct treap_node _node
; /* treap intrusion */
45 struct lispsys
*next_lisp
, /* link in all-Lisps list */
46 *next_accept
, /* link acceptable-Lisps list */
47 *next_prefer
, /* link in preferred-Lisps list */
48 *next_order
; /* link in overall-order list */
49 unsigned f
; /* flags */
50 #define LF_KNOWN 1u /* this is actually a Lisp */
51 #define LF_ACCEPT 2u /* this is an acceptable Lisp */
52 #define LF_PREFER 4u /* this is a preferred Lisp */
53 struct config_section
*sect
; /* configuration section */
54 struct config_var
*var
; /* `run-script variable */
56 #define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp)
57 #define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp)
59 /* Pick out a link from a `struct lispsys' object given its offset. */
60 #define LISP_LINK(lisp, linkoff) \
61 ((struct lispsys **)((unsigned char *)(lisp) + (linkoff)))
63 /* A list of Lisp systems. */
65 struct lispsys
*head
, **tail
; /* list head and tail */
68 static struct argv argv_tail
= ARGV_INIT
; /* accumulates eval-mode args */
69 struct treap lispsys
= TREAP_INIT
; /* track duplicate Lisp systems */
70 static struct lispsys_list
/* lists of Lisp systems */
71 lisps
= { 0, &lisps
.head
}, /* all known */
72 accept
= { 0, &accept
.head
}, /* acceptable */
73 prefer
= { 0, &prefer
.head
}; /* preferred */
75 static unsigned flags
= 0; /* flags for the application */
76 #define AF_CMDLINE 0x0000u /* options are from command-line */
77 #define AF_EMBED 0x0001u /* reading embedded options */
78 #define AF_STATEMASK 0x000fu /* mask of option origin codes */
79 #define AF_BOGUS 0x0010u /* invalid command-line syntax */
80 #define AF_SETCONF 0x0020u /* explicit configuration */
81 #define AF_NOEMBED 0x0040u /* don't read embedded options */
82 #define AF_DRYRUN 0x0080u /* don't actually do it */
83 #define AF_VANILLA 0x0100u /* don't use custom images */
85 /*----- Main code ---------------------------------------------------------*/
87 /* Return the `struct lispsys' entry for the given N-byte NAME. */
88 static struct lispsys
*ensure_lispsys(const char *name
, size_t n
)
91 struct treap_path path
;
93 lisp
= treap_probe(&lispsys
, name
, n
, &path
);
95 lisp
= xmalloc(sizeof(*lisp
));
96 lisp
->f
= 0; lisp
->sect
= 0;
97 treap_insert(&lispsys
, &path
, &lisp
->_node
, name
, n
);
102 /* Add Lisp systems from the comma- or space-sparated list P to LIST.
104 * WHAT is an adjective describing the list flavour; FLAG is a bit to set in
105 * the node's flags word; LINKOFF is the offset of the list's link member.
107 static void add_lispsys(const char *p
, const char *what
,
108 struct lispsys_list
*list
,
109 unsigned flag
, size_t linkoff
)
111 struct lispsys
*lisp
, **link
;
116 while (ISSPACE(*p
)) p
++;
118 q
= p
; while (*p
&& !ISSPACE(*p
) && *p
!= ',') p
++;
119 lisp
= ensure_lispsys(q
, p
- q
);
122 moan("ignoring duplicate %s Lisp `%.*s'", what
, (int)(p
- q
), q
);
124 link
= LISP_LINK(lisp
, linkoff
);
125 lisp
->f
|= flag
; *link
= 0;
126 *list
->tail
= lisp
; list
->tail
= link
;
128 while (ISSPACE(*p
)) p
++;
134 /* Check that the Lisp systems on LIST (linked through LINKOFF) are real.
136 * That is, `LF_KNOWN' is set in their flags.
138 static void check_lisps(const char *what
,
139 struct lispsys_list
*list
, size_t linkoff
)
141 struct lispsys
*lisp
;
143 for (lisp
= list
->head
; lisp
; lisp
= *LISP_LINK(lisp
, linkoff
))
144 if (!(lisp
->f
&LF_KNOWN
))
145 lose("unknown Lisp implementation `%s'", LISPSYS_NAME(lisp
));
148 /* Dump the names of the Lisp systems on LIST (linked through LINKOFF).
150 * WHAT is an adjective describing the list.
152 static void dump_lisps(const char *what
,
153 struct lispsys_list
*list
, size_t linkoff
)
155 struct dstr d
= DSTR_INIT
;
156 struct lispsys
*lisp
;
160 for (lisp
= list
->head
; lisp
; lisp
= *LISP_LINK(lisp
, linkoff
)) {
161 if (first
) first
= 0;
162 else dstr_puts(&d
, ", ");
163 dstr_puts(&d
, LISPSYS_NAME(lisp
));
165 if (first
) dstr_puts(&d
, "(none)");
167 moan("%s: %s", what
, d
.p
);
171 /* Add an eval-mode operation to the `argv_tail' vector.
173 * OP is the operation character (see `eval.lisp' for these) and `val' is the
174 * argument (filename or expression).
176 static void push_eval_op(char op
, const char *val
)
181 if ((flags
&AF_STATEMASK
) != AF_CMDLINE
) {
182 moan("must use `-e', `-p', or `-l' on command line");
189 p
[0] = op
; memcpy(p
+ 1, val
, n
);
190 argv_append(&argv_tail
, p
);
193 /* Help and related functions. */
194 static void version(FILE *fp
)
195 { fprintf(fp
, "%s, version %s\n", progname
, PACKAGE_VERSION
); }
197 static void usage(FILE *fp
)
201 %s [OPTIONS] [--] SCRIPT [ARGUMENTS ...]\n\
202 %s [OPTIONS] [-e EXPR] [-d EXPR] [-p EXPR] [-l FILE]\n\
203 [--] [ARGUMENTS ...]\n\
205 [-CDEnqv] [+DEn] [-L SYS,SYS,...] [-c CONF] [-o [SECT:]VAR=VAL]\n",
209 static void help(FILE *fp
)
211 version(fp
); fputc('\n', fp
); usage(fp
);
214 -h, --help Show this help text and exit successfully.\n\
215 -V, --version Show version number and exit successfully.\n\
218 -n, --dry-run Don't run run anything (useful with `-v').\n\
219 -q, --quiet Don't print warning messages.\n\
220 -v, --verbose Print informational messages (repeatable).\n\
223 -E, --command-line-only Don't read embedded options from script.\n\
224 -c, --config-file=CONF Read configuration from CONF (repeatable).\n\
225 -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
227 Lisp implementation selection:\n\
228 -D, --vanilla-image Run vanilla Lisp images, not custom ones.\n\
229 -L, --accept-lisp=SYS,SYS,... Only use the listed Lisp systems.\n\
232 -d, --dump-expression=EXPR Print (`prin1') EXPR (repeatable).\n\
233 -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\
234 -l, --load-file=FILE Load FILE (repeatable).\n\
235 -p, --print-expression=EXPR Print (`princ') EXPR (repeatable).\n",
239 /* Complain about options which aren't permitted as embedded options. */
240 static void check_command_line(int ch
)
242 if ((flags
&AF_STATEMASK
) != AF_CMDLINE
) {
243 moan("`%c%c' is not permitted as embedded option",
244 ch
&OPTF_NEGATED ?
'+' : '-',
250 /* Parse the options in the argument vector. */
251 static void parse_options(int argc
, char *argv
[])
255 static const struct option opts
[] = {
256 { "help", 0, 0, 'h' },
257 { "version", 0, 0, 'V' },
258 { "vanilla-image", OPTF_NEGATE
, 0, 'D' },
259 { "command-line-only", OPTF_NEGATE
, 0, 'E' },
260 { "accept-lisp", OPTF_ARGREQ
, 0, 'L' },
261 { "config-file", OPTF_ARGREQ
, 0, 'c' },
262 { "dump-expression", OPTF_ARGREQ
, 0, 'd' },
263 { "evaluate-expression", OPTF_ARGREQ
, 0, 'e' },
264 { "load-file", OPTF_ARGREQ
, 0, 'l' },
265 { "dry-run", OPTF_NEGATE
, 0, 'n' },
266 { "set-option", OPTF_ARGREQ
, 0, 'o' },
267 { "print-expression", OPTF_ARGREQ
, 0, 'p' },
268 { "quiet", 0, 0, 'q' },
269 { "verbose", 0, 0, 'v' },
273 #define FLAGOPT(ch, f, extra) \
278 case ch | OPTF_NEGATED: \
282 #define CMDL do { check_command_line(i); } while (0)
284 optarg
= 0; optind
= 0; optprog
= (/*unconst*/ char *)progname
;
286 i
= mdwopt(argc
, argv
, "+hVD+E+L:c:d:e:l:n+o:p:qv", opts
, 0, 0,
287 OPTF_NEGATION
| OPTF_NOPROGNAME
);
290 case 'h': CMDL
; help(stdout
); exit(0);
291 case 'V': CMDL
; version(stdout
); exit(0);
292 FLAGOPT('D', AF_VANILLA
, ; );
293 FLAGOPT('E', AF_NOEMBED
, { CMDL
; });
295 add_lispsys(optarg
, "acceptable", &accept
, LF_ACCEPT
,
296 offsetof(struct lispsys
, next_accept
));
298 case 'c': CMDL
; read_config_path(optarg
, 0); flags
|= AF_SETCONF
; break;
299 case 'd': CMDL
; push_eval_op('?', optarg
); break;
300 case 'e': CMDL
; push_eval_op('!', optarg
); break;
301 case 'l': CMDL
; push_eval_op('<', optarg
); break;
302 FLAGOPT('n', AF_DRYRUN
, { CMDL
; });
303 case 'o': CMDL
; if (set_config_var(optarg
)) flags
|= AF_BOGUS
; break;
304 case 'p': CMDL
; push_eval_op('=', optarg
); break;
305 case 'q': CMDL
; if (verbose
) verbose
--; break;
306 case 'v': CMDL
; verbose
++; break;
307 default: flags
|= AF_BOGUS
; break;
315 /* Extract and process the embedded options from a SCRIPT. */
316 static void handle_embedded_args(const char *script
)
318 struct dstr d
= DSTR_INIT
;
319 struct argv av
= ARGV_INIT
;
320 char *p
, *q
, *r
; const char *l
;
325 /* Open the script. If this doesn't work, then we have no hope. */
326 fp
= fopen(script
, "r");
327 if (!fp
) lose("can't read script `%s': %s", script
, strerror(errno
));
329 /* Read the second line. */
330 if (dstr_readline(&d
, fp
)) goto end
;
331 dstr_reset(&d
); if (dstr_readline(&d
, fp
)) goto end
;
333 /* Check to find the magic marker. */
334 p
= strstr(d
.p
, "@RUNLISP:"); if (!p
) goto end
;
335 p
+= 9; q
= p
; l
= d
.p
+ d
.len
;
337 /* Split the line into words.
339 * Do this by hand because we have strange things to support, such as Emacs
340 * turds and the early `--' exit.
342 * We work in place: `p' is the input cursor and advances through the
343 * string as we parse, until it meets the limit pointer `l'; `q' is the
344 * output cursor which will always be no further forward than `p'.
347 /* Iterate over the words. */
350 while (p
< l
&& ISSPACE(*p
)) p
++;
352 /* If we've reached the end then we're done. */
355 /* Check for an Emacs local-variables `-*-' turd.
357 * If we find one, find the matching end marker and move past it.
359 if (l
- p
>= 3 && p
[0] == '-' && p
[1] == '*' && p
[2] == '-') {
360 p
= strstr(p
+ 3, "-*-");
362 lose("%s:2: unfinished local-variables list", script
);
367 /* If we find a `--' marker then stop immediately. */
368 if (l
- p
>= 2 && p
[0] == '-' && p
[1] == '-' &&
369 (l
== p
+ 2 || ISSPACE(p
[2])))
372 /* Push the output cursor position onto the output, because this is where
373 * the next word will start.
377 /* Collect characters until we find an unquoted space. */
378 while (p
< l
&& (qstate
|| !ISSPACE(*p
))) {
381 /* A quote. Skip past, and toggle quotedness. */
383 { p
++; qstate
= !qstate
; }
385 else if (*p
== '\\') {
386 /* A backslash. Just emit the following character. */
388 p
++; if (p
>= l
) lose("%s:2: unfinished `\\' escape", script
);
391 } else if (*p
== '\'') {
392 /* A single quote. Find its matching end quote, and emit everything
396 p
++; r
= strchr(p
, '\'');
397 if (!r
|| r
> l
) lose("%s:2: missing `''", script
);
398 n
= r
- p
; memmove(q
, p
, n
); q
+= n
; p
= r
+ 1;
401 /* An ordinary constituent. Gather a bunch of these up and emit them
404 n
= strcspn(p
, qstate ?
"\"\\" : "\"'\\ \f\n\r\t\v");
405 if (n
> l
- p
) n
= l
- p
;
406 memmove(q
, p
, n
); q
+= n
; p
+= n
;
410 /* Check that we're not still inside quotes. */
411 if (qstate
) lose("%s:2: missing `\"'", script
);
413 /* Finish off this word and prepare to start the next. */
414 *q
++ = 0; if (p
< l
) p
++;
417 /* Parse the arguments we've collected as options. Object if we find
418 * positional arguments.
420 flags
= (flags
&~AF_STATEMASK
) | AF_EMBED
;
421 parse_options(av
.n
, (char * /*unconst*/*)av
.v
);
423 lose("%s:2: positional argument `%s' not permitted here",
424 script
, av
.v
[optind
]);
430 lose("error reading script `%s': %s", script
, strerror(errno
));
433 dstr_release(&d
); argv_release(&av
);
437 int main(int argc
, char *argv
[])
439 struct config_section_iter si
;
440 struct config_section
*sect
;
441 struct config_var
*var
;
442 struct lispsys_list order
;
443 struct lispsys
*lisp
, **tail
;
446 struct dstr d
= DSTR_INIT
;
447 struct argv av
= ARGV_INIT
;
450 set_progname(argv
[0]);
453 /* Parse the command-line options. */
454 flags
= (flags
&~AF_STATEMASK
) | AF_CMDLINE
;
455 parse_options(argc
- 1, argv
+ 1); optind
++;
457 /* We now know enough to decide whether we're in eval or script mode. In
458 * the former case, don't check for embedded options (it won't work because
459 * we don't know where the `eval.lisp' script is yet, and besides, there
460 * aren't any). In the latter case, pick out the script name, leaving the
461 * remaining positional arguments for later.
463 if (argv_tail
.n
) { flags
|= AF_NOEMBED
; script
= 0; }
464 else if (optind
< argc
) script
= argv
[optind
++];
465 else flags
|= AF_BOGUS
;
467 /* Check that everything worked. */
468 if (flags
&AF_BOGUS
) { usage(stderr
); exit(127); }
470 /* Reestablish ARGC/ARGV to refer to the tail of positional arguments to be
471 * passed onto the eventual script. For eval mode, that includes the
472 * operations already queued up, so we'll have to accumulate everything in
475 argc
-= optind
; argv
+= optind
;
477 argv_append(&argv_tail
, "--");
478 argv_appendn(&argv_tail
, argv
, argc
);
479 argc
= argv_tail
.n
; argv
= argv_tail
.v
;
482 /* Fetch embedded options. */
483 if (!(flags
&AF_NOEMBED
)) handle_embedded_args(script
);
485 /* Load default configuration if no explicit files were requested. */
486 if (!(flags
&AF_SETCONF
)) load_default_config();
488 /* Determine the preferred Lisp systems. Check the environment first;
489 * otherwise use the configuration file.
491 p
= my_getenv("RUNLISP_PREFER", 0);
493 var
= config_find_var(&config
, toplevel
, CF_INHERIT
, "prefer");
496 config_subst_var(&config
, toplevel
, var
, &d
); p
= d
.p
;
500 add_lispsys(p
, "preferred", &prefer
, LF_PREFER
,
501 offsetof(struct lispsys
, next_prefer
));
503 /* If we're in eval mode, then find the `eval.lisp' script. */
505 script
= config_subst_string_alloc(&config
, common
, "<internal>",
506 "${@ENV:RUNLISP_EVAL?"
507 "${@CONFIG:eval-script?"
508 "${@data-dir}/eval.lisp}}");
510 /* We now have the script name, so publish it for `uiop'.
512 * As an aside, this is a terrible interface. It's too easy to forget to
513 * set it. (To illustrate this, `cl-launch -x' indeed forgets to set it.)
514 * If you're lucky, the script just thinks that its argument is `nil', in
515 * which case maybe it can use `*load-pathname*' as a fallback. If you're
516 * unlucky, your script was invoked (possibly indirectly) by another
517 * script, and now you've accidentally inherited the calling script's name.
519 * It would have been far better simply to repeat the script name as the
520 * first user argument, if nothing else had come readily to mind.
522 if (setenv("__CL_ARGV0", script
, 1))
523 lose("failed to set script-name environment variable");
525 /* And publish it in the configuration for the `run-script' commands. */
526 config_set_var(&config
, builtin
, CF_LITERAL
, "@script", script
);
528 /* Dump the final configuration if we're being very verbose. */
529 if (verbose
>= 5) dump_config();
531 /* Identify the configuration sections which correspond to actual Lisp
532 * system definitions, and gather them into the `known' list.
535 for (config_start_section_iter(&config
, &si
);
536 (sect
= config_next_section(&si
)); ) {
537 var
= config_find_var(&config
, sect
, CF_INHERIT
, "run-script");
539 lisp
= ensure_lispsys(CONFIG_SECTION_NAME(sect
),
540 CONFIG_SECTION_NAMELEN(sect
));
541 lisp
->f
|= LF_KNOWN
; lisp
->sect
= sect
; lisp
->var
= var
;
542 *tail
= lisp
; tail
= &lisp
->next_lisp
;
544 *tail
= 0; lisps
.tail
= tail
;
546 /* Make sure that the acceptable and preferred Lisps actually exist. */
547 check_lisps("acceptable", &accept
, offsetof(struct lispsys
, next_accept
));
548 check_lisps("preferred", &prefer
, offsetof(struct lispsys
, next_prefer
));
550 /* If there are no acceptable Lisps, then we'll take all of them. */
553 moan("no explicitly acceptable implementations: allowing all");
555 for (lisp
= lisps
.head
; lisp
; lisp
= lisp
->next_lisp
)
556 { lisp
->f
|= LF_ACCEPT
; *tail
= lisp
; tail
= &lisp
->next_accept
; }
557 *tail
= 0; accept
.tail
= tail
;
560 /* Build the final list of Lisp systems in the order in which we'll try
561 * them: first, preferred Lisps which are acceptable, and then acceptable
562 * Lisps which aren't preferred.
565 for (lisp
= prefer
.head
; lisp
; lisp
= lisp
->next_prefer
)
566 if (lisp
->f
&LF_ACCEPT
) { *tail
= lisp
; tail
= &lisp
->next_order
; }
567 for (lisp
= accept
.head
; lisp
; lisp
= lisp
->next_accept
)
568 if (!(lisp
->f
&LF_PREFER
)) { *tail
= lisp
; tail
= &lisp
->next_order
; }
571 /* Maybe dump out the various lists of Lisp systems we've collected. */
573 dump_lisps("known Lisps", &lisps
, offsetof(struct lispsys
, next_lisp
));
575 dump_lisps("acceptable Lisps", &accept
,
576 offsetof(struct lispsys
, next_accept
));
577 dump_lisps("preferred Lisps", &prefer
,
578 offsetof(struct lispsys
, next_prefer
));
579 dump_lisps("overall preference order", &order
,
580 offsetof(struct lispsys
, next_order
));
583 /* Try to actually run the script. */
584 for (lisp
= order
.head
; lisp
; lisp
= lisp
->next_order
) {
585 /* Try each of the selected systems in turn. */
587 /* See whether there's a custom image file. If so, set `@image' in the
588 * system's configuration section.
590 if (!(flags
&AF_VANILLA
) &&
591 config_find_var(&config
, lisp
->sect
, CF_INHERIT
, "image-file")) {
592 var
= config_find_var(&config
, lisp
->sect
, CF_INHERIT
, "image-path");
594 lose("variable `image-path' not defined for Lisp `%s'",
596 dstr_reset(&d
); config_subst_var(&config
, lisp
->sect
, var
, &d
);
597 if (file_exists_p(d
.p
, verbose
>= 2 ? FEF_VERBOSE
: 0))
598 config_set_var(&config
, lisp
->sect
, CF_LITERAL
, "@image", "t");
601 /* Build the command line from `run-script'. */
603 config_subst_split_var(&config
, lisp
->sect
, lisp
->var
, &av
);
605 moan("empty command for Lisp implementation `%s'", LISPSYS_NAME(lisp
));
609 /* Append our additional positional arguments. */
610 argv_appendn(&av
, argv
, argc
);
612 /* Try to run the Lisp system. */
614 (flags
&AF_DRYRUN ? TEF_DRYRUN
: 0) |
615 (verbose
>= 2 ? TEF_VERBOSE
: 0)))
619 /* No. Much errors. So failure. Very sadness. */
620 lose("no acceptable Lisp systems found");
623 /*----- That's all, folks -------------------------------------------------*/