From: Mark Wooding Date: Wed, 26 Aug 2020 03:08:39 +0000 (+0100) Subject: @@@ work in progress X-Git-Url: https://git.distorted.org.uk/~mdw/runlisp/commitdiff_plain/7b8ff279e7304e41b243459d78c3b6703bb8c3f5 @@@ work in progress --- diff --git a/Makefile.am b/Makefile.am index 02e9b42..42cb2e1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -39,8 +39,19 @@ ACLOCAL_AMFLAGS = -Im4 bin_PROGRAMS += runlisp runlisp_SOURCES = runlisp.c +runlisp_SOURCES += common.c common.h +runlisp_SOURCES += lib.c lib.h +runlisp_SOURCES += mdwopt.c mdwopt.h man_MANS += runlisp.1 +noinst_PROGRAMS += old-runlisp +old_runlisp_SOURCES = old-runlisp.c +old_runlisp_SOURCES += lib.c lib.h + +noinst_PROGRAMS += toy +toy_SOURCES = toy.c +toy_SOURCES += lib.c lib.h + ###-------------------------------------------------------------------------- ### Additional machinery. @@ -50,53 +61,53 @@ EXTRA_DIST += eval.lisp ###-------------------------------------------------------------------------- ### Image dumping. -nodist_bin_SCRIPTS += dump-runlisp-image +bin_PROGRAMS += dump-runlisp-image +dump_runlisp_image_SOURCES = dump-runlisp-image.c +dump_runlisp_image_SOURCES += common.c common.h +dump_runlisp_image_SOURCES += lib.c lib.h +dump_runlisp_image_SOURCES += mdwopt.c mdwopt.h man_MANS += dump-runlisp-image.1 +DUMP_RUNLISP_IMAGE = $(v_dump)./dump-runlisp-image \ + -f -c$(srcdir)/runlisp.conf -O$@ + v_dump = $(v_dump_@AM_V@) v_dump_ = $(v_dump_@AM_DEFAULT_V@) v_dump_0 = @echo " DUMP $@"; -EXTRA_DIST += dump-runlisp-image.in -CLEANFILES += dump-runlisp-image -dump-runlisp-image: dump-runlisp-image.in - $(SUBST) $(srcdir)/dump-runlisp-image.in >$@.new \ - $(SUBSTITUTIONS) && \ - chmod +x $@.new && mv $@.new $@ - if DUMP_SBCL image_DATA += sbcl+asdf.core CLEANFILES += sbcl+asdf.core -sbcl+asdf.core: dump-runlisp-image - $(v_dump)./dump-runlisp-image -o$@ sbcl +sbcl+asdf.core: dump-runlisp-image runlisp.conf + $(DUMP_RUNLISP_IMAGE) sbcl endif if DUMP_CCL image_DATA += ccl+asdf.image CLEANFILES += ccl+asdf.image -ccl+asdf.image: dump-runlisp-image - $(v_dump)./dump-runlisp-image -o$@ ccl +ccl+asdf.image: dump-runlisp-image runlisp.conf + $(DUMP_RUNLISP_IMAGE) ccl endif if DUMP_CLISP image_DATA += clisp+asdf.mem CLEANFILES += clisp+asdf.mem -clisp+asdf.mem: dump-runlisp-image - $(v_dump)./dump-runlisp-image -o$@ clisp +clisp+asdf.mem: dump-runlisp-image runlisp.conf + $(DUMP_RUNLISP_IMAGE) clisp endif if DUMP_ECL image_SCRIPTS += ecl+asdf CLEANFILES += ecl+asdf -ecl+asdf: dump-runlisp-image - $(v_dump)./dump-runlisp-image -o$@ ecl +ecl+asdf: dump-runlisp-image runlisp.conf + $(DUMP_RUNLISP_IMAGE) -odata-dir=$(srcdir) ecl endif if DUMP_CMUCL image_DATA += cmucl+asdf.core CLEANFILES += cmucl+asdf.core -cmucl+asdf.core: dump-runlisp-image - $(v_dump)./dump-runlisp-image -o$@ cmucl +cmucl+asdf.core: dump-runlisp-image runlisp.conf + $(DUMP_RUNLISP_IMAGE) cmucl endif ###-------------------------------------------------------------------------- diff --git a/bench/Makefile.am b/bench/Makefile.am index cb5eef7..1bf09ae 100644 --- a/bench/Makefile.am +++ b/bench/Makefile.am @@ -48,18 +48,22 @@ CLEANFILES += *.out *.bench ###-------------------------------------------------------------------------- ### Lisp systems using `runlisp'. -RUNLISP = $(top_builddir)/runlisp -I$(top_builddir)/ +RUNLISP = $(top_builddir)/runlisp \ + -c$(top_srcdir)/runlisp.conf \ + -oimage-dir=$(top_builddir) EXTRA_DIST += t.lisp RUNLISP_BENCHES = $(foreach l,$(LISPS), runlisp.$l.bench) BENCHES += $(RUNLISP_BENCHES) $(RUNLISP_BENCHES): runlisp.%.bench: timeit $(FORCE) - $(v_bench)./timeit $(RUNLISP) -L$* -- $(srcdir)/t.lisp a b c >runlisp.$*.out 2>$@ + $(v_bench)./timeit $(RUNLISP) -L$* -- \ + $(srcdir)/t.lisp a b c >runlisp.$*.out 2>$@ RUNLISP_NOIMAGE_BENCHES = $(foreach l,$(LISPS), runlisp-noimage.$l.bench) BENCHES += $(RUNLISP_NOIMAGE_BENCHES) $(RUNLISP_NOIMAGE_BENCHES): runlisp-noimage.%.bench: timeit $(FORCE) - $(v_bench)./timeit $(RUNLISP) -D -L$* -- $(srcdir)/t.lisp a b c >runlisp-noimage.$*.out 2>$@ + $(v_bench)./timeit $(RUNLISP) -D -L$* -- \ + $(srcdir)/t.lisp a b c >runlisp-noimage.$*.out 2>$@ ###-------------------------------------------------------------------------- ### Lisp systems using `cl-launch'. diff --git a/common.c b/common.c new file mode 100644 index 0000000..b0d5857 --- /dev/null +++ b/common.c @@ -0,0 +1,374 @@ +/* -*-c-*- + * + * Common functionality of a less principled nature + * + * (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 . + */ + +/*----- Header files ------------------------------------------------------*/ + +#include "config.h" + +#include +#include +#include +#include +#include + +#include +#include +#include + +#include + +#include "common.h" +#include "lib.h" + +/*----- Public variables --------------------------------------------------*/ + +struct config config = CONFIG_INIT; +struct config_section *toplevel, *builtin, *common, *env; +unsigned verbose = 1; + +/*----- Internal utilities ------------------------------------------------*/ + +static void escapify(struct dstr *d, const char *p) +{ + size_t n; + + for (;;) { + n = strcspn(p, "\"'\\"); + if (n) { dstr_putm(d, p, n); p += n; } + if (!*p) break; + dstr_putc(d, '\\'); dstr_putc(d, *p++); + } + dstr_putz(d); +} + +static void homedir(struct dstr *d) +{ + static const char *home = 0; + const char *p; + struct passwd *pw; + + if (!home) { + p = my_getenv("HOME", 0); + if (p) home = p; + else { + pw = getpwuid(getuid()); + if (!pw) lose("can't find user in password database"); + home = xstrdup(pw->pw_dir); + } + } + dstr_puts(d, home); +} + +static void user_config_dir(struct dstr *d) +{ + const char *p; + + p = my_getenv("XDG_CONFIG_HOME", 0); + if (p) dstr_puts(d, p); + else { homedir(d); dstr_puts(d, "/.config"); } +} + +/*----- Miscellany --------------------------------------------------------*/ + +const char *my_getenv(const char *name, const char *dflt) +{ + struct config_var *var; + + var = config_find_var(&config, env, 0, name); + return (var ? var->val : dflt); +} + +long parse_int(const char *what, const char *p, long min, long max) +{ + long n; + int oerr = errno; + char *q; + + errno = 0; + n = strtol(p, &q, 0); + while (ISSPACE(*q)) q++; + if (errno || *q) lose("invalid %s `%s'", what, p); + if (n < min || n > max) + lose("%s %ld out of range (must be between %ld and %ld)", + what, n, min, max); + errno = oerr; + return (n); +} + +void argv_string(struct dstr *d, const struct argv *av) +{ + size_t i; + + for (i = 0; i < av->n; i++) { + if (i) { dstr_putc(d, ','); dstr_putc(d, ' '); } + dstr_putc(d, '`'); escapify(d, av->v[i]); dstr_putc(d, '\''); + } + dstr_putz(d); +} + +/*----- File utilities ----------------------------------------------------*/ + +int file_exists_p(const char *path, unsigned f) +{ + struct stat st; + + if (stat(path, &st)) { + if (f&FEF_VERBOSE) moan("file `%s' not found", path); + return (0); + } else if (!(S_ISREG(st.st_mode))) { + if (f&FEF_VERBOSE) moan("`%s' is not a regular file", path); + return (0); + } else if ((f&FEF_EXEC) && access(path, X_OK)) { + if (f&FEF_VERBOSE) moan("file `%s' is not executable", path); + return (0); + } else { + if (f&FEF_VERBOSE) moan("found file `%s'", path); + return (1); + } +} + +int found_in_path_p(const char *prog, unsigned f) +{ + struct dstr p = DSTR_INIT, d = DSTR_INIT; + const char *path; + char *q; + size_t n, avail, proglen; + int i, rc; + + if (strchr(prog, '/')) + return (file_exists_p(prog, f)); + path = my_getenv("PATH", 0); + if (path) + dstr_puts(&p, path); + else { + dstr_puts(&p, ".:"); + i = 0; + again: + avail = p.sz - p.len; + n = confstr(_CS_PATH, p.p + p.len, avail); + if (avail > n) { i++; assert(i < 2); dstr_ensure(&p, n); goto again; } + } + + q = p.p; proglen = strlen(prog); + for (;;) { + n = strcspn(q, ":"); + dstr_reset(&d); + if (n) dstr_putm(&d, q, n); + else dstr_putc(&d, '.'); + dstr_putc(&d, '/'); + dstr_putm(&d, prog, proglen); + dstr_putz(&d); + if (file_exists_p(d.p, verbose >= 4 ? f : f&~FEF_VERBOSE)) { + if (verbose == 2) moan("found program `%s'", d.p); + rc = 1; goto end; + } + q += n; if (!*q) break; else q++; + } + + rc = 0; +end: + dstr_release(&p); dstr_release(&d); + return (rc); +} + +int try_exec(struct argv *av, unsigned f) +{ + struct dstr d = DSTR_INIT; + int rc; + + assert(av->n); argv_appendz(av); + if (verbose >= 2) { argv_string(&d, av); moan("trying %s...", d.p); } + if (f&TEF_DRYRUN) { + if (found_in_path_p(av->v[0], f&TEF_VERBOSE ? FEF_VERBOSE : 0)) + { rc = 0; goto end; } + } else { + execvp(av->v[0], (/*unconst*/ char **)av->v); + if (errno != ENOENT) { + moan("failed to exec `%s': %s", av->v[0], strerror(errno)); + _exit(2); + } + } + + if (verbose >= 2) moan("`%s' not found", av->v[0]); + rc = -1; +end: + dstr_release(&d); + return (rc); +} + +/*----- Configuration -----------------------------------------------------*/ + +void read_config_file(const char *what, const char *file, unsigned f) +{ + if (!config_read_file(&config, file, f)) { + if (verbose >= 2) + moan("read %s configuration file `%s'", what, file); + } else { + if (verbose >= 3) + moan("ignoring missing %s configuration file `%s'", what, file); + } +} + +static int order_strings(const void *xx, const void *yy) + { const char *const *x = xx, *const *y = yy; return (strcmp(*x, *y)); } + +void read_config_dir(const char *what, const char *path, unsigned f) +{ + struct argv av = ARGV_INIT; + struct dstr dd = DSTR_INIT; + struct stat st; + DIR *dir; + struct dirent *d; + size_t i, n, len; + + dir = opendir(path); + if (!dir) { + if (!(f&CF_NOENTOK) || errno != ENOENT) + lose("failed to read %s configuration directory `%s': %s", + what, path, strerror(errno)); + if (verbose >= 3) + moan("ignoring missing %s configuration directory `%s'", what, path); + return; + } + + dstr_puts(&dd, path); dstr_putc(&dd, '/'); n = dd.len; + for (;;) { + d = readdir(dir); if (!d) break; + len = strlen(d->d_name); + if (len < 5 || STRCMP(d->d_name + len - 5, !=, ".conf")) continue; + dd.len = n; dstr_putm(&dd, d->d_name, len); dstr_putz(&dd); + if (stat(dd.p, &st)) + lose("failed to read file metadata for `%s': %s", + dd.p, strerror(errno)); + if (!S_ISREG(st.st_mode)) continue; + argv_append(&av, xstrdup(d->d_name)); + } + + qsort(av.v, av.n, sizeof(*av.v), order_strings); + + for (i = 0; i < av.n; i++) { + dd.len = n; dstr_puts(&dd, av.v[i]); + read_config_file(what, dd.p, f&~CF_NOENTOK); + } + + for (i = 0; i < av.n; i++) free((/*unconst*/ char *)av.v[i]); + argv_release(&av); dstr_release(&dd); closedir(dir); + return; +} + +void read_config_path(const char *path, unsigned f) +{ + struct stat st; + + if (!stat(path, &st) && S_ISDIR(st.st_mode)) + read_config_dir("command-line specified ", path, f); + else + read_config_file("command-line specified", path, f); +} + +int set_config_var(const char *assign) +{ + struct config_section *sect; + const char *p, *q; + + p = strchr(assign, '='); + if (!p) { moan("missing `=' in option assignment"); return (-1); } + q = strchr(assign, ':'); + if (!q || q > p) + { sect = toplevel; q = assign; } + else { + sect = config_find_section_n(&config, CF_CREAT, assign, q - assign); + q++; + } + config_set_var_n(&config, sect, CF_LITERAL | CF_OVERRIDE, + q, p - q, p + 1, strlen(p + 1)); + return (0); +} + +void init_config(void) +{ + toplevel = config_find_section(&config, CF_CREAT, "@CONFIG"); + builtin = config_find_section(&config, CF_CREAT, "@BUILTIN"); + common = config_find_section(&config, CF_CREAT, "@COMMON"); + env = config_find_section(&config, CF_CREAT, "@ENV"); + config_set_fallback(&config, common); + config_set_parent(builtin, 0); + config_set_parent(common, builtin); + config_set_parent(toplevel, 0); + config_read_env(&config, env); + + config_set_var(&config, toplevel, CF_LITERAL, "data-dir", + my_getenv("RUNLISP_DATADIR", DATADIR)); + config_set_var(&config, toplevel, CF_LITERAL, "image-dir", + my_getenv("RUNLISP_IMAGEDIR", IMAGEDIR)); + +#ifdef ECL_OPTIONS_GNU + config_set_var(&config, builtin, CF_LITERAL, "@ECLOPT", "--"); +#else + config_set_var(&config, builtin, CF_LITERAL, "@ECLOPT", "-"); +#endif +} + +void load_default_config(void) +{ + const char *p; + struct dstr d = DSTR_INIT; + + p = my_getenv("RUNLISP_SYSCONFIG", ETCDIR "/runlisp.conf"); + read_config_file("system", p, 0); + p = my_getenv("RUNLISP_SYSCONFIG_DIR", ETCDIR "/runlisp.d"); + read_config_dir("system", p, CF_NOENTOK); + p = my_getenv("RUNLISP_USERCONFIG", 0); + if (p) + read_config_file("user", p, CF_NOENTOK); + else { + dstr_reset(&d); homedir(&d); dstr_puts(&d, "/.runlisp.conf"); + read_config_file("user", d.p, CF_NOENTOK); + dstr_reset(&d); user_config_dir(&d); dstr_puts(&d, "/runlisp.conf"); + read_config_file("user", d.p, CF_NOENTOK); + } + dstr_release(&d); +} + +void dump_config(void) +{ + struct config_section_iter si; + struct config_section *sect; + struct config_var_iter vi; + struct config_var *var; + struct dstr d = DSTR_INIT; + + for (config_start_section_iter(&config, &si); + (sect = config_next_section(&si)); ) + for (config_start_var_iter(sect, &vi); + (var = config_next_var(&vi)); ) { + dstr_reset(&d); escapify(&d, var->val); + moan("config %s:%s = `%s'", + CONFIG_SECTION_NAME(sect), CONFIG_VAR_NAME(var), d.p); + } + dstr_release(&d); +} + +/*----- That's all, folks -------------------------------------------------*/ diff --git a/common.h b/common.h new file mode 100644 index 0000000..6ec38c5 --- /dev/null +++ b/common.h @@ -0,0 +1,76 @@ +/* -*-c-*- + * + * Common functionality of a less principled nature + * + * (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 . + */ + +#ifndef COMMON_H +#define COMMON_H + +#ifdef __cplusplus + extern "C" { +#endif + +/*----- Externally defined types ------------------------------------------*/ + +struct dstr; +struct argv; + +/*----- Public variables --------------------------------------------------*/ + +extern struct config config; +extern struct config_section *toplevel, *builtin, *common, *env; +extern unsigned verbose; + +/*----- Functions provided ------------------------------------------------*/ + +extern const char *my_getenv(const char */*name*/, const char */*dflt*/); +extern long parse_int(const char */*what*/, const char */*p*/, + long /*min*/, long /*max*/); +extern void argv_string(struct dstr */*d*/, const struct argv */*av*/); + +#define FEF_EXEC 1u +#define FEF_VERBOSE 2u +extern int file_exists_p(const char */*path*/, unsigned /*f*/); +extern int found_in_path_p(const char */*prog*/, unsigned /*f*/); + +#define TEF_DRYRUN 1u +#define TEF_VERBOSE 2u +extern int try_exec(struct argv */*av*/, unsigned /*f*/); + +extern void read_config_file(const char */*what*/, + const char */*file*/, unsigned /*f*/); +extern void read_config_dir(const char */*what*/, + const char */*path*/, unsigned /*f*/); +extern void read_config_path(const char */*path*/, unsigned /*f*/); +extern int set_config_var(const char */*assign*/); +extern void init_config(void); +extern void load_default_config(void); +extern void dump_config(void); + +/*----- That's all, folks -------------------------------------------------*/ + +#ifdef __cplusplus + } +#endif + +#endif diff --git a/configure.ac b/configure.ac index 042df98..66446f3 100644 --- a/configure.ac +++ b/configure.ac @@ -34,6 +34,9 @@ mdw_SILENT_RULES AC_PROG_CC AX_CFLAGS_WARN_ALL +mdw_DECL_ENVIRON +AC_CHECK_FUNC([strsignal]) +case $ac_cv_func_strsignal in no) AC_DECL_SYS_SIGLIST ;; esac AC_CHECK_PROGS([AUTOM4TE], [autom4te]) @@ -43,6 +46,7 @@ dnl Checking for Lisp implementations. imagedir=$localstatedir/$PACKAGE_NAME; AC_SUBST(imagedir) mdw_DEFINE_PATHS([ mdw_DEFINE_PATH([IMAGEDIR], [$imagedir]) + mdw_DEFINE_PATH([ETCDIR], [$sysconfdir]) mdw_DEFINE_PATH([DATADIR], [$datadir/$PACKAGE_NAME])]) AC_ARG_ENABLE([imagedump], diff --git a/dump-ecl b/dump-ecl new file mode 100755 index 0000000..538ca27 --- /dev/null +++ b/dump-ecl @@ -0,0 +1,113 @@ +### -*-sh-*- +### +### Auxiliary script for dumping ECL +### +### (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 . + +set -e + +case $# in 4) ;; *) echo >&2 "usage: $0 IMAGE ECL ECLOPT TMP"; exit 2 ;; esac +image=$1 ecl=$2 eclopt=$3 tmp=$4 + +run () { echo "$*"; "$@"; } + +## Start by compiling a copy of ASDF. +cat >"$tmp/ecl-build.lisp" <"$tmp/ecl-run.lisp" <. + */ + +/*----- Header files ------------------------------------------------------*/ + +#include "config.h" + +#include +#include +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#include +#include +#include +#include +#include + +#include "common.h" +#include "lib.h" +#include "mdwopt.h" + +/*----- Static data -------------------------------------------------------*/ + +#define MAXLINE 16384u +struct linebuf { + int fd; + char *buf; + unsigned off, len; +}; + +enum { + JST_READY, + JST_RUN, + JST_DEAD, + JST_NSTATE +}; + +struct job { + struct treap_node _node; + struct job *next; + struct argv av; + unsigned st; + FILE *log; + pid_t kid; + int exit; + struct linebuf out, err; +}; +#define JOB_NAME(job) TREAP_NODE_KEY(job) +#define JOB_NAMELEN(job) TREAP_NODE_KEYLEN(job) + +static struct treap jobs = TREAP_INIT; +static struct job *job_ready, *job_run, *job_dead; +static unsigned nrun, maxrun = 1; +static int rc = 0; +static int nullfd; + +static int sig_pipe[2] = { -1, -1 }; +static sigset_t caught, pending; +static int sigloss = -1; + +static unsigned flags = 0; +#define AF_BOGUS 0x0001u +#define AF_SETCONF 0x0002u +#define AF_DRYRUN 0x0004u +#define AF_ALL 0x0008u +#define AF_FORCE 0x0010u +#define AF_CHECKINST 0x0020u + +/*----- Main code ---------------------------------------------------------*/ + +static PRINTF_LIKE(1, 2) void bad(const char *msg, ...) + { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); rc = 2; } + +static const char *tmpdir; + +static void set_tmpdir(void) +{ + struct dstr d = DSTR_INIT; + size_t n; + unsigned i; + + dstr_putf(&d, "%s/runlisp.%d.", my_getenv("TMPDIR", "/tmp"), getpid()); + i = 0; n = d.len; + for (;;) { + d.len = n; dstr_putf(&d, "%d", rand()); + if (!mkdir(d.p, 0700)) break; + else if (errno != EEXIST) + lose("failed to create temporary directory `%s': %s", + d.p, strerror(errno)); + else if (++i >= 32) { + dstr_puts(&d, "???"); + lose("failed to create temporary directory `%s': too many attempts", + d.p); + } + } + tmpdir = xstrndup(d.p, d.len); dstr_release(&d); +} + +static void recursive_delete_(struct dstr *dd) +{ + size_t n = dd->len; + DIR *dir; + struct dirent *d; + + dd->p[n] = 0; + dir = opendir(dd->p); + if (!dir) + lose("failed to open directory `%s' for cleanup: %s", + dd->p, strerror(errno)); + + dd->p[n++] = '/'; + for (;;) { + d = readdir(dir); if (!d) break; + if (d->d_name[0] == '.' && (!d->d_name[1] || + (d->d_name[1] == '.' && !d->d_name[2]))) + continue; + dd->len = n; dstr_puts(dd, d->d_name); + if (!unlink(dd->p)); + else if (errno == EISDIR) recursive_delete_(dd); + else lose("failed to delete file `%s': %s", dd->p, strerror(errno)); + } + closedir(dir); + dd->p[--n] = 0; + if (rmdir(dd->p)) + lose("failed to delete directory `%s': %s", dd->p, strerror(errno)); +} + +static void recursive_delete(const char *path) +{ + struct dstr d = DSTR_INIT; + dstr_puts(&d, path); recursive_delete_(&d); dstr_release(&d); +} + +static void cleanup(void) + { if (tmpdir) { recursive_delete(tmpdir); tmpdir = 0; } } + +static int configure_fd(const char *what, int fd, int nonblock, int cloexec) +{ + int fl, nfl; + + if (nonblock != -1) { + fl = fcntl(fd, F_GETFL); if (fl < 0) goto fail; + if (nonblock) nfl = fl | O_NONBLOCK; + else nfl = fl&~O_NONBLOCK; + if (fl != nfl && fcntl(fd, F_SETFL, nfl)) goto fail; + } + + if (cloexec != -1) { + fl = fcntl(fd, F_GETFD); if (fl < 0) goto fail; + if (cloexec) nfl = fl | FD_CLOEXEC; + else nfl = fl&~FD_CLOEXEC; + if (fl != nfl && fcntl(fd, F_SETFD, nfl)) goto fail; + } + + return (0); + +fail: + bad("failed to configure %s descriptor: %s", what, strerror(errno)); + return (-1); +} + +static void handle_signal(int sig) +{ + sigset_t old; + char x = '!'; + + sigprocmask(SIG_BLOCK, &caught, &old); + sigaddset(&pending, sig); + sigprocmask(SIG_SETMASK, &old, 0); + + DISCARD(write(sig_pipe[1], &x, 1)); +} + +#define JF_QUIET 1u +static void add_job(struct job ***tail_inout, unsigned f, + const char *name, size_t len) +{ + struct job *job; + struct treap_path path; + struct config_section *sect; + struct config_var *dump_var, *cmd_var; + struct dstr d = DSTR_INIT; + struct argv av = ARGV_INIT; + unsigned fef; + + job = treap_probe(&jobs, name, len, &path); + if (job) { + if (verbose >= 2) { + moan("ignoring duplicate Lisp `%s'", JOB_NAME(job)); + return; + } + } + + sect = config_find_section_n(&config, 0, name, len); + if (!sect) lose("unknown Lisp implementation `%.*s'", (int)len, name); + name = CONFIG_SECTION_NAME(sect); + dump_var = config_find_var(&config, sect, 0, "dump-image"); + if (!dump_var) { + if (!(f&JF_QUIET)) + lose("don't know how to dump images for Lisp implementation `%s'", + name); + goto end; + } + cmd_var = config_find_var(&config, sect, 0, "command"); + if (!cmd_var) + lose("no `command' defined for Lisp implementation `%s'", name); + + config_subst_split_var(&config, sect, dump_var, &av); + if (!av.n) lose("empty command for Lisp implementation `%s'", name); + + if (flags&AF_CHECKINST) { + dstr_reset(&d); + fef = (verbose >= 2 ? FEF_VERBOSE : 0); + config_subst_var(&config, sect, cmd_var, &d); + if (!found_in_path_p(d.p, fef) || + (STRCMP(d.p, !=, av.v[0]) && !found_in_path_p(av.v[0], fef))) { + if (verbose >= 2) moan("skipping Lisp implementation `%s'", name); + goto end; + } + } + + if (!(flags&AF_FORCE)) { + dstr_reset(&d); + config_subst_string(&config, sect, "", "${@IMAGE}", &d); + if (!access(d.p, F_OK)) { + if (verbose >= 2) + moan("image `%s' already exists: skipping `%s'", d.p, name); + goto end; + } + } + + job = xmalloc(sizeof(*job)); + job->st = JST_READY; + job->kid = -1; + job->out.fd = -1; job->out.buf = 0; + job->err.fd = -1; job->err.buf = 0; + job->av = av; argv_init(&av); + treap_insert(&jobs, &path, &job->_node, name, len); + **tail_inout = job; *tail_inout = &job->next; +end: + dstr_release(&d); argv_release(&av); +} + +static void release_job(struct job *job) +{ + if (job->kid > 0) kill(job->kid, SIGKILL); /* ?? */ + if (job->log && job->log != stdout) fclose(job->log); + free(job->out.buf); if (job->out.fd >= 0) close(job->out.fd); + free(job->err.buf); if (job->err.fd >= 0) close(job->err.fd); + free(job); +} + +static void finish_job(struct job *job) +{ + char buf[16483]; + size_t n; + int ok = 0; + + fprintf(job->log, "%-13s > ", JOB_NAME(job)); + if (WIFEXITED(job->exit)) { + if (!WEXITSTATUS(job->exit)) + { fputs("completed successfully\n", job->log); ok = 1; } + else + fprintf(job->log, "failed with exit status %d\n", + WEXITSTATUS(job->exit)); + } else if (WIFSIGNALED(job->exit)) + fprintf(job->log, "killed by signal %d (%s%s)", WTERMSIG(job->exit), +#if defined(HAVE_STRSIGNAL) + strsignal(WTERMSIG(job->exit)), +#elif defined(HAVE_DECL_SYS_SIGLIST) + sys_siglist[WTERMSIG(job->exit)], +#else + "unknown signal", +#endif +#ifdef WCOREDUMP + WCOREDUMP(job->exit) ? "; core dumped" : +#endif + ""); + else + fprintf(job->log, "exited with incomprehensible status %06o\n", + job->exit); + + if (!ok && verbose < 2) { + rewind(job->log); + for (;;) { + n = fread(buf, 1, sizeof(buf), job->log); + if (n) fwrite(buf, 1, n, stdout); + if (n < sizeof(buf)) break; + } + } + + release_job(job); +} + +static int find_newline(struct linebuf *buf, size_t *linesz_out) +{ + char *nl; + + if (buf->off + buf->len <= MAXLINE) { + nl = memchr(buf->buf + buf->off, '\n', buf->len); + if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); } + } else { + nl = memchr(buf->buf + buf->off, '\n', MAXLINE - buf->off); + if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); } + nl = memchr(buf->buf, '\n', buf->len - (MAXLINE - buf->off)); + if (nl) + { *linesz_out = (nl - buf->buf) + (MAXLINE - buf->off); return (0); } + } + return (-1); +} + +static void write_line(struct job *job, struct linebuf *buf, + size_t n, char marker, const char *tail) +{ + fprintf(job->log, "%-13s %c ", JOB_NAME(job), marker); + if (buf->off + n <= MAXLINE) + fwrite(buf->buf + buf->off, 1, n, job->log); + else { + fwrite(buf->buf + buf->off, 1, MAXLINE - buf->off, job->log); + fwrite(buf->buf, 1, n - (MAXLINE - buf->off), job->log); + } + fputs(tail, job->log); +} + +static void prefix_lines(struct job *job, struct linebuf *buf, char marker) +{ + struct iovec iov[2]; int niov; + ssize_t n; + size_t linesz; + + assert(buf->len < MAXLINE); + if (!buf->off) { + iov[0].iov_base = buf->buf + buf->len; + iov[0].iov_len = MAXLINE - buf->len; + niov = 1; + } else if (buf->off + buf->len >= MAXLINE) { + iov[0].iov_base = buf->buf + buf->off + buf->len - MAXLINE; + iov[0].iov_len = MAXLINE - buf->len; + niov = 1; + } else { + iov[0].iov_base = buf->buf + buf->off + buf->len; + iov[0].iov_len = MAXLINE - (buf->off + buf->len); + iov[1].iov_base = buf->buf; + iov[1].iov_len = buf->off; + niov = 1; + } + + n = readv(buf->fd, iov, niov); + if (n < 0) { + if (errno == EAGAIN || errno == EWOULDBLOCK) return; + lose("failed to read job `%s' output stream: %s", + JOB_NAME(job), strerror(errno)); + } + buf->len += n; + + while (!find_newline(buf, &linesz)) { + write_line(job, buf, linesz, marker, "\n"); + buf->len -= linesz + 1; + buf->off += linesz + 1; if (buf->off >= MAXLINE) buf->off -= MAXLINE; + } + if (!buf->len) + buf->off = 0; + else if (buf->len == MAXLINE) { + write_line(job, buf, MAXLINE, marker, " [...]\n"); + buf->off = buf->len = 0; + } + + if (!n) { + close(buf->fd); buf->fd = -1; + if (buf->len) + write_line(job, buf, buf->len, marker, " [missing final newline]\n"); + } +} + +static void reap_children(void) +{ + struct job *job, **link; + pid_t kid; + int st; + + for (;;) { + kid = waitpid(0, &st, WNOHANG); + if (kid <= 0) break; + for (link = &job_run; (job = *link); link = &job->next) + if (job->kid == kid) goto found; + moan("unexpected child process %d exited with status %06o", kid, st); + continue; + found: + job->exit = st; job->st = JST_DEAD; job->kid = -1; nrun--; + *link = job->next; job->next = job_dead; job_dead = job; + } + if (kid < 0 && errno != ECHILD) + lose("failed to collect child process exit status: %s", strerror(errno)); +} + +static void check_signals(void) +{ + sigset_t old, pend; + char buf[32]; + ssize_t n; + + sigprocmask(SIG_BLOCK, &caught, &old); + pend = pending; sigemptyset(&pending); + for (;;) { + n = read(sig_pipe[0], buf, sizeof(buf)); + if (!n) lose("(internal) signal pipe closed!"); + if (n < 0) break; + } + if (errno != EAGAIN && errno != EWOULDBLOCK) + lose("failed to read signal pipe: %s", strerror(errno)); + sigprocmask(SIG_SETMASK, &old, 0); + + if (sigismember(&pend, SIGINT)) sigloss = SIGINT; + else if (sigismember(&pend, SIGHUP)) sigloss = SIGHUP; + else if (sigismember(&pend, SIGTERM)) sigloss = SIGTERM; + if (sigismember(&pend, SIGCHLD)) reap_children(); +} + +#define SIGF_IGNOK 1u +static void set_signal_handler(const char *what, int sig, unsigned f) +{ + struct sigaction sa, sa_old; + + sigaddset(&caught, sig); + + if (f&SIGF_IGNOK) { + if (sigaction(sig, 0, &sa_old)) goto fail; + if (sa_old.sa_handler == SIG_IGN) return; + } + + sa.sa_handler = handle_signal; + sigemptyset(&sa.sa_mask); + sa.sa_flags = SA_NOCLDSTOP; + if (sigaction(sig, &sa, 0)) goto fail; + + return; + +fail: + lose("failed to set %s signal handler: %s", what, strerror(errno)); +} + +static NORETURN void job_child(struct job *job) +{ + try_exec(&job->av, + !(flags&AF_CHECKINST) && verbose >= 2 ? TEF_VERBOSE : 0); + moan("failed to run `%s': %s", job->av.v[0], strerror(errno)); + _exit(2); +} + +static void start_jobs(void) +{ + struct dstr d = DSTR_INIT; + int p_out[2], p_err[2]; + struct job *job; + pid_t kid; + + while (job_ready && nrun < maxrun) { + job = job_ready; job_ready = job->next; + p_out[0] = p_out[1] = p_err[0] = p_err[1] = -1; + dstr_reset(&d); dstr_putf(&d, "%s/%s", tmpdir, JOB_NAME(job)); + if (mkdir(d.p, 0700)) { + bad("failed to create working directory for job `%s': %s", + JOB_NAME(job), strerror(errno)); + goto fail; + } + if (verbose >= 2) + job->log = stdout; + else { + dstr_puts(&d, "/log"); job->log = fopen(d.p, "w+"); + if (!job->log) + lose("failed to open log file `%s': %s", d.p, strerror(errno)); + } + if (pipe(p_out) || pipe(p_err)) { + bad("failed to create pipes for job `%s': %s", + JOB_NAME(job), strerror(errno)); + goto fail; + } + if (configure_fd("job stdout pipe", p_out[0], 1, 1) || + configure_fd("job stdout pipe", p_out[1], 0, 1) || + configure_fd("job stderr pipe", p_err[0], 1, 1) || + configure_fd("job stderr pipe", p_err[1], 0, 1) || + configure_fd("log file", fileno(job->log), 1, 1)) + goto fail; + job->out.buf = xmalloc(MAXLINE); job->out.off = job->out.len = 0; + job->out.fd = p_out[0]; p_out[0] = -1; + job->err.buf = xmalloc(MAXLINE); job->err.off = job->err.len = 0; + job->err.fd = p_err[0]; p_err[0] = -1; + dstr_reset(&d); argv_string(&d, &job->av); + fprintf(job->log, "%-13s > starting %s\n", JOB_NAME(job), d.p); + fflush(stdout); + kid = fork(); + if (kid < 0) { + bad("failed to fork process for job `%s': %s", + JOB_NAME(job), strerror(errno)); + goto fail; + } + if (!kid) { + if (dup2(nullfd, 0) < 0 || + dup2(p_out[1], 1) < 0 || + dup2(p_err[1], 2) < 0) + lose("failed to juggle job `%s' file descriptors: %s", + JOB_NAME(job), strerror(errno)); + job_child(job); + } + close(p_out[1]); close(p_err[1]); + job->kid = kid; + job->st = JST_RUN; job->next = job_run; job_run = job; nrun++; + continue; + fail: + if (p_out[0] >= 0) close(p_out[0]); + if (p_out[1] >= 0) close(p_out[1]); + if (p_err[0] >= 0) close(p_err[0]); + if (p_err[1] >= 0) close(p_err[1]); + release_job(job); + } + dstr_release(&d); +} + +static void version(FILE *fp) + { fprintf(fp, "%s, runlisp version %s\n", progname, PACKAGE_VERSION); } + +static void usage(FILE *fp) +{ + fprintf(fp, "\ +usage: %s [-afnqv] [-c CONF] [-o [SECT:]VAR=VAL]\n\ + [-O FILE|DIR] [-j NJOBS] [LISP ...]\n", + 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\ + -c, --config-file=CONF Read configuration from CONF (repeatable).\n\ + -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\ +\n\ +Image dumping:\n\ + -O, --output=FILE|DIR Store image(s) in FILE or DIR.\n\ + -a, --all-configured Dump all implementations configured.\n\ + -f, --force Dump images even if they already exist.\n\ + -i, --check-installed Check Lisp systems exist before invoking.\n\ + -j, --jobs=NJOBS Run up to NJOBS jobs in parallel.\n", + fp); +} + +int main(int argc, char *argv[]) +{ + struct config_section_iter si; + struct config_section *sect; + struct config_var *var; + const char *out = 0, *p, *q, *l; + struct job *job, **tail, **link, *next; + struct stat st; + struct dstr d = DSTR_INIT; + int i, fd, nfd, first; + fd_set fd_in; + + static const struct option opts[] = { + { "help", 0, 0, 'h' }, + { "version", 0, 0, 'V' }, + { "output", OPTF_ARGREQ, 0, 'O' }, + { "all-configured", 0, 0, 'a' }, + { "config-file", OPTF_ARGREQ, 0, 'c' }, + { "force", OPTF_NEGATE, 0, 'f' }, + { "check-installed", OPTF_NEGATE, 0, 'i' }, + { "jobs", OPTF_ARGREQ, 0, 'j' }, + { "dry-run", OPTF_NEGATE, 0, 'n' }, + { "set-option", OPTF_ARGREQ, 0, 'o' }, + { "quiet", 0, 0, 'q' }, + { "verbose", 0, 0, 'v' }, + { 0, 0, 0, 0 } + }; + + set_progname(argv[0]); + init_config(); + + optprog = (/*unconst*/ char *)progname; + for (;;) { + i = mdwopt(argc - 1, argv + 1, "hVO:ac:f+i+j:n+o: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 'O': out = optarg; break; + case 'a': flags |= AF_ALL; break; + case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break; + case 'f': flags |= AF_FORCE; break; + case 'f' | OPTF_NEGATED: flags &= ~AF_FORCE; break; + case 'i': flags |= AF_CHECKINST; break; + case 'i' | OPTF_NEGATED: flags &= ~AF_CHECKINST; break; + case 'j': maxrun = parse_int("number of jobs", optarg, 1, 65535); 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 'q': if (verbose) verbose--; break; + case 'v': verbose++; break; + default: flags |= AF_BOGUS; break; + } + } + + optind++; + if ((flags&AF_ALL) ? optind < argc : optind >= argc) flags |= AF_BOGUS; + if (flags&AF_BOGUS) { usage(stderr); exit(2); } + + if (!(flags&AF_SETCONF)) load_default_config(); + + if (!out) + config_set_var(&config, builtin, 0, + "@IMAGE", "${@CONFIG:image-dir}/${image-file}"); + else if (stat(out, &st) || !S_ISDIR(st.st_mode)) + config_set_var(&config, builtin, CF_LITERAL, "@IMAGE", out); + else { + config_set_var(&config, builtin, CF_LITERAL, "@%OUTDIR", out); + config_set_var(&config, builtin, 0, + "@IMAGE", "${@BUILTIN:@%OUTDIR}/${image-file}"); + } + + atexit(cleanup); + if (pipe(sig_pipe)) + lose("failed to create signal pipe: %s", strerror(errno)); + configure_fd("signal pipe (read end)", sig_pipe[0], 1, 1); + configure_fd("signal pipe (write end)", sig_pipe[1], 1, 1); + sigemptyset(&caught); sigemptyset(&pending); + set_signal_handler("SIGTERM", SIGTERM, SIGF_IGNOK); + set_signal_handler("SIGINT", SIGINT, SIGF_IGNOK); + set_signal_handler("SIGHUP", SIGHUP, SIGF_IGNOK); + set_signal_handler("SIGCHLD", SIGCHLD, 0); + + set_tmpdir(); + config_set_var(&config, builtin, CF_LITERAL, "@%TMPDIR", tmpdir); + config_set_var(&config, builtin, 0, + "@TMPDIR", "${@BUILTIN:@%TMPDIR}/${@NAME}"); + + if (verbose >= 5) dump_config(); + + tail = &job_ready; + if (!(flags&AF_ALL)) + for (i = optind; i < argc; i++) + add_job(&tail, 0, argv[i], strlen(argv[i])); + else { + var = config_find_var(&config, toplevel, 0, "dump"); + if (!var) + for (config_start_section_iter(&config, &si); + (sect = config_next_section(&si)); ) + add_job(&tail, JF_QUIET, + CONFIG_SECTION_NAME(sect), + CONFIG_SECTION_NAMELEN(sect)); + else { + p = var->val; l = p + var->n; + for (;;) { + while (p < l && ISSPACE(*p)) p++; + if (p >= l) break; + q = p; + while (p < l && !ISSPACE(*p) && *p != ',') p++; + add_job(&tail, 0, q, p - q); + if (p < l) p++; + } + } + } + *tail = 0; + + if (verbose >= 3) { + dstr_reset(&d); + first = 1; + for (job = job_ready; job; job = job->next) { + if (first) first = 0; + else dstr_puts(&d, ", "); + dstr_putf(&d, "`%s'", JOB_NAME(job)); + } + if (first) dstr_puts(&d, "(none)"); + dstr_putz(&d); + moan("dumping Lisps: %s", d.p); + } + + if (flags&AF_DRYRUN) { + for (job = job_ready; job; job = job->next) { + if (try_exec(&job->av, + TEF_DRYRUN | + (verbose >= 2 && !(flags&AF_CHECKINST) ? + TEF_VERBOSE : 0))) + rc = 2; + else if (verbose >= 2) + printf("%-13s > (not dumping `%s': dry run)\n", + JOB_NAME(job), JOB_NAME(job)); + } + return (rc); + } + + for (;;) { + fd = open("/dev/null", O_RDWR); + if (fd < 0) lose("failed to open `/dev/null': %s", strerror(errno)); + if (fd > 2) { nullfd = fd; break; } + } + configure_fd("null fd", nullfd, 0, 1); + + for (;;) { + start_jobs(); + if (!job_run && !job_dead) break; + +#define SET_FD(dir, fd) do { \ + int _fd = (fd); \ + \ + FD_SET(_fd, &fd_##dir); \ + if (_fd >= nfd) nfd = _fd + 1; \ +} while (0) + + FD_ZERO(&fd_in); nfd = 0; + SET_FD(in, sig_pipe[0]); + for (job = job_run; job; job = job->next) { + if (job->out.fd >= 0) SET_FD(in, job->out.fd); + if (job->err.fd >= 0) SET_FD(in, job->err.fd); + } + for (job = job_dead; job; job = job->next) { + if (job->out.fd >= 0) SET_FD(in, job->out.fd); + if (job->err.fd >= 0) SET_FD(in, job->err.fd); + } + +#undef SET_FD + + if (select(nfd, &fd_in, 0, 0, 0) < 0) { + if (errno == EINTR) continue; + else lose("select failed: %s", strerror(errno)); + } + + if (FD_ISSET(sig_pipe[0], &fd_in)) { + check_signals(); + if (sigloss >= 0) { + for (job = job_ready; job; job = next) + { next = job->next; release_job(job); } + for (job = job_run; job; job = next) + { next = job->next; release_job(job); } + for (job = job_dead; job; job = next) + { next = job->next; release_job(job); } + break; + } + } + + for (job = job_run; job; job = job->next) { + if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in)) + prefix_lines(job, &job->out, '|'); + if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in)) + prefix_lines(job, &job->err, '*'); + } + for (link = &job_dead, job = *link; job; job = next) { + next = job->next; + if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in)) + prefix_lines(job, &job->out, '|'); + if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in)) + prefix_lines(job, &job->err, '*'); + if (job->out.fd >= 0 || job->err.fd >= 0) link = &job->next; + else { *link = next; finish_job(job); } + } + } + + check_signals(); + if (sigloss) { cleanup(); signal(sigloss, SIG_DFL); raise(sigloss); } + + return (rc); +} + +/*----- That's all, folks -------------------------------------------------*/ diff --git a/lib.c b/lib.c new file mode 100644 index 0000000..104eebd --- /dev/null +++ b/lib.c @@ -0,0 +1,970 @@ +/* -*-c-*- + * + * Common definitions for `runlisp' + * + * (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 . + */ + +/*----- Header files ------------------------------------------------------*/ + +#include "config.h" + +#include + +#include +#include +#include +#include +#include +#include + +#include + +#include "lib.h" + +/*----- Miscellany --------------------------------------------------------*/ + +int str_lt(const char *a, size_t an, const char *b, size_t bn) +{ + if (an < bn) return (MEMCMP(a, <=, b, an)); + else return (MEMCMP(a, <, b, bn)); +} + +/*----- Diagnostic utilities ----------------------------------------------*/ + +const char *progname = "???"; + +void set_progname(const char *prog) +{ + const char *p; + + p = strrchr(prog, '/'); + progname = p ? p + 1 : progname; +} + +void vmoan(const char *msg, va_list ap) +{ + fprintf(stderr, "%s: ", progname); + vfprintf(stderr, msg, ap); + fputc('\n', stderr); +} + +void moan(const char *msg, ...) + { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); } + +void lose(const char *msg, ...) + { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); exit(127); } + +/*----- Memory allocation -------------------------------------------------*/ + +void *xmalloc(size_t n) +{ + void *p; + + if (!n) return (0); + p = malloc(n); if (!p) lose("failed to allocate memory"); + return (p); +} + +void *xrealloc(void *p, size_t n) +{ + if (!n) { free(p); return (0); } + else if (!p) return (xmalloc(n)); + p = realloc(p, n); if (!p) lose("failed to allocate memory"); + return (p); +} + +char *xstrndup(const char *p, size_t n) +{ + char *q = xmalloc(n + 1); + + memcpy(q, p, n); q[n] = 0; + return (q); +} + +char *xstrdup(const char *p) { return (xstrndup(p, strlen(p))); } + +/*----- Dynamic strings ---------------------------------------------------*/ + +void dstr_init(struct dstr *d) { d->p = 0; d->len = d->sz = 0; } + +void dstr_reset(struct dstr *d) { d->len = 0; } + +void dstr_ensure(struct dstr *d, size_t n) +{ + size_t need = d->len + n, newsz; + + if (need <= d->sz) return; + newsz = d->sz ? 2*d->sz : 16; + while (newsz < need) newsz *= 2; + d->p = xrealloc(d->p, newsz); d->sz = newsz; +} + +void dstr_release(struct dstr *d) { free(d->p); } + +void dstr_putm(struct dstr *d, const void *p, size_t n) + { dstr_ensure(d, n); memcpy(d->p + d->len, p, n); d->len += n; } + +void dstr_puts(struct dstr *d, const char *p) +{ + size_t n = strlen(p); + + dstr_ensure(d, n + 1); + memcpy(d->p + d->len, p, n + 1); + d->len += n; +} + +void dstr_putc(struct dstr *d, int ch) + { dstr_ensure(d, 1); d->p[d->len++] = ch; } + +void dstr_putcn(struct dstr *d, int ch, size_t n) + { dstr_ensure(d, n); memset(d->p + d->len, ch, n); d->len += n; } + +void dstr_putz(struct dstr *d) + { dstr_ensure(d, 1); d->p[d->len] = 0; } + +void dstr_vputf(struct dstr *d, const char *p, va_list ap) +{ + va_list ap2; + size_t r; + int n; + + r = d->sz - d->len; + va_copy(ap2, ap); + n = vsnprintf(d->p + d->len, r, p, ap2); assert(n >= 0); + va_end(ap2); + if (n >= r) { + dstr_ensure(d, n + 1); r = d->sz - d->len; + n = vsnprintf(d->p + d->len, r, p, ap); assert(n >= 0); assert(n < r); + } + d->len += n; +} + +PRINTF_LIKE(2, 3) void dstr_putf(struct dstr *d, const char *p, ...) + { va_list ap; va_start(ap, p); dstr_vputf(d, p, ap); va_end(ap); } + +int dstr_readline(struct dstr *d, FILE *fp) +{ + size_t n; + int any = 0; + + for (;;) { + dstr_ensure(d, 2); + if (!fgets(d->p + d->len, d->sz - d->len, fp)) break; + n = strlen(d->p + d->len); assert(n > 0); any = 1; + d->len += n; + if (d->p[d->len - 1] == '\n') { d->p[--d->len] = 0; break; } + } + + if (!any) return (-1); + else return (0); +} + +/*----- Dynamic vectors of strings ----------------------------------------*/ + +void argv_init(struct argv *av) + { av->v = 0; av->o = av->n = av->sz = 0; } + +void argv_reset(struct argv *av) { av->n = 0; } + +void argv_ensure(struct argv *av, size_t n) +{ + size_t need = av->n + av->o + n, newsz; + + if (need <= av->sz) return; + newsz = av->sz ? 2*av->sz : 8; + while (newsz < need) newsz *= 2; + av->v = + (const char **)xrealloc(av->v - av->o, newsz*sizeof(const char *)) + + av->o; + av->sz = newsz; +} + +void argv_ensure_offset(struct argv *av, size_t n) +{ + size_t newoff; + + /* Stupid version. We won't, in practice, be prepending lots of stuff, so + * avoid the extra bookkeeping involved in trying to make a double-ended + * extendable array asymptotically efficient. + */ + if (av->o >= n) return; + newoff = 16; + while (newoff < n) newoff *= 2; + argv_ensure(av, newoff - av->o); + memmove(av->v + newoff - av->o, av->v, av->n*sizeof(const char *)); + av->v += newoff - av->o; av->o = newoff; +} + +void argv_release(struct argv *av) { free(av->v - av->o); } + +void argv_append(struct argv *av, const char *p) + { argv_ensure(av, 1); av->v[av->n++] = p; } + +void argv_appendz(struct argv *av) + { argv_ensure(av, 1); av->v[av->n] = 0; } + +void argv_appendn(struct argv *av, const char *const *v, size_t n) +{ + argv_ensure(av, n); + memcpy(av->v + av->n, v, n*sizeof(const char *)); + av->n += n; +} + +void argv_appendav(struct argv *av, const struct argv *bv) + { argv_appendn(av, bv->v, bv->n); } + +void argv_appendv(struct argv *av, va_list ap) +{ + const char *p; + + for (;;) + { p = va_arg(ap, const char *); if (!p) break; argv_append(av, p); } +} + +void argv_appendl(struct argv *av, ...) + { va_list ap; va_start(ap, av); argv_appendv(av, ap); va_end(ap); } + +void argv_prepend(struct argv *av, const char *p) + { argv_ensure_offset(av, 1); *--av->v = p; av->o--; av->n++; } + +void argv_prependn(struct argv *av, const char *const *v, size_t n) +{ + argv_ensure_offset(av, n); + av->o -= n; av->v -= n; av->n += n; + memcpy(av->v, v, n*sizeof(const char *)); +} + +void argv_prependav(struct argv *av, const struct argv *bv) + { argv_prependn(av, bv->v, bv->n); } + +void argv_prependv(struct argv *av, va_list ap) +{ + const char *p, **v; + size_t n = 0; + + for (;;) { + p = va_arg(ap, const char *); if (!p) break; + argv_prepend(av, p); n++; + } + v = av->v; + while (n >= 2) { + p = v[0]; v[0] = v[n - 1]; v[n - 1] = p; + v++; n -= 2; + } +} + +void argv_prependl(struct argv *av, ...) + { va_list ap; va_start(ap, av); argv_prependv(av, ap); va_end(ap); } + +/*----- Treaps ------------------------------------------------------------*/ + +void treap_init(struct treap *t) { t->root = 0; } + +void *treap_lookup(const struct treap *t, const char *k, size_t kn) +{ + struct treap_node *n = t->root, *candidate = 0; + + while (n) { + if (str_lt(k, kn, n->k, n->kn)) n = n->left; + else { candidate = n; n = n->right; } + } + if (!candidate || str_lt(candidate->k, candidate->kn, k, kn)) return (0); + return (candidate); +} + +void *treap_probe(struct treap *t, const char *k, size_t kn, + struct treap_path *p) +{ + struct treap_node **nn = &t->root, *candidate = 0; + unsigned i = 0; + + for (;;) { + assert(i < TREAP_PATHMAX); p->path[i++] = nn; + if (!*nn) break; + if (str_lt(k, kn, (*nn)->k, (*nn)->kn)) nn = &(*nn)->left; + else { candidate = *nn; nn = &(*nn)->right; } + } + p->nsteps = i; + if (!candidate || str_lt(candidate->k, candidate->kn, k, kn)) return (0); + return (candidate); +} + +void treap_insert(struct treap *t, const struct treap_path *p, + struct treap_node *n, const char *k, size_t kn) +{ + size_t i = p->nsteps; + struct treap_node **nn, **uu, *u; + unsigned wt; + + n->k = xstrndup(k, kn); n->kn = kn; + n->wt = wt = rand(); n->left = n->right = 0; + assert(i); nn = p->path[--i]; + while (i--) { + uu = p->path[i]; u = *uu; + if (wt <= u->wt) break; + if (nn == &u->left) { u->left = n->right; n->right = u; } + else { u->right = n->left; n->left = u; } + nn = uu; + } + *nn = n; +} + +void *treap_remove(struct treap *t, const char *k, size_t kn) +{ + struct treap_node **nn = &t->root, **candidate = 0, *n, *l, *r; + + while (*nn) { + if (str_lt(k, kn, (*nn)->k, (*nn)->kn)) nn = &(*nn)->left; + else { candidate = nn; nn = &(*nn)->right; } + } + if (!candidate || str_lt((*candidate)->k, (*candidate)->kn, k, kn)) + return (0); + + n = *candidate; l = n->left; r = n->right; + for (;;) { + if (l && (!r || l->wt > r->wt)) { nn = &l->right; l = l->right; } + else if (r) { nn = &r->left; r = r->left; } + else break; + } + *nn = 0; + free(n->k); + return (n); +} + +void treap_start_iter(struct treap *t, struct treap_iter *i) +{ + struct treap_node *n = t->root; + unsigned sp = 0; + + while (n) { + assert(sp < TREAP_PATHMAX); + i->stack[sp++] = n; n = n->left; + } + i->sp = sp; +} + +void *treap_next(struct treap_iter *i) +{ + struct treap_node *n, *o; + unsigned sp = i->sp; + + if (!sp) return (0); + n = i->stack[--sp]; + o = n->right; + while (o) { + assert(sp < TREAP_PATHMAX); + i->stack[sp++] = o; o = o->left; + } + i->sp = sp; + return (n); +} + +static void check_node(struct treap_node *n, unsigned maxwt, + const char *klo, const char *khi) +{ + assert(n->wt <= maxwt); + if (klo) assert(STRCMP(n->k, >, klo)); + if (khi) assert(STRCMP(n->k, <, khi)); + if (n->left) check_node(n->left, n->wt, klo, n->k); + if (n->right) check_node(n->right, n->wt, n->k, khi); +} + +void treap_check(struct treap *t) + { if (t->root) check_node(t->root, t->root->wt, 0, 0); } + +static void dump_node(struct treap_node *n, int ind) +{ + if (n->left) dump_node(n->left, ind + 1); + printf(";;%*s [%10u] `%s'\n", 2*ind, "", n->wt, n->k); + if (n->right) dump_node(n->right, ind + 1); +} + +void treap_dump(struct treap *t) { if (t->root) dump_node(t->root, 0); } + +/*----- Configuration file parsing ----------------------------------------*/ + +#ifndef DECL_ENVIRON + extern char **environ; +#endif + +void config_init(struct config *conf) + { treap_init(&conf->sections); } + +struct config_section *config_find_section(struct config *conf, unsigned f, + const char *name) + { return (config_find_section_n(conf, f, name, strlen(name))); } + +struct config_section *config_find_section_n(struct config *conf, unsigned f, + const char *name, size_t sz) +{ + struct config_section *sect; + struct treap_path path; + + if (!(f&CF_CREAT)) + sect = treap_lookup(&conf->sections, name, sz); + else { + sect = treap_probe(&conf->sections, name, sz, &path); + if (!sect) { + sect = xmalloc(sizeof(*sect)); + if (!conf->head) conf->tail = &conf->head; + sect->next = 0; *conf->tail = sect; conf->tail = §->next; + sect->parents = 0; sect->nparents = SIZE_MAX; + treap_init(§->vars); treap_init(§->cache); + treap_insert(&conf->sections, &path, §->_node, name, sz); + config_set_var_n(conf, sect, CF_LITERAL, "@NAME", 5, name, sz); + } + } + return (sect); +} + +void config_set_fallback(struct config *conf, struct config_section *sect) +{ + if (sect->nparents == SIZE_MAX) sect->nparents = 0; + conf->fallback = sect; +} + +void config_set_parent(struct config_section *sect, + struct config_section *parent) +{ + if (!parent) + sect->nparents = 0; + else { + sect->parents = xmalloc(sizeof(*sect->parents)); + sect->parents[0] = parent; sect->nparents = 1; + } +} + +void config_start_section_iter(struct config *conf, + struct config_section_iter *i) + { i->sect = conf->head; } + +struct config_section *config_next_section(struct config_section_iter *i) +{ + struct config_section *sect; + + sect = i->sect; + if (sect) i->sect = sect->next; + return (sect); +} + +static void set_config_section_parents(struct config *conf, + struct config_section *sect) +{ + struct config_section *parent; + struct config_var *var; + struct argv av = ARGV_INIT; + size_t i, n; + char *p, *q; + + if (sect->nparents != SIZE_MAX) return; + + var = treap_lookup(§->vars, "@PARENTS", 8); + if (!var) { + if (!conf->fallback) + sect->nparents = 0; + else { + sect->parents = xmalloc(sizeof(*sect->parents)); + sect->nparents = 1; + sect->parents[0] = conf->fallback; + } + } else { + p = var->val; + for (;;) { + while (ISSPACE(*p)) p++; + if (!*p) break; + q = p; while (*q && *q != ',' && !ISSPACE(*q)) q++; + argv_append(&av, p); argv_append(&av, q); + p = q; if (*p == ',') p++; + } + sect->nparents = av.n/2; + sect->parents = xmalloc(sect->nparents*sizeof(sect->parents)); + for (i = 0; i < av.n; i += 2) { + n = av.v[i + 1] - av.v[i]; + parent = config_find_section_n(conf, 0, av.v[i], n); + if (!parent) + lose("%s:%u: unknown parent section `%.*s'", + var->file, var->line, (int)n, av.v[i]); + sect->parents[i/2] = parent; + } + argv_release(&av); + } +} + +struct config_var *search_recursive(struct config *conf, + struct config_section *sect, + const char *name, size_t sz) +{ + struct config_cache_entry *cache; + struct treap_path path; + struct config_var *var, *v; + size_t i, j = j; + + cache = treap_probe(§->cache, name, sz, &path); + if (!cache) { + cache = xmalloc(sizeof(*cache)); cache->f = CF_OPEN; + treap_insert(§->cache, &path, &cache->_node, name, sz); + } else if (cache->f&CF_OPEN) + lose("inheritance cycle through section `%s'", + CONFIG_SECTION_NAME(sect)); + else + return (cache->var); + + set_config_section_parents(conf, sect); + + var = treap_lookup(§->vars, name, sz); + if (!var) { + for (i = 0; i < sect->nparents; i++) { + v = search_recursive(conf, sect->parents[i], name, sz); + if (!v); + else if (!var) { var = v; j = i; } + else if (var != v) + lose("section `%s' inherits variable `%s' ambiguously " + "via `%s' and `%s'", + CONFIG_SECTION_NAME(sect), CONFIG_VAR_NAME(var), + CONFIG_SECTION_NAME(sect->parents[j]), + CONFIG_SECTION_NAME(sect->parents[i])); + } + } + + cache->var = var; cache->f &= ~CF_OPEN; + return (var); +} + +struct config_var *config_find_var(struct config *conf, + struct config_section *sect, + unsigned f, const char *name) + { return (config_find_var_n(conf, sect, f, name, strlen(name))); } + +struct config_var *config_find_var_n(struct config *conf, + struct config_section *sect, + unsigned f, const char *name, size_t sz) +{ + struct config_var *var; + struct treap_path path; + + if (f&CF_INHERIT) + var = search_recursive(conf, sect, name, sz); + else if (!(f&CF_CREAT)) + var = treap_lookup(§->vars, name, sz); + else { + var = treap_probe(§->vars, name, sz, &path); + if (!var) { + var = xmalloc(sizeof(*var)); + var->val = 0; var->file = 0; var->f = 0; var->line = 1; + treap_insert(§->vars, &path, &var->_node, name, sz); + } + } + return (var); +} + +void config_start_var_iter(struct config_section *sect, + struct config_var_iter *i) + { treap_start_iter(§->vars, &i->i); } + +struct config_var *config_next_var(struct config_var_iter *i) + { return (treap_next(&i->i)); } + +void config_set_var(struct config *conf, struct config_section *sect, + unsigned f, + const char *name, const char *value) +{ + config_set_var_n(conf, sect, f, + name, strlen(name), + value, strlen(value)); +} + +void config_set_var_n(struct config *conf, struct config_section *sect, + unsigned f, + const char *name, size_t namelen, + const char *value, size_t valuelen) +{ + struct config_var *var = + config_find_var_n(conf, sect, CF_CREAT, name, namelen); + + if (var->f&~f&CF_OVERRIDE) return; + free(var->val); var->val = xstrndup(value, valuelen); var->n = valuelen; + var->f = f; +} + +int config_read_file(struct config *conf, const char *file, unsigned f) +{ + struct config_section *sect; + struct config_var *var; + struct dstr d = DSTR_INIT, dd = DSTR_INIT; + unsigned line = 0; + char *p, *q; + FILE *fp; + + fp = fopen(file, "r"); + if (!fp) { + if ((f&CF_NOENTOK) && errno == ENOENT) return (-1); + lose("failed to open configuration file `%s': %s", + file, strerror(errno)); + } + + sect = config_find_section(conf, CF_CREAT, "@CONFIG"); var = 0; + + for (;;) { + dstr_reset(&d); if (dstr_readline(&d, fp)) break; + line++; + + if (d.p[0] && !ISSPACE(d.p[0])) { + if (var) { + if (!(var->f&CF_OVERRIDE)) + { var->val = xstrndup(dd.p, dd.len); var->n = dd.len; } + var = 0; + } + if (d.p[0] == ';') + ; + else if (d.p[0] == '[') { + p = d.p + 1; q = strchr(p, ']'); + if (!q) lose("%s:%u: missing `]' in section header", file, line); + sect = config_find_section_n(conf, CF_CREAT, p, q - p); + q++; while (ISSPACE(*q)) q++; + if (*q) lose("%s:%u: trailing junk after `]' in section header", + file, line); + } else { + p = d.p; + while (*p && !ISSPACE(*p) && *p != '{' && *p != '}' && *p != '=') + p++; + var = config_find_var_n(conf, sect, CF_CREAT, d.p, p - d.p); + while (ISSPACE(*p)) p++; + if (*p != '=') lose("%s:%u: missing `=' in assignment", file, line); + p++; while (ISSPACE(*p)) p++; + if (!(var->f&CF_OVERRIDE)) { + free(var->val); var->val = 0; var->f = 0; + free(var->file); var->file = xstrdup(file); var->line = line; + } + dstr_reset(&dd); dstr_puts(&dd, p); + } + } else { + p = d.p; while (ISSPACE(*p)) p++; + if (*p) { + if (!var) + lose("%s:%u: continuation line, but no variable", file, line); + if (dd.len) dstr_putc(&dd, ' '); + dstr_puts(&dd, p); + } + } + } + + if (var && !(var->f&CF_OVERRIDE)) + { var->val = xstrndup(dd.p, dd.len); var->n = dd.len; } + + dstr_release(&d); dstr_release(&dd); + if (fclose(fp)) + lose("error reading configuration file `%s': %s", file, strerror(errno)); + return (0); +} + +void config_read_env(struct config *conf, struct config_section *sect) +{ + const char *p, *v; + size_t i; + + for (i = 0; (p = environ[i]) != 0; i++) { + v = strchr(p, '='); if (!v) continue; + config_set_var_n(conf, sect, CF_LITERAL, p, v - p, v + 1, strlen(v + 1)); + } +} + +/*----- Substitution and quoting ------------------------------------------*/ + +struct subst { + struct config *config; + struct config_section *home, *fallback; + struct argv *av; + struct dstr *d; +}; + +static const char *scan_name(const char *p, const char *l) +{ + while (p < l && + (ISALNUM(*p) || *p == '-' || *p == '_' || *p == '.' || *p == '/' || + *p == '*' || *p == '+' || *p == '%' || *p == '@')) + p++; + return (p); +} + +static void filter_string(const char *p, const char *l, struct subst *sb, + unsigned qfilt) +{ + size_t r, n; + + if (!qfilt) + dstr_putm(sb->d, p, l - p); + else for (;;) { + r = l - p; n = strcspn(p, "\"\\"); + if (n > r) n = r; + dstr_putm(sb->d, p, n); + if (n >= r) break; + dstr_putcn(sb->d, '\\', qfilt); dstr_putc(sb->d, p[n]); + p += n + 1; + } +} + +static const char *retrieve_varspec(const char *p, const char *l, + struct subst *sb, + struct config_var **var_out) +{ + struct config_section *sect = sb->home; + const char *t; + + t = scan_name(p, l); + if (t < l && *t == ':') { + sect = config_find_section_n(sb->config, 0, p, t - p); + p = t + 1; t = scan_name(p, l); + } + + if (!sect) *var_out = 0; + else *var_out = config_find_var_n(sb->config, sect, CF_INHERIT, p, t - p); + return (t); +} + +#define SF_SPLIT 0x0001u +#define SF_QUOT 0x0002u +#define SF_SUBST 0x0004u +#define SF_SUBEXPR 0x0008u +#define SF_SPANMASK 0x00ffu +#define SF_WORD 0x0100u +#define SF_SKIP 0x0200u +#define SF_LITERAL 0x0400u + +static const char *subst(const char *p, const char *l, struct subst *sb, + const char *file, unsigned line, + unsigned qfilt, unsigned f) +{ + struct config_var *var; + const char *q0, *q1, *t; + unsigned subqfilt, ff; + size_t n; + +#define ESCAPE "\\" +#define SUBST "$" +#define WORDSEP " \f\r\n\t\v'\"" +#define QUOT "\"" +#define DELIM "|}" + + static const char *const delimtab[] = + { ESCAPE, + ESCAPE WORDSEP, + 0, + ESCAPE QUOT, + ESCAPE SUBST, + ESCAPE SUBST WORDSEP, + 0, + ESCAPE SUBST QUOT, + ESCAPE DELIM, + ESCAPE DELIM WORDSEP, + 0, + ESCAPE DELIM QUOT, + ESCAPE DELIM SUBST, + ESCAPE DELIM SUBST WORDSEP, + 0, + ESCAPE DELIM SUBST QUOT }; + +#undef COMMON +#undef WORDSEP +#undef SQUOT +#undef DELIM + + if (!file) file = ""; + + if (f&SF_LITERAL) { + filter_string(p, l, sb, qfilt); + f |= SF_WORD; + goto done; + } + + while (p < l) { + + if ((f&(SF_SPLIT | SF_QUOT)) == SF_SPLIT && ISSPACE(*p)) { + if (f&SF_WORD) { + if (!(f&SF_SKIP)) { + argv_append(sb->av, xstrndup(sb->d->p, sb->d->len)); + dstr_reset(sb->d); + } + f &= ~SF_WORD; + } + do p++; while (p < l && ISSPACE(*p)); + + } else if (*p == '\\') { + p++; + if (p >= l) lose("%s:%u: unfinished `\\' escape", file, line); + if (!(f&SF_SKIP)) { + if (qfilt && (*p == '"' || *p == '\\')) + dstr_putcn(sb->d, '\\', qfilt); + dstr_putc(sb->d, *p); + } + p++; + + } else if ((f&SF_SPLIT) && *p == '"') { + f ^= SF_QUOT; f |= SF_WORD; p++; + + } else if ((f&(SF_SPLIT | SF_QUOT)) == SF_SPLIT && *p == '\'') { + t = strchr(p, '\''); if (!t) lose("%s:%u: missing `''", file, line); + if (!(f&SF_SKIP)) filter_string(p, t, sb, qfilt); + p = t + 1; f |= SF_WORD; + + } else if ((f&SF_SUBEXPR) && (*p == '|' || *p == '}')) { + break; + + } else if ((f&SF_SUBST) && *p == '$') { + p++; if (p >= l) lose("%s:%u: incomplete substitution", file, line); + ff = f&~(SF_QUOT | (f&SF_WORD ? SF_SPLIT : 0)); + switch (*p) { + + case '?': + p = retrieve_varspec(p + 1, l, sb, &var); + if (p > l || *p != '{') lose("%s:%u: expected `{'", file, line); + p++; + ff |= SF_SUBEXPR; + p = subst(p, l, sb, file, line, qfilt, + ff | (var ? 0 : SF_SKIP)); + if (p < l && *p == '|') + p = subst(p + 1, l, sb, file, line, qfilt, + ff | (var ? SF_SKIP : 0)); + if (p >= l || *p != '}') lose("%s:%u: missing `}'", file, line); + p++; + break; + + case '{': + q0 = p + 1; p = retrieve_varspec(q0, l, sb, &var); q1 = p; + subqfilt = qfilt; + while (p < l) { + if (*p != '|') break; + p++; t = scan_name(p, l); + if (t - p == 1 && *p == 'q') subqfilt = 2*subqfilt + 1; + else + lose("%s:%u: unknown filter `%.*s'", + file, line, (int)(t - p), p); + p = t; + } + if (!(f&SF_SKIP) && var) { + if (var->f&CF_EXPAND) + lose("%s:%u: recursive expansion of variable `%.*s'", + file, line, (int)(q1 - q0), q0); + var->f |= CF_EXPAND; + subst(var->val, var->val + var->n, sb, + var->file, var->line, subqfilt, + ff | (var->f&CF_LITERAL ? SF_LITERAL : 0)); + var->f &= ~CF_EXPAND; + } + if (p < l && *p == '?') + p = subst(p + 1, l, sb, file, line, subqfilt, + ff | SF_SUBEXPR | (var ? SF_SKIP : 0)); + else if (!var && !(f&SF_SKIP)) + lose("%s:%u: unknown variable `%.*s'", + file, line, (int)(q1 - q0), q0); + if (p >= l || *p != '}') lose("%s:%u: missing `}'", file, line); + p++; + break; + + default: + lose("%s:%u: unexpected substitution `%c'", file, line, *p); + } + if (p < l && !(~f&~(SF_WORD | SF_SPLIT)) && !ISSPACE(*p) && + !((f&SF_SUBEXPR) && (*p == '|' || *p == '}'))) + lose("%s:%u: surprising word boundary " + "after splicing substitution", + file, line); + } + + else { + n = strcspn(p, delimtab[f&SF_SPANMASK]); + if (n > l - p) n = l - p; + if (!(f&SF_SKIP)) filter_string(p, p + n, sb, qfilt); + p += n; f |= SF_WORD; + } + } + +done: + if (f&SF_QUOT) lose("%s:%u: missing `\"'", file, line); + if ((f&(SF_WORD | SF_SPLIT | SF_SKIP)) == (SF_SPLIT | SF_WORD)) { + argv_append(sb->av, xstrndup(sb->d->p, sb->d->len)); + dstr_reset(sb->d); + } + + return (p); +} + +void config_subst_string(struct config *config, struct config_section *home, + const char *what, const char *p, struct dstr *d) +{ + struct subst sb; + + sb.config = config; sb.home = home; sb.d = d; + subst(p, p + strlen(p), &sb, what, 0, 0, SF_SUBST); + dstr_putz(d); +} + +char *config_subst_string_alloc(struct config *config, + struct config_section *home, + const char *what, const char *p) +{ + struct dstr d = DSTR_INIT; + char *q; + + config_subst_string(config, home, what, p, &d); + q = xstrndup(d.p, d.len); dstr_release(&d); return (q); +} + +void config_subst_var(struct config *config, struct config_section *home, + struct config_var *var, struct dstr *d) +{ + struct subst sb; + + sb.config = config; sb.home = home; sb.d = d; + var->f |= CF_EXPAND; + subst(var->val, var->val + var->n, &sb, var->file, var->line, 0, + SF_SUBST | (var->f&CF_LITERAL ? SF_LITERAL : 0)); + var->f &= ~CF_EXPAND; + dstr_putz(d); +} + +char *config_subst_var_alloc(struct config *config, + struct config_section *home, + struct config_var *var) +{ + struct dstr d = DSTR_INIT; + char *q; + + config_subst_var(config, home, var, &d); + q = xstrndup(d.p, d.len); dstr_release(&d); return (q); +} + +void config_subst_split_var(struct config *config, + struct config_section *home, + struct config_var *var, struct argv *av) +{ + struct dstr d = DSTR_INIT; + struct subst sb; + + sb.config = config; sb.home = home; sb.av = av; sb.d = &d; + var->f |= CF_EXPAND; + subst(var->val, var->val + var->n, &sb, var->file, var->line, 0, + SF_SUBST | SF_SPLIT | (var->f&CF_LITERAL ? SF_LITERAL : 0)); + var->f &= ~CF_EXPAND; + dstr_release(&d); +} + +/*----- That's all, folks -------------------------------------------------*/ diff --git a/lib.h b/lib.h new file mode 100644 index 0000000..2209c30 --- /dev/null +++ b/lib.h @@ -0,0 +1,319 @@ +/* -*-c-*- + * + * Common definitions for `runlisp' + * + * (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 . + */ + +#ifndef LIB_H +#define LIB_H + +#ifdef __cplusplus + extern "C" { +#endif + +/*----- Header files ------------------------------------------------------*/ + +#include +#include +#include +#include + +/*----- Handy macros ------------------------------------------------------*/ + +#define N(v) (sizeof(v)/sizeof((v)[0])) + +#if defined(__GNUC__) +# define GCC_VERSION_P(maj, min) \ + (__GNUC__ > (maj) || (__GNUC__ == (maj) && __GNUC_MINOR__ >= (min))) +#else +# define GCC_VERSION_P(maj, min) 0 +#endif + +#ifdef __clang__ +# define CLANG_VERSION_P(maj, min) \ + (__clang_major__ > (maj) || (__clang_major__ == (maj) && \ + __clang_minor__ >= (min))) +#else +# define CLANG_VERSION_P(maj, min) 0 +#endif + +#if GCC_VERSION_P(2, 5) || CLANG_VERSION_P(3, 3) +# define NORETURN __attribute__((__noreturn__)) +# define PRINTF_LIKE(fix, aix) __attribute__((__format__(printf, fix, aix))) +#endif + +#if GCC_VERSION_P(4, 0) || CLANG_VERSION_P(3, 3) +# define EXECL_LIKE(ntrail) __attribute__((__sentinel__(ntrail))) +#endif + +#define CTYPE_HACK(func, ch) (func((unsigned char)(ch))) +#define ISSPACE(ch) CTYPE_HACK(isspace, ch) +#define ISALNUM(ch) CTYPE_HACK(isalnum, ch) + +#define MEMCMP(x, op, y, n) (memcmp((x), (y), (n)) op 0) +#define STRCMP(x, op, y) (strcmp((x), (y)) op 0) +#define STRNCMP(x, op, y, n) (strncmp((x), (y), (n)) op 0) + +#define DISCARD(x) do if (x); while (0) + +#define END ((const char *)0) + +#ifndef SIZE_MAX +# define SIZE_MAX (-(size_t)1) +#endif + +/*----- Miscellany --------------------------------------------------------*/ + +extern int str_lt(const char */*a*/, size_t /*an*/, + const char */*b*/, size_t /*bn*/); + +/*----- Diagnostic utilities ----------------------------------------------*/ + +extern const char *progname; + +extern void set_progname(const char */*prog*/); +extern void vmoan(const char */*msg*/, va_list /*ap*/); +extern PRINTF_LIKE(1, 2) void moan(const char */*msg*/, ...); +extern NORETURN PRINTF_LIKE(1, 2) void lose(const char */*msg*/, ...); + +/*----- Memory allocation -------------------------------------------------*/ + +extern void *xmalloc(size_t /*n*/); +extern void *xrealloc(void */*p*/, size_t /*n*/); +extern char *xstrndup(const char */*p*/, size_t /*n*/); +extern char *xstrdup(const char */*p*/); + +/*----- Dynamic strings ---------------------------------------------------*/ + +struct dstr { + char *p; + size_t len, sz; +}; +#define DSTR_INIT { 0, 0, 0 } + +extern void dstr_init(struct dstr */*d*/); +extern void dstr_reset(struct dstr */*d*/); +extern void dstr_ensure(struct dstr */*d*/, size_t /*n*/); +extern void dstr_release(struct dstr */*d*/); +extern void dstr_putm(struct dstr */*d*/, const void */*p*/, size_t /*n*/); +extern void dstr_puts(struct dstr */*d*/, const char */*p*/); +extern void dstr_putc(struct dstr */*d*/, int /*ch*/); +extern void dstr_putz(struct dstr */*d*/); +extern void dstr_vputf(struct dstr */*d*/, + const char */*p*/, va_list /*ap*/); +extern PRINTF_LIKE(2, 3) + void dstr_putf(struct dstr */*d*/, const char */*p*/, ...); +extern int dstr_readline(struct dstr */*d*/, FILE */*fp*/); + +/*----- Dynamic vectors of strings ----------------------------------------*/ + +struct argv { + const char **v; + size_t o, n, sz; +}; +#define ARGV_INIT { 0, 0, 0, 0 } + +extern void argv_init(struct argv */*a*/v); +extern void argv_reset(struct argv */*av*/); +extern void argv_ensure(struct argv */*av*/, size_t /*n*/); +extern void argv_ensure_offset(struct argv */*av*/, size_t /*n*/); +extern void argv_release(struct argv */*av*/); +extern void argv_append(struct argv */*av*/, const char */*p*/); +extern void argv_appendz(struct argv */*av*/); +extern void argv_appendn(struct argv */*av*/, + const char *const */*v*/, size_t /*n*/); +extern void argv_appendav(struct argv */*av*/, const struct argv */*bv*/); +extern void argv_appendv(struct argv */*av*/, va_list /*ap*/); +extern EXECL_LIKE(0) void argv_appendl(struct argv */*av*/, ...); +extern void argv_prepend(struct argv */*av*/, const char */*p*/); +extern void argv_prependn(struct argv */*av*/, + const char *const */*v*/, size_t /*n*/); +extern void argv_prependav(struct argv */*av*/, const struct argv */*bv*/); +extern void argv_prependv(struct argv */*av*/, va_list /*ap*/); +extern EXECL_LIKE(0) void argv_prependl(struct argv */*av*/, ...); + +/*----- Treaps ------------------------------------------------------------*/ + +struct treap { + struct treap_node *root; +}; +#define TREAP_INIT { 0 } + +struct treap_node { + unsigned wt; + struct treap_node *left, *right; + char *k; size_t kn; +}; +#define TREAP_NODE_KEY(n) (((const struct treap_node *)(n))->k + 0) +#define TREAP_NODE_KEYLEN(n) (((const struct treap_node *)(n))->kn + 0) + +#define TREAP_PATHMAX 64 +struct treap_path { + struct treap_node **path[TREAP_PATHMAX]; + unsigned nsteps; +}; + +struct treap_iter { + struct treap_node *stack[TREAP_PATHMAX]; + unsigned sp; +}; + +extern void treap_init(struct treap */*t*/); +extern void *treap_lookup(const struct treap */*t*/, + const char */*k*/, size_t /*kn*/); +extern void *treap_probe(struct treap */*t*/, + const char */*k*/, size_t /*kn*/, + struct treap_path */*p*/); +extern void treap_insert(struct treap */*t*/, const struct treap_path */*p*/, + struct treap_node */*n*/, + const char */*k*/, size_t /*kn*/); +extern void *treap_remove(struct treap */*t*/, + const char */*k*/, size_t /*kn*/); +extern void treap_start_iter(struct treap */*t*/, struct treap_iter */*i*/); +extern void *treap_next(struct treap_iter */*i*/); +extern void treap_check(struct treap */*t*/); +extern void treap_dump(struct treap */*t*/); + +/*----- Configuration file parsing ----------------------------------------*/ + +struct config { + struct treap sections; + struct config_section *head, **tail; + struct config_section *fallback; +}; +#define CONFIG_INIT { TREAP_INIT, 0, 0 } + +struct config_section { + struct treap_node _node; + struct config_section *next; + struct config_section **parents; size_t nparents; + struct treap vars; + struct treap cache; +}; +#define CONFIG_SECTION_NAME(sect) TREAP_NODE_KEY(sect) +#define CONFIG_SECTION_NAMELEN(sect) TREAP_NODE_KEYLEN(sect) + +struct config_cache_entry { + struct treap_node _node; + unsigned f; +#define CF_OPEN 1u + struct config_var *var; +}; + +struct config_var { + struct treap_node _node; + char *file; unsigned line; + char *val; size_t n; + unsigned f; +}; +#define CONFIG_VAR_NAME(var) TREAP_NODE_KEY(var) +#define CONFIG_VAR_NAMELEN(var) TREAP_NODE_KEYLEN(var) +#define CF_LITERAL 1u +#define CF_EXPAND 2u +#define CF_OVERRIDE 4u + +struct config_section_iter { + struct config_section *sect; +}; + +struct config_var_iter { + struct treap_iter i; +}; + +extern void config_init(struct config */*conf*/); + +extern struct config_section *config_find_section(struct config */*conf*/, + unsigned /*f*/, + const char */*name*/); +extern struct config_section *config_find_section_n(struct config */*conf*/, + unsigned /*f*/, + const char */*name*/, + size_t /*sz*/); +#define CF_CREAT 1u + +extern void config_set_fallback(struct config */*conf*/, + struct config_section */*sect*/); +extern void config_set_parent(struct config_section */*sect*/, + struct config_section */*parent*/); + +extern void config_start_section_iter(struct config */*conf*/, + struct config_section_iter */*i*/); +extern struct config_section *config_next_section + (struct config_section_iter */*i*/); + +extern struct config_var *config_find_var(struct config */*conf*/, + struct config_section */*sect*/, + unsigned /*f*/, + const char */*name*/); +extern struct config_var *config_find_var_n(struct config */*conf*/, + struct config_section */*sect*/, + unsigned /*f*/, + const char */*name*/, + size_t /*sz*/); +#define CF_INHERIT 2u + +extern void config_set_var(struct config */*conf*/, + struct config_section */*sect*/, unsigned /*f*/, + const char */*name*/, const char */*value*/); +extern void config_set_var_n(struct config */*conf*/, + struct config_section */*sect*/, unsigned /*f*/, + const char */*name*/, size_t /*namelen*/, + const char */*value*/, size_t /*valuelen*/); +extern void config_start_var_iter(struct config_section */*sect*/, + struct config_var_iter */*i*/); +extern struct config_var *config_next_var(struct config_var_iter */*i*/); + +extern int config_read_file(struct config */*conf*/, const char */*file*/, + unsigned /*f*/); +extern int config_read_dir(struct config */*conf*/, + const char */*dir*/, unsigned /*f*/); +extern void config_read_env(struct config */*conf*/, + struct config_section */*sect*/); +#define CF_NOENTOK 1u + +extern void config_subst_string(struct config */*config*/, + struct config_section */*home*/, + const char */*what*/, + const char */*p*/, struct dstr */*d*/); +extern char *config_subst_string_alloc(struct config */*config*/, + struct config_section */*home*/, + const char */*what*/, + const char */*p*/); +extern void config_subst_var(struct config */*config*/, + struct config_section */*home*/, + struct config_var */*var*/, + struct dstr */*d*/); +extern char *config_subst_var_alloc(struct config */*config*/, + struct config_section */*home*/, + struct config_var */*var*/); +extern void config_subst_split_var(struct config */*config*/, + struct config_section */*home*/, + struct config_var */*var*/, + struct argv */*av*/); + +/*----- That's all, folks -------------------------------------------------*/ + +#ifdef __cplusplus + } +#endif + +#endif diff --git a/m4/mdw-dir-texmf.m4 b/m4/mdw-dir-texmf.m4 deleted file mode 120000 index 3290ae1..0000000 --- a/m4/mdw-dir-texmf.m4 +++ /dev/null @@ -1 +0,0 @@ -../.ext/cfd/m4/mdw-dir-texmf.m4 \ No newline at end of file diff --git a/m4/mdw-libtool-version-info.m4 b/m4/mdw-libtool-version-info.m4 deleted file mode 120000 index 3298202..0000000 --- a/m4/mdw-libtool-version-info.m4 +++ /dev/null @@ -1 +0,0 @@ -../.ext/cfd/m4/mdw-libtool-version-info.m4 \ No newline at end of file diff --git a/m4/mdw-manext.m4 b/m4/mdw-manext.m4 deleted file mode 120000 index 56bc718..0000000 --- a/m4/mdw-manext.m4 +++ /dev/null @@ -1 +0,0 @@ -../.ext/cfd/m4/mdw-manext.m4 \ No newline at end of file diff --git a/mdwopt.c b/mdwopt.c new file mode 120000 index 0000000..09bed29 --- /dev/null +++ b/mdwopt.c @@ -0,0 +1 @@ +.ext/cfd/src/mdwopt.c \ No newline at end of file diff --git a/mdwopt.h b/mdwopt.h new file mode 120000 index 0000000..a97fb41 --- /dev/null +++ b/mdwopt.h @@ -0,0 +1 @@ +.ext/cfd/src/mdwopt.h \ No newline at end of file diff --git a/old-runlisp.c b/old-runlisp.c new file mode 100644 index 0000000..2557dc3 --- /dev/null +++ b/old-runlisp.c @@ -0,0 +1,985 @@ +/* -*-c-*- + * + * Invoke a Lisp script + * + * (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 . + */ + +/*----- Header files ------------------------------------------------------*/ + +#include "config.h" + +#include +#include +#include +#include +#include +#include +#include + +#include +#include + +#include + +#include "lib.h" + +/*----- Common Lisp runes -------------------------------------------------*/ + +/* A common preamble rune to do the necessary things. + * + * We need to ensure that `asdf' (and therefore `uiop') is loaded. And we + * should arrange for `:runlisp-script' to find its way into the `*features*' + * list so that scripts can notice that they're being invoked from the + * command line rather than loaded into a resident session, and actually do + * something useful. + */ +#define COMMON_PRELUDE_RUNE \ + "(progn " \ + "(setf *load-verbose* nil *compile-verbose* nil) " \ + "(require \"asdf\") " \ + "(funcall (intern \"REGISTER-IMMUTABLE-SYSTEM\" " \ + "(find-package \"ASDF\")) " \ + "\"asdf\") " \ + "(set-dispatch-macro-character " \ + "#\\# #\\! " \ + "(lambda (#1=#:stream #2=#:char #3=#:arg) " \ + "(declare (ignore #2# #3#)) " \ + "(values (read-line #1#)))) " \ + "(pushnew :runlisp-script *features*))" + +/* Get `uiop' to re-check the command-line arguments following an image + * restore. + */ +#define IMAGE_RESTORE_RUNE \ + "(uiop:call-image-restore-hook)" + +/* Some Lisps leave crud in the `COMMON-LISP-USER' package. Clear it out. */ +#define CLEAR_CL_USER_RUNE \ + "(let ((#4=#:pkg (find-package \"COMMON-LISP-USER\"))) " \ + "(with-package-iterator (#5=#:next #4# :internal) " \ + "(loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how) " \ + "(#5#) " \ + "(declare (ignore #8#)) " \ + "(unless #6# (return)) " \ + "(unintern #7# #4#)))))" + +/*----- The Lisp implementation table -------------------------------------*/ + +/* The systems, in decreasing order of (not quite my personal) preference. + * This list is used to initialize various tables and constants. + */ +#define LISP_SYSTEMS(_) \ + _(sbcl) \ + _(ccl) \ + _(clisp) \ + _(ecl) \ + _(cmucl) \ + _(abcl) + +enum { +#define DEFSYS(sys) sys##_INDEX, + LISP_SYSTEMS(DEFSYS) +#undef DEFSYS + NSYS +}; + +enum { +#define DEFFLAG(sys) sys##_FLAG = 1 << sys##_INDEX, + LISP_SYSTEMS(DEFFLAG) +#undef DEFFLAG + ALL_SYSTEMS = 0 +#define SETFLAG(sys) | sys##_FLAG + LISP_SYSTEMS(SETFLAG) +#undef SETFLAG +}; + +struct argstate; +struct argv; + +#define DECLENTRY(sys) \ +static void run_##sys(struct argstate *, const char *); + LISP_SYSTEMS(DECLENTRY) +#undef DECLENTRY + +static const struct systab { + const char *name; + unsigned f; + void (*run)(struct argstate *, const char *); +} systab[] = { +#define SYSENTRY(sys) { #sys, sys##_FLAG, run_##sys }, + LISP_SYSTEMS(SYSENTRY) +#undef SYSENTRY +}; + +static const struct systab *find_system(const char *name) +{ + const struct systab *sys; + size_t i; + + for (i = 0; i < NSYS; i++) { + sys = &systab[i]; + if (STRCMP(name, ==, sys->name)) return (sys); + } + lose("unknown Lisp system `%s'", name); +} + +static void lisp_quote_string(struct dstr *d, const char *p) +{ + size_t n; + + for (;;) { + n = strcspn(p, "\"\\"); + if (n) { dstr_putm(d, p, n); p += n; } + if (!*p) break; + dstr_putc(d, '\\'); dstr_putc(d, *p++); + } + dstr_putz(d); +} + +static const char *expand_rune(struct dstr *d, const char *rune, ...) +{ + const struct argv *av; + va_list ap; + size_t i, n; + + va_start(ap, rune); + for (;;) { + n = strcspn(rune, "%"); + if (n) { dstr_putm(d, rune, n); rune += n; } + if (!*rune) break; + switch (*++rune) { + case '%': dstr_putc(d, '%'); break; + case 'e': lisp_quote_string(d, va_arg(ap, const char *)); break; + case 'E': + av = va_arg(ap, const struct argv *); + for (i = 0; i < av->n; i++) { + if (i) dstr_putc(d, ' '); + dstr_putc(d, '"'); + lisp_quote_string(d, av->v[i]); + dstr_putc(d, '"'); + } + break; + default: lose("*** BUG unknown expansion `%%%c'", *rune); + } + rune++; + } + dstr_putz(d); + return (d->p); +} + +/*----- Argument processing -----------------------------------------------*/ + +struct syslist { + const struct systab *sys[NSYS]; + size_t n; + unsigned f; +}; +#define SYSLIST_INIT { { 0 }, 0, 0 } + +struct argstate { + unsigned f; +#define F_BOGUS 1u +#define F_NOEMBED 2u +#define F_NOACT 4u +#define F_NODUMP 8u +#define F_AUX 16u + int verbose; + char *imagedir; + struct syslist allow, pref; + struct argv av; +}; +#define ARGSTATE_INIT { 0, 1, 0, SYSLIST_INIT, SYSLIST_INIT, ARGV_INIT } + +/*----- Running programs --------------------------------------------------*/ + +#define FEF_EXEC 1u +static int file_exists_p(const struct argstate *arg, const char *path, + unsigned f) +{ + struct stat st; + + if (stat(path, &st)) { + if (arg && arg->verbose > 2) moan("file `%s' not found", path); + return (0); + } else if (!(S_ISREG(st.st_mode))) { + if (arg && arg->verbose > 2) moan("`%s' is not a regular file", path); + return (0); + } else if ((f&FEF_EXEC) && access(path, X_OK)) { + if (arg && arg->verbose > 2) moan("file `%s' is not executable", path); + return (0); + } else { + if (arg && arg->verbose > 2) moan("found file `%s'", path); + return (1); + } +} + +static int found_in_path_p(const struct argstate *arg, const char *prog) +{ + struct dstr p = DSTR_INIT, d = DSTR_INIT; + const char *path; + char *q; + size_t n, avail, proglen; + int i; + + if (strchr(prog, '/')) return (file_exists_p(arg, prog, 0)); + path = getenv("PATH"); + if (path) + dstr_puts(&p, path); + else { + dstr_puts(&p, ".:"); + i = 0; + again: + avail = p.sz - p.len; + n = confstr(_CS_PATH, p.p + p.len, avail); + if (avail > n) { i++; assert(i < 2); dstr_ensure(&p, n); goto again; } + } + + q = p.p; proglen = strlen(prog); + for (;;) { + n = strcspn(q, ":"); + dstr_reset(&d); + if (q[n]) dstr_putm(&d, q, n); + else dstr_putc(&d, '.'); + dstr_putc(&d, '/'); + dstr_putm(&d, prog, proglen); + dstr_putz(&d); + if (file_exists_p(arg, d.p, FEF_EXEC)) { + if (arg->verbose == 2) moan("found program `%s'", d.p); + return (1); + } + q += n; if (!*q) break; else q++; + } + return (0); +} + +static void try_exec(const struct argstate *arg, struct argv *av) +{ + struct dstr d = DSTR_INIT; + size_t i; + + assert(av->n); argv_appendz(av); + if (arg->verbose > 1) { + for (i = 0; i < av->n; i++) { + if (i) { dstr_putc(&d, ','); dstr_putc(&d, ' '); } + dstr_putc(&d, '"'); + lisp_quote_string(&d, av->v[i]); + dstr_putc(&d, '"'); + } + dstr_putz(&d); + moan("trying %s...", d.p); + } + if (arg->f&F_NOACT) + { if (found_in_path_p(arg, av->v[0])) exit(0); } + else { + execvp(av->v[0], (/*unconst*/ char **)av->v); + if (errno != ENOENT) + lose("failed to exec `%s': %s", av->v[0], strerror(errno)); + } + if (arg->verbose > 1) moan("`%s' not found", av->v[0]); + dstr_release(&d); +} + +static const char *getenv_or_default(const char *var, const char *dflt) + { const char *p = getenv(var); return (p ? p : dflt); } + +/*----- Invoking Lisp systems ---------------------------------------------*/ + +/* Steel Bank Common Lisp. */ + +static void run_sbcl(struct argstate *arg, const char *script) +{ + struct dstr d = DSTR_INIT; + + argv_prependl(&arg->av, "--script", script, END); + + dstr_puts(&d, arg->imagedir); + dstr_putc(&d, '/'); + dstr_puts(&d, "sbcl+asdf.core"); + if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0)) + argv_prependl(&arg->av, + "--core", d.p, + "--eval", IMAGE_RESTORE_RUNE, + END); + else + argv_prependl(&arg->av, "--eval", COMMON_PRELUDE_RUNE, END); + + argv_prependl(&arg->av, getenv_or_default("SBCL", "sbcl"), + "--noinform", + END); + try_exec(arg, &arg->av); + dstr_release(&d); +} + +/* Clozure Common Lisp. */ + +#define CCL_QUIT_RUNE \ + "(ccl:quit)" + +static void run_ccl(struct argstate *arg, const char *script) +{ + struct dstr d = DSTR_INIT; + + argv_prependl(&arg->av, "-b", "-n", "-Q", + "-l", script, + "-e", CCL_QUIT_RUNE, + "--", + END); + + dstr_puts(&d, arg->imagedir); + dstr_putc(&d, '/'); + dstr_puts(&d, "ccl+asdf.image"); + if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0)) + argv_prependl(&arg->av, "-I", d.p, "-e", IMAGE_RESTORE_RUNE, END); + else + argv_prependl(&arg->av, "-e", COMMON_PRELUDE_RUNE, END); + + argv_prepend(&arg->av, getenv_or_default("CCL", "ccl")); + try_exec(arg, &arg->av); + dstr_release(&d); +} + +/* GNU CLisp. + * + * CLisp causes much sadness. Superficially, it's the most sensible of all + * of the systems supported here: you just run `clisp SCRIPT -- ARGS ...' and + * it works. + * + * The problems come when you want to do some preparatory work (e.g., load + * `asdf') and then run the script. There's a `-x' option to evaluate some + * Lisp code, but it has three major deficiencies. + * + * * It insists on printing the values of the forms it evaluates. It + * prints a blank line even if the form goes out of its way to produce no + * values at all. So the whole thing has to be a single top-level form + * which quits the Lisp rather than returning. + * + * * For some idiotic reason, you can have /either/ `-x' forms /or/ a + * script, but not both. So we have to include the `load' here + * explicitly. I suppose that was inevitable because we have to inhibit + * printing of the result forms, but it's still a separate source of + * annoyance. + * + * * The icing on the cake: the `-x' forms are collectively concatenated -- + * without spaces! -- and used to build a string stream, which is then + * assigned over the top of `*standard-input*', making the original stdin + * somewhat fiddly to track down. + * + * There's an `-i' option which will load a file without any of this + * stupidity, but nothing analogous for immediate expressions. + */ + +#define CLISP_COMMON_STARTUP_RUNES \ + "(setf *standard-input* (ext:make-stream :input)) " \ + "(load \"%e\" :verbose nil :print nil) " \ + "(ext:quit)" + +#define CLISP_STARTUP_RUNE \ + "(progn " \ + COMMON_PRELUDE_RUNE " " \ + CLISP_COMMON_STARTUP_RUNES ")" + +#define CLISP_STARTUP_IMAGE_RUNE \ + "(progn " \ + IMAGE_RESTORE_RUNE " " \ + CLISP_COMMON_STARTUP_RUNES ")" + +static void run_clisp(struct argstate *arg, const char *script) +{ + struct dstr d = DSTR_INIT, dd = DSTR_INIT; + + dstr_puts(&d, arg->imagedir); + dstr_putc(&d, '/'); + dstr_puts(&d, "clisp+asdf.mem"); + if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0)) + argv_prependl(&arg->av, "-M", d.p, "-q", + "-x", expand_rune(&dd, CLISP_STARTUP_IMAGE_RUNE, script), + "--", + END); + else + argv_prependl(&arg->av, "-norc", "-q", + "-x", expand_rune(&dd, CLISP_STARTUP_RUNE, script), + "--", + END); + + argv_prepend(&arg->av, getenv_or_default("CLISP", "clisp")); + try_exec(arg, &arg->av); + dstr_release(&d); + dstr_release(&dd); + +#undef f +} + +/* Embeddable Common Lisp. * + * + * ECL is changing its command-line option syntax in version 16. I have no + * idea why they think the result can ever be worth the pain of a transition. + */ + +#if ECL_OPTIONS_GNU +# define ECLOPT "--" +#else +# define ECLOPT "-" +#endif + +#define ECL_STARTUP_RUNE \ + "(progn " \ + COMMON_PRELUDE_RUNE " " \ + CLEAR_CL_USER_RUNE ")" + +static void run_ecl(struct argstate *arg, const char *script) +{ + struct dstr d = DSTR_INIT; + + dstr_puts(&d, arg->imagedir); + dstr_putc(&d, '/'); + dstr_puts(&d, "ecl+asdf"); + if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, FEF_EXEC)) { + argv_prependl(&arg->av, "-s", script, "--", END); + argv_prependl(&arg->av, d.p, END); + } else { + argv_prependl(&arg->av, ECLOPT "shell", script, "--", END); + argv_prependl(&arg->av, getenv_or_default("ECL", "ecl"), ECLOPT "norc", + ECLOPT "eval", ECL_STARTUP_RUNE, + END); + } + try_exec(arg, &arg->av); +} + +/* Carnegie--Mellon University Common Lisp. */ + +#define CMUCL_STARTUP_RUNE \ + "(progn " \ + "(setf ext:*require-verbose* nil) " \ + COMMON_PRELUDE_RUNE ")" +#define CMUCL_QUIT_RUNE \ + "(ext:quit)" + +static void run_cmucl(struct argstate *arg, const char *script) +{ + struct dstr d = DSTR_INIT; + + argv_prependl(&arg->av, + "-load", script, + "-eval", CMUCL_QUIT_RUNE, + "--", + END); + + dstr_puts(&d, arg->imagedir); + dstr_putc(&d, '/'); + dstr_puts(&d, "cmucl+asdf.core"); + if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0)) + argv_prependl(&arg->av, "-core", d.p, "-eval", IMAGE_RESTORE_RUNE, END); + else + argv_prependl(&arg->av, "-batch", "-noinit", "-nositeinit", "-quiet", + "-eval", CMUCL_STARTUP_RUNE, + END); + + argv_prepend(&arg->av, getenv_or_default("CMUCL", "cmucl")); + try_exec(arg, &arg->av); + dstr_release(&d); +} + +/* Armed Bear Common Lisp. * + * + * CLisp made a worthy effort, but ABCL still manages to take the price. + * + * * ABCL manages to avoid touching the `stderr' stream at all, ever. Its + * startup machinery finds `stdout' (as `java.lang.System.out'), wraps it + * up in a Lisp stream, and uses the result as `*standard-output*' and + * `*error-output*' (and a goodly number of other things too). So we + * must manufacture a working `stderr' the hard way. + * + * * There doesn't appear to be any easy way to prevent toplevel errors + * from invoking the interactive debugger. For extra fun, the debugger + * reads from `stdin' by default, so an input file which somehow manages + * to break the script can then take over its brain by providing Lisp + * forms for the debugger to evaluate. + */ + +#define ABCL_STARTUP_RUNE \ + "(let ((#9=#:script \"%e\")) " \ + COMMON_PRELUDE_RUNE " " \ + CLEAR_CL_USER_RUNE " " \ + \ + /* Replace the broken `*error-output*' stream with a working \ + * copy of `stderr'. \ + */ \ + "(setf *error-output* " \ + "(java:jnew \"org.armedbear.lisp.Stream\" " \ + "'sys::system-stream " \ + "(java:jfield \"java.lang.System\" \"err\") " \ + "'character " \ + "java:+true+)) " \ + \ + /* Trap errors signalled by the script and arrange for them \ + * to actually kill the process rather than ending up in the \ + * interactive debugger. \ + */ \ + "(handler-case (load #9# :verbose nil :print nil) " \ + "(error (error) " \ + "(format *error-output* \"~A (unhandled error): ~A~%%\" " \ + "#9# error) " \ + "(ext:quit :status 255))))" + +static void run_abcl(struct argstate *arg, const char *script) +{ + struct dstr d = DSTR_INIT; + + argv_prependl(&arg->av, getenv_or_default("ABCL", "abcl"), + "--batch", "--noinform", "--noinit", "--nosystem", + "--eval", expand_rune(&d, ABCL_STARTUP_RUNE, script), + "--", + END); + try_exec(arg, &arg->av); + dstr_release(&d); +} + +/*----- Main code ---------------------------------------------------------*/ + +static void version(FILE *fp) + { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); } + +static void usage(FILE *fp) +{ + fprintf(fp, "usage: %s [-CDEnqv] [-I IMAGEDIR] " + "[-L SYS,SYS,...] [-P SYS,SYS,...]\n" + "\t[--] SCRIPT [ARGUMENTS ...] |\n" + "\t[-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n", + progname); +} + +static void help(FILE *fp) +{ + version(fp); fputc('\n', fp); usage(fp); + fputs("\n\ +Options:\n\ + --help Show this help text and exit successfully.\n\ + --version Show the version number and exit successfully.\n\ + -C Clear the list of preferred Lisp systems.\n\ + -D Run system Lisp images, rather than custom images.\n\ + -E Don't read embedded options from the script.\n\ + -I IMAGEDIR Look for custom images in IMAGEDIR rather than\n\ + `" IMAGEDIR "'.\n\ + -L SYS,SYS,... Only use the listed Lisp systems.the script.\n\ + -P SYS,SYS,... Prefer the listed Lisp systems.\n\ + -e EXPR Evaluate EXPR (can be repeated).\n\ + -l FILE Load FILE (can be repeated).\n\ + -n Don't actually run the script (useful with `-v')\n\ + -p EXPR Print (`prin1') EXPR (can be repeated).\n\ + -q Don't print warning messages.\n\ + -v Print informational messages (repeat for even more).\n", + fp); +} + +static void push_eval_op(struct argstate *arg, char op, const char *val) +{ + char *p; + size_t n; + + if (arg->f&F_AUX) { + moan("must use `-e', `-p', or `-l' on command line"); + arg->f |= F_BOGUS; + return; + } + + n = strlen(val) + 1; + p = xmalloc(n + 1); + p[0] = op; memcpy(p + 1, val, n); + argv_append(&arg->av, p); +} + +/* Parse a comma-separated list of system names SPEC, and add the named + * systems to LIST. + */ +static void parse_syslist(const char *spec, const struct argstate *arg, + struct syslist *list, const char *what) +{ + char *copy = xstrdup(spec), *p = copy, *q; + const struct systab *sys; + size_t n; + + for (;;) { + n = strcspn(p, ","); + if (p[n]) q = p + n + 1; + else q = 0; + p[n] = 0; sys = find_system(p); + if (list->f&sys->f) { + if (arg->verbose > 0) + moan("ignoring duplicate system `%s' in %s list", p, what); + } else { + list->sys[list->n++] = sys; + list->f |= sys->f; + } + if (!q) break; + p = q; + } + free(copy); +} + +/* Parse a vector ARGS of command-line arguments. Update ARG with the + * results. NARG is the number of arguments, and *I_INOUT is the current + * index into the vector, to be updated on exit to identify the first + * non-option argument (or the end of the vector). + */ +static void parse_arguments(struct argstate *arg, const char *const *args, + size_t nargs, size_t *i_inout) +{ + const char *o, *a; + char opt; + + for (;;) { + if (*i_inout >= nargs) break; + o = args[*i_inout]; + if (STRCMP(o, ==, "--help")) { help(stdout); exit(0); } + else if (STRCMP(o, ==, "--version")) { version(stdout); exit(0); } + if (!*o || *o != '-' || !o[1]) break; + (*i_inout)++; + if (STRCMP(o, ==, "--")) break; + o++; + while (o && *o) { + opt = *o++; + switch (opt) { + +#define GETARG do { \ + if (*o) \ + { a = o; o = 0; } \ + else { \ + if (*i_inout >= nargs) goto noarg; \ + a = args[(*i_inout)++]; \ + } \ +} while (0) + + case 'C': arg->pref.n = 0; arg->pref.f = 0; break; + case 'D': arg->f |= F_NODUMP; break; + case 'E': arg->f |= F_NOEMBED; break; + case 'e': GETARG; push_eval_op(arg, '!', a); break; + case 'p': GETARG; push_eval_op(arg, '?', a); break; + case 'l': GETARG; push_eval_op(arg, '<', a); break; + case 'n': arg->f |= F_NOACT; break; + case 'q': if (arg->verbose) arg->verbose--; break; + case 'v': arg->verbose++; break; + + case 'I': + free(arg->imagedir); + GETARG; arg->imagedir = xstrdup(a); + break; + + case 'L': + GETARG; + parse_syslist(a, arg, &arg->allow, "allowed"); + break; + + case 'P': + GETARG; + parse_syslist(a, arg, &arg->pref, "preferred"); + break; + + default: + moan("unknown option `%c'", opt); + arg->f |= F_BOGUS; + break; + +#undef GETARG + + } + } + } + goto end; + +noarg: + moan("missing argument for `-%c'", opt); + arg->f |= F_BOGUS; +end: + return; +} + +/* Parse a string P into words (destructively), and process them as + * command-line options, updating ARG. Non-option arguments are not + * permitted. If `SOSF_EMACS' is set in FLAGS, then ignore `-*- ... -*-' + * editor turds. If `SOSF_ENDOK' is set, then accept `--' and ignore + * whatever comes after; otherwise, reject all positional arguments. + */ +#define SOSF_EMACS 1u +#define SOSF_ENDOK 2u +static void scan_options_from_string(char *p, struct argstate *arg, + unsigned flags, + const char *what, const char *file) +{ + struct argv av = ARGV_INIT; + char *q; + size_t i; + int st = 0; + unsigned f = 0; +#define f_escape 1u + + for (;;) { + while (ISSPACE(*p)) p++; + if (!*p) break; + if ((flags&SOSF_EMACS) && p[0] == '-' && p[1] == '*' && p[2] == '-') { + p = strstr(p + 3, "-*-"); + if (!p) lose("unfinished local-variables list in %s `%s'", what, file); + p += 3; continue; + } + if ((flags&SOSF_ENDOK) && + p[0] == '-' && p[1] == '-' && (!p[2] || ISSPACE(p[2]))) + break; + argv_append(&av, p); q = p; + for (;;) { + if (!*p) break; + else if (f&f_escape) { *q++ = *p; f &= ~f_escape; } + else if (st && *p == st) st = 0; + else if (st != '\'' && *p == '\\') f |= f_escape; + else if (!st && (*p == '"' || *p == '\'')) st = *p; + else if (!st && ISSPACE(*p)) break; + else *q++ = *p; + p++; + } + + if (*p) p++; + *q = 0; + if (f&f_escape) lose("unfinished escape in %s `%s'", what, file); + if (st) lose("unfinished `%c' string in %s `%s'", st, what, file); + } + + i = 0; parse_arguments(arg, av.v, av.n, &i); + if (i < av.n) + lose("positional argument `%s' in %s `%s'", av.v[i], what, file); + argv_release(&av); + +#undef f_escape +} + +/* Read SCRIPT, and check for a `@RUNLISP:' marker in the second line. If + * there is one, parse options from it, and update ARG. + */ +static void check_for_embedded_args(const char *script, struct argstate *arg) +{ + struct dstr d = DSTR_INIT; + char *p; + FILE *fp = 0; + + fp = fopen(script, "r"); + if (!fp) lose("can't read script `%s': %s", script, strerror(errno)); + + if (dstr_readline(&d, fp)) goto end; + dstr_reset(&d); if (dstr_readline(&d, fp)) goto end; + + p = strstr(d.p, "@RUNLISP:"); + if (p) + scan_options_from_string(p + 9, arg, SOSF_EMACS | SOSF_ENDOK, + "embedded options in script", script); + +end: + if (fp) { + if (ferror(fp)) + lose("error reading script `%s': %s", script, strerror(errno)); + fclose(fp); + } + dstr_release(&d); +} + +/* Read the file PATH (if it exists) and update ARG with the arguments parsed + * from it. Ignore blank lines and (Unix- or Lisp-style) comments. + */ +static void read_config_file(const char *path, struct argstate *arg) +{ + FILE *fp = 0; + struct dstr d = DSTR_INIT; + char *p; + + fp = fopen(path, "r"); + if (!fp) { + if (errno == ENOENT) { + if (arg->verbose > 2) + moan("ignoring nonexistent configuration file `%s'", path); + goto end; + } + lose("failed to open configuration file `%s': %s", + path, strerror(errno)); + } + if (arg->verbose > 1) + moan("reading configuration file `%s'", path); + for (;;) { + dstr_reset(&d); + if (dstr_readline(&d, fp)) break; + p = d.p; + while (ISSPACE(*p)) p++; + if (!*p || *p == ';' || *p == '#') continue; + scan_options_from_string(p, arg, 0, "configuration file `%s'", path); + } + if (arg->f&F_BOGUS) + lose("invalid options in configuration file `%s'", path); + +end: + if (fp) { + if (ferror(fp)) + lose("error reading configuration file `%s': %s", + path, strerror(errno)); + fclose(fp); + } + dstr_release(&d); +} + +int main(int argc, char *argv[]) +{ + struct dstr d = DSTR_INIT; + const char *script, *p; + const char *home; + struct passwd *pw; + char *t; + size_t i, n; + struct argstate arg = ARGSTATE_INIT; + + /* Scan the command line. This gets low priority, since it's probably + * from the script shebang. + */ + set_progname(argv[0]); i = 1; + parse_arguments(&arg, (const char *const *)argv, argc, &i); + arg.f |= F_AUX; + if ((i >= argc && !arg.av.n) || (arg.f&F_BOGUS)) + { usage(stderr); exit(255); } + + /* Prepare the argument vector. Keep track of the number of arguments + * here: we'll need to refer to this later. + */ + if (!arg.av.n) { + script = argv[i++]; + if (!(arg.f&F_NOEMBED)) check_for_embedded_args(script, &arg); + if (arg.f&F_BOGUS) + lose("invalid options in `%s' embedded option list", script); + } else { + script = getenv("RUNLISP_EVAL"); + if (!script) script = DATADIR "/eval.lisp"; + argv_append(&arg.av, "--"); + } + argv_appendn(&arg.av, (const char *const *)argv + i, argc - i); + n = arg.av.n; + + /* Find the user's home directory. (Believe them if they set something + * strange.) + */ + home = getenv("HOME"); + if (!home) { + pw = getpwuid(getuid()); + if (!pw) lose("can't find user in password database"); + home = pw->pw_dir; + } + + /* Check user configuration file `~/.runlisprc'. */ + dstr_reset(&d); + dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".runlisprc"); + read_config_file(d.p, &arg); + + /* Check user configuration file `~/.config/runlisprc'. */ + dstr_reset(&d); + p = getenv("XDG_CONFIG_HOME"); + if (p) + dstr_puts(&d, p); + else + { dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".config"); } + dstr_putc(&d, '/'); dstr_puts(&d, "runlisprc"); + read_config_file(d.p, &arg); + + /* Finally, check the environment variables. */ + p = getenv("RUNLISP_OPTIONS"); + if (p) { + t = xstrdup(p); + scan_options_from_string(t, &arg, 0, + "environment variable", "RUNLISP_OPTIONS"); + free(t); + } + if (arg.f&F_BOGUS) + lose("invalid options in environment variable `RUNLISP_OPTIONS'"); + if (!arg.imagedir) { + arg.imagedir = getenv("RUNLISP_IMAGEDIR"); + if (!arg.imagedir) arg.imagedir = IMAGEDIR; + } + + /* If no systems are listed as acceptable, try them all. */ + if (!arg.allow.n) { + if (arg.verbose > 1) + moan("no explicitly allowed implementations: allowing all"); + for (i = 0; i < NSYS; i++) arg.allow.sys[i] = &systab[i]; + arg.allow.n = NSYS; arg.allow.f = (1u << NSYS) - 1; + } + + /* Print what we're going to do. */ + if (arg.verbose > 2) { + dstr_reset(&d); p = ""; + for (i = 0; i < arg.allow.n; i++) + { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); } + dstr_putz(&d); moan("permitted Lisps: %s", d.p); + + dstr_reset(&d); p = ""; + for (i = 0; i < arg.pref.n; i++) + { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); } + dstr_putz(&d); moan("preferred Lisps: %s", d.p); + + dstr_reset(&d); p = ""; + for (i = 0; i < arg.pref.n; i++) + if (arg.pref.sys[i]->f&arg.allow.f) + { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); } + for (i = 0; i < arg.allow.n; i++) + if (!(arg.allow.sys[i]->f&arg.pref.f)) + { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); } + moan("overall preference order: %s", d.p); + } + + /* Inform `uiop' of the script name. + * + * 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"); + + /* Work through the list of preferred Lisp systems, trying the ones which + * are allowed. + */ + for (i = 0; i < arg.pref.n; i++) + if (arg.pref.sys[i]->f&arg.allow.f) { + arg.av.o += arg.av.n - n; arg.av.v += arg.av.n - n; arg.av.n = n; + arg.pref.sys[i]->run(&arg, script); + } + + /* That didn't work. Try the remaining allowed systems, in the given + * order. + */ + for (i = 0; i < arg.allow.n; i++) + if (!(arg.allow.sys[i]->f&arg.pref.f)) { + arg.av.o += arg.av.n - n; arg.av.v += arg.av.n - n; arg.av.n = n; + arg.allow.sys[i]->run(&arg, script); + } + + /* No joy. Give up. */ + argv_release(&arg.av); + lose("no supported Lisp systems found"); +} + +/*----- That's all, folks -------------------------------------------------*/ diff --git a/runlisp.c b/runlisp.c index 300c8ed..c555f13 100644 --- a/runlisp.c +++ b/runlisp.c @@ -1,6 +1,6 @@ /* -*-c-*- * - * Invoke a Lisp script + * Invoke Lisp scripts and implementations * * (c) 2020 Mark Wooding */ @@ -27,1017 +27,247 @@ #include "config.h" -#include #include #include -#include #include #include #include -#include -#include +#include "common.h" +#include "lib.h" +#include "mdwopt.h" -#include +/*----- Static data -------------------------------------------------------*/ -/*----- Common Lisp runes -------------------------------------------------*/ - -/* A common preamble rune to do the necessary things. - * - * We need to ensure that `asdf' (and therefore `uiop') is loaded. And we - * should arrange for `:runlisp-script' to find its way into the `*features*' - * list so that scripts can notice that they're being invoked from the - * command line rather than loaded into a resident session, and actually do - * something useful. - */ -#define COMMON_PRELUDE_RUNE \ - "(progn " \ - "(setf *load-verbose* nil *compile-verbose* nil) " \ - "(require \"asdf\") " \ - "(funcall (intern \"REGISTER-IMMUTABLE-SYSTEM\" " \ - "(find-package \"ASDF\")) " \ - "\"asdf\") " \ - "(set-dispatch-macro-character " \ - "#\\# #\\! " \ - "(lambda (#1=#:stream #2=#:char #3=#:arg) " \ - "(declare (ignore #2# #3#)) " \ - "(values (read-line #1#)))) " \ - "(pushnew :runlisp-script *features*))" - -/* Get `uiop' to re-check the command-line arguments following an image - * restore. - */ -#define IMAGE_RESTORE_RUNE \ - "(uiop:call-image-restore-hook)" - -/* Some Lisps leave crud in the `COMMON-LISP-USER' package. Clear it out. */ -#define CLEAR_CL_USER_RUNE \ - "(let ((#4=#:pkg (find-package \"COMMON-LISP-USER\"))) " \ - "(with-package-iterator (#5=#:next #4# :internal) " \ - "(loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how) " \ - "(#5#) " \ - "(declare (ignore #8#)) " \ - "(unless #6# (return)) " \ - "(unintern #7# #4#)))))" - -/*----- Handy macros ------------------------------------------------------*/ - -#define N(v) (sizeof(v)/sizeof((v)[0])) - -#if defined(__GNUC__) -# define GCC_VERSION_P(maj, min) \ - (__GNUC__ > (maj) || (__GNUC__ == (maj) && __GNUC_MINOR__ >= (min))) -#else -# define GCC_VERSION_P(maj, min) 0 -#endif - -#ifdef __clang__ -# define CLANG_VERSION_P(maj, min) \ - (__clang_major__ > (maj) || (__clang_major__ == (maj) && \ - __clang_minor__ >= (min))) -#else -# define CLANG_VERSION_P(maj, min) 0 -#endif - -#if GCC_VERSION_P(2, 5) || CLANG_VERSION_P(3, 3) -# define NORETURN __attribute__((__noreturn__)) -# define PRINTF_LIKE(fix, aix) __attribute__((__format__(printf, fix, aix))) -#endif - -#if GCC_VERSION_P(4, 0) || CLANG_VERSION_P(3, 3) -# define EXECL_LIKE(ntrail) __attribute__((__sentinel__(ntrail))) -#endif - -#define CTYPE_HACK(func, ch) (func((unsigned char)(ch))) -#define ISSPACE(ch) CTYPE_HACK(isspace, ch) - -#define MEMCMP(x, op, y, n) (memcmp((x), (y), (n)) op 0) -#define STRCMP(x, op, y) (strcmp((x), (y)) op 0) -#define STRNCMP(x, op, y, n) (strncmp((x), (y), (n)) op 0) - -#define END ((const char *)0) - -/*----- The Lisp implementation table -------------------------------------*/ - -/* The systems, in decreasing order of (not quite my personal) preference. - * This list is used to initialize various tables and constants. - */ -#define LISP_SYSTEMS(_) \ - _(sbcl) \ - _(ccl) \ - _(clisp) \ - _(ecl) \ - _(cmucl) \ - _(abcl) - -enum { -#define DEFSYS(sys) sys##_INDEX, - LISP_SYSTEMS(DEFSYS) -#undef DEFSYS - NSYS -}; - -enum { -#define DEFFLAG(sys) sys##_FLAG = 1 << sys##_INDEX, - LISP_SYSTEMS(DEFFLAG) -#undef DEFFLAG - ALL_SYSTEMS = 0 -#define SETFLAG(sys) | sys##_FLAG - LISP_SYSTEMS(SETFLAG) -#undef SETFLAG -}; - -struct argstate; -struct argv; - -#define DECLENTRY(sys) \ -static void run_##sys(struct argstate *, const char *); - LISP_SYSTEMS(DECLENTRY) -#undef DECLENTRY - -static const struct systab { - const char *name; +struct lispsys { + struct treap_node _node; + struct lispsys *next_lisp, *next_accept, *next_prefer, *next_order; unsigned f; - void (*run)(struct argstate *, const char *); -} systab[] = { -#define SYSENTRY(sys) { #sys, sys##_FLAG, run_##sys }, - LISP_SYSTEMS(SYSENTRY) -#undef SYSENTRY +#define LF_KNOWN 1u +#define LF_ACCEPT 2u +#define LF_PREFER 4u + struct config_section *sect; + struct config_var *var; }; +#define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp) +#define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp) -/*----- Diagnostic utilities ----------------------------------------------*/ - -static const char *progname = "runlisp"; - -static void set_progname(const char *prog) -{ - const char *p; - - p = strrchr(prog, '/'); - progname = p ? p + 1 : progname; -} - -static void vmoan(const char *msg, va_list ap) -{ - fprintf(stderr, "%s: ", progname); - vfprintf(stderr, msg, ap); - fputc('\n', stderr); -} - -static PRINTF_LIKE(1, 2) void moan(const char *msg, ...) - { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); } - -static NORETURN PRINTF_LIKE(1, 2) void lose(const char *msg, ...) - { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); exit(127); } - -/*----- Memory allocation -------------------------------------------------*/ - -static void *xmalloc(size_t n) -{ - void *p; - - if (!n) return (0); - p = malloc(n); if (!p) lose("failed to allocate memory"); - return (p); -} - -static void *xrealloc(void *p, size_t n) -{ - if (!n) { free(p); return (0); } - else if (!p) return (xmalloc(n)); - p = realloc(p, n); if (!p) lose("failed to allocate memory"); - return (p); -} - -static char *xstrdup(const char *p) -{ - size_t n = strlen(p) + 1; - char *q = xmalloc(n); - - memcpy(q, p, n); - return (q); -} - -/*----- Dynamic strings ---------------------------------------------------*/ - -struct dstr { - char *p; - size_t len, sz; +struct lispsys_list { + struct lispsys *head, **tail; }; -#define DSTR_INIT { 0, 0, 0 } - -/* -static void dstr_init(struct dstr *d) { d->p = 0; d->len = d->sz = 0; } -*/ - -static void dstr_reset(struct dstr *d) { d->len = 0; } - -static void dstr_ensure(struct dstr *d, size_t n) -{ - size_t need = d->len + n, newsz; - - if (need <= d->sz) return; - newsz = d->sz ? 2*d->sz : 16; - while (newsz < need) newsz *= 2; - d->p = xrealloc(d->p, newsz); d->sz = newsz; -} - -static void dstr_release(struct dstr *d) { free(d->p); } - -static void dstr_putm(struct dstr *d, const void *p, size_t n) - { dstr_ensure(d, n); memcpy(d->p + d->len, p, n); d->len += n; } - -static void dstr_puts(struct dstr *d, const char *p) -{ - size_t n = strlen(p); - dstr_ensure(d, n + 1); - memcpy(d->p + d->len, p, n + 1); - d->len += n; -} - -static void dstr_putc(struct dstr *d, int ch) - { dstr_ensure(d, 1); d->p[d->len++] = ch; } - -static void dstr_putz(struct dstr *d) - { dstr_ensure(d, 1); d->p[d->len] = 0; } - -static int dstr_readline(struct dstr *d, FILE *fp) -{ - size_t n; - int any = 0; - - for (;;) { - dstr_ensure(d, 2); - if (!fgets(d->p + d->len, d->sz - d->len, fp)) break; - n = strlen(d->p + d->len); assert(n > 0); any = 1; - d->len += n; - if (d->p[d->len - 1] == '\n') { d->p[--d->len] = 0; break; } - } - - if (!any) return (-1); - else return (0); -} -/*----- Dynamic vectors of strings ----------------------------------------*/ - -struct argv { - const char **v; - size_t o, n, sz; -}; -#define ARGV_INIT { 0, 0, 0, 0 } - -/* -static void argv_init(struct argv *av) - { av->v = 0; av->o = av->n = av->sz = 0; } -*/ - -/* -static void argv_reset(struct argv *av) { av->o = av->n = 0; } -*/ - -static void argv_ensure(struct argv *av, size_t n) -{ - size_t need = av->n + av->o + n, newsz; - - if (need <= av->sz) return; - newsz = av->sz ? 2*av->sz : 8; - while (newsz < need) newsz *= 2; - av->v = xrealloc(av->v, newsz*sizeof(const char *)); av->sz = newsz; -} +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 void argv_ensure_offset(struct argv *av, size_t n) -{ - size_t newoff; - - /* Stupid version. We won't, in practice, be prepending lots of stuff, so - * avoid the extra bookkeeping involved in trying to make a double-ended - * extendable array asymptotically efficient. - */ - if (av->o >= n) return; - newoff = 16; - while (newoff < n) newoff *= 2; - argv_ensure(av, newoff - av->o); - memmove(av->v + newoff, av->v + av->o, av->n*sizeof(const char *)); - av->o = newoff; -} - -static void argv_release(struct argv *av) { free(av->v); } - -static void argv_append(struct argv *av, const char *p) - { argv_ensure(av, 1); av->v[av->n++ + av->o] = p; } +/*----- Main code ---------------------------------------------------------*/ -static void argv_appendz(struct argv *av) - { argv_ensure(av, 1); av->v[av->n + av->o] = 0; } +static void version(FILE *fp) + { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); } -static void argv_appendn(struct argv *av, const char *const *v, size_t n) +static void usage(FILE *fp) { - argv_ensure(av, n); - memcpy(av->v + av->n + av->o, v, n*sizeof(const char *)); - av->n += n; + 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 argv_appendav(struct argv *av, const struct argv *bv) - { argv_appendn(av, bv->v + bv->o, bv->n); } -*/ - -/* -static void argv_appendv(struct argv *av, va_list ap) +static void help(FILE *fp) { - const char *p; - - for (;;) - { p = va_arg(ap, const char *); if (!p) break; argv_append(av, p); } + 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); } -*/ -/* -static EXECL_LIKE(0) void argv_appendl(struct argv *av, ...) - { va_list ap; va_start(ap, av); argv_appendv(av, ap); va_end(ap); } -*/ - -static void argv_prepend(struct argv *av, const char *p) - { argv_ensure_offset(av, 1); av->v[--av->o] = p; av->n++; } - -/* -static void argv_prependn(struct argv *av, const char *const *v, size_t n) +static struct lispsys *ensure_lispsys(const char *name, size_t n) { - argv_ensure_offset(av, 1); - av->o -= n; av->n += n; - memcpy(av->v + av->o, v, n*sizeof(const char *)); -} -*/ + struct lispsys *lisp; + struct treap_path path; -/* -static void argv_prependav(struct argv *av, const struct argv *bv) - { argv_prependn(av, bv->v + bv->o, bv->n); } -*/ - -static void argv_prependv(struct argv *av, va_list ap) -{ - const char *p, **v; - size_t n = 0; - - for (;;) { - p = va_arg(ap, const char *); if (!p) break; - argv_prepend(av, p); n++; - } - v = av->v + av->o; - while (n >= 2) { - p = v[0]; v[0] = v[n - 1]; v[n - 1] = p; - v++; n -= 2; + 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); } -static EXECL_LIKE(0) void argv_prependl(struct argv *av, ...) - { va_list ap; va_start(ap, av); argv_prependv(av, ap); va_end(ap); } - -/*----- Lisp system table (redux) -----------------------------------------*/ - -static const struct systab *find_system(const char *name) -{ - const struct systab *sys; - size_t i; +#define LISP_LINK(lisp, linkoff) \ + ((struct lispsys **)((unsigned char *)(lisp) + (linkoff))) - for (i = 0; i < NSYS; i++) { - sys = &systab[i]; - if (STRCMP(name, ==, sys->name)) return (sys); - } - lose("unknown Lisp system `%s'", name); -} - -static void lisp_quote_string(struct dstr *d, const char *p) +static void add_lispsys(const char *p, const char *what, + struct lispsys_list *list, + unsigned flag, size_t linkoff) { - size_t n; + struct lispsys *lisp, **link; + const char *q; + if (!*p) return; for (;;) { - n = strcspn(p, "\"\\"); - if (n) { dstr_putm(d, p, n); p += n; } if (!*p) break; - dstr_putc(d, '\\'); dstr_putc(d, *p++); - } - dstr_putz(d); -} - -static const char *expand_rune(struct dstr *d, const char *rune, ...) -{ - const struct argv *av; - va_list ap; - size_t i, n; - - va_start(ap, rune); - for (;;) { - n = strcspn(rune, "%"); - if (n) { dstr_putm(d, rune, n); rune += n; } - if (!*rune) break; - switch (*++rune) { - case '%': dstr_putc(d, '%'); break; - case 'e': lisp_quote_string(d, va_arg(ap, const char *)); break; - case 'E': - av = va_arg(ap, const struct argv *); - for (i = 0; i < av->n; i++) { - if (i) dstr_putc(d, ' '); - dstr_putc(d, '"'); - lisp_quote_string(d, av->v[i]); - dstr_putc(d, '"'); - } - break; - default: lose("*** BUG unknown expansion `%%%c'", *rune); + q = p; while (*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; } - rune++; - } - dstr_putz(d); - return (d->p); -} - -/*----- Argument processing -----------------------------------------------*/ - -struct syslist { - const struct systab *sys[NSYS]; - size_t n; - unsigned f; -}; -#define SYSLIST_INIT { { 0 }, 0, 0 } - -struct argstate { - unsigned f; -#define F_BOGUS 1u -#define F_NOEMBED 2u -#define F_NOACT 4u -#define F_NODUMP 8u -#define F_AUX 16u - int verbose; - char *imagedir; - struct syslist allow, pref; - struct argv av; -}; -#define ARGSTATE_INIT { 0, 1, 0, SYSLIST_INIT, SYSLIST_INIT, ARGV_INIT } - -/*----- Running programs --------------------------------------------------*/ - -#define FEF_EXEC 1u -static int file_exists_p(const struct argstate *arg, const char *path, - unsigned f) -{ - struct stat st; - - if (stat(path, &st)) { - if (arg && arg->verbose > 2) moan("file `%s' not found", path); - return (0); - } else if (!(S_ISREG(st.st_mode))) { - if (arg && arg->verbose > 2) moan("`%s' is not a regular file", path); - return (0); - } else if ((f&FEF_EXEC) && access(path, X_OK)) { - if (arg && arg->verbose > 2) moan("file `%s' is not executable", path); - return (0); - } else { - if (arg && arg->verbose > 2) moan("found file `%s'", path); - return (1); + if (!*p) break; + p++; } } -static int found_in_path_p(const struct argstate *arg, const char *prog) +static void check_lisps(const char *what, + struct lispsys_list *list, size_t linkoff) { - struct dstr p = DSTR_INIT, d = DSTR_INIT; - const char *path; - char *q; - size_t n, avail, proglen; - int i; + struct lispsys *lisp; - if (strchr(prog, '/')) return (file_exists_p(arg, prog, 0)); - path = getenv("PATH"); - if (path) - dstr_puts(&p, path); - else { - dstr_puts(&p, ".:"); - i = 0; - again: - avail = p.sz - p.len; - n = confstr(_CS_PATH, p.p + p.len, avail); - if (avail > n) { i++; assert(i < 2); dstr_ensure(&p, n); goto again; } - } - - q = p.p; proglen = strlen(prog); - for (;;) { - n = strcspn(q, ":"); - dstr_reset(&d); - if (q[n]) dstr_putm(&d, q, n); - else dstr_putc(&d, '.'); - dstr_putc(&d, '/'); - dstr_putm(&d, prog, proglen); - dstr_putz(&d); - if (file_exists_p(arg, d.p, FEF_EXEC)) { - if (arg->verbose == 2) moan("found program `%s'", d.p); - return (1); - } - q += n; if (!*q) break; else q++; - } - return (0); + for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff)) + if (!(lisp->f&LF_KNOWN)) + lose("unknown Lisp implementation `%s'", LISPSYS_NAME(lisp)); } -static void try_exec(const struct argstate *arg, struct argv *av) +static void dump_lisps(const char *what, + struct lispsys_list *list, size_t linkoff) { struct dstr d = DSTR_INIT; - size_t i; - - assert(av->n); argv_appendz(av); - if (arg->verbose > 1) { - for (i = 0; i < av->n; i++) { - if (i) { dstr_putc(&d, ','); dstr_putc(&d, ' '); } - dstr_putc(&d, '"'); - lisp_quote_string(&d, av->v[av->o + i]); - dstr_putc(&d, '"'); - } - dstr_putz(&d); - moan("trying %s...", d.p); - } - if (arg->f&F_NOACT) - { if (found_in_path_p(arg, av->v[av->o])) exit(0); } - else { - execvp(av->v[av->o], (/*unconst*/ char **)av->v + av->o); - if (errno != ENOENT) - lose("failed to exec `%s': %s", av->v[av->o], strerror(errno)); + 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_putf(&d, "`%s'", LISPSYS_NAME(lisp)); } - if (arg->verbose > 1) moan("`%s' not found", av->v[av->o]); + if (first) dstr_puts(&d, "(none)"); + dstr_putz(&d); + moan("%s: %s", what, d.p); dstr_release(&d); } -static const char *getenv_or_default(const char *var, const char *dflt) - { const char *p = getenv(var); return (p ? p : dflt); } - -/*----- Invoking Lisp systems ---------------------------------------------*/ - -/* Steel Bank Common Lisp. */ - -static void run_sbcl(struct argstate *arg, const char *script) -{ - struct dstr d = DSTR_INIT; - - argv_prependl(&arg->av, "--script", script, END); - - dstr_puts(&d, arg->imagedir); - dstr_putc(&d, '/'); - dstr_puts(&d, "sbcl+asdf.core"); - if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0)) - argv_prependl(&arg->av, - "--core", d.p, - "--eval", IMAGE_RESTORE_RUNE, - END); - else - argv_prependl(&arg->av, "--eval", COMMON_PRELUDE_RUNE, END); - - argv_prependl(&arg->av, getenv_or_default("SBCL", "sbcl"), - "--noinform", - END); - try_exec(arg, &arg->av); - dstr_release(&d); -} - -/* Clozure Common Lisp. */ - -#define CCL_QUIT_RUNE \ - "(ccl:quit)" - -static void run_ccl(struct argstate *arg, const char *script) -{ - struct dstr d = DSTR_INIT; - - argv_prependl(&arg->av, "-b", "-n", "-Q", - "-l", script, - "-e", CCL_QUIT_RUNE, - "--", - END); - - dstr_puts(&d, arg->imagedir); - dstr_putc(&d, '/'); - dstr_puts(&d, "ccl+asdf.image"); - if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0)) - argv_prependl(&arg->av, "-I", d.p, "-e", IMAGE_RESTORE_RUNE, END); - else - argv_prependl(&arg->av, "-e", COMMON_PRELUDE_RUNE, END); - - argv_prepend(&arg->av, getenv_or_default("CCL", "ccl")); - try_exec(arg, &arg->av); - dstr_release(&d); -} - -/* GNU CLisp. - * - * CLisp causes much sadness. Superficially, it's the most sensible of all - * of the systems supported here: you just run `clisp SCRIPT -- ARGS ...' and - * it works. - * - * The problems come when you want to do some preparatory work (e.g., load - * `asdf') and then run the script. There's a `-x' option to evaluate some - * Lisp code, but it has three major deficiencies. - * - * * It insists on printing the values of the forms it evaluates. It - * prints a blank line even if the form goes out of its way to produce no - * values at all. So the whole thing has to be a single top-level form - * which quits the Lisp rather than returning. - * - * * For some idiotic reason, you can have /either/ `-x' forms /or/ a - * script, but not both. So we have to include the `load' here - * explicitly. I suppose that was inevitable because we have to inhibit - * printing of the result forms, but it's still a separate source of - * annoyance. - * - * * The icing on the cake: the `-x' forms are collectively concatenated -- - * without spaces! -- and used to build a string stream, which is then - * assigned over the top of `*standard-input*', making the original stdin - * somewhat fiddly to track down. - * - * There's an `-i' option which will load a file without any of this - * stupidity, but nothing analogous for immediate expressions. - */ - -#define CLISP_COMMON_STARTUP_RUNES \ - "(setf *standard-input* (ext:make-stream :input)) " \ - "(load \"%e\" :verbose nil :print nil) " \ - "(ext:quit)" - -#define CLISP_STARTUP_RUNE \ - "(progn " \ - COMMON_PRELUDE_RUNE " " \ - CLISP_COMMON_STARTUP_RUNES ")" - -#define CLISP_STARTUP_IMAGE_RUNE \ - "(progn " \ - IMAGE_RESTORE_RUNE " " \ - CLISP_COMMON_STARTUP_RUNES ")" - -static void run_clisp(struct argstate *arg, const char *script) -{ - struct dstr d = DSTR_INIT, dd = DSTR_INIT; - - dstr_puts(&d, arg->imagedir); - dstr_putc(&d, '/'); - dstr_puts(&d, "clisp+asdf.mem"); - if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0)) - argv_prependl(&arg->av, "-M", d.p, "-q", - "-x", expand_rune(&dd, CLISP_STARTUP_IMAGE_RUNE, script), - "--", - END); - else - argv_prependl(&arg->av, "-norc", "-q", - "-x", expand_rune(&dd, CLISP_STARTUP_RUNE, script), - "--", - END); - - argv_prepend(&arg->av, getenv_or_default("CLISP", "clisp")); - try_exec(arg, &arg->av); - dstr_release(&d); - dstr_release(&dd); - -#undef f -} - -/* Embeddable Common Lisp. * - * - * ECL is changing its command-line option syntax in version 16. I have no - * idea why they think the result can ever be worth the pain of a transition. - */ - -#if ECL_OPTIONS_GNU -# define ECLOPT "--" -#else -# define ECLOPT "-" -#endif - -#define ECL_STARTUP_RUNE \ - "(progn " \ - COMMON_PRELUDE_RUNE " " \ - CLEAR_CL_USER_RUNE ")" - -static void run_ecl(struct argstate *arg, const char *script) -{ - struct dstr d = DSTR_INIT; - - dstr_puts(&d, arg->imagedir); - dstr_putc(&d, '/'); - dstr_puts(&d, "ecl+asdf"); - if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, FEF_EXEC)) { - argv_prependl(&arg->av, "-s", script, "--", END); - argv_prependl(&arg->av, d.p, END); - } else { - argv_prependl(&arg->av, ECLOPT "shell", script, "--", END); - argv_prependl(&arg->av, getenv_or_default("ECL", "ecl"), ECLOPT "norc", - ECLOPT "eval", ECL_STARTUP_RUNE, - END); - } - try_exec(arg, &arg->av); -} - -/* Carnegie--Mellon University Common Lisp. */ - -#define CMUCL_STARTUP_RUNE \ - "(progn " \ - "(setf ext:*require-verbose* nil) " \ - COMMON_PRELUDE_RUNE ")" -#define CMUCL_QUIT_RUNE \ - "(ext:quit)" - -static void run_cmucl(struct argstate *arg, const char *script) -{ - struct dstr d = DSTR_INIT; - - argv_prependl(&arg->av, - "-load", script, - "-eval", CMUCL_QUIT_RUNE, - "--", - END); - - dstr_puts(&d, arg->imagedir); - dstr_putc(&d, '/'); - dstr_puts(&d, "cmucl+asdf.core"); - if (!(arg->f&F_NODUMP) && file_exists_p(arg, d.p, 0)) - argv_prependl(&arg->av, "-core", d.p, "-eval", IMAGE_RESTORE_RUNE, END); - else - argv_prependl(&arg->av, "-batch", "-noinit", "-nositeinit", "-quiet", - "-eval", CMUCL_STARTUP_RUNE, - END); - - argv_prepend(&arg->av, getenv_or_default("CMUCL", "cmucl")); - try_exec(arg, &arg->av); - dstr_release(&d); -} - -/* Armed Bear Common Lisp. * - * - * CLisp made a worthy effort, but ABCL still manages to take the price. - * - * * ABCL manages to avoid touching the `stderr' stream at all, ever. Its - * startup machinery finds `stdout' (as `java.lang.System.out'), wraps it - * up in a Lisp stream, and uses the result as `*standard-output*' and - * `*error-output*' (and a goodly number of other things too). So we - * must manufacture a working `stderr' the hard way. - * - * * There doesn't appear to be any easy way to prevent toplevel errors - * from invoking the interactive debugger. For extra fun, the debugger - * reads from `stdin' by default, so an input file which somehow manages - * to break the script can then take over its brain by providing Lisp - * forms for the debugger to evaluate. - */ - -#define ABCL_STARTUP_RUNE \ - "(let ((#9=#:script \"%e\")) " \ - COMMON_PRELUDE_RUNE " " \ - CLEAR_CL_USER_RUNE " " \ - \ - /* Replace the broken `*error-output*' stream with a working \ - * copy of `stderr'. \ - */ \ - "(setf *error-output* " \ - "(java:jnew \"org.armedbear.lisp.Stream\" " \ - "'sys::system-stream " \ - "(java:jfield \"java.lang.System\" \"err\") " \ - "'character " \ - "java:+true+)) " \ - \ - /* Trap errors signalled by the script and arrange for them \ - * to actually kill the process rather than ending up in the \ - * interactive debugger. \ - */ \ - "(handler-case (load #9# :verbose nil :print nil) " \ - "(error (error) " \ - "(format *error-output* \"~A (unhandled error): ~A~%%\" " \ - "#9# error) " \ - "(ext:quit :status 255))))" - -static void run_abcl(struct argstate *arg, const char *script) -{ - struct dstr d = DSTR_INIT; - - argv_prependl(&arg->av, getenv_or_default("ABCL", "abcl"), - "--batch", "--noinform", "--noinit", "--nosystem", - "--eval", expand_rune(&d, ABCL_STARTUP_RUNE, script), - "--", - END); - try_exec(arg, &arg->av); - dstr_release(&d); -} - -/*----- Main code ---------------------------------------------------------*/ - -static void version(FILE *fp) - { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); } - -static void usage(FILE *fp) -{ - fprintf(fp, "usage: %s [-CDEnqv] [-I IMAGEDIR] " - "[-L SYS,SYS,...] [-P SYS,SYS,...]\n" - "\t[--] SCRIPT [ARGUMENTS ...] |\n" - "\t[-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n", - progname); -} - -static void help(FILE *fp) -{ - version(fp); fputc('\n', fp); usage(fp); - fputs("\n\ -Options:\n\ - --help Show this help text and exit successfully.\n\ - --version Show the version number and exit successfully.\n\ - -C Clear the list of preferred Lisp systems.\n\ - -D Run system Lisp images, rather than custom images.\n\ - -E Don't read embedded options from the script.\n\ - -I IMAGEDIR Look for custom images in IMAGEDIR rather than\n\ - `" IMAGEDIR "'.\n\ - -L SYS,SYS,... Only use the listed Lisp systems.the script.\n\ - -P SYS,SYS,... Prefer the listed Lisp systems.\n\ - -e EXPR Evaluate EXPR (can be repeated).\n\ - -l FILE Load FILE (can be repeated).\n\ - -n Don't actually run the script (useful with `-v')\n\ - -p EXPR Print (`prin1') EXPR (can be repeated).\n\ - -q Don't print warning messages.\n\ - -v Print informational messages (repeat for even more).\n", - fp); -} - -/* Parse a comma-separated list of system names SPEC, and add the named - * systems to LIST. - */ -static void parse_syslist(const char *spec, const struct argstate *arg, - struct syslist *list, const char *what) -{ - char *copy = xstrdup(spec), *p = copy, *q; - const struct systab *sys; - size_t n; - - for (;;) { - n = strcspn(p, ","); - if (p[n]) q = p + n + 1; - else q = 0; - p[n] = 0; sys = find_system(p); - if (list->f&sys->f) { - if (arg->verbose > 0) - moan("ignoring duplicate system `%s' in %s list", p, what); - } else { - list->sys[list->n++] = sys; - list->f |= sys->f; - } - if (!q) break; - p = q; - } - free(copy); -} - -static void push_eval_op(struct argstate *arg, char op, const char *val) +static void push_eval_op(char op, const char *val) { char *p; size_t n; - if (arg->f&F_AUX) { + if ((flags&AF_STATEMASK) != AF_CMDLINE) { moan("must use `-e', `-p', or `-l' on command line"); - arg->f |= F_BOGUS; + flags |= AF_BOGUS; return; } n = strlen(val) + 1; p = xmalloc(n + 1); p[0] = op; memcpy(p + 1, val, n); - argv_append(&arg->av, p); + argv_append(&argv_tail, p); } -/* Parse a vector ARGS of command-line arguments. Update ARG with the - * results. NARG is the number of arguments, and *I_INOUT is the current - * index into the vector, to be updated on exit to identify the first - * non-option argument (or the end of the vector). - */ -static void parse_arguments(struct argstate *arg, const char *const *args, - size_t nargs, size_t *i_inout) +static void parse_options(int argc, char *argv[]) { - const char *o, *a; - char opt; - - for (;;) { - if (*i_inout >= nargs) break; - o = args[*i_inout]; - if (STRCMP(o, ==, "--help")) { help(stdout); exit(0); } - else if (STRCMP(o, ==, "--version")) { version(stdout); exit(0); } - if (!*o || *o != '-' || !o[1]) break; - (*i_inout)++; - if (STRCMP(o, ==, "--")) break; - o++; - while (o && *o) { - opt = *o++; - switch (opt) { - -#define GETARG do { \ - if (*o) \ - { a = o; o = 0; } \ - else { \ - if (*i_inout >= nargs) goto noarg; \ - a = args[(*i_inout)++]; \ - } \ -} while (0) - - case 'C': arg->pref.n = 0; arg->pref.f = 0; break; - case 'D': arg->f |= F_NODUMP; break; - case 'E': arg->f |= F_NOEMBED; break; - case 'e': GETARG; push_eval_op(arg, '!', a); break; - case 'p': GETARG; push_eval_op(arg, '?', a); break; - case 'l': GETARG; push_eval_op(arg, '<', a); break; - case 'n': arg->f |= F_NOACT; break; - case 'q': if (arg->verbose) arg->verbose--; break; - case 'v': arg->verbose++; break; - - case 'I': - free(arg->imagedir); - GETARG; arg->imagedir = xstrdup(a); - break; - - case 'L': - GETARG; - parse_syslist(a, arg, &arg->allow, "allowed"); - break; - - case 'P': - GETARG; - parse_syslist(a, arg, &arg->pref, "preferred"); - break; - - default: - moan("unknown option `%c'", opt); - arg->f |= F_BOGUS; - break; - -#undef GETARG - - } - } - } - goto end; - -noarg: - moan("missing argument for `-%c'", opt); - arg->f |= F_BOGUS; -end: - return; -} - -/* Parse a string P into words (destructively), and process them as - * command-line options, updating ARG. Non-option arguments are not - * permitted. If `SOSF_EMACS' is set in FLAGS, then ignore `-*- ... -*-' - * editor turds. If `SOSF_ENDOK' is set, then accept `--' and ignore - * whatever comes after; otherwise, reject all positional arguments. - */ -#define SOSF_EMACS 1u -#define SOSF_ENDOK 2u -static void scan_options_from_string(char *p, struct argstate *arg, - unsigned flags, - const char *what, const char *file) -{ - struct argv av = ARGV_INIT; - char *q; - size_t i; - int st = 0; - unsigned f = 0; -#define f_escape 1u + 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' }, + { "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 } + }; + + optarg = 0; optind = 0; optprog = (/*unconst*/ char *)progname; for (;;) { - while (ISSPACE(*p)) p++; - if (!*p) break; - if ((flags&SOSF_EMACS) && p[0] == '-' && p[1] == '*' && p[2] == '-') { - p = strstr(p + 3, "-*-"); - if (!p) lose("unfinished local-variables list in %s `%s'", what, file); - p += 3; continue; - } - if ((flags&SOSF_ENDOK) && - p[0] == '-' && p[1] == '-' && (!p[2] || ISSPACE(p[2]))) - break; - argv_append(&av, p); q = p; - for (;;) { - if (!*p) break; - else if (f&f_escape) { *q++ = *p; f &= ~f_escape; } - else if (st && *p == st) st = 0; - else if (st != '\'' && *p == '\\') f |= f_escape; - else if (!st && (*p == '"' || *p == '\'')) st = *p; - else if (!st && ISSPACE(*p)) break; - else *q++ = *p; - p++; + 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 '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; + default: flags |= AF_BOGUS; break; } - if (*p) p++; - *q = 0; - if (f&f_escape) lose("unfinished escape in %s `%s'", what, file); - if (st) lose("unfinished `%c' string in %s `%s'", st, what, file); } - - i = 0; parse_arguments(arg, av.v, av.n, &i); - if (i < av.n) - lose("positional argument `%s' in %s `%s'", av.v[i], what, file); - argv_release(&av); - -#undef f_escape } -/* Read SCRIPT, and check for a `@RUNLISP:' marker in the second line. If - * there is one, parse options from it, and update ARG. - */ -static void check_for_embedded_args(const char *script, struct argstate *arg) +static void handle_embedded_args(const char *script) { struct dstr d = DSTR_INIT; - char *p; + struct argv av = ARGV_INIT; + char *p, *q, *r; const char *l; + size_t n; + int qstate = 0; FILE *fp = 0; fp = fopen(script, "r"); @@ -1046,203 +276,173 @@ static void check_for_embedded_args(const char *script, struct argstate *arg) if (dstr_readline(&d, fp)) goto end; dstr_reset(&d); if (dstr_readline(&d, fp)) goto end; - p = strstr(d.p, "@RUNLISP:"); - if (p) - scan_options_from_string(p + 9, arg, SOSF_EMACS | SOSF_ENDOK, - "embedded options in script", script); - -end: - if (fp) { - if (ferror(fp)) - lose("error reading script `%s': %s", script, strerror(errno)); - fclose(fp); - } - dstr_release(&d); -} - -/* Read the file PATH (if it exists) and update ARG with the arguments parsed - * from it. Ignore blank lines and (Unix- or Lisp-style) comments. - */ -static void read_config_file(const char *path, struct argstate *arg) -{ - FILE *fp = 0; - struct dstr d = DSTR_INIT; - char *p; + p = strstr(d.p, "@RUNLISP:"); if (!p) goto end; + p += 9; q = p; l = d.p + d.len; + for (;;) { + while (p < l && ISSPACE(*p)) p++; + if (p >= l) break; + 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 (l - p >= 2 && p[0] == '-' && p[1] == '-' && + (l == p + 2 || ISSPACE(p[2]))) + break; - fp = fopen(path, "r"); - if (!fp) { - if (errno == ENOENT) { - if (arg->verbose > 2) - moan("ignoring nonexistent configuration file `%s'", path); - goto end; + argv_append(&av, q); + while (p < l && (qstate || !ISSPACE(*p))) { + if (*p == '"') { p++; qstate = !qstate; } + else if (*p == '\\') { + p++; if (p >= l) lose("%s:2: unfinished `\\' escape", script); + *q++ = *p++; + } else if (*p == '\'') { + 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 { + n = strcspn(p, qstate ? "\"\\" : "\"'\\ \f\n\r\t\v"); + if (n > l - p) n = l - p; + memmove(q, p, n); q += n; p += n; + } } - lose("failed to open configuration file `%s': %s", - path, strerror(errno)); - } - if (arg->verbose > 1) - moan("reading configuration file `%s'", path); - for (;;) { - dstr_reset(&d); - if (dstr_readline(&d, fp)) break; - p = d.p; - while (ISSPACE(*p)) p++; - if (!*p || *p == ';' || *p == '#') continue; - scan_options_from_string(p, arg, 0, "configuration file `%s'", path); + if (qstate) lose("%s:2: missing `\"'", script); + if (p < l) p++; + *q++ = 0; } - if (arg->f&F_BOGUS) - lose("invalid options in configuration file `%s'", path); + + 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: if (fp) { if (ferror(fp)) - lose("error reading configuration file `%s': %s", - path, strerror(errno)); + lose("error reading script `%s': %s", script, strerror(errno)); fclose(fp); } - dstr_release(&d); + dstr_release(&d); argv_release(&av); } 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; struct dstr d = DSTR_INIT; - const char *script, *p; - const char *home; - struct passwd *pw; - char *t; - size_t i, n; - struct argstate arg = ARGSTATE_INIT; - - /* Scan the command line. This gets low priority, since it's probably - * from the script shebang. - */ - set_progname(argv[0]); i = 1; - parse_arguments(&arg, (const char *const *)argv, argc, &i); - arg.f |= F_AUX; - if ((i >= argc && !arg.av.n) || (arg.f&F_BOGUS)) - { usage(stderr); exit(255); } - - /* Prepare the argument vector. Keep track of the number of arguments - * here: we'll need to refer to this later. - */ - if (!arg.av.n) { - script = argv[i++]; - if (!(arg.f&F_NOEMBED)) check_for_embedded_args(script, &arg); - if (arg.f&F_BOGUS) - lose("invalid options in `%s' embedded option list", script); - } else { - script = getenv("RUNLISP_EVAL"); - if (!script) script = DATADIR "/eval.lisp"; - argv_append(&arg.av, "--"); - } - argv_appendn(&arg.av, (const char *const *)argv + i, argc - i); - n = arg.av.n; + struct argv av = ARGV_INIT; - /* Find the user's home directory. (Believe them if they set something - * strange.) - */ - home = getenv("HOME"); - if (!home) { - pw = getpwuid(getuid()); - if (!pw) lose("can't find user in password database"); - home = pw->pw_dir; - } + set_progname(argv[0]); - /* Check user configuration file `~/.runlisprc'. */ - dstr_reset(&d); - dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".runlisprc"); - read_config_file(d.p, &arg); + init_config(); + config_set_var(&config, toplevel, 0, "prefer", "${@ENV:RUNLISP_PREFER?}"); - /* Check user configuration file `~/.config/runlisprc'. */ - dstr_reset(&d); - p = getenv("XDG_CONFIG_HOME"); - if (p) - dstr_puts(&d, p); - else - { dstr_puts(&d, home); dstr_putc(&d, '/'); dstr_puts(&d, ".config"); } - dstr_putc(&d, '/'); dstr_puts(&d, "runlisprc"); - read_config_file(d.p, &arg); + flags = (flags&~AF_STATEMASK) | AF_CMDLINE; + parse_options(argc - 1, argv + 1); optind++; - /* Finally, check the environment variables. */ - p = getenv("RUNLISP_OPTIONS"); - if (p) { - t = xstrdup(p); - scan_options_from_string(t, &arg, 0, - "environment variable", "RUNLISP_OPTIONS"); - free(t); - } - if (arg.f&F_BOGUS) - lose("invalid options in environment variable `RUNLISP_OPTIONS'"); - if (!arg.imagedir) { - arg.imagedir = getenv("RUNLISP_IMAGEDIR"); - if (!arg.imagedir) arg.imagedir = IMAGEDIR; + if (argv_tail.n) + flags |= AF_NOEMBED; + else if (!script && !argv_tail.n) { + if (optind < argc) script = argv[optind]++; + else flags |= AF_BOGUS; } - /* If no systems are listed as acceptable, try them all. */ - if (!arg.allow.n) { - if (arg.verbose > 1) - moan("no explicitly allowed implementations: allowing all"); - for (i = 0; i < NSYS; i++) arg.allow.sys[i] = &systab[i]; - arg.allow.n = NSYS; arg.allow.f = (1u << NSYS) - 1; + 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; } - /* Print what we're going to do. */ - if (arg.verbose > 2) { - dstr_reset(&d); p = ""; - for (i = 0; i < arg.allow.n; i++) - { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); } - moan("permitted Lisps: %s", d.p); + if (flags&AF_BOGUS) { usage(stderr); exit(2); } + if (!(flags&AF_NOEMBED)) handle_embedded_args(script); + if (!(flags&AF_SETCONF)) load_default_config(); + if (verbose >= 5) dump_config(); - dstr_reset(&d); p = ""; - for (i = 0; i < arg.pref.n; i++) - { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); } - moan("preferred Lisps: %s", d.p); + 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)); - dstr_reset(&d); p = ""; - for (i = 0; i < arg.pref.n; i++) - if (arg.pref.sys[i]->f&arg.allow.f) - { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.pref.sys[i]->name); } - for (i = 0; i < arg.allow.n; i++) - if (!(arg.allow.sys[i]->f&arg.pref.f)) - { dstr_puts(&d, p); p = ", "; dstr_puts(&d, arg.allow.sys[i]->name); } - moan("overall preference order: %s", d.p); - } + if (!script) + script = config_subst_string_alloc + (&config, common, "", + "${@ENV:RUNLISP_EVAL?${@CONFIG:data-dir}/eval.lisp}"); - /* Inform `uiop' of the script name. - * - * 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); + + 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; + + check_lisps("acceptable", &accept, offsetof(struct lispsys, next_accept)); + check_lisps("preferred", &prefer, offsetof(struct lispsys, next_prefer)); + + 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; + } - /* Work through the list of preferred Lisp systems, trying the ones which - * are allowed. - */ - for (i = 0; i < arg.pref.n; i++) - if (arg.pref.sys[i]->f&arg.allow.f) { - arg.av.o += arg.av.n - n; arg.av.n = n; - arg.pref.sys[i]->run(&arg, script); - } + 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; + + 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)); + } - /* That didn't work. Try the remaining allowed systems, in the given - * order. - */ - for (i = 0; i < arg.allow.n; i++) - if (!(arg.allow.sys[i]->f&arg.pref.f)) { - arg.av.o += arg.av.n - n; arg.av.n = n; - arg.allow.sys[i]->run(&arg, script); + for (lisp = order.head; lisp; lisp = lisp->next_order) { + if (config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) { + var = config_find_var(&config, lisp->sect, CF_INHERIT, "image-path"); + 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"); } + 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); + if (!try_exec(&av, + (flags&AF_DRYRUN ? TEF_DRYRUN : 0) | + (verbose >= 2 ? TEF_VERBOSE : 0))) + return (0); + } - /* No joy. Give up. */ - argv_release(&arg.av); - lose("no supported Lisp systems found"); + lose("no acceptable Lisp systems found"); } /*----- That's all, folks -------------------------------------------------*/ diff --git a/runlisp.conf b/runlisp.conf new file mode 100644 index 0000000..d2bad4e --- /dev/null +++ b/runlisp.conf @@ -0,0 +1,299 @@ +;;; -*-conf-windows-*- + +;; Summary of syntax. +;; +;; Sections are started with a line `[NAME]', starting in the leftmost +;; column. Empty lines and lines starting with `;' -- /without/ preceding +;; whitespace -- are ignored. Assignments have the form `VAR = VALUE'; the +;; VALUE may be continued across multiple lines, if they begin with +;; whitespace. All of the lines are stripped of initial and final whitespace +;; and concatenated with spaces. +;; +;; Values may contain substitutions: +;; +;; * ${[SECTION:]VAR[?ALT]} -- replace with the value of VAR in SECTION; if +;; not found, use ALT instead. (If ALT isn't provided, it's an error.) +;; +;; * $?[SECTION:]VAR{YES[|NO]} -- look up VAR in SECTION (or in the +;; (original) current section, and `@COMMON'); if found, use YES, +;; otherwise use NO. +;; +;; Variables are looked up starting in the home (or explicitly specified) +;; section, then proceeding to the parents assigned to `@PARENTS'. +;; (`@PARENTS' usually defaults to `@COMMON'; the parent of `@COMMON' is +;; `@BUILTIN'; `@BUILTIN' and `@CONFIG' have no parents.) +;; +;; At top-level, the text is split into words at whitespace, unless prevented +;; by double- and single-quote, or escaped by `\'. Within single quotes, all +;; characters are treated literally. Within double quotes, `\' and `$' still +;; works. A variable reference within quotes, or within a word, suppresses +;; word-splitting and quoting, within the variable value -- but `$' +;; expansions still work. + +;;;-------------------------------------------------------------------------- +[@COMMON] + +;; Turn `#!' into a comment-to-end-of-line. This is used in all Lisp +;; invocations, even though some of them don't apparently need it. For +;; example, SBCL ignores an initial line beginning `#!' as a special feature +;; of its `--script' option. Other Lisps won't do this, so a countermeasure +;; like the following is necessary in their case. For the sake of a +;; consistent environment, we ignore `#!' lines everywhere, even in Lisps +;; which have their own, more specific, solution to this problem. +ignore-shebang = + (set-dispatch-macro-character + #\\# #\\! + (lambda (#1=#:stream #2=#:char #3=#:arg) + (declare (ignore #2# #3#)) + (values (read-line #1#)))) + +;; Clear all present symbols from the `COMMON-LISP-USER' package. Some Lisps +;; leave débris in `COMMON-LISP-USER' -- for example, ECL leaves some +;; allegedly useful symbols lying around, while ABCL has a straight-up bug in +;; its `adjoin.lisp' file. +clear-cl-user = + (let ((#4=#:pkg (find-package "COMMON-LISP-USER"))) + (with-package-iterator (#5=#:next #4# :internal) + (loop (multiple-value-bind (#6=#:anyp #7=#:sym #8=#:how) + (#5#) + (declare (ignore #8#)) + (unless #6# (return)) + (unintern #7# #4#))))) + +;; Add `:runlisp-script' to `*features*' so that scripts can tell whether +;; they're supposed to sit quietly and be debugged in a Lisp session or run +;; as a script. +set-script-feature = + (pushnew :runlisp-script *features*) + +;; Load the system's ASDF. +require-asdf = + (require "asdf") + +;; Prevent ASDF from upgrading itself. Otherwise it will do this +;; automatically if a script invokes `asdf:load-system', but that will have a +;; bad effect on startup time, and risks spamming the output streams with +;; drivel. +inhibit-asdf-upgrade = + (funcall (intern "REGISTER-IMMUTABLE-SYSTEM" + (find-package "ASDF")) + "asdf") + +;; Upgrade ASDF from the source registry. +upgrade-asdf = + (funcall (intern "UPGRADE-ASDF" (find-package "ASDF"))) + +;; Common actions when resuming a custom image. +image-restore = + (uiop:call-image-restore-hook) + +;; Common prelude for script startup in vanilla images. Most of this is +;; already done in custom images. +run-script-prelude = + (progn + (setf *load-verbose* nil *compile-verbose* nil) + ${require-asdf} + ${inhibit-asdf-upgrade} + ${ignore-shebang} + ${set-script-feature}) + +;; Common prelude for dumping images. +dump-image-prelude = + (progn + ${require-asdf} + ${upgrade-asdf} + ${inhibit-asdf-upgrade} + ${ignore-shebang} + ${set-script-feature}) + +image-path = ${@CONFIG:image-dir}/${image-file} + +;;;-------------------------------------------------------------------------- +[sbcl] + +command = ${@ENV:SBCL?sbcl} +image-file = sbcl+asdf.core + +run-script = + ${command} --noinform + $?@IMAGE{--core "${image-path}" --eval "${image-restore}" | + --eval "${run-script-prelude}"} + --script ${@SCRIPT} + +dump-image = + ${command} --noinform --no-userinit --no-sysinit --disable-debugger + --eval "${dump-image-prelude}" + --eval "(sb-ext:save-lisp-and-die \"${@IMAGE|q}\")" + + +;;;-------------------------------------------------------------------------- +[ccl] + +command = ${@ENV:CCL?ccl} +image-file = ccl+asdf.image + +run-script = + ${command} -b -n -Q + $?@IMAGE{-I "${image-path}" -e "${image-restore}" | + -e "${run-script-prelude}"} + -l ${@SCRIPT} -e "(ccl:quit)" -- + +;; A snaglet occurs here. CCL wants to use the image name as a clue to where +;; the rest of its installation is; but in fact the image is nowhere near its +;; installation. So we must hack... +dump-image = + ${command} -b -n -Q + -e "${dump-image-prelude}" + -e "(ccl::in-development-mode + (let ((#1=#:real-ccl-dir (ccl::ccl-directory))) + (defun ccl::ccl-directory () + (let* ((#2=#:dirpath + (ccl:getenv \"CCL_DEFAULT_DIRECTORY\"))) + (if (and #2# (plusp (length (namestring #2#)))) + (ccl::native-to-directory-pathname #2#) + #1#)))) + (compile 'ccl::ccl-directory))" + -e "(ccl:save-application \"${@IMAGE|q}\" + :init-file nil + :error-handler :quit)" + +;;;-------------------------------------------------------------------------- +[clisp] + +;; CLisp causes much sadness. Superficially, it's the most sensible of all +;; of the systems supported here: you just run `clisp SCRIPT -- ARGS ...' and +;; it works. +;; +;; The problems come when you want to do some preparatory work (e.g., load +;; `asdf') and then run the script. There's a `-x' option to evaluate some +;; Lisp code, but it has three major deficiencies. +;; +;; * It insists on printing the values of the forms it evaluates. It +;; prints a blank line even if the form goes out of its way to produce no +;; values at all. So the whole thing has to be a single top-level form +;; which quits the Lisp rather than returning. +;; +;; * For some idiotic reason, you can have /either/ `-x' forms /or/ a +;; script, but not both. So we have to include the `load' here +;; explicitly. I suppose that was inevitable because we have to inhibit +;; printing of the result forms, but it's still a separate source of +;; annoyance. +;; +;; * The icing on the cake: the `-x' forms are collectively concatenated -- +;; without spaces! -- and used to build a string stream, which is then +;; assigned over the top of `*standard-input*', making the original stdin +;; somewhat fiddly to track down. +;; +;; There's a `-i' option which will load a file without any of this +;; stupidity, but nothing analogous for immediate expressions. + +clisp-common-startup = + (setf *standard-input* (ext:make-stream :input)) + (load "${@SCRIPT|q}" :verbose nil :print nil) + (ext:quit) + +command = ${@ENV:CLISP?clisp} +image-file = clisp+asdf.mem + +run-script = + ${command} + $?@IMAGE{-M "${image-path}" -q + -x "(progn + ${image-restore} + ${clisp-common-startup})" | + -norc -q + -x "(progn + ${run-script-prelude} + ${clisp-common-startup})"} + -- + +dump-image = + ${command} -norc -q -q + -x "${dump-image-prelude}" + -x "(ext:saveinitmem \"${@IMAGE|q}\" :norc t :script t)" + +;;;-------------------------------------------------------------------------- +[ecl] + +command = ${@ENV:ECL?ecl} +image-file = ecl+asdf + +run-script = + $?@IMAGE{"${image-path}" -s ${@SCRIPT} | + ${@ENV:ECL?ecl} "${@ECLOPT}norc" + "${@ECLOPT}eval" "(progn + ${run-script-prelude} + ${clear-cl-user})" + "${@ECLOPT}shell" ${@SCRIPT}} + -- + +dump-image = + "${@CONFIG:data-dir}/dump-ecl" + "${@IMAGE}" "${command}" "${@ECLOPT}" "${@TMPDIR}" + +;;;-------------------------------------------------------------------------- +[cmucl] + +command = ${@ENV:CMUCL?cmucl} +image-file = cmucl+asdf.core + +run-script = + ${command} + $?@IMAGE{-core "${image-path}" -eval "${image-restore}" | + -batch -noinit -nositeinit -quiet + -eval "(progn + (setf ext:*require-verbose* nil) + ${run-script-prelude})"} + -load ${@SCRIPT} -eval "(ext:quit)" -- + +dump-image = + ${command} -batch -noinit -nositeinit -quiet + -eval "${dump-image-prelude}" + -eval "(ext:save-lisp \"${@IMAGE|q}\" + :batch-mode t :print-herald nil + :site-init nil :load-init-file nil)" + +;;;-------------------------------------------------------------------------- +[abcl] + +;; CLisp made a worthy effort, but ABCL still manages to take the prize. +;; +;; * ABCL manages to avoid touching the `stderr' stream at all, ever. Its +;; startup machinery finds `stdout' (as `java.lang.System.out'), wraps it +;; up in a Lisp stream, and uses the result as `*standard-output*' and +;; `*error-output*' (and a goodly number of other things too). So we +;; must manufacture a working `stderr' the hard way. +;; +;; * There doesn't appear to be any easy way to prevent toplevel errors +;; from invoking the interactive debugger. For extra fun, the debugger +;; reads from `stdin' by default, so an input file which somehow manages +;; to break the script can then take over its brain by providing Lisp +;; forms for the debugger to evaluate. +;; +;; * And, just to really top everything off, ABCL's `adjoin.lisp' is +;; missing an `(in-package ...)' form at the top, so it leaks symbols +;; into the `COMMON-LISP-USER' package. + +command = ${@ENV:ABCL?abcl} + +abcl-startup = + (let ((#9=#:script "${@SCRIPT|q}")) + ${run-script-prelude} + ${clear-cl-user} + (setf *error-output* + (java:jnew "org.armedbear.lisp.Stream" + \'sys::system-stream + (java:jfield "java.lang.System" "err") + \'character + java:+true+)) + (handler-case (load #9# :verbose nil :print nil) + (error (error) + (format *error-output* "~A (unhandled error): ~A~%" #9# error) + (ext:quit :status 255)))) + +run-script = + ${command} --batch --noinform --noinit --nosystem + --eval "${abcl-startup}" + -- + +;;;----- That's all, folks --------------------------------------------------