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 -------------------------------------------------------*/
43 struct treap_node _node
;
44 struct lispsys
*next_lisp
, *next_accept
, *next_prefer
, *next_order
;
49 struct config_section
*sect
;
50 struct config_var
*var
;
52 #define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp)
53 #define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp)
56 struct lispsys
*head
, **tail
;
59 static struct argv argv_tail
= ARGV_INIT
;
60 const char *script
= 0;
62 static unsigned flags
= 0;
63 #define AF_CMDLINE 0x0000u
64 #define AF_EMBED 0x0001u
65 #define AF_ENV 0x0002u
66 #define AF_CONF 0x0003u
67 #define AF_STATEMASK 0x000fu
68 #define AF_BOGUS 0x0010u
69 #define AF_SETCONF 0x0020u
70 #define AF_NOEMBED 0x0040u
71 #define AF_DRYRUN 0x0080u
72 #define AF_VANILLA 0x0100u
74 struct treap lispsys
= TREAP_INIT
;
75 static struct lispsys_list
76 lisps
= { 0, &lisps
.head
},
77 accept
= { 0, &accept
.head
},
78 prefer
= { 0, &prefer
.head
};
80 /*----- Main code ---------------------------------------------------------*/
82 static void version(FILE *fp
)
83 { fprintf(fp
, "%s, version %s\n", progname
, PACKAGE_VERSION
); }
85 static void usage(FILE *fp
)
89 %s [OPTIONS] [--] SCRIPT [ARGUMENTS ...]\n\
90 %s [OPTIONS] [-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n\
92 [-CDEnqv] [+DEn] [-L SYS,SYS,...] [-c CONF] [-o [SECT:]VAR=VAL]\n",
96 static void help(FILE *fp
)
98 version(fp
); fputc('\n', fp
); usage(fp
);
101 -h, --help Show this help text and exit successfully.\n\
102 -V, --version Show version number and exit successfully.\n\
105 -n, --dry-run Don't run run anything (useful with `-v').\n\
106 -q, --quiet Don't print warning messages.\n\
107 -v, --verbose Print informational messages (repeatable).\n\
110 -E, --command-line-only Don't read embedded options from script.\n\
111 -c, --config-file=CONF Read configuration from CONF (repeatable).\n\
112 -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
114 Lisp implementation selection:\n\
115 -D, --vanilla-image Run vanilla Lisp images, not custom ones.\n\
116 -L, --accept-lisp=SYS,SYS,... Only use the listed Lisp systems.\n\
119 -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\
120 -l, --load-file=FILE Load FILE (repeatable).\n\
121 -p, --print-expression=EXPR Print (`prin1') EXPR (repeatable).\n",
125 static struct lispsys
*ensure_lispsys(const char *name
, size_t n
)
127 struct lispsys
*lisp
;
128 struct treap_path path
;
130 lisp
= treap_probe(&lispsys
, name
, n
, &path
);
132 lisp
= xmalloc(sizeof(*lisp
));
133 lisp
->f
= 0; lisp
->sect
= 0;
134 treap_insert(&lispsys
, &path
, &lisp
->_node
, name
, n
);
139 #define LISP_LINK(lisp, linkoff) \
140 ((struct lispsys **)((unsigned char *)(lisp) + (linkoff)))
142 static void add_lispsys(const char *p
, const char *what
,
143 struct lispsys_list
*list
,
144 unsigned flag
, size_t linkoff
)
146 struct lispsys
*lisp
, **link
;
152 q
= p
; while (*p
&& *p
!= ',') p
++;
153 lisp
= ensure_lispsys(q
, p
- q
);
156 moan("ignoring duplicate %s Lisp `%.*s'", what
, (int)(p
- q
), q
);
158 link
= LISP_LINK(lisp
, linkoff
);
159 lisp
->f
|= flag
; *link
= 0;
160 *list
->tail
= lisp
; list
->tail
= link
;
167 static void check_lisps(const char *what
,
168 struct lispsys_list
*list
, size_t linkoff
)
170 struct lispsys
*lisp
;
172 for (lisp
= list
->head
; lisp
; lisp
= *LISP_LINK(lisp
, linkoff
))
173 if (!(lisp
->f
&LF_KNOWN
))
174 lose("unknown Lisp implementation `%s'", LISPSYS_NAME(lisp
));
177 static void dump_lisps(const char *what
,
178 struct lispsys_list
*list
, size_t linkoff
)
180 struct dstr d
= DSTR_INIT
;
181 struct lispsys
*lisp
;
185 for (lisp
= list
->head
; lisp
; lisp
= *LISP_LINK(lisp
, linkoff
)) {
186 if (first
) first
= 0;
187 else dstr_puts(&d
, ", ");
188 dstr_putf(&d
, "`%s'", LISPSYS_NAME(lisp
));
190 if (first
) dstr_puts(&d
, "(none)");
192 moan("%s: %s", what
, d
.p
);
196 static void push_eval_op(char op
, const char *val
)
201 if ((flags
&AF_STATEMASK
) != AF_CMDLINE
) {
202 moan("must use `-e', `-p', or `-l' on command line");
209 p
[0] = op
; memcpy(p
+ 1, val
, n
);
210 argv_append(&argv_tail
, p
);
213 static void parse_options(int argc
, char *argv
[])
217 static const struct option opts
[] = {
218 { "help", 0, 0, 'h' },
219 { "version", 0, 0, 'V' },
220 { "vanilla-image", OPTF_NEGATE
, 0, 'D' },
221 { "command-line-only", OPTF_NEGATE
, 0, 'E' },
222 { "accept-lisp", OPTF_ARGREQ
, 0, 'L' },
223 { "config-file", OPTF_ARGREQ
, 0, 'c' },
224 { "evaluate-expression", OPTF_ARGREQ
, 0, 'e' },
225 { "load-file", OPTF_ARGREQ
, 0, 'l' },
226 { "dry-run", OPTF_NEGATE
, 0, 'n' },
227 { "set-option", OPTF_ARGREQ
, 0, 'o' },
228 { "print-expression", OPTF_ARGREQ
, 0, 'p' },
229 { "quiet", 0, 0, 'q' },
230 { "verbose", 0, 0, 'v' },
234 optarg
= 0; optind
= 0; optprog
= (/*unconst*/ char *)progname
;
236 i
= mdwopt(argc
, argv
, "+hVD+E+L:c:e:l:n+o:p:qv", opts
, 0, 0,
237 OPTF_NEGATION
| OPTF_NOPROGNAME
);
240 case 'h': help(stdout
); exit(0);
241 case 'V': version(stdout
); exit(0);
242 case 'D': flags
|= AF_VANILLA
; break;
243 case 'D' | OPTF_NEGATED
: flags
&= ~AF_VANILLA
; break;
244 case 'E': flags
|= AF_NOEMBED
; break;
245 case 'E' | OPTF_NEGATED
: flags
&= ~AF_NOEMBED
; break;
247 add_lispsys(optarg
, "acceptable", &accept
, LF_ACCEPT
,
248 offsetof(struct lispsys
, next_accept
));
250 case 'c': read_config_path(optarg
, 0); flags
|= AF_SETCONF
; break;
251 case 'e': push_eval_op('!', optarg
); break;
252 case 'l': push_eval_op('<', optarg
); break;
253 case 'n': flags
|= AF_DRYRUN
; break;
254 case 'n' | OPTF_NEGATED
: flags
&= ~AF_DRYRUN
; break;
255 case 'o': if (set_config_var(optarg
)) flags
|= AF_BOGUS
; break;
256 case 'p': push_eval_op('?', optarg
); break;
257 case 'q': if (verbose
) verbose
--; break;
258 case 'v': verbose
++; break;
259 default: flags
|= AF_BOGUS
; break;
264 static void handle_embedded_args(const char *script
)
266 struct dstr d
= DSTR_INIT
;
267 struct argv av
= ARGV_INIT
;
268 char *p
, *q
, *r
; const char *l
;
273 fp
= fopen(script
, "r");
274 if (!fp
) lose("can't read script `%s': %s", script
, strerror(errno
));
276 if (dstr_readline(&d
, fp
)) goto end
;
277 dstr_reset(&d
); if (dstr_readline(&d
, fp
)) goto end
;
279 p
= strstr(d
.p
, "@RUNLISP:"); if (!p
) goto end
;
280 p
+= 9; q
= p
; l
= d
.p
+ d
.len
;
282 while (p
< l
&& ISSPACE(*p
)) p
++;
284 if (l
- p
>= 3 && p
[0] == '-' && p
[1] == '*' && p
[2] == '-') {
285 p
= strstr(p
+ 3, "-*-");
287 lose("%s:2: unfinished local-variables list", script
);
291 if (l
- p
>= 2 && p
[0] == '-' && p
[1] == '-' &&
292 (l
== p
+ 2 || ISSPACE(p
[2])))
296 while (p
< l
&& (qstate
|| !ISSPACE(*p
))) {
297 if (*p
== '"') { p
++; qstate
= !qstate
; }
298 else if (*p
== '\\') {
299 p
++; if (p
>= l
) lose("%s:2: unfinished `\\' escape", script
);
301 } else if (*p
== '\'') {
302 p
++; r
= strchr(p
, '\'');
303 if (!r
|| r
> l
) lose("%s:2: missing `''", script
);
304 n
= r
- p
; memmove(q
, p
, n
); q
+= n
; p
= r
+ 1;
306 n
= strcspn(p
, qstate ?
"\"\\" : "\"'\\ \f\n\r\t\v");
307 if (n
> l
- p
) n
= l
- p
;
308 memmove(q
, p
, n
); q
+= n
; p
+= n
;
311 if (qstate
) lose("%s:2: missing `\"'", script
);
316 flags
= (flags
&~AF_STATEMASK
) | AF_EMBED
;
317 parse_options(av
.n
, (char * /*unconst*/*)av
.v
);
319 lose("%s:2: positional argument `%s' not permitted here",
320 script
, av
.v
[optind
]);
325 lose("error reading script `%s': %s", script
, strerror(errno
));
328 dstr_release(&d
); argv_release(&av
);
331 int main(int argc
, char *argv
[])
333 struct config_section_iter si
;
334 struct config_section
*sect
;
335 struct config_var
*var
;
336 struct lispsys_list order
;
337 struct lispsys
*lisp
, **tail
;
338 struct dstr d
= DSTR_INIT
;
339 struct argv av
= ARGV_INIT
;
341 set_progname(argv
[0]);
344 config_set_var(&config
, toplevel
, 0, "prefer", "${@ENV:RUNLISP_PREFER?}");
346 flags
= (flags
&~AF_STATEMASK
) | AF_CMDLINE
;
347 parse_options(argc
- 1, argv
+ 1); optind
++;
351 else if (!script
&& !argv_tail
.n
) {
352 if (optind
< argc
) script
= argv
[optind
]++;
353 else flags
|= AF_BOGUS
;
356 argc
-= optind
; argv
+= optind
;
358 argv_append(&argv_tail
, "--");
359 argv_appendn(&argv_tail
, (const char *const *)argv
, argc
);
360 argc
= argv_tail
.n
; argv
= (/*unconst*/ char */
*unconst*/
*)argv_tail
.v
;
363 if (flags
&AF_BOGUS
) { usage(stderr
); exit(2); }
364 if (!(flags
&AF_NOEMBED
)) handle_embedded_args(script
);
365 if (!(flags
&AF_SETCONF
)) load_default_config();
366 if (verbose
>= 5) dump_config();
369 var
= config_find_var(&config
, toplevel
, CF_INHERIT
, "prefer");
370 config_subst_var(&config
, toplevel
, var
, &d
);
371 add_lispsys(d
.p
, "preferred", &prefer
, LF_PREFER
,
372 offsetof(struct lispsys
, next_prefer
));
375 script
= config_subst_string_alloc
376 (&config
, common
, "<internal>",
377 "${@ENV:RUNLISP_EVAL?${@CONFIG:data-dir}/eval.lisp}");
379 if (setenv("__CL_ARGV0", script
, 1))
380 lose("failed to set script-name environment variable");
381 config_set_var(&config
, builtin
, CF_LITERAL
, "@SCRIPT", script
);
384 for (config_start_section_iter(&config
, &si
);
385 (sect
= config_next_section(&si
)); ) {
386 var
= config_find_var(&config
, sect
, CF_INHERIT
, "run-script");
388 lisp
= ensure_lispsys(CONFIG_SECTION_NAME(sect
),
389 CONFIG_SECTION_NAMELEN(sect
));
390 lisp
->f
|= LF_KNOWN
; lisp
->sect
= sect
; lisp
->var
= var
;
391 *tail
= lisp
; tail
= &lisp
->next_lisp
;
393 *tail
= 0; lisps
.tail
= tail
;
395 check_lisps("acceptable", &accept
, offsetof(struct lispsys
, next_accept
));
396 check_lisps("preferred", &prefer
, offsetof(struct lispsys
, next_prefer
));
400 moan("no explicitly acceptable implementations: allowing all");
402 for (lisp
= lisps
.head
; lisp
; lisp
= lisp
->next_lisp
)
403 { lisp
->f
|= LF_ACCEPT
; *tail
= lisp
; tail
= &lisp
->next_accept
; }
404 *tail
= 0; accept
.tail
= tail
;
408 for (lisp
= prefer
.head
; lisp
; lisp
= lisp
->next_prefer
)
409 if (lisp
->f
&LF_ACCEPT
) { *tail
= lisp
; tail
= &lisp
->next_order
; }
410 for (lisp
= accept
.head
; lisp
; lisp
= lisp
->next_accept
)
411 if (!(lisp
->f
&LF_PREFER
)) { *tail
= lisp
; tail
= &lisp
->next_order
; }
415 dump_lisps("known Lisps", &lisps
, offsetof(struct lispsys
, next_lisp
));
417 dump_lisps("acceptable Lisps", &accept
,
418 offsetof(struct lispsys
, next_accept
));
419 dump_lisps("preferred Lisps", &prefer
,
420 offsetof(struct lispsys
, next_prefer
));
421 dump_lisps("overall preference order", &order
,
422 offsetof(struct lispsys
, next_order
));
425 for (lisp
= order
.head
; lisp
; lisp
= lisp
->next_order
) {
426 if (config_find_var(&config
, lisp
->sect
, CF_INHERIT
, "image-file")) {
427 var
= config_find_var(&config
, lisp
->sect
, CF_INHERIT
, "image-path");
428 dstr_reset(&d
); config_subst_var(&config
, lisp
->sect
, var
, &d
);
429 if (file_exists_p(d
.p
, verbose
>= 2 ? FEF_VERBOSE
: 0))
430 config_set_var(&config
, lisp
->sect
, CF_LITERAL
, "@IMAGE", "t");
433 config_subst_split_var(&config
, lisp
->sect
, lisp
->var
, &av
);
435 moan("empty command for Lisp implementation `%s'", LISPSYS_NAME(lisp
));
438 argv_appendn(&av
, (const char *const *)argv
, argc
);
440 (flags
&AF_DRYRUN ? TEF_DRYRUN
: 0) |
441 (verbose
>= 2 ? TEF_VERBOSE
: 0)))
445 lose("no acceptable Lisp systems found");
448 /*----- That's all, folks -------------------------------------------------*/