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] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n\
204 [-CDEnqv] [+DEn] [-L SYS,SYS,...] [-c CONF] [-o [SECT:]VAR=VAL]\n",
208 static void help(FILE *fp
)
210 version(fp
); fputc('\n', fp
); usage(fp
);
213 -h, --help Show this help text and exit successfully.\n\
214 -V, --version Show version number and exit successfully.\n\
217 -n, --dry-run Don't run run anything (useful with `-v').\n\
218 -q, --quiet Don't print warning messages.\n\
219 -v, --verbose Print informational messages (repeatable).\n\
222 -E, --command-line-only Don't read embedded options from script.\n\
223 -c, --config-file=CONF Read configuration from CONF (repeatable).\n\
224 -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
226 Lisp implementation selection:\n\
227 -D, --vanilla-image Run vanilla Lisp images, not custom ones.\n\
228 -L, --accept-lisp=SYS,SYS,... Only use the listed Lisp systems.\n\
231 -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\
232 -l, --load-file=FILE Load FILE (repeatable).\n\
233 -p, --print-expression=EXPR Print (`prin1') EXPR (repeatable).\n",
237 /* Complain about options which aren't permitted as embedded options. */
238 static void check_command_line(int ch
)
240 if ((flags
&AF_STATEMASK
) != AF_CMDLINE
) {
241 moan("`%c%c' is not permitted as embedded option",
242 ch
&OPTF_NEGATED ?
'+' : '-',
248 /* Parse the options in the argument vector. */
249 static void parse_options(int argc
, char *argv
[])
253 static const struct option opts
[] = {
254 { "help", 0, 0, 'h' },
255 { "version", 0, 0, 'V' },
256 { "vanilla-image", OPTF_NEGATE
, 0, 'D' },
257 { "command-line-only", OPTF_NEGATE
, 0, 'E' },
258 { "accept-lisp", OPTF_ARGREQ
, 0, 'L' },
259 { "config-file", OPTF_ARGREQ
, 0, 'c' },
260 { "evaluate-expression", OPTF_ARGREQ
, 0, 'e' },
261 { "load-file", OPTF_ARGREQ
, 0, 'l' },
262 { "dry-run", OPTF_NEGATE
, 0, 'n' },
263 { "set-option", OPTF_ARGREQ
, 0, 'o' },
264 { "print-expression", OPTF_ARGREQ
, 0, 'p' },
265 { "quiet", 0, 0, 'q' },
266 { "verbose", 0, 0, 'v' },
270 #define FLAGOPT(ch, f, extra) \
275 case ch | OPTF_NEGATED: \
279 #define CMDL do { check_command_line(i); } while (0)
281 optarg
= 0; optind
= 0; optprog
= (/*unconst*/ char *)progname
;
283 i
= mdwopt(argc
, argv
, "+hVD+E+L:c:e:l:n+o:p:qv", opts
, 0, 0,
284 OPTF_NEGATION
| OPTF_NOPROGNAME
);
287 case 'h': CMDL
; help(stdout
); exit(0);
288 case 'V': CMDL
; version(stdout
); exit(0);
289 FLAGOPT('D', AF_VANILLA
, ; );
290 FLAGOPT('E', AF_NOEMBED
, { CMDL
; });
292 add_lispsys(optarg
, "acceptable", &accept
, LF_ACCEPT
,
293 offsetof(struct lispsys
, next_accept
));
295 case 'c': CMDL
; read_config_path(optarg
, 0); flags
|= AF_SETCONF
; break;
296 case 'e': CMDL
; push_eval_op('!', optarg
); break;
297 case 'l': CMDL
; push_eval_op('<', optarg
); break;
298 FLAGOPT('n', AF_DRYRUN
, { CMDL
; });
299 case 'o': CMDL
; if (set_config_var(optarg
)) flags
|= AF_BOGUS
; break;
300 case 'p': CMDL
; push_eval_op('?', optarg
); break;
301 case 'q': CMDL
; if (verbose
) verbose
--; break;
302 case 'v': CMDL
; verbose
++; break;
303 default: flags
|= AF_BOGUS
; break;
308 /* Extract and process the embedded options from a SCRIPT. */
309 static void handle_embedded_args(const char *script
)
311 struct dstr d
= DSTR_INIT
;
312 struct argv av
= ARGV_INIT
;
313 char *p
, *q
, *r
; const char *l
;
318 /* Open the script. If this doesn't work, then we have no hope. */
319 fp
= fopen(script
, "r");
320 if (!fp
) lose("can't read script `%s': %s", script
, strerror(errno
));
322 /* Read the second line. */
323 if (dstr_readline(&d
, fp
)) goto end
;
324 dstr_reset(&d
); if (dstr_readline(&d
, fp
)) goto end
;
326 /* Check to find the magic marker. */
327 p
= strstr(d
.p
, "@RUNLISP:"); if (!p
) goto end
;
328 p
+= 9; q
= p
; l
= d
.p
+ d
.len
;
330 /* Split the line into words.
332 * Do this by hand because we have strange things to support, such as Emacs
333 * turds and the early `--' exit.
335 * We work in place: `p' is the input cursor and advances through the
336 * string as we parse, until it meets the limit pointer `l'; `q' is the
337 * output cursor which will always be no further forward than `p'.
340 /* Iterate over the words. */
343 while (p
< l
&& ISSPACE(*p
)) p
++;
345 /* If we've reached the end then we're done. */
348 /* Check for an Emacs local-variables `-*-' turd.
350 * If we find one, find the matching end marker and move past it.
352 if (l
- p
>= 3 && p
[0] == '-' && p
[1] == '*' && p
[2] == '-') {
353 p
= strstr(p
+ 3, "-*-");
355 lose("%s:2: unfinished local-variables list", script
);
360 /* If we find a `--' marker then stop immediately. */
361 if (l
- p
>= 2 && p
[0] == '-' && p
[1] == '-' &&
362 (l
== p
+ 2 || ISSPACE(p
[2])))
365 /* Push the output cursor position onto the output, because this is where
366 * the next word will start.
370 /* Collect characters until we find an unquoted space. */
371 while (p
< l
&& (qstate
|| !ISSPACE(*p
))) {
374 /* A quote. Skip past, and toggle quotedness. */
376 { p
++; qstate
= !qstate
; }
378 else if (*p
== '\\') {
379 /* A backslash. Just emit the following character. */
381 p
++; if (p
>= l
) lose("%s:2: unfinished `\\' escape", script
);
384 } else if (*p
== '\'') {
385 /* A single quote. Find its matching end quote, and emit everything
389 p
++; r
= strchr(p
, '\'');
390 if (!r
|| r
> l
) lose("%s:2: missing `''", script
);
391 n
= r
- p
; memmove(q
, p
, n
); q
+= n
; p
= r
+ 1;
394 /* An ordinary constituent. Gather a bunch of these up and emit them
397 n
= strcspn(p
, qstate ?
"\"\\" : "\"'\\ \f\n\r\t\v");
398 if (n
> l
- p
) n
= l
- p
;
399 memmove(q
, p
, n
); q
+= n
; p
+= n
;
403 /* Check that we're not still inside quotes. */
404 if (qstate
) lose("%s:2: missing `\"'", script
);
406 /* Finish off this word and prepare to start the next. */
407 *q
++ = 0; if (p
< l
) p
++;
410 /* Parse the arguments we've collected as options. Object if we find
411 * positional arguments.
413 flags
= (flags
&~AF_STATEMASK
) | AF_EMBED
;
414 parse_options(av
.n
, (char * /*unconst*/*)av
.v
);
416 lose("%s:2: positional argument `%s' not permitted here",
417 script
, av
.v
[optind
]);
423 lose("error reading script `%s': %s", script
, strerror(errno
));
426 dstr_release(&d
); argv_release(&av
);
430 int main(int argc
, char *argv
[])
432 struct config_section_iter si
;
433 struct config_section
*sect
;
434 struct config_var
*var
;
435 struct lispsys_list order
;
436 struct lispsys
*lisp
, **tail
;
439 struct dstr d
= DSTR_INIT
;
440 struct argv av
= ARGV_INIT
;
443 set_progname(argv
[0]);
446 /* Parse the command-line options. */
447 flags
= (flags
&~AF_STATEMASK
) | AF_CMDLINE
;
448 parse_options(argc
- 1, argv
+ 1); optind
++;
450 /* We now know enough to decide whether we're in eval or script mode. In
451 * the former case, don't check for embedded options (it won't work because
452 * we don't know where the `eval.lisp' script is yet, and besides, there
453 * aren't any). In the latter case, pick out the script name, leaving the
454 * remaining positional arguments for later.
456 if (argv_tail
.n
) { flags
|= AF_NOEMBED
; script
= 0; }
457 else if (optind
< argc
) script
= argv
[optind
++];
458 else flags
|= AF_BOGUS
;
460 /* Check that everything worked. */
461 if (flags
&AF_BOGUS
) { usage(stderr
); exit(127); }
463 /* Reestablish ARGC/ARGV to refer to the tail of positional arguments to be
464 * passed onto the eventual script. For eval mode, that includes the
465 * operations already queued up, so we'll have to accumulate everything in
468 argc
-= optind
; argv
+= optind
;
470 argv_append(&argv_tail
, "--");
471 argv_appendn(&argv_tail
, argv
, argc
);
472 argc
= argv_tail
.n
; argv
= argv_tail
.v
;
475 /* Fetch embedded options. */
476 if (!(flags
&AF_NOEMBED
)) handle_embedded_args(script
);
478 /* Load default configuration if no explicit files were requested. */
479 if (!(flags
&AF_SETCONF
)) load_default_config();
481 /* Determine the preferred Lisp systems. Check the environment first;
482 * otherwise use the configuration file.
484 p
= my_getenv("RUNLISP_PREFER", 0);
486 var
= config_find_var(&config
, toplevel
, CF_INHERIT
, "prefer");
489 config_subst_var(&config
, toplevel
, var
, &d
); p
= d
.p
;
493 add_lispsys(p
, "preferred", &prefer
, LF_PREFER
,
494 offsetof(struct lispsys
, next_prefer
));
496 /* If we're in eval mode, then find the `eval.lisp' script. */
498 script
= config_subst_string_alloc(&config
, common
, "<internal>",
499 "${@ENV:RUNLISP_EVAL?"
500 "${@CONFIG:eval-script?"
501 "${@data-dir}/eval.lisp}}");
503 /* We now have the script name, so publish it for `uiop'.
505 * As an aside, this is a terrible interface. It's too easy to forget to
506 * set it. (To illustrate this, `cl-launch -x' indeed forgets to set it.)
507 * If you're lucky, the script just thinks that its argument is `nil', in
508 * which case maybe it can use `*load-pathname*' as a fallback. If you're
509 * unlucky, your script was invoked (possibly indirectly) by another
510 * script, and now you've accidentally inherited the calling script's name.
512 * It would have been far better simply to repeat the script name as the
513 * first user argument, if nothing else had come readily to mind.
515 if (setenv("__CL_ARGV0", script
, 1))
516 lose("failed to set script-name environment variable");
518 /* And publish it in the configuration for the `run-script' commands. */
519 config_set_var(&config
, builtin
, CF_LITERAL
, "@script", script
);
521 /* Dump the final configuration if we're being very verbose. */
522 if (verbose
>= 5) dump_config();
524 /* Identify the configuration sections which correspond to actual Lisp
525 * system definitions, and gather them into the `known' list.
528 for (config_start_section_iter(&config
, &si
);
529 (sect
= config_next_section(&si
)); ) {
530 var
= config_find_var(&config
, sect
, CF_INHERIT
, "run-script");
532 lisp
= ensure_lispsys(CONFIG_SECTION_NAME(sect
),
533 CONFIG_SECTION_NAMELEN(sect
));
534 lisp
->f
|= LF_KNOWN
; lisp
->sect
= sect
; lisp
->var
= var
;
535 *tail
= lisp
; tail
= &lisp
->next_lisp
;
537 *tail
= 0; lisps
.tail
= tail
;
539 /* Make sure that the acceptable and preferred Lisps actually exist. */
540 check_lisps("acceptable", &accept
, offsetof(struct lispsys
, next_accept
));
541 check_lisps("preferred", &prefer
, offsetof(struct lispsys
, next_prefer
));
543 /* If there are no acceptable Lisps, then we'll take all of them. */
546 moan("no explicitly acceptable implementations: allowing all");
548 for (lisp
= lisps
.head
; lisp
; lisp
= lisp
->next_lisp
)
549 { lisp
->f
|= LF_ACCEPT
; *tail
= lisp
; tail
= &lisp
->next_accept
; }
550 *tail
= 0; accept
.tail
= tail
;
553 /* Build the final list of Lisp systems in the order in which we'll try
554 * them: first, preferred Lisps which are acceptable, and then acceptable
555 * Lisps which aren't preferred.
558 for (lisp
= prefer
.head
; lisp
; lisp
= lisp
->next_prefer
)
559 if (lisp
->f
&LF_ACCEPT
) { *tail
= lisp
; tail
= &lisp
->next_order
; }
560 for (lisp
= accept
.head
; lisp
; lisp
= lisp
->next_accept
)
561 if (!(lisp
->f
&LF_PREFER
)) { *tail
= lisp
; tail
= &lisp
->next_order
; }
564 /* Maybe dump out the various lists of Lisp systems we've collected. */
566 dump_lisps("known Lisps", &lisps
, offsetof(struct lispsys
, next_lisp
));
568 dump_lisps("acceptable Lisps", &accept
,
569 offsetof(struct lispsys
, next_accept
));
570 dump_lisps("preferred Lisps", &prefer
,
571 offsetof(struct lispsys
, next_prefer
));
572 dump_lisps("overall preference order", &order
,
573 offsetof(struct lispsys
, next_order
));
576 /* Try to actually run the script. */
577 for (lisp
= order
.head
; lisp
; lisp
= lisp
->next_order
) {
578 /* Try each of the selected systems in turn. */
580 /* See whether there's a custom image file. If so, set `@image' in the
581 * system's configuration section.
583 if (!(flags
&AF_VANILLA
) &&
584 config_find_var(&config
, lisp
->sect
, CF_INHERIT
, "image-file")) {
585 var
= config_find_var(&config
, lisp
->sect
, CF_INHERIT
, "image-path");
587 lose("variable `image-path' not defined for Lisp `%s'",
589 dstr_reset(&d
); config_subst_var(&config
, lisp
->sect
, var
, &d
);
590 if (file_exists_p(d
.p
, verbose
>= 2 ? FEF_VERBOSE
: 0))
591 config_set_var(&config
, lisp
->sect
, CF_LITERAL
, "@image", "t");
594 /* Build the command line from `run-script'. */
596 config_subst_split_var(&config
, lisp
->sect
, lisp
->var
, &av
);
598 moan("empty command for Lisp implementation `%s'", LISPSYS_NAME(lisp
));
602 /* Append our additional positional arguments. */
603 argv_appendn(&av
, argv
, argc
);
605 /* Try to run the Lisp system. */
607 (flags
&AF_DRYRUN ? TEF_DRYRUN
: 0) |
608 (verbose
>= 2 ? TEF_VERBOSE
: 0)))
612 /* No. Much errors. So failure. Very sadness. */
613 lose("no acceptable Lisp systems found");
616 /*----- That's all, folks -------------------------------------------------*/