From: Mark Wooding Date: Mon, 31 Aug 2020 03:13:52 +0000 (+0100) Subject: @@@ more wip X-Git-Url: https://git.distorted.org.uk/~mdw/runlisp/commitdiff_plain/8996f767e047eefa8af4d01b1434b54f4c169b79 @@@ more wip --- diff --git a/Makefile.am b/Makefile.am index 42cb2e1..9bb717c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -26,7 +26,6 @@ include $(top_srcdir)/vars.am SUBDIRS = -pkgdata_DATA = image_DATA = image_SCRIPTS = @@ -35,18 +34,28 @@ SUBDIRS += . ACLOCAL_AMFLAGS = -Im4 ###-------------------------------------------------------------------------- +### A library of common code. + +noinst_LIBRARIES += librunlisp.a +librunlisp_a_SOURCES = + +librunlisp_a_SOURCES += common.c common.h +librunlisp_a_SOURCES += lib.c lib.h +librunlisp_a_SOURCES += mdwopt.c mdwopt.h + +###-------------------------------------------------------------------------- ### The main driver program. 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 +runlisp_LDADD = librunlisp.a man_MANS += runlisp.1 +doc_DATA += runlisp.pdf +EXTRA_DIST += runlisp.1 noinst_PROGRAMS += old-runlisp old_runlisp_SOURCES = old-runlisp.c -old_runlisp_SOURCES += lib.c lib.h +old_runlisp_LDADD = librunlisp.a noinst_PROGRAMS += toy toy_SOURCES = toy.c @@ -58,18 +67,47 @@ toy_SOURCES += lib.c lib.h pkgdata_DATA += eval.lisp EXTRA_DIST += eval.lisp +pkgdata_DATA += dump-ecl +EXTRA_DIST += dump-ecl + +bin_PROGRAMS += query-runlisp-config +query_runlisp_config_SOURCES = query-runlisp-config.c +query_runlisp_config_LDADD = librunlisp.a +man_MANS += query-runlisp-config.1 +doc_DATA += query-runlisp-config.pdf + +man_MANS += runlisp.conf.5 +doc_DATA += runlisp.conf.pdf + +EXTRA_DIST += runlisp-base.conf +install-data-hook:: + $(MKDIR_P) $(DESTDIR)$(pkgconfdir)/runlisp.d + cp $(srcdir)/runlisp-base.conf \ + $(DESTDIR)$(pkgconfdir)/runlisp.d/0base.conf +uninstall-hook:: + rm -f $(DESTDIR)$(pkgconfdir)/runlisp.d/0base.conf + +EXTRA_DIST += runlisp.conf +install-data-hook:: + $(MKDIR_P) $(DESTDIR)$(pkgconfdir) + if ! [ -f $(DESTDIR)$(pkgconfdir)/runlisp.conf ]; then \ + cp $(srcdir)/runlisp.conf $(DESTDIR)$(pkgconfdir)/; \ + fi +uninstall-hook:: + rm -f $(DESTDIR)$(pkgconfdir)/runlisp.conf + ###-------------------------------------------------------------------------- ### Image dumping. 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 +dump_runlisp_image_LDADD = librunlisp.a man_MANS += dump-runlisp-image.1 +doc_DATA += dump-runlisp-image.pdf +EXTRA_DIST += dump-runlisp-image.1 DUMP_RUNLISP_IMAGE = $(v_dump)./dump-runlisp-image \ - -f -c$(srcdir)/runlisp.conf -O$@ + -f -c$(srcdir)/runlisp-base.conf -O$@ v_dump = $(v_dump_@AM_V@) v_dump_ = $(v_dump_@AM_DEFAULT_V@) @@ -78,47 +116,52 @@ v_dump_0 = @echo " DUMP $@"; if DUMP_SBCL image_DATA += sbcl+asdf.core CLEANFILES += sbcl+asdf.core -sbcl+asdf.core: dump-runlisp-image runlisp.conf +sbcl+asdf.core: dump-runlisp-image runlisp-base.conf $(DUMP_RUNLISP_IMAGE) sbcl endif if DUMP_CCL image_DATA += ccl+asdf.image CLEANFILES += ccl+asdf.image -ccl+asdf.image: dump-runlisp-image runlisp.conf +ccl+asdf.image: dump-runlisp-image runlisp-base.conf $(DUMP_RUNLISP_IMAGE) ccl endif if DUMP_CLISP image_DATA += clisp+asdf.mem CLEANFILES += clisp+asdf.mem -clisp+asdf.mem: dump-runlisp-image runlisp.conf +clisp+asdf.mem: dump-runlisp-image runlisp-base.conf $(DUMP_RUNLISP_IMAGE) clisp endif if DUMP_ECL image_SCRIPTS += ecl+asdf CLEANFILES += ecl+asdf -ecl+asdf: dump-runlisp-image runlisp.conf +ecl+asdf: dump-runlisp-image runlisp-base.conf dump-ecl $(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 runlisp.conf +cmucl+asdf.core: dump-runlisp-image runlisp-base.conf $(DUMP_RUNLISP_IMAGE) cmucl endif ###-------------------------------------------------------------------------- -### Benchmarking and testing. +### Other subdirectories. +## Documentation. +SUBDIRS += doc + +## Testing. +SUBDIRS += t + +## Benchmarking. if BENCHMARK SUBDIRS += bench endif -SUBDIRS += t - ###-------------------------------------------------------------------------- ### Distribution. diff --git a/README.org b/README.org index 0465005..91f3ef8 100644 --- a/README.org +++ b/README.org @@ -18,12 +18,15 @@ Currently, the following Lisp implementations are supported: + Embeddable Common Lisp (~ecl~), and + Steel Bank Common Lisp (~sbcl~). -I'm happy to take patches to support additional free Lisp -implementations. I'm not interested in supporting non-free Lisp -systems. +Adding more Lisps is simply a matter of writing the necessary runes in a +configuration file. Of course, there's a benefit to having a collection +of high-quality configuration runes curated centrally, so I'm happy to +accept submissions in support of any free[fn:free] Lisp implementations. +[fn:free] Here I mean free as in freedom. -* Writing scripts in Lisp + +* Writing scripts in Common Lisp ** Basic use @@ -197,55 +200,193 @@ meaningful. (Currently, it reveals the name of the script which ** Where =runlisp= looks for configuration You can influence which Lisp implementations are chosen by ~runlisp~ by -writing a configuration file, and/or setting an environment variable. +writing configuration files, and/or setting environment variables. -~runlisp~ looks for configuration in ~~/.runlisprc~, and in -~~/.config/runlisprc~. You could put configuration in both, but that -doesn't seem like a great idea. A configuration file just contains -blank lines, comments, and command-line options, just as you'd write -them to the shell. Simple quoting and escaping is provided: see the -manual page for the full details. Each line is processed independently, -so it doesn't work to write an option on one line and then its argument -on the next. +The ~runlisp~ program looks for configuration in a number of places. -The environment variable ~RUNLISP_OPTIONS~ is processed /after/ reading -the configuration file(s), if any. Again, it should contain -command-line options, as you'd write them to the shell. + + There's a system-global directory ~SYSCONFDIR/runlisp/runlisp.d/~. + All of the files in this directory named ~SOMETHING.conf~ are read, + in increasing lexicographical order by name. The package comes with + a file ~0base.conf~ intended to be read first, so that it can be + overridden if necessar. This sets up basic definitions, and defines + the necessary runes for those Lisp implementations which are + supported `out of the box'. New Lisp packages might come with + additional files to drop into this directory. -** Deciding which Lisp implementation to use + + There's a system-global file ~SYSCONFDIR/runlisp/runlisp.conf~ which + is intended to be edited by the system administrator to account for + any local quirks. This is read /after/ the directory, which is + intended to be used by distribution packages, so that the system + administrator can override them. + + + Users can create files ~$HOME/.runlisp.conf~ and/or + ~$HOME/.config/runlisp.conf~[fn:xdg-config] in their home + directories to add support for privately installed Lisp systems, or + to override settings made by earlier configuration files. + +The configuration syntax is complicated, and explained in detail in the +*runlisp.conf* manpage. -The most useful option to use here is ~-P~, which builds up a -/preference list/, in order. The argument to ~-P~ is a comma-separated -list of Lisp implementation names, just like you'd give to ~-L~. +Configuration options can also be set on the command line, though the +effects are subtly different. Again, see the manual pages for details. + +[fn:xdg-config] More properly, in ~$XDG_CONFIG_HOME/runlisp.conf~, if +you set that. + + +** Deciding which Lisp implementation to use -If you provide multiple ~-P~ options (e.g., on different lines of your -configuration file, or separately in the configuration file and -environment variable, then the lists are concatenated. Since the -environment variable is processed after the configuration file, this -means that +The ~prefer~ option specifies a /preference list/ of Lisp +implementations. The value is a list of Lisp implementation names, as +you'd give to ~-L~, separated by commas and/or spaces. If the +environment variable ~RUNLISP_PREFER~ is set, then this overrides any +value found in the configuration files. When deciding which Lisp implementation to use, ~runlisp~ works as follows. It builds a list of /acceptable/ Lisp implementations from the -~-L~ options, and a list of /preferred/ Lisp implementations from the -~-P~ options. If there aren't any ~-L~ options, then it assumes that -/all/ Lisp implementations are acceptable; but if there are no ~-P~ -options then it assumes that /no/ Lisp implementations are preferred. -It then works through the preferred list in order: if it finds an -implementation which is installed and acceptable, then it uses that one. -If that doesn't work, then it works through the acceptable -implementations that it hasn't tried yet, in order, and if it finds one -of those that's installed, then it runs that one. Otherwise it reports -an error and gives up. - -** Clearing the preferred list - -Since the environment variable is processed after the configuration -files, it can only append more Lisp implementations to the end of the -preferred list, which may well not be so helpful. There's an additional -option ~-C~, which completely clears the preferred list. The idea is -that you can write ~-C~ at the start of your ~RUNLISP_OPTIONS~ -environment variable to temporarily override your usual configuration -for some special effect. +~-L~ command-line option, and a list of /preferred/ Lisp implementations +from the ~prefer~ configuration option (or environment variable). If +there aren't any ~-L~ options, then it assumes that /all/ Lisp +implementations are acceptable; if no ~prefer~ option is set then it +assumes that /no/ Lisp implementations are preferred. It then works +through the preferred list in order: if it finds an implementation which +is installed and acceptable, then it uses that one. If that doesn't +work, then it works through the acceptable implementations that it +hasn't tried yet, in order, and if it finds one of those that's +installed, then it runs that one. Otherwise it reports an error and +gives up. + + +** Supporting new Lisp implementations + +~runlisp~ tries hard to make adding support for a new Lisp as painless +as possible. An awkward Lisp will of course cause trouble, but +~runlisp~ itself is easy. + +As a simple example, let's add support for the 32-bit version of +Clozure~CL. The source code for Clozure~CL easily builds both 32- and +64-bit binaries in either 32- or 64-bit userlands, and one might +reasonably want to use the 32-bit CCL for some reason. The following +configuration stanza is sufficient + +: [ccl32] +: @PARENTS = ccl +: command = ${@ENV:CCL32?ccl32} +: image-file = ccl32+asdf.image + + + The first line heads a configuration section, providing the name + which will be used for this Lisp implementation, e.g., in ~-L~ + options or ~prefer~ lists. + + + The second line tells ~runlisp~ that configuration settings not + found in this section should be looked up in the ~ccl~ section + instead. + + + The third line defines the command to be used to invoke the Lisp + system. It tries to find an environment variable named ~CCL32~, + falling back to looking up ~ccl32~ in the path otherwise. + +And, err..., that's it. The ~@PARENTS~ setting uses the detailed +command-line runes for ~ccl~, so they don't need to be written out +again. + +That was rather anticlimactic, because all of the work got done +somewhere else. So let's look at a complete example: Steel Bank Common +Lisp. (SBCL's command-line interface is well thought-out, so this is an +ideal opportunity to explain how ~runlisp~ configuration works, without +getting bogged down in the details of fighting less amenable Lisps.) + +The provided ~0base.conf~ file defines SBCL as follows. + +: [sbcl] +: +: command = ${@ENV:SBCL?sbcl} +: image-file = ${@NAME}+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 \"${@IMAGENEW|q}\")" + +Let's take this in slightly larger pieces. + + + We see the ~[sbcl]~ section heading, and the ~command~ setting + again. These should now be unsurprising. + + + There's no ~@PARENTS~ setting, so by default the ~sbcl~ section + inherits settings from the ~@COMMON~ section, defined in + ~0base.conf~. We shall use a number of definitions from this + section. + + + The ~image-file~ gives the name of the custom image file to look for + when trying to start SBCL, but not the directory. (The directory is + named by the ~image-dir~ configuration setting.) The image file + will be named ~sbcl+asdf.core~, but this isn't what's written. + Instead, it uses ~${@NAME}~, which is replaced by the name of the + section being processed. When we're running SBCL, this does the + same thing; but if someone wants to configure a new ~foo~ Lisp and + set ~@PARENTS~ to ~sbcl~, then the image file for ~foo~ will be + named ~foo+asdf.core~ by default. You needn't take such care when + configuring Lisp implementations for your own purposes, but it's + important for configurations which will be widely used. + + + The ~run-script~ setting explains how to get SBCL to run a script. + This string is broken into words at (unquoted) spaces. + + The syntax ~$?VAR{CONSEQ|ALT}~ means: if a configuration setting + ~VAR~ is defined, then expand to ~CONSEQ~; otherwise, expand to + ~ALT~. In this case, if the magic setting ~@IMAGE~ is defined, then + we add the tokens ~--core "${image-path}" --eval "${image-restore}"~ + to the SBCL command line; otherwise, we add ~--eval + "${run-script-prelude}"~. The ~@IMAGE~ setting is defined by + ~runlisp~ only if (a)~a custom image was found in the correct placem + and (b)~use of custom images isn't disabled on its command line. + + The ~${image-path}~ token expands to the full pathname to the custom + image file; ~image-restore~ is a predefined Lisp expression to be + run when starting from a dumped image (e.g., to get ASDF to refresh + its idea of which systems are available). + + The ~run-script-prelude~ is another (somewhat involved) Lisp + expression which sets up a Lisp environment suitable for running + scripts -- e.g., by arranging to ignore ~#!~ lines, and pushing + ~:runlisp-script~ onto ~*features*~. + + Finally, regardless of whether we're using a custom or vanilla + image, we add the tokens ~--script "${@SCRIPT}"~ to the command + line. The ~${@SCRIPT}~ token is replaced by the actual script + pathname. ~runlisp~ then appends further arguments from its own + command line and runs the command. (For most Lisps, ~uiop~ needs a + ~--~ marker before the user arguments, but not for SBCL.) + + + Finally, ~dump-image~ defines a command line for dumping a custom + images. The ~dump-image-prelude~ setting is a Lisp expression for + setting up a Lisp so that it will be in a useful state when dumped: + it's very similar to ~run-script-prelude~, and is built out of many + of the same pieces. + + The thing we haven't seen before is ~${@IMAENEW|q}~. The + ~@IMAGENEW~ setting is defined by the ~dump-runlisp-image~ program + the name the file in which the new image should be + saved.[fn:image-rename] The ~|q~ `filter' is new: it means that the + filename should be escaped suitable for inclusion in a Lisp quoted + string, by prefixing each ~\~ or ~"~ with a ~\~. + +That's more or less all there is. SBCL is a particularly simple +example, but mostly because other Lisp implementations require fancier +stunts /at the Lisp level/. The ~runlisp~-level configuration isn't any +more complicated than SBCL. + +[fn:image-rename] ~dump-runlisp-image~ wants to avoid clobbering an +existing image with a half-finished one, so it tries to arrange for the +new image to be written to a different file, and then renames it once +it's been created successfully.) * What's wrong with =cl-launch=? @@ -278,12 +419,12 @@ a half times faster on SBCL. |------------------+-------------------+-----------------+----------------------| | *Implementation* | *~cl-launch~ (s)* | *~runlisp~ (s)* | *~runlisp~ (factor)* | |------------------+-------------------+-----------------+----------------------| -| ABCL | 7.3036 | 2.6027 | 2.806 | -| Clozure CL | 1.2769 | 0.9678 | 1.319 | -| GNU CLisp | 1.2498 | 0.2659 | 4.700 | -| CMU CL | 0.9665 | 0.3065 | 3.153 | -| ECL | 0.8025 | 0.3173 | 2.529 | -| SBCL | 0.3266 | 0.0739 | 4.419 | +| ABCL | 7.3378 | 2.6474 | 2.772 | +| Clozure CL | 1.2888 | 0.9742 | 1.323 | +| GNU CLisp | 1.2405 | 0.2703 | 4.589 | +| CMU CL | 0.9521 | 0.3097 | 3.074 | +| ECL | 0.8020 | 0.3236 | 2.478 | +| SBCL | 0.3205 | 0.0874 | 3.667 | |------------------+-------------------+-----------------+----------------------| #+TBLFM: $4=$2/$3;%.3f @@ -301,12 +442,12 @@ in figure [[fig:lisp-graph]]. |------------------+-------------------+-----------------+----------------------| | *Implementation* | *~cl-launch~ (s)* | *~runlisp~ (s)* | *~runlisp~ (factor)* | |------------------+-------------------+-----------------+----------------------| -| ABCL | 7.3036 | 2.5873 | 2.823 | -| Clozure CL | 1.2769 | 0.0088 | 145.102 | -| GNU CLisp | 1.2498 | 0.0146 | 85.603 | -| CMU CL | 0.9665 | 0.0063 | 153.413 | -| ECL | 0.8025 | 0.3185 | 2.520 | -| SBCL | 0.3266 | 0.0077 | 42.416 | +| ABCL | 7.3378 | 2.7023 | 2.715 | +| Clozure CL | 1.2888 | 0.0371 | 34.739 | +| GNU CLisp | 1.2405 | 0.0191 | 64.948 | +| CMU CL | 0.9521 | 0.0060 | 158.683 | +| ECL | 0.8020 | 0.3275 | 2.449 | +| SBCL | 0.3205 | 0.0064 | 50.078 | |------------------+-------------------+-----------------+----------------------| #+TBLFM: $4=$2/$3;%.3f @@ -327,20 +468,20 @@ of other languages, and timed them; the results are tabulated in table |------------------------------+-------------| | *Implementation* | *Time (ms)* | |------------------------------+-------------| -| Clozure CL | 8.8 | -| GNU CLisp | 14.6 | -| CMU CL | 6.3 | -| SBCL | 7.7 | +| Clozure CL | 37.1 | +| GNU CLisp | 19.1 | +| CMU CL | 6.0 | +| SBCL | 6.4 | |------------------------------+-------------| -| Perl | 1.2 | -| Python | 10.3 | +| Perl | 1.1 | +| Python | 6.8 | |------------------------------+-------------| -| Debian Almquist shell (dash) | 1.4 | -| GNU Bash | 2.0 | -| Z Shell | 4.1 | +| Debian Almquist shell (dash) | 1.2 | +| GNU Bash | 1.5 | +| Z Shell | 3.1 | |------------------------------+-------------| -| Tiny C (compile & run) | 1.2 | -| GCC (precompiled) | 0.5 | +| Tiny C (compile & run) | 1.6 | +| GCC (precompiled) | 0.6 | |------------------------------+-------------| #+CAPTION: Comparison of ~runlisp~ and other script interpreters @@ -371,11 +512,15 @@ be used in ~~/.cl-launchrc~ to select a Lisp system for a particular `software system', though this notion doesn't appear to be well-defined, but this all works by editing a single ~$LISPS~ shell variable. By contrast, ~runlisp~ has a ~-L~ option with which scripts can specify the -Lisp systems they support (in a preference order), and a ~-P~ option -with which users can express their own preferences (e.g., in the -environment or a configuration file): ~runlisp~ will never choose a Lisp -system which the script can't deal with, but it will respect the user's -relative preferences. +Lisp systems they support (in a preference order), and a ~prefer~ +configuration setting with which users can express their own +preferences: ~runlisp~ will never choose a Lisp system which the script +can't deal with, but it will respect the user's relative preferences. + +Also, ~cl-launch~ is a monolith. Adding a new Lisp implementation to +it, or changing how a particular implementation is invoked, is rather +involved. By contrast, ~runlisp~ makes this remarkably easy, as +described in [[Supporting new Lisp implementations]]. ** It doesn't establish a (useful) common environment diff --git a/bench/Makefile.am b/bench/Makefile.am index 1bf09ae..a7ee2c6 100644 --- a/bench/Makefile.am +++ b/bench/Makefile.am @@ -49,7 +49,7 @@ CLEANFILES += *.out *.bench ### Lisp systems using `runlisp'. RUNLISP = $(top_builddir)/runlisp \ - -c$(top_srcdir)/runlisp.conf \ + -c$(top_srcdir)/runlisp-base.conf \ -oimage-dir=$(top_builddir) EXTRA_DIST += t.lisp diff --git a/common.c b/common.c index b0d5857..1c0b0ce 100644 --- a/common.c +++ b/common.c @@ -44,25 +44,123 @@ /*----- Public variables --------------------------------------------------*/ -struct config config = CONFIG_INIT; -struct config_section *toplevel, *builtin, *common, *env; -unsigned verbose = 1; +struct config config = CONFIG_INIT; /* main configuration */ +struct config_section *toplevel, *builtin, *common, *env; /* well-known + * sections */ +unsigned verbose = 1; /* verbosity level */ -/*----- Internal utilities ------------------------------------------------*/ +/*----- Miscellany --------------------------------------------------------*/ + +/* Look up the environment variable NAME. + * + * If it's found, return the value; otherwise return DFLT. This function + * looks up the environment variable in the `@ENV' configuration section, so + * (a) it's likely more efficient than getenv(3), and (b) the `init_config' + * function must have been called earlier. + */ +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); +} + +/* Parse and return an integer from the string P. + * + * Report an error if the string doesn't look like an integer, or if it's not + * between MIN and MAX (inclusive). Qualify error messages using the + * adjective WHAT. + */ +long parse_int(const char *what, const char *p, long min, long max) +{ + long n; + int oerr = errno; + char *q; -static void escapify(struct dstr *d, const char *p) + 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); +} + +/* Append a word P to string D, quoting and/or escaping it in shell style. + * + * It tries to pick a `good' way to protect metacharacters, but the precise + * details aren't guaranteed to remain stable. + */ +static void putword(struct dstr *d, const char *p) { + unsigned bare = 0, sq = 2, dq = 2; + const char *q, *e, *f; size_t n; + /* Pass one: count up how many extra escaping and/or quoting characters + * we'd need for each quoting strategy: `bare' is no quoting, just adding + * toothpicks before naughty characters; `dq' is double quotes, with fewer + * toothpicks; and `sq' is single quotes, with the somewhat awful rune + * `'\''' rune replacing embedded single quotes. The quoting strategies + * start off with a two-character penalty for the surrounding quotes. + */ + for (q = p; *q; q++) + switch (*q) { + case '\\': case '"': case '`': case '$': case '!': bare++; dq++; break; + case '\'': bare++; sq += 3; break; + case '^': case '|': case ';': case '&': case '(': case ')': + case '<': case '>': + case '*': case '?': case '[': + case '#': + bare++; break; + default: + if (ISSPACE(*q)) bare++; + break; + } + + /* Prepare for the output loop: `q' will be a string of naughty characters + * which need escaping somehow; `e' is a sequence to insert before each + * naughty character, and `f' is a final string to add to the end. We'll + * put the initial quote on ourselves, if necessary. + */ + if (bare < dq && bare < sq) + { q = "\\\"`$!'^|;&()<>*?[# \b\f\n\r\t\v"; e = "\\"; f = ""; } + else if (dq < sq) + { q = "\\\"`$!"; e = "\\"; dstr_putc(d, '"'); f = "\""; } + else + { q = "'"; e = "'\\'"; dstr_putc(d, '\''); f = "'"; } + + /* Work through the input string inserting escapes as we go. */ for (;;) { - n = strcspn(p, "\"'\\"); + n = strcspn(p, q); if (n) { dstr_putm(d, p, n); p += n; } if (!*p) break; - dstr_putc(d, '\\'); dstr_putc(d, *p++); + dstr_puts(d, e); dstr_putc(d, *p++); + } + dstr_puts(d, f); +} + +/* Format string-vector AV as a sequence of possibly-quoted words. + * + * Append the resulting list to D. + */ +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, ' '); + putword(d, av->v[i]); } dstr_putz(d); } +/*----- Internal utilities ------------------------------------------------*/ + +/* Append the user's home directory to D. */ static void homedir(struct dstr *d) { static const char *home = 0; @@ -70,6 +168,7 @@ static void homedir(struct dstr *d) struct passwd *pw; if (!home) { + p = my_getenv("HOME", 0); if (p) home = p; else { @@ -81,6 +180,7 @@ static void homedir(struct dstr *d) dstr_puts(d, home); } +/* Append the user's XDG configuration directory to D. */ static void user_config_dir(struct dstr *d) { const char *p; @@ -90,46 +190,15 @@ static void user_config_dir(struct dstr *d) 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 ----------------------------------------------------*/ +/* Return whether PATH names an existing file. + * + * This will return zero if PATH names something which isn't a regular file. + * If `FEF_EXEC' is set in F, then additionally ensure that it's executable + * by the (real) calling uid. If `FEF_VERBOSE' is set in F, then report on + * the outcome of the check to standard error. + */ int file_exists_p(const char *path, unsigned f) { struct stat st; @@ -149,6 +218,13 @@ int file_exists_p(const char *path, unsigned f) } } +/* Return whether PROG can be found in the `PATH'. + * + * If PROG is a pathname (absolute or relative -- i.e., if it contains a + * `/'), then just check that it names an executable program. Otherwise + * check to see whether `DIR/PROG' exists and is executable for any DIR in + * the `PATH'. The flags F are as for `file_exists_p'. + */ int found_in_path_p(const char *prog, unsigned f) { struct dstr p = DSTR_INIT, d = DSTR_INIT; @@ -158,7 +234,7 @@ int found_in_path_p(const char *prog, unsigned f) int i, rc; if (strchr(prog, '/')) - return (file_exists_p(prog, f)); + return (file_exists_p(prog, f | FEF_EXEC)); path = my_getenv("PATH", 0); if (path) dstr_puts(&p, path); @@ -180,7 +256,7 @@ int found_in_path_p(const char *prog, unsigned f) dstr_putc(&d, '/'); dstr_putm(&d, prog, proglen); dstr_putz(&d); - if (file_exists_p(d.p, verbose >= 4 ? f : f&~FEF_VERBOSE)) { + if (file_exists_p(d.p, (verbose >= 4 ? f : f&~FEF_VERBOSE) | FEF_EXEC)) { if (verbose == 2) moan("found program `%s'", d.p); rc = 1; goto end; } @@ -193,6 +269,15 @@ end: return (rc); } +/* Try to run a program as indicated by the argument list AV. + * + * This is essentially execvp(3). If `TEF_VERBOSE' is set in F then trace + * what's going on to standard error. If `TEF_DRYRUN' is set in F then don't + * actually try to run the program: just check whether it exists and is + * vaguely plausible. Return -1 if there was a problem, or 0 if it was + * successful but didn't actually run the program because of the flags + * settings. + */ int try_exec(struct argv *av, unsigned f) { struct dstr d = DSTR_INIT; @@ -204,7 +289,7 @@ int try_exec(struct argv *av, unsigned f) 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); + execvp(av->v[0], av->v); if (errno != ENOENT) { moan("failed to exec `%s': %s", av->v[0], strerror(errno)); _exit(2); @@ -220,6 +305,54 @@ end: /*----- Configuration -----------------------------------------------------*/ +/* Initialize the configuration machinery. + * + * This establishes the standard configuration sections `@CONFIG', + * `@BUILTIN', `@COMMON', and `@ENV', setting the corresponding global + * variables, and populates `@BUILTIN' (from compile-time configuration) and + * `@ENV' (from the environment variables). + */ +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(env, 0); + config_set_parent(toplevel, 0); + config_read_env(&config, env); + + config_set_var(&config, builtin, CF_LITERAL, + "@%data-dir", DATADIR); + config_set_var(&config, builtin, 0, + "@data-dir", "${@ENV:RUNLISP_DATADIR?" + "${@CONFIG:data-dir?" + "${@BUILTIN:@%data-dir}}}"); + config_set_var(&config, builtin, CF_LITERAL, + "@%image-dir", IMAGEDIR); + config_set_var(&config, builtin, 0, + "@image-dir", "${@ENV:RUNLISP_IMAGEDIR?" + "${@CONFIG:image-dir?" + "${@BUILTIN:@%image-dir}}}"); + +#ifdef ECL_OPTIONS_GNU + config_set_var(&config, builtin, CF_LITERAL, "@%ecl-opt", "--"); +#else + config_set_var(&config, builtin, CF_LITERAL, "@%ecl-opt", "-"); +#endif + config_set_var(&config, builtin, 0, + "@ecl-opt", "${@CONFIG:ecl-opt?${@BUILTIN:@%ecl-opt}}"); +} + +/* Read a named configuration FILE. + * + * WHAT is an adjective describing the configuration file, to be used in + * diagnostics; FILE is the actual filename to read; and F holds `CF_...' + * flags for `config_read_file', which actually does most of the work. + */ void read_config_file(const char *what, const char *file, unsigned f) { if (!config_read_file(&config, file, f)) { @@ -231,9 +364,24 @@ void read_config_file(const char *what, const char *file, unsigned f) } } +/* Order strings lexicographically. + * + * This function is intended to be passed an argument to qsort(3). + */ static int order_strings(const void *xx, const void *yy) { const char *const *x = xx, *const *y = yy; return (strcmp(*x, *y)); } +/* Read all of the configuration files in directory PATH. + * + * WHAT is an adjective describing the configuration directory, to be used in + * diagnostics; FILE is the actual filename to read; and F holds `CF_...' + * flags for `config_read_file', which actually reads the files. + * + * All of the files named `*.conf' in the directory are read, in ascending + * lexicographical order by name. If `CF_NOENTOK' is set in F, then ignore + * an error explaining that the directory doesn't exist. (This only ignores + * `ENOENT': any other problem is still a fatal error.) + */ void read_config_dir(const char *what, const char *path, unsigned f) { struct argv av = ARGV_INIT; @@ -273,11 +421,17 @@ void read_config_dir(const char *what, const char *path, unsigned f) read_config_file(what, dd.p, f&~CF_NOENTOK); } - for (i = 0; i < av.n; i++) free((/*unconst*/ char *)av.v[i]); + for (i = 0; i < av.n; i++) free(av.v[i]); argv_release(&av); dstr_release(&dd); closedir(dir); return; } +/* Read configuration from a file or directory PATH. + * + * If PATH exists and names a directory then process all of the files within, + * as for `read_config_dir'; otherwise try to read it as a file, as for + * `read_config_file'. The flags F are passed to the respective function. + */ void read_config_path(const char *path, unsigned f) { struct stat st; @@ -288,6 +442,13 @@ void read_config_path(const char *path, unsigned f) read_config_file("command-line specified", path, f); } +/* Apply a configuration variable setting in command-line syntax. + * + * ASSIGN should be a string in the form `[SECT:]VAR=VALUE'. Set VAR to + * VALUE in section SECT (defaults to `@CONFIG'). The variable is set with + * `CF_OVERRIDE' set to prevent the setting from being overwritten by a + * configuration file. + */ int set_config_var(const char *assign) { struct config_section *sect; @@ -298,48 +459,33 @@ int set_config_var(const char *assign) q = strchr(assign, ':'); if (!q || q > p) { sect = toplevel; q = assign; } + else if (q == assign) + lose("expected section or variable name in option assignment"); else { sect = config_find_section_n(&config, CF_CREAT, assign, q - assign); q++; } + if (p == q) lose("expected variable name in option assignment"); 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 -} - +/* Load the default configuration files. + * + * This will read `ETCDIR/runlisp.d/*.conf', `ETCDIR/runlisp.conf', + * `~/.runlisp.conf', and `~/.config/runlisp.conf'. + */ 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_SYSCONFIG", ETCDIR "/runlisp.conf"); + read_config_file("system", p, 0); + p = my_getenv("RUNLISP_USERCONFIG", 0); if (p) read_config_file("user", p, CF_NOENTOK); @@ -352,23 +498,20 @@ void load_default_config(void) dstr_release(&d); } +/* Dump the configuration to standard error. */ 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); + for (config_start_var_iter(&config, sect, &vi); + (var = config_next_var(&vi)); ) + moan("config %s:%s = %s", + CONFIG_SECTION_NAME(sect), CONFIG_VAR_NAME(var), var->val); } /*----- That's all, folks -------------------------------------------------*/ diff --git a/common.h b/common.h index 6ec38c5..b761052 100644 --- a/common.h +++ b/common.h @@ -44,28 +44,127 @@ extern unsigned verbose; /*----- Functions provided ------------------------------------------------*/ extern const char *my_getenv(const char */*name*/, const char */*dflt*/); + /* Look up the environment variable NAME. + * + * If it's found, return the value; otherwise return DFLT. This + * function looks up the environment variable in the `@ENV' + * configuration section, so (a) it's likely more efficient than + * getenv(3), and (b) the `init_config' function must have been + * called earlier. + */ + extern long parse_int(const char */*what*/, const char */*p*/, long /*min*/, long /*max*/); + /* Parse and return an integer from the string P. + * + * Report an error if the string doesn't look like an integer, or if + * it's not between MIN and MAX (inclusive). Qualify error messages + * using the adjective WHAT. + */ + extern void argv_string(struct dstr */*d*/, const struct argv */*av*/); + /* Format string-vector AV as a sequence of possibly-quoted words. + * + * Append the resulting list to D. + */ +extern int file_exists_p(const char */*path*/, unsigned /*f*/); #define FEF_EXEC 1u #define FEF_VERBOSE 2u -extern int file_exists_p(const char */*path*/, unsigned /*f*/); + /* Return whether PATH names an existing file. + * + * This will return zero if PATH names something which isn't a + * regular file. If `FEF_EXEC' is set in F, then additionally ensure + * that it's executable by the (real) calling uid. If `FEF_VERBOSE' + * is set in F, then report on the outcome of the check to standard + * error. + */ + extern int found_in_path_p(const char */*prog*/, unsigned /*f*/); + /* Return whether PROG can be found in the `PATH'. + * + * If PROG is a pathname (absolute or relative -- i.e., if it + * contains a `/'), then just check that it names an executable + * program. Otherwise check to see whether `DIR/PROG' exists and is + * executable for any DIR in the `PATH'. The flags F are as for + * `file_exists_p'. + */ +extern int try_exec(struct argv */*av*/, unsigned /*f*/); #define TEF_DRYRUN 1u #define TEF_VERBOSE 2u -extern int try_exec(struct argv */*av*/, unsigned /*f*/); + /* Try to run a program as indicated by the argument list AV. + * + * This is essentially execvp(3). If `TEF_VERBOSE' is set in F then + * trace what's going on to standard error. If `TEF_DRYRUN' is set + * in F then don't actually try to run the program: just check + * whether it exists and is vaguely plausible. Return -1 if there + * was a problem, or 0 if it was successful but didn't actually run + * the program because of the flags settings. + */ + +extern void init_config(void); + /* Initialize the configuration machinery. + * + * This establishes the standard configuration sections `@CONFIG', + * `@BUILTIN', `@COMMON', and `@ENV', setting the corresponding + * global variables, and populates `@BUILTIN' (from compile-time + * configuration) and `@ENV' (from the environment variables). + */ extern void read_config_file(const char */*what*/, const char */*file*/, unsigned /*f*/); + /* Read a named configuration FILE. + * + * WHAT is an adjective describing the configuration file, to be used + * in diagnostics; FILE is the actual filename to read; and F holds + * `CF_...' flags for `config_read_file', which actually does most + * of the work. + */ + extern void read_config_dir(const char */*what*/, const char */*path*/, unsigned /*f*/); + /* Read all of the configuration files in directory PATH. + * + * WHAT is an adjective describing the configuration directory, to be + * used in diagnostics; FILE is the actual filename to read; and F + * holds `CF_...' flags for `config_read_file', which actually reads + * the files. + * + * All of the files named `*.conf' in the directory are read, in + * ascending lexicographical order by name. If `CF_NOENTOK' is set + * in F, then ignore an error explaining that the directory doesn't + * exist. (This only ignores `ENOENT': any other problem is still a + * fatal error.) + */ + extern void read_config_path(const char */*path*/, unsigned /*f*/); + /* Read configuration from a file or directory PATH. + * + * If PATH exists and names a directory then process all of the files + * within, as for `read_config_dir'; otherwise try to read it as a + * file, as for `read_config_file'. The flags F are passed to the + * respective function. + */ + extern int set_config_var(const char */*assign*/); -extern void init_config(void); + /* Apply a configuration variable setting in command-line syntax. + * + * ASSIGN should be a string in the form `[SECT:]VAR=VALUE'. Set VAR + * to VALUE in section SECT (defaults to `@CONFIG'). The variable is + * set with `CF_OVERRIDE' set to prevent the setting from being + * overwritten by a configuration file. + */ + extern void load_default_config(void); + /* Load the default configuration files. + * + * This will read `ETCDIR/runlisp.d/*.conf', `ETCDIR/runlisp.conf', + * `~/.runlisp.conf', and `~/.config/runlisp.conf'. + */ + extern void dump_config(void); + /* Dump the configuration to standard error. */ /*----- That's all, folks -------------------------------------------------*/ diff --git a/configure.ac b/configure.ac index 66446f3..ac42a38 100644 --- a/configure.ac +++ b/configure.ac @@ -38,6 +38,8 @@ mdw_DECL_ENVIRON AC_CHECK_FUNC([strsignal]) case $ac_cv_func_strsignal in no) AC_DECL_SYS_SIGLIST ;; esac +AC_PROG_RANLIB + AC_CHECK_PROGS([AUTOM4TE], [autom4te]) dnl-------------------------------------------------------------------------- @@ -46,7 +48,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([ETCDIR], [$sysconfdir/$PACKAGE_NAME]) mdw_DEFINE_PATH([DATADIR], [$datadir/$PACKAGE_NAME])]) AC_ARG_ENABLE([imagedump], diff --git a/doc/bench.data b/doc/bench.data index 25d0a83..a0d486e 100644 --- a/doc/bench.data +++ b/doc/bench.data @@ -1,22 +1,22 @@ #> lisp "Lisp system" "\\texttt{cl-launch}" "\\texttt{runlisp} (vanilla image)" "\\texttt{runlisp} (custom image)" -"ABCL" 7.3036 2.6027 2.5873 -"Clozure CL" 1.2769 0.9678 0.0088 -"GNU CLisp" 1.2498 0.2659 0.0146 -"CMU CL" 0.9665 0.3065 0.0063 -"ECL" 0.8025 0.3173 0.3185 -"SBCL" 0.3266 0.0739 0.0077 +"ABCL" 7.3378 2.6474 2.7023 +"Clozure CL" 1.2888 0.9742 0.0371 +"GNU CLisp" 1.2405 0.2703 0.0191 +"CMU CL" 0.9521 0.3097 0.0060 +"ECL" 0.8020 0.3236 0.3275 +"SBCL" 0.3205 0.0874 0.0064 #> interp -"Clozure CL" 0.0088 -"GNU CLisp" 0.0146 -"CMU CL" 0.0063 -"SBCL" 0.0077 -"Perl" 0.0012 -"Python" 0.0103 -"dash" 0.0014 -"GNU Bash" 0.0020 -"Z Shell" 0.0041 -"Tiny C" 0.0012 -"GCC" 0.0005 +"Clozure CL" 0.0371 +"GNU CLisp" 0.0191 +"CMU CL" 0.0060 +"SBCL" 0.0064 +"Perl" 0.0011 +"Python" 0.0068 +"dash" 0.0012 +"GNU Bash" 0.0015 +"Z Shell" 0.0031 +"Tiny C" 0.0016 +"GCC" 0.0006 diff --git a/doc/interp-graph.tikz b/doc/interp-graph.tikz index ac39f8a..a11c8f4 100644 --- a/doc/interp-graph.tikz +++ b/doc/interp-graph.tikz @@ -1,6 +1,6 @@ \begin{tikzpicture}[gnuplot] %% generated with GNUPLOT 5.2p6 (Lua 5.3; terminal rev. Nov 2018, script rev. 107) -%% Sat 15 Aug 2020 14:07:28 BST +%% Wed 26 Aug 2020 21:13:41 BST \path (0.000,0.000) rectangle (12.500,8.750); \gpcolor{color=gp lt color border} \gpsetlinetype{gp lt border} @@ -9,21 +9,21 @@ \draw[gp path] (1.136,1.363)--(1.316,1.363); \node[gp node right] at (0.952,1.363) {$0$}; \draw[gp path] (1.136,2.248)--(1.316,2.248); -\node[gp node right] at (0.952,2.248) {$2$}; +\node[gp node right] at (0.952,2.248) {$5$}; \draw[gp path] (1.136,3.133)--(1.316,3.133); -\node[gp node right] at (0.952,3.133) {$4$}; +\node[gp node right] at (0.952,3.133) {$10$}; \draw[gp path] (1.136,4.017)--(1.316,4.017); -\node[gp node right] at (0.952,4.017) {$6$}; +\node[gp node right] at (0.952,4.017) {$15$}; \draw[gp path] (1.136,4.902)--(1.316,4.902); -\node[gp node right] at (0.952,4.902) {$8$}; +\node[gp node right] at (0.952,4.902) {$20$}; \draw[gp path] (1.136,5.787)--(1.316,5.787); -\node[gp node right] at (0.952,5.787) {$10$}; +\node[gp node right] at (0.952,5.787) {$25$}; \draw[gp path] (1.136,6.672)--(1.316,6.672); -\node[gp node right] at (0.952,6.672) {$12$}; +\node[gp node right] at (0.952,6.672) {$30$}; \draw[gp path] (1.136,7.556)--(1.316,7.556); -\node[gp node right] at (0.952,7.556) {$14$}; +\node[gp node right] at (0.952,7.556) {$35$}; \draw[gp path] (1.136,8.441)--(1.316,8.441); -\node[gp node right] at (0.952,8.441) {$16$}; +\node[gp node right] at (0.952,8.441) {$40$}; \node[gp node left,rotate=-35] at (1.853,1.179) {Clozure CL}; \node[gp node left,rotate=-35] at (2.754,1.179) {GNU CLisp}; \node[gp node left,rotate=-35] at (3.655,1.179) {CMU CL}; @@ -37,29 +37,29 @@ \node[gp node left,rotate=-35] at (10.862,1.179) {GCC}; \draw[gp path] (1.136,8.441)--(1.136,1.363)--(11.947,1.363); \node[gp node center,rotate=-270] at (0.276,4.902) {Time (ms) to run trivial script}; -\gpfill{rgb color={0.580,0.000,0.827}} (1.812,1.363)--(2.263,1.363)--(2.263,5.257)--(1.812,5.257)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (1.812,1.363)--(2.263,1.363)--(2.263,7.929)--(1.812,7.929)--cycle; \gpcolor{rgb color={0.580,0.000,0.827}} -\draw[gp path] (1.812,1.363)--(1.812,5.256)--(2.262,5.256)--(2.262,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (2.713,1.363)--(3.164,1.363)--(3.164,7.823)--(2.713,7.823)--cycle; -\draw[gp path] (2.713,1.363)--(2.713,7.822)--(3.163,7.822)--(3.163,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (3.614,1.363)--(4.065,1.363)--(4.065,4.151)--(3.614,4.151)--cycle; -\draw[gp path] (3.614,1.363)--(3.614,4.150)--(4.064,4.150)--(4.064,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (4.514,1.363)--(4.966,1.363)--(4.966,4.770)--(4.514,4.770)--cycle; -\draw[gp path] (4.514,1.363)--(4.514,4.769)--(4.965,4.769)--(4.965,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (5.415,1.363)--(5.867,1.363)--(5.867,1.895)--(5.415,1.895)--cycle; -\draw[gp path] (5.415,1.363)--(5.415,1.894)--(5.866,1.894)--(5.866,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (6.316,1.363)--(6.768,1.363)--(6.768,5.920)--(6.316,5.920)--cycle; -\draw[gp path] (6.316,1.363)--(6.316,5.919)--(6.767,5.919)--(6.767,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (7.217,1.363)--(7.669,1.363)--(7.669,1.983)--(7.217,1.983)--cycle; -\draw[gp path] (7.217,1.363)--(7.217,1.982)--(7.668,1.982)--(7.668,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (8.118,1.363)--(8.570,1.363)--(8.570,2.249)--(8.118,2.249)--cycle; -\draw[gp path] (8.118,1.363)--(8.118,2.248)--(8.569,2.248)--(8.569,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (9.019,1.363)--(9.470,1.363)--(9.470,3.178)--(9.019,3.178)--cycle; -\draw[gp path] (9.019,1.363)--(9.019,3.177)--(9.469,3.177)--(9.469,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (9.920,1.363)--(10.371,1.363)--(10.371,1.895)--(9.920,1.895)--cycle; -\draw[gp path] (9.920,1.363)--(9.920,1.894)--(10.370,1.894)--(10.370,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (10.821,1.363)--(11.272,1.363)--(11.272,1.585)--(10.821,1.585)--cycle; -\draw[gp path] (10.821,1.363)--(10.821,1.584)--(11.271,1.584)--(11.271,1.363)--cycle; +\draw[gp path] (1.812,1.363)--(1.812,7.928)--(2.262,7.928)--(2.262,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (2.713,1.363)--(3.164,1.363)--(3.164,4.744)--(2.713,4.744)--cycle; +\draw[gp path] (2.713,1.363)--(2.713,4.743)--(3.163,4.743)--(3.163,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (3.614,1.363)--(4.065,1.363)--(4.065,2.426)--(3.614,2.426)--cycle; +\draw[gp path] (3.614,1.363)--(3.614,2.425)--(4.064,2.425)--(4.064,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (4.514,1.363)--(4.966,1.363)--(4.966,2.496)--(4.514,2.496)--cycle; +\draw[gp path] (4.514,1.363)--(4.514,2.495)--(4.965,2.495)--(4.965,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (5.415,1.363)--(5.867,1.363)--(5.867,1.559)--(5.415,1.559)--cycle; +\draw[gp path] (5.415,1.363)--(5.415,1.558)--(5.866,1.558)--(5.866,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (6.316,1.363)--(6.768,1.363)--(6.768,2.567)--(6.316,2.567)--cycle; +\draw[gp path] (6.316,1.363)--(6.316,2.566)--(6.767,2.566)--(6.767,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (7.217,1.363)--(7.669,1.363)--(7.669,1.576)--(7.217,1.576)--cycle; +\draw[gp path] (7.217,1.363)--(7.217,1.575)--(7.668,1.575)--(7.668,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (8.118,1.363)--(8.570,1.363)--(8.570,1.629)--(8.118,1.629)--cycle; +\draw[gp path] (8.118,1.363)--(8.118,1.628)--(8.569,1.628)--(8.569,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (9.019,1.363)--(9.470,1.363)--(9.470,1.913)--(9.019,1.913)--cycle; +\draw[gp path] (9.019,1.363)--(9.019,1.912)--(9.469,1.912)--(9.469,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (9.920,1.363)--(10.371,1.363)--(10.371,1.647)--(9.920,1.647)--cycle; +\draw[gp path] (9.920,1.363)--(9.920,1.646)--(10.370,1.646)--(10.370,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (10.821,1.363)--(11.272,1.363)--(11.272,1.470)--(10.821,1.470)--cycle; +\draw[gp path] (10.821,1.363)--(10.821,1.469)--(11.271,1.469)--(11.271,1.363)--cycle; \gpcolor{color=gp lt color border} \draw[gp path] (1.136,8.441)--(1.136,1.363)--(11.947,1.363); %% coordinates of the plot area diff --git a/doc/lisp-graph.tikz b/doc/lisp-graph.tikz index 2a6ea13..067d53d 100644 --- a/doc/lisp-graph.tikz +++ b/doc/lisp-graph.tikz @@ -1,6 +1,6 @@ \begin{tikzpicture}[gnuplot] %% generated with GNUPLOT 5.2p6 (Lua 5.3; terminal rev. Nov 2018, script rev. 107) -%% Sat 15 Aug 2020 14:07:24 BST +%% Wed 26 Aug 2020 21:13:41 BST \path (0.000,0.000) rectangle (12.500,8.750); \gpcolor{color=gp lt color border} \gpsetlinetype{gp lt border} @@ -36,52 +36,52 @@ \gpfill{rgb color={0.580,0.000,0.827}} (10.663,8.030)--(11.579,8.030)--(11.579,8.184)--(10.663,8.184)--cycle; \gpcolor{rgb color={0.580,0.000,0.827}} \draw[gp path] (10.663,8.030)--(11.579,8.030)--(11.579,8.184)--(10.663,8.184)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (2.209,1.363)--(2.524,1.363)--(2.524,7.826)--(2.209,7.826)--cycle; -\draw[gp path] (2.209,1.363)--(2.209,7.825)--(2.523,7.825)--(2.523,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (3.779,1.363)--(4.094,1.363)--(4.094,2.494)--(3.779,2.494)--cycle; -\draw[gp path] (3.779,1.363)--(3.779,2.493)--(4.093,2.493)--(4.093,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (5.350,1.363)--(5.665,1.363)--(5.665,2.470)--(5.350,2.470)--cycle; -\draw[gp path] (5.350,1.363)--(5.350,2.469)--(5.664,2.469)--(5.664,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (6.921,1.363)--(7.236,1.363)--(7.236,2.219)--(6.921,2.219)--cycle; -\draw[gp path] (6.921,1.363)--(6.921,2.218)--(7.235,2.218)--(7.235,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (2.209,1.363)--(2.524,1.363)--(2.524,7.856)--(2.209,7.856)--cycle; +\draw[gp path] (2.209,1.363)--(2.209,7.855)--(2.523,7.855)--(2.523,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (3.779,1.363)--(4.094,1.363)--(4.094,2.504)--(3.779,2.504)--cycle; +\draw[gp path] (3.779,1.363)--(3.779,2.503)--(4.093,2.503)--(4.093,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (5.350,1.363)--(5.665,1.363)--(5.665,2.462)--(5.350,2.462)--cycle; +\draw[gp path] (5.350,1.363)--(5.350,2.461)--(5.664,2.461)--(5.664,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (6.921,1.363)--(7.236,1.363)--(7.236,2.206)--(6.921,2.206)--cycle; +\draw[gp path] (6.921,1.363)--(6.921,2.205)--(7.235,2.205)--(7.235,1.363)--cycle; \gpfill{rgb color={0.580,0.000,0.827}} (8.491,1.363)--(8.807,1.363)--(8.807,2.074)--(8.491,2.074)--cycle; \draw[gp path] (8.491,1.363)--(8.491,2.073)--(8.806,2.073)--(8.806,1.363)--cycle; -\gpfill{rgb color={0.580,0.000,0.827}} (10.062,1.363)--(10.377,1.363)--(10.377,1.653)--(10.062,1.653)--cycle; -\draw[gp path] (10.062,1.363)--(10.062,1.652)--(10.376,1.652)--(10.376,1.363)--cycle; +\gpfill{rgb color={0.580,0.000,0.827}} (10.062,1.363)--(10.377,1.363)--(10.377,1.648)--(10.062,1.648)--cycle; +\draw[gp path] (10.062,1.363)--(10.062,1.647)--(10.376,1.647)--(10.376,1.363)--cycle; \gpcolor{color=gp lt color border} \node[gp node right] at (10.479,7.799) {\texttt{runlisp} (vanilla image)}; \gpfill{rgb color={0.000,0.620,0.451}} (10.663,7.722)--(11.579,7.722)--(11.579,7.876)--(10.663,7.876)--cycle; \gpcolor{rgb color={0.000,0.620,0.451}} \draw[gp path] (10.663,7.722)--(11.579,7.722)--(11.579,7.876)--(10.663,7.876)--cycle; -\gpfill{rgb color={0.000,0.620,0.451}} (2.523,1.363)--(2.838,1.363)--(2.838,3.667)--(2.523,3.667)--cycle; -\draw[gp path] (2.523,1.363)--(2.523,3.666)--(2.837,3.666)--(2.837,1.363)--cycle; -\gpfill{rgb color={0.000,0.620,0.451}} (4.093,1.363)--(4.409,1.363)--(4.409,2.220)--(4.093,2.220)--cycle; -\draw[gp path] (4.093,1.363)--(4.093,2.219)--(4.408,2.219)--(4.408,1.363)--cycle; -\gpfill{rgb color={0.000,0.620,0.451}} (5.664,1.363)--(5.979,1.363)--(5.979,1.599)--(5.664,1.599)--cycle; -\draw[gp path] (5.664,1.363)--(5.664,1.598)--(5.978,1.598)--(5.978,1.363)--cycle; -\gpfill{rgb color={0.000,0.620,0.451}} (7.235,1.363)--(7.550,1.363)--(7.550,1.635)--(7.235,1.635)--cycle; -\draw[gp path] (7.235,1.363)--(7.235,1.634)--(7.549,1.634)--(7.549,1.363)--cycle; -\gpfill{rgb color={0.000,0.620,0.451}} (8.806,1.363)--(9.121,1.363)--(9.121,1.645)--(8.806,1.645)--cycle; -\draw[gp path] (8.806,1.363)--(8.806,1.644)--(9.120,1.644)--(9.120,1.363)--cycle; -\gpfill{rgb color={0.000,0.620,0.451}} (10.376,1.363)--(10.691,1.363)--(10.691,1.429)--(10.376,1.429)--cycle; -\draw[gp path] (10.376,1.363)--(10.376,1.428)--(10.690,1.428)--(10.690,1.363)--cycle; +\gpfill{rgb color={0.000,0.620,0.451}} (2.523,1.363)--(2.838,1.363)--(2.838,3.706)--(2.523,3.706)--cycle; +\draw[gp path] (2.523,1.363)--(2.523,3.705)--(2.837,3.705)--(2.837,1.363)--cycle; +\gpfill{rgb color={0.000,0.620,0.451}} (4.093,1.363)--(4.409,1.363)--(4.409,2.226)--(4.093,2.226)--cycle; +\draw[gp path] (4.093,1.363)--(4.093,2.225)--(4.408,2.225)--(4.408,1.363)--cycle; +\gpfill{rgb color={0.000,0.620,0.451}} (5.664,1.363)--(5.979,1.363)--(5.979,1.603)--(5.664,1.603)--cycle; +\draw[gp path] (5.664,1.363)--(5.664,1.602)--(5.978,1.602)--(5.978,1.363)--cycle; +\gpfill{rgb color={0.000,0.620,0.451}} (7.235,1.363)--(7.550,1.363)--(7.550,1.638)--(7.235,1.638)--cycle; +\draw[gp path] (7.235,1.363)--(7.235,1.637)--(7.549,1.637)--(7.549,1.363)--cycle; +\gpfill{rgb color={0.000,0.620,0.451}} (8.806,1.363)--(9.121,1.363)--(9.121,1.650)--(8.806,1.650)--cycle; +\draw[gp path] (8.806,1.363)--(8.806,1.649)--(9.120,1.649)--(9.120,1.363)--cycle; +\gpfill{rgb color={0.000,0.620,0.451}} (10.376,1.363)--(10.691,1.363)--(10.691,1.441)--(10.376,1.441)--cycle; +\draw[gp path] (10.376,1.363)--(10.376,1.440)--(10.690,1.440)--(10.690,1.363)--cycle; \gpcolor{color=gp lt color border} \node[gp node right] at (10.479,7.491) {\texttt{runlisp} (custom image)}; \gpfill{rgb color={0.337,0.706,0.914}} (10.663,7.414)--(11.579,7.414)--(11.579,7.568)--(10.663,7.568)--cycle; \gpcolor{rgb color={0.337,0.706,0.914}} \draw[gp path] (10.663,7.414)--(11.579,7.414)--(11.579,7.568)--(10.663,7.568)--cycle; -\gpfill{rgb color={0.337,0.706,0.914}} (2.837,1.363)--(3.152,1.363)--(3.152,3.653)--(2.837,3.653)--cycle; -\draw[gp path] (2.837,1.363)--(2.837,3.652)--(3.151,3.652)--(3.151,1.363)--cycle; -\gpfill{rgb color={0.337,0.706,0.914}} (4.408,1.363)--(4.723,1.363)--(4.723,1.372)--(4.408,1.372)--cycle; -\draw[gp path] (4.408,1.363)--(4.408,1.371)--(4.722,1.371)--(4.722,1.363)--cycle; -\gpfill{rgb color={0.337,0.706,0.914}} (5.978,1.363)--(6.293,1.363)--(6.293,1.377)--(5.978,1.377)--cycle; -\draw[gp path] (5.978,1.363)--(5.978,1.376)--(6.292,1.376)--(6.292,1.363)--cycle; -\gpfill{rgb color={0.337,0.706,0.914}} (7.549,1.363)--(7.864,1.363)--(7.864,1.370)--(7.549,1.370)--cycle; -\draw[gp path] (7.549,1.363)--(7.549,1.369)--(7.863,1.369)--(7.863,1.363)--cycle; -\gpfill{rgb color={0.337,0.706,0.914}} (9.120,1.363)--(9.435,1.363)--(9.435,1.646)--(9.120,1.646)--cycle; -\draw[gp path] (9.120,1.363)--(9.120,1.645)--(9.434,1.645)--(9.434,1.363)--cycle; -\gpfill{rgb color={0.337,0.706,0.914}} (10.690,1.363)--(11.006,1.363)--(11.006,1.371)--(10.690,1.371)--cycle; -\draw[gp path] (10.690,1.363)--(10.690,1.370)--(11.005,1.370)--(11.005,1.363)--cycle; +\gpfill{rgb color={0.337,0.706,0.914}} (2.837,1.363)--(3.152,1.363)--(3.152,3.755)--(2.837,3.755)--cycle; +\draw[gp path] (2.837,1.363)--(2.837,3.754)--(3.151,3.754)--(3.151,1.363)--cycle; +\gpfill{rgb color={0.337,0.706,0.914}} (4.408,1.363)--(4.723,1.363)--(4.723,1.397)--(4.408,1.397)--cycle; +\draw[gp path] (4.408,1.363)--(4.408,1.396)--(4.722,1.396)--(4.722,1.363)--cycle; +\gpfill{rgb color={0.337,0.706,0.914}} (5.978,1.363)--(6.293,1.363)--(6.293,1.381)--(5.978,1.381)--cycle; +\draw[gp path] (5.978,1.363)--(5.978,1.380)--(6.292,1.380)--(6.292,1.363)--cycle; +\gpfill{rgb color={0.337,0.706,0.914}} (7.549,1.363)--(7.864,1.363)--(7.864,1.369)--(7.549,1.369)--cycle; +\draw[gp path] (7.549,1.363)--(7.549,1.368)--(7.863,1.368)--(7.863,1.363)--cycle; +\gpfill{rgb color={0.337,0.706,0.914}} (9.120,1.363)--(9.435,1.363)--(9.435,1.654)--(9.120,1.654)--cycle; +\draw[gp path] (9.120,1.363)--(9.120,1.653)--(9.434,1.653)--(9.434,1.363)--cycle; +\gpfill{rgb color={0.337,0.706,0.914}} (10.690,1.363)--(11.006,1.363)--(11.006,1.370)--(10.690,1.370)--cycle; +\draw[gp path] (10.690,1.363)--(10.690,1.369)--(11.005,1.369)--(11.005,1.363)--cycle; \gpcolor{color=gp lt color border} \draw[gp path] (0.952,8.441)--(0.952,1.363)--(11.947,1.363); %% coordinates of the plot area diff --git a/dump-ecl b/dump-ecl index 538ca27..1f5373e 100755 --- a/dump-ecl +++ b/dump-ecl @@ -30,84 +30,144 @@ image=$1 ecl=$2 eclopt=$3 tmp=$4 run () { echo "$*"; "$@"; } ## Start by compiling a copy of ASDF. -cat >"$tmp/ecl-build.lisp" <"$tmp/ecl-build.lisp" <<'EOF' (require "asdf") -(defparameter *asdf* (asdf:find-system "asdf")) +(defparameter *asdf* (asdf:find-system "asdf") + "The `asdf' system itself.") (defun right-here (pathname pattern) + "An `asdf:initialize-output-translations' function: use current directory. + + This function should be used in a `(:function ...)' form as the right hand + side of an `asdf:initialize-output-translations' entry. It causes the + output file to be written to the current directory, regardless of the + pathname of the input file(s)." (declare (ignore pattern)) - (merge-pathnames - (make-pathname :name (concatenate 'string - (string-downcase - (lisp-implementation-type)) - "-" - (pathname-name pathname)) - :type nil - :version nil - :defaults *default-pathname-defaults*) - pathname)) -(asdf:initialize-output-translations '(:output-translations - ((#p"/" :**/ :*.*.*) - (:function right-here)) - :ignore-inherited-configuration)) + (merge-pathnames (make-pathname :name (pathname-name pathname) + :type nil + :version nil + :defaults *default-pathname-defaults*) + pathname)) + +;; Configure the translations. +(asdf:initialize-output-translations + '(:output-translations ((#p"/" :**/ :*.*.*) (:function right-here)) + :ignore-inherited-configuration)) +;; Generate a linkable library for `asdf'. (asdf:operate 'asdf:lib-op *asdf*) + +;; We're done. (si:quit 0) EOF (cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-build.lisp") ## And now compile our driver code. -cat >"$tmp/ecl-run.lisp" <"$tmp/ecl-run.lisp" <<'EOF' (cl:defpackage #:runlisp (:use #:common-lisp)) (cl:in-package #:runlisp) (defun main () - $ignore_shebang_rune + "Run a script, passing it some arguments." + + ;; Ensure that `#!' is treated as a comment-to-end-of-line. + (set-dispatch-macro-character + #\# #\! + (lambda (#1=#:stream #2=#:char #3=#:arg) + (declare (ignore #2# #3#)) + (values (read-line #1#)))) + + ;; Inhibit `asdf' from trying to update itself. This will only make script + ;; startup even slower than it already is. (asdf:register-immutable-system "asdf") + + ;; Remove extraneous symbols from the `COMMON-LISP-USER' package. For some + ;; reason, ECL likes to intern symbols in this package. They're at best + ;; useless to us, and possibly a nuisance. (let ((pkg (find-package "COMMON-LISP-USER"))) (with-package-iterator (next pkg :internal) (loop (multiple-value-bind (anyp sym how) (next) (declare (ignore how)) (unless anyp (return)) (unintern sym pkg))))) - $set_script_feature_rune + + ;; Inform the script that it's being run from the command line. + (pushnew :runlisp-script *features*) + + ;; Work through our command-line arguments to figure out what to do. (let ((winning t) (script nil) (marker nil) (prog (file-namestring (si:argv 0))) (i 1) (argc (si:argc))) + (labels ((lose (msg &rest args) + ;; Report an error and give up; MSG and ARGS are as for + ;; `format'. (format *error-output* "~&~A: ~?~%" prog msg args) (setf winning nil)) + (quit (rc) + ;; End the process, exiting with status RC. (si:quit rc)) + (usage (stream) + ;; Print a synopsis of this front-end's usage to STREAM. (format stream "~&usage: ~A -s SCRIPT -- ARGS~%" prog)) + (getarg () + ;; Collect and the next command-line argument. Return `nil' + ;; if there are none remaining. (and (< i argc) (prog1 (si:argv i) (incf i))))) + + ;; Work through the options. (loop (let ((arg (getarg))) - (cond ((null arg) (return)) - ((string= arg "--") (setf marker t) (return)) - ((string= arg "-s") (setf script (getarg))) - ((string= arg "-h") (usage *standard-output*) (quit 0)) - (t (lose "unrecognized option \`~A'" arg))))) - (unless script (lose "nothing to do")) + (cond + + ;; If there's nothing left, we're done parsing. + ((null arg) (return)) + + ;; If we've found `--' then remember this, and stop. + ((string= arg "--") (setf marker t) (return)) + + ;; If we've found `-s' then the next argument is the script. + ((string= arg "-s") (setf script (getarg))) + + ;; If we've found `-h' then give a very brief usage summary. + ((string= arg "-h") (usage *standard-output*) (quit 0)) + + ;; Otherwise it's an error. + (t (lose "unrecognized option \`~A'" arg))))) + + ;; Check various things. If there's no script, then there's nothing + ;; for us to do. The `uiop' library uses a `--' marker to find the + ;; start of the user options, so things won't work if it's missing. (unless marker (lose "unexpected end of options (missing \`--'?)")) + + ;; If anything went wrong then remind the user of the usage, and exit + ;; unsuccessfully. (unless winning (usage *error-output*) (quit 255)) + + ;; Run the script. If it encounters an error and fails to handle it, + ;; then report it briefly and exit. (handler-case (let ((*package* (find-package "COMMON-LISP-USER"))) (load script :verbose nil :print nil)) (error (err) (format *error-output* "~&~A (uncaught error): ~A~%" prog err) (quit 255))) + + ;; Everything worked. We're done. (quit 0)))) + +;; Just run the main function. (Done this way so that it gets compiled.) (main) EOF -(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "ecl-asdf.fas" \ +(cd "$tmp" && run "$ecl" ${eclopt}norc ${eclopt}load "asdf.fas" \ -s -o "ecl-run.o" ${eclopt}compile "ecl-run.lisp") ## Finally link everything together. run "$ecl" ${eclopt}norc -o "$image"\ - ${eclopt}link "$tmp/ecl-asdf.o" "$tmp/ecl-run.o" + ${eclopt}link "$tmp/asdf.o" "$tmp/ecl-run.o" ###----- That's all, folks -------------------------------------------------- diff --git a/dump-runlisp-image.1 b/dump-runlisp-image.1 index d6bd3f5..61f06e4 100644 --- a/dump-runlisp-image.1 +++ b/dump-runlisp-image.1 @@ -42,7 +42,7 @@ .ds , \h'.16667m' . .\"-------------------------------------------------------------------------- -.TH runlisp 1 "12 August 2020" "Mark Wooding" +.TH dump-runlisp-image 1 "12 August 2020" "Mark Wooding" .SH NAME dump-runlisp-image \- dump Lisp images for faster script execution . @@ -256,17 +256,12 @@ for its command name). . .\"-------------------------------------------------------------------------- . -.SH "BUGS" -.hP \*o -There's no support for making images for ABCL. -I don't really know what this would look like, -but I suspect it wouldn't help very much. -ABCL is terribly slow to start up anyway. +.SH SEE ALSO +.BR query-runlisp-config (1), +.BR runlisp (1), +.BR runlisp.conf (5). . -.SH "SEE ALSO" -.BR runlisp (1). -. -.SH "AUTHOR" +.SH AUTHOR Mark Wooding, . .\"----- That's all, folks -------------------------------------------------- diff --git a/dump-runlisp-image.c b/dump-runlisp-image.c index 8e2d86f..1c6cb55 100644 --- a/dump-runlisp-image.c +++ b/dump-runlisp-image.c @@ -52,119 +52,146 @@ /*----- Static data -------------------------------------------------------*/ -#define MAXLINE 16384u +/* The state required to break an output stream from a subprocess into lines + * so we can prefix them appropriately. Once our process starts, the `buf' + * points to a buffer of `MAXLINE' bytes. This is arranged as a circular + * buffer, containing `len' bytes starting at offset `off', and wrapping + * around to the start of the buffer if it runs off the end. + * + * The descriptor `fd' is reset to -1 after it's seen end-of-file. + */ struct linebuf { - int fd; - char *buf; - unsigned off, len; + int fd; /* our file descriptor (or -1) */ + char *buf; /* line buffer, or null */ + unsigned off, len; /* offset */ }; +#define MAXLINE 16384u /* maximum acceptable line length */ +/* Job-state constants. */ enum { - JST_READY, - JST_RUN, - JST_DEAD, + JST_READY, /* not yet started */ + JST_RUN, /* currently running */ + JST_DEAD, /* process exited */ JST_NSTATE }; +/* The state associated with an image-dumping job. */ 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; + struct treap_node _node; /* treap intrusion */ + struct job *next; /* next job in whichever list */ + struct argv av; /* argument vector to execute */ + char *imgnew, *imgout; /* staging and final output files */ + unsigned st; /* job state (`JST_...') */ + FILE *log; /* log output file (`stdout'?) */ + pid_t kid; /* process id of child (or -1) */ + int exit; /* exit status from child */ + struct linebuf out, err; /* line buffers for stdout, stderr */ }; #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 struct treap jobs = TREAP_INIT; /* Lisp systems scheduled to dump */ +static struct job *job_ready, *job_run, *job_dead; /* list jobs by state */ +static unsigned nrun, maxrun = 1; /* running and maximum job counts */ +static int rc = 0; /* code that we should return */ +static int nullfd; /* file descriptor for `/dev/null' */ +static const char *tmpdir; /* temporary directory path */ -static int sig_pipe[2] = { -1, -1 }; -static sigset_t caught, pending; -static int sigloss = -1; +static int sig_pipe[2] = { -1, -1 }; /* pipe for reporting signals */ +static sigset_t caught, pending; /* signals we catch; have caught */ +static int sigloss = -1; /* signal that caused us to lose */ -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 +static unsigned flags = 0; /* flags for the application */ +#define AF_BOGUS 0x0001u /* invalid comand-line syntax */ +#define AF_SETCONF 0x0002u /* explicit configuration */ +#define AF_DRYRUN 0x0004u /* don't actually do it */ +#define AF_ALL 0x0008u /* dump all known Lisps */ +#define AF_FORCE 0x0010u /* dump even if images exist */ +#define AF_CHECKINST 0x0020u /* check Lisp exists before dump */ -/*----- Main code ---------------------------------------------------------*/ +/*----- Miscellany --------------------------------------------------------*/ +/* Report a (printf(3)-style) message MSG, and remember to fail later. */ 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; } + { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); rc = 127; } -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); -} +/*----- File utilities ----------------------------------------------------*/ +/* Main recursive subroutine for `recursive_delete'. + * + * The string DD currently contains the pathname of a directory, without a + * trailing `/' (though there is /space/ for a terminating zero or whatever). + * Recursively delete all of the files and directories within it. Appending + * further text to DD is OK, but clobbering the characters which are there + * already isn't allowed. + */ static void recursive_delete_(struct dstr *dd) { - size_t n = dd->len; DIR *dir; struct dirent *d; + size_t n = dd->len; - dd->p[n] = 0; - dir = opendir(dd->p); + /* Open the directory. */ + dd->p[n] = 0; dir = opendir(dd->p); if (!dir) lose("failed to open directory `%s' for cleanup: %s", dd->p, strerror(errno)); + /* We'll need to build pathnames for the files inside the directory, so add + * the separating `/' character. Remember the length of this prefix + * because this is the point we'll be rewinding to for each filename we + * find. + */ dd->p[n++] = '/'; + + /* Now go through each file in turn. */ for (;;) { + + /* Get a filename. If we've run out then we're done. Skip the special + * `.' and `..' entries. + */ d = readdir(dir); if (!d) break; if (d->d_name[0] == '.' && (!d->d_name[1] || (d->d_name[1] == '.' && !d->d_name[2]))) continue; + + /* Rewind the string offset and append the new filename. */ dd->len = n; dstr_puts(dd, d->d_name); + + /* Try to delete it the usual way. If it was actually a directory then + * recursively delete it instead. (We could lstat(2) it first, but this + * should be at least as quick to identify a directory, and it'll save a + * lstat(2) call in the (common) case that it's not a directory. + */ if (!unlink(dd->p)); else if (errno == EISDIR) recursive_delete_(dd); else lose("failed to delete file `%s': %s", dd->p, strerror(errno)); } + + /* We're done. Try to delete the directory. (It's possible that there was + * some problem with enumerating the directory, but we'll ignore that: if + * it matters then the directory won't be empty and the rmdir(2) will + * fail.) + */ closedir(dir); dd->p[--n] = 0; if (rmdir(dd->p)) lose("failed to delete directory `%s': %s", dd->p, strerror(errno)); } +/* Recursively delete the thing named PATH. */ 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; } } - +/* Configure a file descriptor FD. + * + * Set its nonblocking state to NONBLOCK and close-on-exec state to CLOEXEC. + * In both cases, -1 means to leave it alone, zero means to turn it off, and + * any other nonzero value means to turn it on. + */ static int configure_fd(const char *what, int fd, int nonblock, int cloexec) { int fl, nfl; @@ -190,18 +217,291 @@ fail: return (-1); } +/* Create a temporary directory and remember where we put it. */ +static void set_tmpdir(void) +{ + struct dstr d = DSTR_INIT; + size_t n; + unsigned i; + + /* Start building the path name. Remember the length: we'll rewind to + * here and try again if our first attempt doesn't work. + */ + dstr_putf(&d, "%s/runlisp.%d.", my_getenv("TMPDIR", "/tmp"), getpid()); + i = 0; n = d.len; + + /* Keep trying until it works. */ + for (;;) { + + /* Build a complete name. */ + d.len = n; dstr_putf(&d, "%d", rand()); + + /* Try to create the directory. If it worked, we're done. If it failed + * with `EEXIST' then we'll try again for a while, but give up it it + * doesn't look like we're making any progress. If it failed for some + * other reason then there's probably not much hope so give up. + */ + 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) { + d.len = n; dstr_puts(&d, "???"); + lose("failed to create temporary directory `%s': too many attempts", + d.p); + } + } + + /* Remember the directory name. */ + tmpdir = xstrndup(d.p, d.len); dstr_release(&d); +} + +/*----- Signal handling ---------------------------------------------------*/ + +/* Forward reference into job management. */ +static void reap_children(void); + +/* Clean things up on exit. + * + * Currently this just means to delete the temporary directory if we've made + * one. + */ +static void cleanup(void) + { if (tmpdir) { recursive_delete(tmpdir); tmpdir = 0; } } + +/* Check to see whether any signals have arrived, and do the sensible thing + * with them. + */ +static void check_signals(void) +{ + sigset_t old, pend; + char buf[32]; + ssize_t n; + + /* Ensure exclusive access to the signal-handling machinery, drain the + * signal pipe, and take a copy of the set of caught signals. + */ + 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); + + /* Check for each signal of interest to us. + * + * Interrupty signals just set `sigloss' -- the `run_jobs' loop will know + * to unravel everything if this happens. If `SIGCHLD' happened, then + * check on job process status. + */ + 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(); +} + +/* The actual signal handler. + * + * Set the appropriate signal bit in `pending', and a byte (of any value) + * down the signal pipe to wake up the select(2) loop. + */ static void handle_signal(int sig) { sigset_t old; char x = '!'; + /* Ensure exclusive access while we fiddle with the `caught' set. */ sigprocmask(SIG_BLOCK, &caught, &old); sigaddset(&pending, sig); sigprocmask(SIG_SETMASK, &old, 0); + /* Wake up the select(2) loop. If this fails, there's not a lot we can do + * about it. + */ DISCARD(write(sig_pipe[1], &x, 1)); } +/* Install our signal handler to catch SIG. + * + * If `SIGF_IGNOK' is set in F then don't trap the signal if it's currently + * ignored. (This is used for signals like `SIGINT', which usually should + * interrupt us; but if the caller wants us to ignore them, we should do as + * it wants.) + * + * WHAT describes the signal, for use in diagnostic messages. + */ +#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)); +} + +/*----- Line buffering ----------------------------------------------------*/ + +/* Find the next newline in the line buffer BUF. + * + * The search starts at `BUF->off', and potentially covers the entire buffer + * contents. Set *LINESZ_OUT to the length of the line, in bytes. (Callers + * must beware that the text of the line may wrap around the ends of the + * buffer.) Return zero if we found a newline, or nonzero if the search + * failed. + */ +static int find_newline(struct linebuf *buf, size_t *linesz_out) +{ + char *nl; + + if (buf->off + buf->len <= MAXLINE) { + /* The buffer contents is in one piece. Just search it. */ + + nl = memchr(buf->buf + buf->off, '\n', buf->len); + if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); } + + } else { + /* The buffer contents is in two pieces. We must search both of them. */ + + 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); +} + +/* Write a completed line out to the JOB's log file. + * + * The line starts at BUF->off, and continues for N bytes, not including the + * newline (which, in fact, might not exist at all). Precede the actual text + * of the line with the JOB's name, and the MARKER character, and follow it + * with the TAIL text (which should include an actual newline character). + */ +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); +} + +/* Collect output lines from JOB's process and write them to the log. + * + * Read data from BUF's file descriptor. Output complete (or overlong) lines + * usng `write_line'. On end-of-file, output any final incomplete line in + * the same way, close the descriptor, and set it to -1. + */ +static void prefix_lines(struct job *job, struct linebuf *buf, char marker) +{ + struct iovec iov[2]; int niov; + ssize_t n; + size_t linesz; + + /* Read data into the buffer. This fancy dance with readv(2) is probably + * overkill. + * + * We can't have BUF->len = MAXLINE because we'd have flushed out a + * maximum-length buffer as an incomplete line last time. + */ + 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 there's no data to read after all then just move on. Otherwise we + * have a problem. + */ + if (errno == EAGAIN || errno == EWOULDBLOCK) return; + lose("failed to read job `%s' output stream: %s", + JOB_NAME(job), strerror(errno)); + } + + /* Include the new material in the buffer length, and write out any + * complete lines we find. + */ + 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) + /* If there's nothing left then we might as well reset the buffer offset + * to the start of the buffer. + */ + buf->off = 0; + else if (buf->len == MAXLINE) { + /* We've filled the buffer with stuff that's not a whole line. Flush it + * out anyway. + */ + write_line(job, buf, MAXLINE, marker, " [...]\n"); + buf->off = buf->len = 0; + } + + if (!n) { + /* We've hit end-of-file. Close the stream, and write out any + * unterminated partial line. + */ + close(buf->fd); buf->fd = -1; + if (buf->len) + write_line(job, buf, buf->len, marker, " [missing final newline]\n"); + } +} + +/*----- Job management ----------------------------------------------------*/ + +/* Add a new job to the `ready' queue. + * + * The job will be to dump the Lisp system with the given LEN-byte NAME. On + * entry, *TAIL_INOUT should point to the `next' link of the last node in the + * list (or the list head pointer), and will be updated on exit. + * + * This function reports (fatal) errors for most kinds of problems. If + * `JF_QUIET' is set in F then silently ignore a well-described Lisp system + * which nonetheless isn't suitable. (This is specifically intended for the + * case where we try to dump all known Lisp systems, but some don't have a + * `dump-image' command.) + */ #define JF_QUIET 1u static void add_job(struct job ***tail_inout, unsigned f, const char *name, size_t len) @@ -209,11 +509,14 @@ static void add_job(struct job ***tail_inout, unsigned f, struct job *job; struct treap_path path; struct config_section *sect; - struct config_var *dump_var, *cmd_var; + struct config_var *dumpvar, *cmdvar, *imgvar; struct dstr d = DSTR_INIT; struct argv av = ARGV_INIT; + char *imgnew = 0, *imgout = 0; + size_t i; unsigned fef; + /* Check to see whether this Lisp system is already queued up. */ job = treap_probe(&jobs, name, len, &path); if (job) { if (verbose >= 2) { @@ -222,27 +525,42 @@ static void add_job(struct job ***tail_inout, unsigned f, } } + /* Find the configuration for this Lisp system and check that it can be + * dumped. + */ 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) { + dumpvar = config_find_var(&config, sect, 0, "dump-image"); + if (!dumpvar) { 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); + /* Check that the other necessary variables are present. */ + imgvar = config_find_var(&config, sect, 0, "image-file"); + if (!imgvar) lose("variable `image-file' not defined for Lisp `%s'", name); + cmdvar = config_find_var(&config, sect, 0, "command"); + if (!cmdvar) lose("variable `command' not defined for Lisp `%s'", name); + + /* Build the job's command line. */ + config_subst_split_var(&config, sect, dumpvar, &av); + if (!av.n) + lose("empty `dump-image' command for Lisp implementation `%s'", name); + + /* If we're supposed to check that the Lisp exists before proceeding then + * do that. There are /two/ commands to check: the basic Lisp command, + * /and/ the command to actually do the dumping, which might not be the + * same thing. (Be careful not to check the same command twice, though, + * because that would cause us to spam the user with redundant + * diagnostics.) + */ if (flags&AF_CHECKINST) { dstr_reset(&d); fef = (verbose >= 2 ? FEF_VERBOSE : 0); - config_subst_var(&config, sect, cmd_var, &d); + config_subst_var(&config, sect, cmdvar, &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); @@ -250,43 +568,77 @@ static void add_job(struct job ***tail_inout, unsigned f, } } + /* Collect the output image file names. */ + imgnew = + config_subst_string_alloc(&config, sect, "", "${@image-new}"); + imgout = + config_subst_string_alloc(&config, sect, "", "${@image-out}"); + + /* If we're supposed to check whether the image file exists, then we should + * do that. + */ if (!(flags&AF_FORCE)) { - dstr_reset(&d); - config_subst_string(&config, sect, "", "${@IMAGE}", &d); - if (!access(d.p, F_OK)) { + if (!access(imgout, F_OK)) { if (verbose >= 2) moan("image `%s' already exists: skipping `%s'", d.p, name); goto end; } } + /* All preflight checks complete. Build the job and hook it onto the end + * of the list. (Steal the command-line vector so that we don't try to + * free it during cleanup.) + */ 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); + job->imgnew = imgnew; job->imgout = imgout; imgnew = imgout = 0; treap_insert(&jobs, &path, &job->_node, name, len); **tail_inout = job; *tail_inout = &job->next; + end: + /* All done. Cleanup time. */ + for (i = 0; i < av.n; i++) free(av.v[i]); + free(imgnew); free(imgout); dstr_release(&d); argv_release(&av); } +/* Free the JOB and all the resources it holds. + * + * Close the pipes; kill the child process. Everything must go. + */ static void release_job(struct job *job) { + size_t i; + if (job->kid > 0) kill(job->kid, SIGKILL); /* ?? */ if (job->log && job->log != stdout) fclose(job->log); + free(job->imgnew); free(job->imgout); + for (i = 0; i < job->av.n; i++) free(job->av.v[i]); + argv_release(&job->av); 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); } +/* Do all the necessary things when JOB finishes (successfully or not). + * + * Eventually the job is freed (using `release_job'). + */ static void finish_job(struct job *job) { char buf[16483]; size_t n; int ok = 0; + /* Start a final line to the job log describing its eventual fate. + * + * This is where we actually pick apart the exit status. Set `ok' if it + * actually succeeded, because that's all anything else cares about. + */ fprintf(job->log, "%-13s > ", JOB_NAME(job)); if (WIFEXITED(job->exit)) { if (!WEXITSTATUS(job->exit)) @@ -307,102 +659,44 @@ static void finish_job(struct job *job) 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; + else + fprintf(job->log, "exited with incomprehensible status %06o\n", + job->exit); - 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; + /* If it succeeded, then try to rename the completed image file into place. + * + * If that caused trouble then mark the job as failed after all. + */ + if (ok && rename(job->imgnew, job->imgout)) { + fprintf(job->log, "%-13s > failed to rename Lisp `%s' " + "output image `%s' to `%s': %s", + JOB_NAME(job), JOB_NAME(job), + job->imgnew, job->imgout, strerror(errno)); + ok = 0; } - 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)); + /* If the job failed and we're being quiet then write out the log that we + * made. + */ + 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; + } } - 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; - } + /* Also make a node to stderr about what happened. (Just to make sure + * that we've gotten someone's attention.) + */ + if (!ok) bad("failed to dump Lisp `%s'", JOB_NAME(job)); - if (!n) { - close(buf->fd); buf->fd = -1; - if (buf->len) - write_line(job, buf, buf->len, marker, " [missing final newline]\n"); - } + /* Finally free the job control block. */ + release_job(job); } +/* Called after `SIGCHLD': collect exit statuses and mark jobs as dead. */ static void reap_children(void) { struct job *job, **link; @@ -410,74 +704,45 @@ static void reap_children(void) int st; for (;;) { + + /* Collect a child exit status. If there aren't any more then we're + * done. + */ kid = waitpid(0, &st, WNOHANG); if (kid <= 0) break; + + /* Try to find a matching job. If we can't, then we should just ignore + * it. + */ 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: + /* Mark the job as dead, save its exit status, and move it into the dead + * list. + */ job->exit = st; job->st = JST_DEAD; job->kid = -1; nrun--; *link = job->next; job->next = job_dead; job_dead = job; } + + /* If there was a problem with waitpid(2) then report it. */ 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)); -} - +/* Execute the handler for some JOB. */ 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); + _exit(127); } +/* Start up jobs while there are (a) jobs to run and (b) slots to run them + * in. + */ static void start_jobs(void) { struct dstr d = DSTR_INIT; @@ -485,15 +750,31 @@ static void start_jobs(void) struct job *job; pid_t kid; + /* Keep going until either we run out of jobs, or we've got enough running + * already. + */ while (job_ready && nrun < maxrun) { + + /* Set things up ready. If things go wrong, we need to know what stuff + * needs to be cleaned up. + */ job = job_ready; job_ready = job->next; p_out[0] = p_out[1] = p_err[0] = p_err[1] = -1; + + /* Make a temporary subdirectory for this job to use. */ 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; } + + /* Create the job's log file. If we're being verbose then that's just + * our normal standard output -- /not/ stderr: it's likely that users + * will want to pipe this stuff through a pager or something, and that'll + * be easier if we use stdout. Otherwise, make a file in the temporary + * directory. + */ if (verbose >= 2) job->log = stdout; else { @@ -501,6 +782,10 @@ static void start_jobs(void) if (!job->log) lose("failed to open log file `%s': %s", d.p, strerror(errno)); } + + /* Make the pipes to capture the child process's standard output and + * error streams. + */ if (pipe(p_out) || pipe(p_err)) { bad("failed to create pipes for job `%s': %s", JOB_NAME(job), strerror(errno)); @@ -512,13 +797,23 @@ static void start_jobs(void) configure_fd("job stderr pipe", p_err[1], 0, 1) || configure_fd("log file", fileno(job->log), 1, 1)) goto fail; + + /* Initialize the line-buffer structures ready for use. */ 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); + + /* Print a note to the top of the log. */ fprintf(job->log, "%-13s > starting %s\n", JOB_NAME(job), d.p); + + /* Flush the standard output stream. (Otherwise the child might try to + * flush it too.) + */ fflush(stdout); + + /* Spin up the child process. */ kid = fork(); if (kid < 0) { bad("failed to fork process for job `%s': %s", @@ -533,20 +828,114 @@ static void start_jobs(void) JOB_NAME(job), strerror(errno)); job_child(job); } + + /* Close the ends of the pipes that we don't need. Move the job into + * the running list. + */ 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: + /* Clean up the wreckage if it didn't work. */ 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); } + + /* All done except for some final tidying up. */ dstr_release(&d); } +/* Take care of all of the jobs until they're all done. */ +static void run_jobs(void) +{ + struct job *job, *next, **link; + int nfd; + fd_set fd_in; + + for (;;) { + + /* If there are jobs still to be started and we have slots to spare then + * start some more up. + */ + start_jobs(); + + /* If the queues are now all empty then we're done. (No need to check + * `job_ready' here: `start_jobs' would have started them if `job_run' + * was empty. + */ + if (!job_run && !job_dead) break; + + + /* Prepare for the select(2) call: watch for the signal pipe and all of + * the job pipes. + */ +#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 + + /* Find out what's going on. */ + if (select(nfd, &fd_in, 0, 0, 0) < 0) { + if (errno == EINTR) continue; + else lose("select failed: %s", strerror(errno)); + } + + /* If there were any signals then handle them. */ + if (FD_ISSET(sig_pipe[0], &fd_in)) { + check_signals(); + if (sigloss >= 0) { + /* We hit a fatal signal. Kill off the remaining jobs and abort. */ + 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; + } + } + + /* Log any new output from the running jobs. */ + 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, '*'); + } + + /* Finally, clear away any dead jobs once we've collected all their + * output. + */ + for (link = &job_dead, job = *link; job; job = next) { + next = job->next; + if (job->out.fd >= 0 || job->err.fd >= 0) link = &job->next; + else { *link = next; finish_job(job); } + } + } +} + +/*----- Main program ------------------------------------------------------*/ + +/* Help and related functions. */ static void version(FILE *fp) { fprintf(fp, "%s, runlisp version %s\n", progname, PACKAGE_VERSION); } @@ -584,18 +973,19 @@ Image dumping:\n\ fp); } +/* Main program. */ 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 job *job, **tail; struct stat st; struct dstr d = DSTR_INIT; - int i, fd, nfd, first; - fd_set fd_in; + int i, fd, first; + /* Command-line options. */ static const struct option opts[] = { { "help", 0, 0, 'h' }, { "version", 0, 0, 'V' }, @@ -612,9 +1002,11 @@ int main(int argc, char *argv[]) { 0, 0, 0, 0 } }; + /* Initial setup. */ set_progname(argv[0]); init_config(); + /* Parse the options. */ optprog = (/*unconst*/ char *)progname; for (;;) { i = mdwopt(argc - 1, argv + 1, "hVO:ac:f+i+j:n+o:qv", opts, 0, 0, @@ -640,23 +1032,28 @@ int main(int argc, char *argv[]) } } + /* CHeck that everything worked. */ optind++; if ((flags&AF_ALL) ? optind < argc : optind >= argc) flags |= AF_BOGUS; - if (flags&AF_BOGUS) { usage(stderr); exit(2); } + if (flags&AF_BOGUS) { usage(stderr); exit(127); } + /* Load default configuration if no explicit files were requested. */ 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}"); + /* OK, so we've probably got some work to do. Let's set things up ready. + * It'll be annoying if our standard descriptors aren't actually set up + * properly, so we'll make sure those slots are populated. We'll need a + * `/dev/null' descriptor anyway (to be stdin for the jobs). We'll also + * need a temporary directory, and it'll be less temporary if we don't + * arrange to delete it when we're done. And finally we'll need to know + * when a child process exits. + */ + 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); atexit(cleanup); if (pipe(sig_pipe)) lose("failed to create signal pipe: %s", strerror(errno)); @@ -668,26 +1065,57 @@ int main(int argc, char *argv[]) set_signal_handler("SIGHUP", SIGHUP, SIGF_IGNOK); set_signal_handler("SIGCHLD", SIGCHLD, 0); + /* Create the temporary directory and export it into the configuration. */ set_tmpdir(); - config_set_var(&config, builtin, CF_LITERAL, "@%TMPDIR", tmpdir); + config_set_var(&config, builtin, CF_LITERAL, "@%tmp-dir", tmpdir); config_set_var(&config, builtin, 0, - "@TMPDIR", "${@BUILTIN:@%TMPDIR}/${@NAME}"); + "@tmp-dir", "${@BUILTIN:@%tmp-dir}/${@name}"); + + /* Work out where the image files are going to go. If there's no `-O' + * option then we use the main `image-dir'. Otherwise what happens depends + * on whether this is a file or a directory. + */ + if (!out) + config_set_var(&config, builtin, 0, + "@image-out", "${@image-dir}/${image-file}"); + else if (!stat(out, &st) && S_ISDIR(st.st_mode)) { + config_set_var(&config, builtin, CF_LITERAL, "@%out-dir", out); + config_set_var(&config, builtin, 0, + "@image-out", "${@BUILTIN:@%out-dir}/${image-file}"); + } else if (argc - optind != 1) + lose("can't dump multiple Lisps to a single output file"); + else + config_set_var(&config, builtin, CF_LITERAL, "@image-out", out); + /* Set the staging file. */ + config_set_var(&config, builtin, 0, "@image-new", "${@image-out}.new"); + + /* Dump the final configuration if we're being very verbose. */ if (verbose >= 5) dump_config(); + /* Create jobs for the Lisp systems we're supposed to be dumping. */ tail = &job_ready; if (!(flags&AF_ALL)) for (i = optind; i < argc; i++) add_job(&tail, 0, argv[i], strlen(argv[i])); else { + /* So we're supposed to dump `all' of them. If there's a `dump' + * configuration setting then we need to parse that. Otherwise we just + * try all of them. + */ var = config_find_var(&config, toplevel, 0, "dump"); - if (!var) + if (!var) { + /* No setting. Just do all of the Lisps which look available. */ + + flags |= AF_CHECKINST; 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 { + } else { + /* Parse the `dump' list. */ + p = var->val; l = p + var->n; for (;;) { while (p < l && ISSPACE(*p)) p++; @@ -695,12 +1123,14 @@ int main(int argc, char *argv[]) q = p; while (p < l && !ISSPACE(*p) && *p != ',') p++; add_job(&tail, 0, q, p - q); - if (p < l) p++; + while (p < l && ISSPACE(*p)) p++; + if (p < l && *p == ',') p++; } } } *tail = 0; + /* Report on what it is we're about to do. */ if (verbose >= 3) { dstr_reset(&d); first = 1; @@ -714,6 +1144,9 @@ int main(int argc, char *argv[]) moan("dumping Lisps: %s", d.p); } + /* If we're not actually going to do anything after all then now's the time + * to, err, not do that. + */ if (flags&AF_DRYRUN) { for (job = job_ready; job; job = job->next) { if (try_exec(&job->av, @@ -728,75 +1161,16 @@ int main(int argc, char *argv[]) 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); } - } - } + /* Run the jobs. */ + run_jobs(); + /* Finally, check for any last signals. If we hit any fatal signals then + * we should kill ourselves so that the exit status will be right. + */ check_signals(); if (sigloss) { cleanup(); signal(sigloss, SIG_DFL); raise(sigloss); } + /* All done! */ return (rc); } diff --git a/lib.c b/lib.c index 104eebd..523ca23 100644 --- a/lib.c +++ b/lib.c @@ -40,18 +40,12 @@ #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 = "???"; + /* Our program name, for use in error messages. */ +/* Set `progname' from the pathname in PROG (typically from `argv[0]'). */ void set_progname(const char *prog) { const char *p; @@ -60,6 +54,9 @@ void set_progname(const char *prog) progname = p ? p + 1 : progname; } +/* Report an error or warning in Unix style, given a captured argument + * cursor. + */ void vmoan(const char *msg, va_list ap) { fprintf(stderr, "%s: ", progname); @@ -67,14 +64,21 @@ void vmoan(const char *msg, va_list ap) fputc('\n', stderr); } +/* Issue a warning message. */ void moan(const char *msg, ...) { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); } +/* Issue a fatal error message and exit unsuccessfully. */ void lose(const char *msg, ...) { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); exit(127); } /*----- Memory allocation -------------------------------------------------*/ +/* Allocate and return a pointer to N bytes, or report a fatal error. + * + * Release the pointer using `free' as usual. If N is zero, returns null + * (but you are not expected to check for this). + */ void *xmalloc(size_t n) { void *p; @@ -84,6 +88,13 @@ void *xmalloc(size_t n) return (p); } +/* Resize the block at P (from `malloc' or `xmalloc') to be N bytes long. + * + * The block might (and probably will) move, so it returns the new address. + * If N is zero, then the block is freed (if necessary) and a null pointer + * returned; otherwise, if P is null then a fresh block is allocated. If + * allocation fails, then a fatal error is reported. + */ void *xrealloc(void *p, size_t n) { if (!n) { free(p); return (0); } @@ -92,6 +103,11 @@ void *xrealloc(void *p, size_t n) return (p); } +/* Allocate and return a copy of the N-byte string starting at P. + * + * The new string is null-terminated, though P need not be. If allocation + * fails, then a fatal error is reported. + */ char *xstrndup(const char *p, size_t n) { char *q = xmalloc(n + 1); @@ -100,14 +116,24 @@ char *xstrndup(const char *p, size_t n) return (q); } +/* Allocate and return a copy of the null-terminated string starting at P. + * + * If allocation fails, then a fatal error is reported. + */ char *xstrdup(const char *p) { return (xstrndup(p, strlen(p))); } /*----- Dynamic strings ---------------------------------------------------*/ +/* Initialize the string D. + * + * Usually you'd use the static initializer `DSTR_INIT'. + */ void dstr_init(struct dstr *d) { d->p = 0; d->len = d->sz = 0; } +/* Reset string D so it's empty again. */ void dstr_reset(struct dstr *d) { d->len = 0; } +/* Ensure that D has at least N unused bytes available. */ void dstr_ensure(struct dstr *d, size_t n) { size_t need = d->len + n, newsz; @@ -118,11 +144,25 @@ void dstr_ensure(struct dstr *d, size_t n) d->p = xrealloc(d->p, newsz); d->sz = newsz; } +/* Release the memory held by D. + * + * It must be reinitialized (e.g., by `dstr_init') before it can be used + * again. + */ void dstr_release(struct dstr *d) { free(d->p); } +/* Append the N-byte string at P to D. + * + * P need not be null-terminated. D will not be null-terminated + * afterwards. + */ 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; } +/* Append the null-terminated string P to D. + * + * D /is/ guaranteed to be null-terminated after this. + */ void dstr_puts(struct dstr *d, const char *p) { size_t n = strlen(p); @@ -132,15 +172,33 @@ void dstr_puts(struct dstr *d, const char *p) d->len += n; } +/* Append the single character CH to D. + * + * D will not be null-terminated afterwards. + */ void dstr_putc(struct dstr *d, int ch) { dstr_ensure(d, 1); d->p[d->len++] = ch; } +/* Append N copies of the character CH to D. + * + * D will not be null-terminated afterwards. + */ 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; } +/* Null-terminate the string D. + * + * This doesn't change the length of D. If further stuff is appended then + * the null terminator will be overwritten. + */ void dstr_putz(struct dstr *d) { dstr_ensure(d, 1); d->p[d->len] = 0; } +/* Append stuff to D, determined by printf(3) format string P and argument + * tail AP. + * + * D will not be null-terminated afterwards. + */ void dstr_vputf(struct dstr *d, const char *p, va_list ap) { va_list ap2; @@ -158,9 +216,20 @@ void dstr_vputf(struct dstr *d, const char *p, va_list ap) d->len += n; } +/* Append stuff to D, determined by printf(3) format string P and arguments. + * + * D will not be null-terminated afterwards. + */ 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); } +/* Append the next input line from FP to D. + * + * Return 0 on success, or -1 if reading immediately fails or encounters + * end-of-file (call ferror(3) to distinguish). Any trailing newline is + * discarded: it is not possible to determine whether the last line was ended + * with a newline. D is guaranteed to be null-terminated afterwards. + */ int dstr_readline(struct dstr *d, FILE *fp) { size_t n; @@ -180,11 +249,17 @@ int dstr_readline(struct dstr *d, FILE *fp) /*----- Dynamic vectors of strings ----------------------------------------*/ +/* Initialize the vector AV. + * + * Usually you'd use the static initializer `ARGV_INIT'. + */ void argv_init(struct argv *av) { av->v = 0; av->o = av->n = av->sz = 0; } +/* Reset the vector AV so that it's empty again. */ void argv_reset(struct argv *av) { av->n = 0; } +/* Ensure that AV has at least N unused slots at the end. */ void argv_ensure(struct argv *av, size_t n) { size_t need = av->n + av->o + n, newsz; @@ -192,12 +267,11 @@ void argv_ensure(struct argv *av, size_t n) 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->v = xrealloc(av->v - av->o, newsz*sizeof(char *)) + av->o; av->sz = newsz; } +/* Ensure that AV has at least N unused slots at the /start/. */ void argv_ensure_offset(struct argv *av, size_t n) { size_t newoff; @@ -210,59 +284,81 @@ void argv_ensure_offset(struct argv *av, size_t n) 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 *)); + memmove(av->v + newoff - av->o, av->v, av->n*sizeof(char *)); av->v += newoff - av->o; av->o = newoff; } +/* Release the memory held by AV. + * + * It must be reinitialized (e.g., by `argv_init') before it can be used + * again. + */ void argv_release(struct argv *av) { free(av->v - av->o); } -void argv_append(struct argv *av, const char *p) +/* Append the pointer P to AV. */ +void argv_append(struct argv *av, char *p) { argv_ensure(av, 1); av->v[av->n++] = p; } +/* Append a null pointer to AV, without extending the vactor length. + * + * The null pointer will be overwritten when the next string is appended. + */ 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) +/* Append a N-element vector V of pointers to AV. */ +void argv_appendn(struct argv *av, char *const *v, size_t n) { argv_ensure(av, n); memcpy(av->v + av->n, v, n*sizeof(const char *)); av->n += n; } +/* Append the variable-length vector BV to AV. */ void argv_appendav(struct argv *av, const struct argv *bv) { argv_appendn(av, bv->v, bv->n); } +/* Append the pointers from a variable-length argument list AP to AV. + * + * The list is terminated by a null pointer. + */ 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); } + char *p; + for (;;) { p = va_arg(ap, char *); if (!p) break; argv_append(av, p); } } +/* Append the argument pointers, terminated by a null pointer, to AV. */ 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) +/* Prepend the pointer P to AV. */ +void argv_prepend(struct argv *av, 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) +/* Prepend a N-element vector V of pointers to AV. */ +void argv_prependn(struct argv *av, 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 *)); } +/* Prepend the variable-length vector BV to AV. */ void argv_prependav(struct argv *av, const struct argv *bv) { argv_prependn(av, bv->v, bv->n); } +/* Prepend the pointers from a variable-length argument list AP to AV. + * + * The list is terminated by a null pointer. + */ void argv_prependv(struct argv *av, va_list ap) { - const char *p, **v; + char *p, **v; size_t n = 0; for (;;) { - p = va_arg(ap, const char *); if (!p) break; + p = va_arg(ap, char *); if (!p) break; argv_prepend(av, p); n++; } v = av->v; @@ -272,31 +368,85 @@ void argv_prependv(struct argv *av, va_list ap) } } +/* Prepend the argument pointers, terminated by a null pointer, to AV. */ void argv_prependl(struct argv *av, ...) { va_list ap; va_start(ap, av); argv_prependv(av, ap); va_end(ap); } /*----- Treaps ------------------------------------------------------------*/ +/* Return nonzero if the AN-byte string A is strictly precedes the BN-byte + * string B in a lexicographic ordering. + * + * All comparisons of keys is handled by this function. + */ +static int str_lt(const char *a, size_t an, const char *b, size_t bn) +{ + /* This is a little subtle. We need only compare the first N bytes of the + * strings, where N is the length of the shorter string. If this + * distinguishes the two strings, then we're clearly done. Otherwise, if + * the prefixes are equal then the shorter string is the smaller one. If + * the two strings are the same length, then they're equal. + * + * Hence, if A is the strictly shorter string, then A precedes B if A + * precedes or matches the prefix of B; otherwise A only precedes B if A + * strictly precedes the prefix of B. + */ + if (an < bn) return (MEMCMP(a, <=, b, an)); + else return (MEMCMP(a, <, b, bn)); +} + +/* Initialize the treap T. + * + * Usually you'd use the static initializer `TREAP_INIT'. + */ void treap_init(struct treap *t) { t->root = 0; } +/* Look up the KN-byte key K in the treap T. + * + * Return a pointer to the matching node if one was found, or null otherwise. + */ void *treap_lookup(const struct treap *t, const char *k, size_t kn) { struct treap_node *n = t->root, *candidate = 0; - while (n) { + /* This is a simple prototype for some of the search loops we'll encounter + * later. Notice that we use a strict one-sided comparison, rather than + * the more conventional two-sided comparison. + * + * The main loop will find the largest key not greater than K. + */ + while (n) + /* Compare the node's key against our key. If the node is too large, + * then we ignore it and move left. Otherwise remember this node for + * later, and move right to see if we can find a better, larger node. + */ + if (str_lt(k, kn, n->k, n->kn)) n = n->left; else { candidate = n; n = n->right; } - } + + /* If the candidate node is less than our key then we failed. Otherwise, + * by trichotomy, we have found the correct node. + */ if (!candidate || str_lt(candidate->k, candidate->kn, k, kn)) return (0); return (candidate); } +/* Look up the KN-byte K in the treap T, recording a path in P. + * + * This is similar to `treap_lookup', in that it returns the requested node + * if it already exists, or null otherwise, but it also records in P + * information to be used by `treap_insert' to insert a new node with the + * given key it's not there already. + */ 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; + /* This walk is similar to `treap_lookup' above, except that we also record + * the address of each node pointer we visit along the way. + */ for (;;) { assert(i < TREAP_PATHMAX); p->path[i++] = nn; if (!*nn) break; @@ -304,10 +454,16 @@ void *treap_probe(struct treap *t, const char *k, size_t kn, else { candidate = *nn; nn = &(*nn)->right; } } p->nsteps = i; + + /* Check to see whether we found the right node. */ if (!candidate || str_lt(candidate->k, candidate->kn, k, kn)) return (0); return (candidate); } +/* Insert a new node N into T, associating it with the KN-byte key K. + * + * Use the path data P, from `treap_probe', to help with insertion. + */ void treap_insert(struct treap *t, const struct treap_path *p, struct treap_node *n, const char *k, size_t kn) { @@ -315,46 +471,164 @@ void treap_insert(struct treap *t, const struct treap_path *p, struct treap_node **nn, **uu, *u; unsigned wt; + /* Fill in the node structure. */ n->k = xstrndup(k, kn); n->kn = kn; n->wt = wt = rand(); n->left = n->right = 0; + + /* Prepare for the insertion. + * + * The path actually points to each of the links traversed when searching + * for the node, starting with the `root' pointer, then the `left' or + * `right' pointer of the root node, and so on; `nsteps' will always be + * nonzero, since the path will always pass through the root, and the final + * step, `path->path[path->nsteps - 1]' will always be the address of a + * null pointer onto which the freshly inserted node could be hooked in + * order to satisfy the binary-search-tree ordering. (Of course, this will + * likely /not/ satisfy the heap condition, so more work needs to be done.) + * + * Throughout, NN is our current candidate for where to attach the node N. + * As the loop progresses, NN will ascend to links further up the tree, and + * N will be adjusted to accumulate pieces of the existing tree structure. + * We'll stop when we find that the parent node's weight is larger than our + * new node's weight, at which point we can just set *NN = N; or if we run + * out of steps in the path, in which case *NN is the root pointer. + */ assert(i); nn = p->path[--i]; while (i--) { + + /* Collect the next step in the path, and get the pointer to the node. */ uu = p->path[i]; u = *uu; + + /* If this node's weight is higher, then we've found the right level and + * we can stop. + */ if (wt <= u->wt) break; + + /* The node U is lighter than our new node N, so we must rotate in order + * to fix things. If we were currently planning to hook N as the left + * subtree of U, then we rotate like this: + * + * | | + * U N + * / \ / \ + * (N) Z ---> X U + * / \ / \ + * X Y Y Z + * + * On the other hand, if we ere planning to hook N as the right subtree + * of U, then we do the opposite rotation: + * + * | | + * U N + * / \ / \ + * X (N) ---> U Z + * / \ / \ + * Y Z X Y + * + * These transformations clearly preserve the ordering of nodes in the + * binary search tree, and satisfy the heap condition in the subtree + * headed by N. + */ if (nn == &u->left) { u->left = n->right; n->right = u; } else { u->right = n->left; n->left = u; } + + /* And this arrangement must be attached to UU, or some higher attachment + * point. The subtree satisfies the heap condition, and can be attached + * safely at the selected place. + */ nn = uu; } + + /* We've found the right spot. Hook the accumulated subtree into place. */ *nn = n; } +/* Remove the node with the KN-byte K from T. + * + * Return the address of the node we removed, or null if it couldn't be + * found. + */ 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) { + /* Search for the matching node, but keep track of the address of the link + * which points to our target node. + */ + while (*nn) if (str_lt(k, kn, (*nn)->k, (*nn)->kn)) nn = &(*nn)->left; else { candidate = nn; nn = &(*nn)->right; } - } + + /* If this isn't the right node then give up. */ 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); + /* Now we need to disentangle the node from the tree. This is essentially + * the reverse of insertion: we pretend that this node is suddenly very + * light, and mutate the tree so as to restore the heap condition until + * eventually our node is a leaf and can be cut off without trouble. + * + * Throughout, the link *NN notionally points to N, but we don't actually + * update it until we're certain what value it should finally take. + */ + nn = candidate; n = *nn; l = n->left; r = n->right; + for (;;) + + /* If its left subtree is empty then we can replace our node by its right + * subtree and be done. Similarly, if the right subtree is empty then we + * replace the node by its left subtree. + * + * | | | | + * (N) ---> R ; (N) ---> L + * / \ / \ + * * R L * + */ + if (!l) { *nn = r; break; } + else if (!r) { *nn = l; break; } + + /* Otherwise we need to rotate the pointers so that the heavier of the + * two children takes the place of our node; thus we have either + * + * | | + * (N) L + * / \ / \ + * L R ---> X (N) + * / \ / \ + * X Y Y Z + * + * or + * + * | | + * (N) R + * / \ / \ + * L R ---> (N) Y + * / \ / \ + * X Y L X + * + * Again, these transformations clearly preserve the ordering of nodes in + * the binary search tree, and the heap condition. + */ + else if (l->wt > r->wt) { *nn = l; n->left = l->right; nn = &l->right; } + else { *nn = r; n->right = r->left; nn = &r->left; } + + /* Release the key buffer, and return the node that we've now detached. */ + free(n->k); return (n); } +/* Initialize an iterator I over T's nodes. */ void treap_start_iter(struct treap *t, struct treap_iter *i) { struct treap_node *n = t->root; unsigned sp = 0; + /* The `stack' in the iterator structure is an empty ascending stack of + * nodes which have been encountered, and their left subtrees investigated, + * but not yet visited by the iteration. + * + * Iteration begins by stacking the root node, its left child, and so on, + * At the end of this, the topmost entry on the stack is the least node of + * the tree, followed by its parent, grandparent, and so on up to the root. + */ while (n) { assert(sp < TREAP_PATHMAX); i->stack[sp++] = n; n = n->left; @@ -362,12 +636,73 @@ void treap_start_iter(struct treap *t, struct treap_iter *i) i->sp = sp; } +/* Return the next node from I, in ascending order by key. + * + * If there are no more nodes, then return null. + */ void *treap_next(struct treap_iter *i) { struct treap_node *n, *o; unsigned sp = i->sp; + /* We say that a node is /visited/ once it's been returned by this + * iterator. To traverse a tree in order, then, we traverse its left + * subtree, visit the tree root, and traverse its right subtree -- which is + * a fine recursive definition, but we need a nonrecursive implementation. + * + * As is usual in this kind of essential structural recursion, we maintain + * a stack. The invariant that we'll maintain is as follows. + * + * 1. If the stack is empty, then all nodes have been visited. + * + * 2, If the stack is nonempty then the topmost entry on the stack is the + * least node which has not yet been visited -- and therefore is the + * next node to visit. + * + * 3. The earlier entries in the stack are, in (top to bottom) order, + * those of the topmost node's parent, grandparent, etc., up to the + * root, which have not yet been visited. More specifically, a node + * appears in the stack if and only if some node in its left subtree + * is nearer the top of the stack. + * + * When we initialized the iterator state (in `treap_start_iter' above), we + * traced a path to the leftmost leaf, stacking the root, its left-hand + * child, and so on. The leftmost leaf is clearly the first node to be + * visited, and its entire ancestry is on the stack since none of these + * nodes has yet been visited. (If the tree is empty, then we have done + * nothing, the stack is empty, and there are no nodes to visit.) This + * establishes the base case for the induction. + */ + + /* So, if the stack is empty now, then (1) all of the nodes have been + * visited and there's nothing left to do. Return null. + */ if (!sp) return (0); + + /* It's clear that, if we pop the topmost element of the stack, visit it, + * and arrange to reestablish the invariant, then we'll visit the nodes in + * the correct order, pretty much by definition. + * + * So, pop a node off the stack. This is the node we shall return. But + * before we can do that, we must reestablish the above invariant. + * Firstly, the current node is removed from the stack, because we're about + * to visit it, and visited nodes don't belong on the stack. Then there + * are two cases to consider. + * + * * If the current node's right subtree is not empty, then the next node + * to be visited is the leftmost node in that subtree. All of the + * nodes on the stack are ancestors of the current nodes, and the right + * subtree consists of its descendants, so none of them are already on + * the stack, and they're all greater than the current node, and + * therefore haven't been visited. Therefore, we must push the current + * node's right child, its /left/ child, and so on, proceeding + * leftwards until we fall off the bottom of the tree. + * + * * Otherwise, we've finished traversing some subtree. Either we are + * now done, or (3) we have just finished traversing the left subtree + * of the next topmost item on the stack. This must therefore be the + * next node to visit. The rest of the stack is already correct. + */ n = i->stack[--sp]; o = n->right; while (o) { @@ -378,19 +713,44 @@ void *treap_next(struct treap_iter *i) return (n); } -static void check_node(struct treap_node *n, unsigned maxwt, - const char *klo, const char *khi) +/* Recursively check the subtree headed by N. + * + * No node should have weight greater than MAXWT, to satisfy the heap + * condition; if LO is not null, then all node keys should be strictly + * greater than LO, and, similarly, if HI is not null, then all keys should + * be strictly smaller than HI. + */ +static void check_subtree(struct treap_node *n, unsigned maxwt, + const char *klo, const char *khi) { + /* Check the heap condition. */ assert(n->wt <= maxwt); + + /* Check that the key is in bounds. (Use `strcmp' here to ensure that our + * own `str_lt' is working correctly.) + */ 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); + + /* Check the left subtree. Node weights must be bounded above by our own + * weight. And everykey in the left subtree must be smaller than our + * current key. We propagate the lower bound. + */ + if (n->left) check_subtree(n->left, n->wt, klo, n->k); + + /* Finally, check the right subtree. This time, every key must be larger + * than our key, and we propagate the upper bound. + */ + if (n->right) check_subtree(n->right, n->wt, n->k, khi); } +/* Check the treap structure rules for T. */ void treap_check(struct treap *t) - { if (t->root) check_node(t->root, t->root->wt, 0, 0); } + { if (t->root) check_subtree(t->root, t->root->wt, 0, 0); } +/* Recursively dump the subtree headed by N, indenting the output lines by + * IND spaces. + */ static void dump_node(struct treap_node *n, int ind) { if (n->left) dump_node(n->left, ind + 1); @@ -398,6 +758,7 @@ static void dump_node(struct treap_node *n, int ind) if (n->right) dump_node(n->right, ind + 1); } +/* Dump the treap T to standard output, for debugging purposes. */ void treap_dump(struct treap *t) { if (t->root) dump_node(t->root, 0); } /*----- Configuration file parsing ----------------------------------------*/ @@ -406,13 +767,48 @@ void treap_dump(struct treap *t) { if (t->root) dump_node(t->root, 0); } extern char **environ; #endif +/* Advance P past a syntactically valid name, but no further than L. + * + * Return the new pointer. If no name is found, report an error, blaming + * FILE and LINE; WHAT is an adjective for the kind of name that was + * expected. + */ +static const char *scan_name(const char *what, + const char *p, const char *l, + const char *file, unsigned line) +{ + const char *q = p; + + while (q < l && + (ISALNUM(*q) || *q == '-' || *q == '_' || *q == '.' || *q == '/' || + *q == '*' || *q == '+' || *q == '%' || *q == '@')) + q++; + if (q == p) lose("%s:%u: expected %s name", file, line, what); + return (q); +} + +/* Initialize the configuration state CONF. + * + * Usually you'd use the static initializer `CONFIG_INIT'. + */ void config_init(struct config *conf) { treap_init(&conf->sections); } +/* Find and return the section with null-terminated NAME in CONF. + * + * If no section is found, the behaviour depends on whether `CF_CREAT' is set + * in F: if so, an empty section is created and returned; otherwise, a null + * pointer is returned. + */ struct config_section *config_find_section(struct config *conf, unsigned f, const char *name) { return (config_find_section_n(conf, f, name, strlen(name))); } +/* Find and return the section with the SZ-byte NAME in CONF. + * + * This works like `config_find_section', but with an explicit length for the + * NAME rather than null-termination. + */ struct config_section *config_find_section_n(struct config *conf, unsigned f, const char *name, size_t sz) { @@ -430,18 +826,27 @@ struct config_section *config_find_section_n(struct config *conf, unsigned f, 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); + config_set_var_n(conf, sect, CF_LITERAL, "@name", 5, name, sz); } } return (sect); } +/* Set the fallback section for CONF to be SECT. + * + * That is, if a section has no explicit parents, then by default it will + * have a single parent which is SECT. If SECT is null then there is no + * fallback section, and sections which don't have explicitly specified + * parents have no parents at all. (This is the default situation.) + */ void config_set_fallback(struct config *conf, struct config_section *sect) -{ - if (sect->nparents == SIZE_MAX) sect->nparents = 0; - conf->fallback = sect; -} + { conf->fallback = sect; } +/* Arrange that SECT has PARENT as its single parent section. + * + * If PARENT is null, then arrange that SECT has no parents at all. In + * either case, any `@parents' setting will be ignored. + */ void config_set_parent(struct config_section *sect, struct config_section *parent) { @@ -453,10 +858,15 @@ void config_set_parent(struct config_section *sect, } } +/* Initialize I to iterate over the sections defined in CONF. */ void config_start_section_iter(struct config *conf, struct config_section_iter *i) { i->sect = conf->head; } +/* Return the next section from I, in order of creation. + * + * If there are no more sections, then return null. + */ struct config_section *config_next_section(struct config_section_iter *i) { struct config_section *sect; @@ -466,35 +876,59 @@ struct config_section *config_next_section(struct config_section_iter *i) return (sect); } +/* Initialize the `parents' links of SECT, if they aren't set up already. + * + * If SECT contains a `@parents' setting then parse it to determine the + * parents; otherwise use CONF's fallbeck section, as established by + * `config_set_fallback'. + */ 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; + const char *file; unsigned line; size_t i, n; - char *p, *q; + char *p, *q, *l; + struct argv av = ARGV_INIT; + /* If the section already has parents established then there's nothing to + * do. + */ if (sect->nparents != SIZE_MAX) return; - var = treap_lookup(§->vars, "@PARENTS", 8); + /* Look up `@parents', without recursion! */ + var = treap_lookup(§->vars, "@parents", 8); if (!var) { - if (!conf->fallback) + /* No explicit setting: use the fallback setting. */ + + if (!conf->fallback || conf->fallback == sect) sect->nparents = 0; else { - sect->parents = xmalloc(sizeof(*sect->parents)); - sect->nparents = 1; + 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++; + /* Found a `@parents' list: parse it and set the parents list. */ + + file = var->file; line = var->line; if (!file) file = ""; + + /* We do this in two phases. First, we parse out the section names, and + * record start/limit pointer pairs in `av'. + */ + p = var->val; l = p + var->n; while (p < l && ISSPACE(*p)) p++; + while (*p) { + q = p; + p = (/*unconst*/ char *)scan_name("parent section", p, l, file, line); + argv_append(&av, q); argv_append(&av, p); + while (p < l && ISSPACE(*p)) p++; + if (p >= l) break; + if (*p == ',') do p++; while (ISSPACE(*p)); } + + /* Now that we've finished parsing, we know how many parents we're going + * to have, so we can allocate the `parents' vector and fill it in. + */ sect->nparents = av.n/2; sect->parents = xmalloc(sect->nparents*sizeof(sect->parents)); for (i = 0; i < av.n; i += 2) { @@ -502,13 +936,21 @@ static void set_config_section_parents(struct config *conf, 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]); + file, line, (int)n, av.v[i]); sect->parents[i/2] = parent; } - argv_release(&av); } + + /* All done. */ + argv_release(&av); } +/* Find a setting of the SZ-byte variable NAME in CONF, starting from SECT. + * + * If successful, return a pointer to the variable; otherwise return null. + * Inheritance cycles and ambiguous inheritance are diagnosed as fatal + * errors. + */ struct config_var *search_recursive(struct config *conf, struct config_section *sect, const char *name, size_t sz) @@ -518,6 +960,25 @@ struct config_var *search_recursive(struct config *conf, struct config_var *var, *v; size_t i, j = j; + /* If the variable is defined locally then we can just return it. */ + var = treap_lookup(§->vars, name, sz); if (var) return (var); + + /* If we have no parents then there's no way we can find it. */ + set_config_section_parents(conf, sect); + if (!sect->parents) return (0); + + /* Otherwise we must visit the section's parents. We can avoid paying for + * this on every lookup by using a cache. If there's already an entry for + * this variable then we can return the result immediately (note that we + * cache both positive and negative outcomes). Otherwise we create a new + * cache entry, do the full recursive search, and fill in the result when + * we're done. + * + * The cache also helps us detect cycles: we set the `CF_OPEN' flag on a + * new cache entry when it's first created, and clear it when we fill in + * the result: if we encounter an open cache entry again, we know that + * we've found a cycle. + */ cache = treap_probe(§->cache, name, sz, &path); if (!cache) { cache = xmalloc(sizeof(*cache)); cache->f = CF_OPEN; @@ -528,32 +989,51 @@ struct config_var *search_recursive(struct config *conf, 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])); - } + /* Recursively search in each parent. We insist that all parents that find + * a variable find the same binding; otherwise we declare ambiguous + * inheritance. + */ + 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])); } + /* All done: fill the cache entry in, clear the open flag, and return the + * result. + */ cache->var = var; cache->f &= ~CF_OPEN; return (var); } +/* Find and return the variable with null-terminated NAME in SECT. + * + * If `CF_INHERIT' is set in F, then the function searches the section's + * parents recursively; otherwise, it only checks to see whether the variable + * is set directly in SECT. + * + * If no variable is found, the behaviour depends on whether `CF_CREAT' is + * set in F: if so, an empty variable is created and returned; otherwise, a + * null pointer is returned. + * + * Setting both `CF_INHERIT' and `CF_CREAT' is not useful. + */ 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))); } +/* Find and return the variable with the given SZ-byte NAME in SECT. + * + * This works like `config_find_var', but with an explicit length for the + * NAME rather than null-termination. + */ struct config_var *config_find_var_n(struct config *conf, struct config_section *sect, unsigned f, const char *name, size_t sz) @@ -576,22 +1056,26 @@ struct config_var *config_find_var_n(struct config *conf, 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)); } - +/* Set variable NAME to VALUE in SECT, with associated flags F. + * + * The names are null-terminated. The flags are variable flags: see `struct + * config_var' for details. + * + * If the variable is already set and has the `CF_OVERRIDE' flag, then this + * function does nothing unless `CF_OVERRIDE' is /also/ set in F. + */ void config_set_var(struct config *conf, struct config_section *sect, - unsigned f, - const char *name, const char *value) + unsigned f, const char *name, const char *value) { config_set_var_n(conf, sect, f, name, strlen(name), value, strlen(value)); } +/* As `config_set_var', except that the variable NAME and VALUE have explicit + * lengths (NAMELEN and VALUELEN, respectively) rather than being null- + * terminated. + */ void config_set_var_n(struct config *conf, struct config_section *sect, unsigned f, const char *name, size_t namelen, @@ -605,15 +1089,37 @@ void config_set_var_n(struct config *conf, struct config_section *sect, var->f = f; } +/* Initialize I to iterate over the variables directly defined in SECT. */ +void config_start_var_iter(struct config *conf, struct config_section *sect, + struct config_var_iter *i) + { treap_start_iter(§->vars, &i->i); } + +/* Return next variable from I, in ascending lexicographical order. + * + * If there are no more variables, then return null. + */ +struct config_var *config_next_var(struct config_var_iter *i) + { return (treap_next(&i->i)); } + +/* Read and parse configuration FILE, applying its settings to CONF. + * + * If all goes well, the function returns 0. If the file is not found, then + * the behaviour depends on whether `CF_NOENTOK' is set in F: if so, then the + * function simply returns -1. Otherwise, a fatal error is reported. Note + * that this /only/ applies if the file does not exist (specifically, opening + * it fails with `ENOENT') -- any other problems are reported as fatal + * errors regardless of the flag setting. + */ 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; + const char *p, *q, *r; FILE *fp; + /* Try to open the file. */ fp = fopen(file, "r"); if (!fp) { if ((f&CF_NOENTOK) && errno == ENOENT) return (-1); @@ -621,61 +1127,107 @@ int config_read_file(struct config *conf, const char *file, unsigned f) file, strerror(errno)); } + /* Find the initial section. */ sect = config_find_section(conf, CF_CREAT, "@CONFIG"); var = 0; + /* Work through the file, line by line. */ for (;;) { dstr_reset(&d); if (dstr_readline(&d, fp)) break; line++; - if (d.p[0] && !ISSPACE(d.p[0])) { + /* Trim trailing spaces from the line. The syntax is sensitive to + * leading spaces, so we can't trim those yet. + */ + while (d.len && ISSPACE(d.p[d.len - 1])) d.len--; + d.p[d.len] = 0; + + if (!*d.p || *d.p == ';') + /* Ignore comments entirely. (In particular, a comment doesn't + * interrupt a multiline variable value.) + */ + ; + + else if (ISSPACE(d.p[0])) { + /* The line starts with whitespace, so it's a continuation line. */ + + /* Skip the initial whitespace. */ + p = d.p; while (ISSPACE(*p)) p++; + + /* If we aren't collecting a variable value then this is an error. + * Otherwise, accumulate it into the current value. + */ + if (!var) + lose("%s:%u: continuation line, but no variable", file, line); + if (dd.len) dstr_putc(&dd, ' '); + dstr_putm(&dd, p, d.len - (p - d.p)); + + } else { + /* The line starts in the first column. */ + + /* If there's a value value being collected then we must commit it to + * its variable (unless there's already a setting there that says we + * shouldn't). + */ 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); + + /* Now decide what kind of line this is. */ + if (d.p[0] == '[') { + /* It's a section header. */ + + /* Parse the header. */ + p = d.p + 1; while (ISSPACE(*p)) p++; + q = scan_name("section", p, d.p + d.len, file, line); + r = q; while (ISSPACE(*r)) r++; + if (*r != ']') + lose("%s:%u: expected `]' in section header", file, line); + if (r[1]) + lose("%s:%u: trailing junk after `]' in section header", + file, line); + + /* Create the new section. */ 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++; + /* It's a variable assignment. Parse the name out. */ + p = scan_name("variable", d.p, d.p + d.len, file, line); 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++; + + /* Clear out the variable's initial value, unless we shouldn't + * override it. + */ 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 there's a value under construction then commit the result. */ if (var && !(var->f&CF_OVERRIDE)) { var->val = xstrndup(dd.p, dd.len); var->n = dd.len; } - dstr_release(&d); dstr_release(&dd); + /* Close the file. */ if (fclose(fp)) lose("error reading configuration file `%s': %s", file, strerror(errno)); + + /* All done. */ + dstr_release(&d); dstr_release(&dd); return (0); } +/* Populate SECT with environment variables. + * + * Environment variables are always set with `CF_LITERAL'. + */ void config_read_env(struct config *conf, struct config_section *sect) { const char *p, *v; @@ -689,50 +1241,112 @@ void config_read_env(struct config *conf, struct config_section *sect) /*----- Substitution and quoting ------------------------------------------*/ +/* The substitution and word-splitting state. + * + * This only keeps track of the immutable parameters for the substitution + * task: stuff which changes (flags, filtering state, cursor position) is + * maintained separately. + */ struct subst { - struct config *config; - struct config_section *home, *fallback; - struct argv *av; - struct dstr *d; + struct config *config; /* configuration state */ + struct config_section *home; /* home section for lookups */ + struct dstr *d; /* current word being constructed */ + struct argv *av; /* output word list */ }; -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) +/* Flags for `subst' and related functions. */ +#define SF_SPLIT 0x0001u /* split at (unquoted) whitespace */ +#define SF_QUOT 0x0002u /* currently within double quotes */ +#define SF_SUBST 0x0004u /* apply `$-substitutions */ +#define SF_SUBEXPR 0x0008u /* stop at delimiter `|' or `}' */ +#define SF_SPANMASK 0x00ffu /* mask for the above */ + +#define SF_WORD 0x0100u /* output word under construction */ +#define SF_SKIP 0x0200u /* not producing output */ +#define SF_LITERAL 0x0400u /* do not expand or substitute */ +#define SF_UPCASE 0x0800u /* convert to uppercase */ +#define SF_DOWNCASE 0x1000u /* convert to lowercase */ +#define SF_CASEMASK 0x1800u /* mask for case conversions */ + +/* Apply filters encoded in QFILT and F to the text from P to L, and output. + * + * SB is the substitution state which, in particular, explains where the + * output should go. + * + * The filters are encoded as flags `SF_UPCASE' and `SF_DOWNCASE' for case + * conversions, and a nesting depth QFILT for toothpick escaping. (QFILT is + * encoded as the number of toothpicks to print: see `subst' for how this + * determined.) + */ +static void filter_string(const char *p, const char *l, + const struct subst *sb, unsigned qfilt, unsigned f) { size_t r, n; + char *q; const char *pp, *ll; - if (!qfilt) + if (!qfilt && !(f&SF_CASEMASK)) + /* Fast path: there's nothing to do: just write to the output. */ dstr_putm(sb->d, p, l - p); + else for (;;) { - r = l - p; n = strcspn(p, "\"\\"); + /* We must be a bit more circumspect. */ + + /* Determine the length of the next span of characters which don't need + * escaping. (If QFILT is zero then this is everything.) + */ + r = l - p; n = qfilt ? strcspn(p, "\"\\") : r; if (n > r) n = r; - dstr_putm(sb->d, p, n); + + if (!(f&SF_CASEMASK)) + /* No case conversion: we can just emit this chunk. */ + + dstr_putm(sb->d, p, n); + + else { + /* Case conversion to do. Arrange enough space for the output, and + * convert it character by character. + */ + + dstr_ensure(sb->d, n); q = sb->d->p + sb->d->len; pp = p; ll = p + n; + if (f&SF_DOWNCASE) while (pp < ll) *q++ = TOLOWER(*pp++); + else if (f&SF_UPCASE) while (pp < ll) *q++ = TOUPPER(*pp++); + sb->d->len += n; + } + + /* If we've reached the end then stop. */ if (n >= r) break; - dstr_putcn(sb->d, '\\', qfilt); dstr_putc(sb->d, p[n]); - p += n + 1; + + /* Otherwise we must have found a character which requires escaping. + * Emit enough toothpicks. + */ + dstr_putcn(sb->d, '\\', qfilt); + + /* This character is now done, so we can skip over and see if there's + * another chunk of stuff we can do at high speed. + */ + dstr_putc(sb->d, p[n]); p += n + 1; } } +/* Scan and resolve a `[SECT:]VAR' specifier at P. + * + * Return the address of the next character following the specifier. L is a + * limit on the region of the buffer that we should process; SB is the + * substitution state which provides the home section if none is given + * explicitly; FILE and LINE are the source location to blame for problems. + */ static const char *retrieve_varspec(const char *p, const char *l, - struct subst *sb, - struct config_var **var_out) + const struct subst *sb, + struct config_var **var_out, + const char *file, unsigned line) { struct config_section *sect = sb->home; const char *t; - t = scan_name(p, l); + t = scan_name("section or variable", p, l, file, line); if (t < l && *t == ':') { sect = config_find_section_n(sb->config, 0, p, t - p); - p = t + 1; t = scan_name(p, l); + p = t + 1; t = scan_name("variable", p, l, file, line); } if (!sect) *var_out = 0; @@ -740,16 +1354,16 @@ static const char *retrieve_varspec(const char *p, const char *l, 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, +/* Substitute and/or word-split text. + * + * The input text starts at P, and continues to (just before) L. Context for + * the task is provided by SB; the source location to blame is FILE and LINE + * (FILE may be null so that this can be passed directly from a `config_var' + * without further checking); QFILT is the nesting depth in toothpick- + * escaping; and F holds a mask of `SF_...' flags. + */ +static const char *subst(const char *p, const char *l, + const struct subst *sb, const char *file, unsigned line, unsigned qfilt, unsigned f) { @@ -758,46 +1372,63 @@ static const char *subst(const char *p, const char *l, struct subst *sb, 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 }; + /* It would be best if we could process literal text at high speed. To + * this end, + */ + static const char *const delimtab[] = { + +#define ESCAPE "\\" /* always watch for `\'-escapes */ +#define SUBST "$" /* check for `$' if `SF_SUBST' set */ +#define WORDSEP " \f\r\n\t\v'\"" /* space, quotes if `SF_SPLIT' but + * not `SF_QUOT' */ +#define QUOT "\"" /* only quotes if `SF_SPLIT' and + * `SF_QUOT' */ +#define DELIM "|}" /* end delimiters of `SF_SUBEXPR' */ + + 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 + }; + /* Set FILE to be useful if it was null on entry. */ if (!file) file = ""; + /* If the text is literal then hand off to `filter_string'. This obviously + * starts a word. + */ if (f&SF_LITERAL) { - filter_string(p, l, sb, qfilt); + filter_string(p, l, sb, qfilt, f); f |= SF_WORD; goto done; } + /* Chew through the input until it's all gone. */ while (p < l) { if ((f&(SF_SPLIT | SF_QUOT)) == SF_SPLIT && ISSPACE(*p)) { + /* This is whitespace, we're supposed to split, and we're not within + * quotes, so we should split here. + */ + + /* If there's a word in progress then we should commit it. */ if (f&SF_WORD) { if (!(f&SF_SKIP)) { argv_append(sb->av, xstrndup(sb->d->p, sb->d->len)); @@ -805,60 +1436,182 @@ static const char *subst(const char *p, const char *l, struct subst *sb, } f &= ~SF_WORD; } + + /* Skip over further whitespace at high speed. */ do p++; while (p < l && ISSPACE(*p)); } else if (*p == '\\') { - p++; - if (p >= l) lose("%s:%u: unfinished `\\' escape", file, line); + /* This is a toothpick, so start a new word and add the next character + * to it. + */ + + /* If there's no next charact3er then we should be upset. */ + p++; if (p >= l) lose("%s:%u: unfinished `\\' escape", file, line); + if (!(f&SF_SKIP)) { + + /* If this is a double quote or backslash then check DFLT to see if + * it needs escaping. + */ if (qfilt && (*p == '"' || *p == '\\')) dstr_putcn(sb->d, '\\', qfilt); - dstr_putc(sb->d, *p); + + /* Output the character. */ + if (f&SF_DOWNCASE) dstr_putc(sb->d, TOLOWER(*p)); + else if (f&SF_UPCASE) dstr_putc(sb->d, TOUPPER(*p)); + else dstr_putc(sb->d, *p); } - p++; + + /* Move past the escaped character. Remember we started a word. */ + p++; f |= SF_WORD; } else if ((f&SF_SPLIT) && *p == '"') { + /* This is a double quote, and we're word splitting. We're definitely + * in a word now. Toggle whether we're within quotes. + */ + 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); + /* This is a single quote, and we're word splitting but not within + * double quotes. Find the matching end quote, and just output + * everything between literally. + */ + + p++; t = strchr(p, '\''); + if (!t || t >= l) lose("%s:%u: missing `''", file, line); + if (!(f&SF_SKIP)) filter_string(p, t, sb, qfilt, f); p = t + 1; f |= SF_WORD; } else if ((f&SF_SUBEXPR) && (*p == '|' || *p == '}')) { + /* This is an end delimiter, and we're supposed to stop here. */ break; } else if ((f&SF_SUBST) && *p == '$') { + /* This is a `$' and we're supposed to do substitution. */ + + /* The kind of substitution is determined by the next character. */ p++; if (p >= l) lose("%s:%u: incomplete substitution", file, line); + + /* Prepare flags for a recursive substitution. + * + * Hide our quote state from the recursive call. If we're within a + * word, then disable word-splitting. + */ ff = f&~(SF_QUOT | (f&SF_WORD ? SF_SPLIT : 0)); + + /* Now dispatch based on the following character. */ switch (*p) { case '?': - p = retrieve_varspec(p + 1, l, sb, &var); + /* A conditional expression: $?VAR{CONSEQ[|ALT]} */ + + /* Skip initial space. */ + p++; while (p < l && ISSPACE(*p)) p++; + + /* Find the variable. */ + p = retrieve_varspec(p, l, sb, &var, file, line); + + /* Skip whitespace again. */ + while (p < l && ISSPACE(*p)) p++; + + /* Expect the opening `{'. */ if (p > l || *p != '{') lose("%s:%u: expected `{'", file, line); p++; + + /* We'll process the parts recursively, but we need to come back + * when we hit the appropriate delimiters, so arrange for that. + */ ff |= SF_SUBEXPR; + + /* Process the consequent (skip if the variable wasn't found). */ p = subst(p, l, sb, file, line, qfilt, ff | (var ? 0 : SF_SKIP)); + + /* If there's a `|' then process the alternative too (skip if the + * variable /was/ found). + */ if (p < l && *p == '|') p = subst(p + 1, l, sb, file, line, qfilt, ff | (var ? SF_SKIP : 0)); + + /* We should now be past the closing `}'. */ 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; + /* A variable substitution: ${VAR[|FILT]...[?ALT]} */ + + /* Skip initial whitespace. */ + p++; while (p < l && ISSPACE(*p)) p++; + + /* Find the variable. */ + q0 = p; p = retrieve_varspec(p, l, sb, &var, file, line); q1 = p; + + /* Determine the filters to apply when substituting the variable + * value. + */ subqfilt = qfilt; - while (p < l) { - if (*p != '|') break; - p++; t = scan_name(p, l); - if (t - p == 1 && *p == 'q') subqfilt = 2*subqfilt + 1; + for (;;) { + + /* Skip spaces again. */ + while (p < l && ISSPACE(*p)) p++; + + /* If there's no `|' then there are no more filters, so stop. */ + if (p >= l || *p != '|') break; + + /* Skip the `|' and more spaces. */ + p++; while (p < l && ISSPACE(*p)) p++; + + /* Collect the filter name. */ + t = scan_name("filter", p, l, file, line); + + /* Dispatch on the filter name. */ + if (t - p == 1 && *p == 'q') + /* `q' -- quote for Lisp string. + * + * We're currently adding Q `\' characters before each naughty + * character. But a backslash itself is naughty too, so that + * makes Q + 1 naughty characters, each of which needs a + * toothpick, so now we need Q + (Q + 1) = 2 Q + 1 toothpicks. + * + * Calculate this here rather than at each point toothpicks + * needs to be deployed. + */ + + subqfilt = 2*subqfilt + 1; + + else if (t - p == 1 && *p == 'l') + /* `u' -- convert to uppercase. + * + * If a case conversion is already set, then that will override + * whatever we do here, so don't bother. + */ + + { if (!(ff&SF_CASEMASK)) ff |= SF_DOWNCASE; } + + else if (t - p == 1 && *p == 'u') + /* `u' -- convert to uppercase. + * + * If a case conversion is already set, then that will override + * whatever we do here, so don't bother. + */ + { if (!(ff&SF_CASEMASK)) ff |= SF_UPCASE; } + else + /* Something else we didn't understand. */ lose("%s:%u: unknown filter `%.*s'", file, line, (int)(t - p), p); + + /* Continue from after the filter name. */ p = t; } + + /* If we're not skipping, and we found a variable, then substitute + * its value. This is the point where we need to be careful about + * recursive expansion. + */ if (!(f&SF_SKIP) && var) { if (var->f&CF_EXPAND) lose("%s:%u: recursive expansion of variable `%.*s'", @@ -869,19 +1622,35 @@ static const char *subst(const char *p, const char *l, struct subst *sb, ff | (var->f&CF_LITERAL ? SF_LITERAL : 0)); var->f &= ~CF_EXPAND; } + + /* If there's an alternative, then we need to process (or maybe + * skip) it. Otherwise, we should complain if there was no + * veriable, and we're not skipping. + */ 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); + + /* Expect a `}' here. (No need to skip spaces: we already did that + * after scanning for filters, and either there was no alternative, + * or we advanced to a delimiter character anyway.) + */ if (p >= l || *p != '}') lose("%s:%u: missing `}'", file, line); p++; break; default: - lose("%s:%u: unexpected substitution `%c'", file, line, *p); + /* Something else. That's a shame. */ + lose("%s:%u: unexpected `$'-substitution `%c'", file, line, *p); } + + /* Complain if we started out in word-splitting state, and therefore + * have added a whole number of words to the output, but there's a + * word-fragment stuck onto the end of this substitution. + */ if (p < l && !(~f&~(SF_WORD | SF_SPLIT)) && !ISSPACE(*p) && !((f&SF_SUBEXPR) && (*p == '|' || *p == '}'))) lose("%s:%u: surprising word boundary " @@ -890,23 +1659,42 @@ static const char *subst(const char *p, const char *l, struct subst *sb, } else { + /* Something else. Try to skip over this at high speed. + * + * This makes use of the table we set up earlier. + */ + 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); + if (!(f&SF_SKIP)) filter_string(p, p + n, sb, qfilt, f); p += n; f |= SF_WORD; } } done: + /* Sort out the wreckage. */ + + /* If we're still within quotes then something has gone wrong. */ if (f&SF_QUOT) lose("%s:%u: missing `\"'", file, line); + + /* If we're within a word, and should be splitting, then commit the word to + * the output list. + */ 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); } + /* And, with that, we're done. */ return (p); } +/* Expand substitutions in a string. + * + * Expand the null-terminated string P relative to the HOME section, using + * configuration CONFIG, and appending the result to dynamic string D. Blame + * WHAT in any error messages. + */ void config_subst_string(struct config *config, struct config_section *home, const char *what, const char *p, struct dstr *d) { @@ -917,6 +1705,12 @@ void config_subst_string(struct config *config, struct config_section *home, dstr_putz(d); } +/* Expand substitutions in a string. + * + * Expand the null-terminated string P relative to the HOME section, using + * configuration CONFIG, returning the result as a freshly malloc(3)ed + * string. Blame WHAT in any error messages. + */ char *config_subst_string_alloc(struct config *config, struct config_section *home, const char *what, const char *p) @@ -928,6 +1722,11 @@ char *config_subst_string_alloc(struct config *config, q = xstrndup(d.p, d.len); dstr_release(&d); return (q); } +/* Expand substitutions in a variable. + * + * Expand the value of the variable VAR relative to the HOME section, using + * configuration CONFIG, appending the result to dynamic string D. + */ void config_subst_var(struct config *config, struct config_section *home, struct config_var *var, struct dstr *d) { @@ -941,6 +1740,12 @@ void config_subst_var(struct config *config, struct config_section *home, dstr_putz(d); } +/* Expand substitutions in a variable. + * + * Expand the value of the variable VAR relative to the HOME section, using + * configuration CONFIG, returning the result as a freshly malloc(3)ed + * string. + */ char *config_subst_var_alloc(struct config *config, struct config_section *home, struct config_var *var) @@ -952,6 +1757,12 @@ char *config_subst_var_alloc(struct config *config, q = xstrndup(d.p, d.len); dstr_release(&d); return (q); } +/* Expand substitutions in a variable and split into words. + * + * Expand and word-split the value of the variable VAR relative to the HOME + * section, using configuration CONFIG, appending the resulting words into + * the vector AV. + */ void config_subst_split_var(struct config *config, struct config_section *home, struct config_var *var, struct argv *av) diff --git a/lib.h b/lib.h index 2209c30..97d8a96 100644 --- a/lib.h +++ b/lib.h @@ -40,7 +40,9 @@ /*----- Handy macros ------------------------------------------------------*/ #define N(v) (sizeof(v)/sizeof((v)[0])) + /* The number of elements in the array V. */ +/* Figure out the compiler version to see whether fancy tricks will work. */ #if defined(__GNUC__) # define GCC_VERSION_P(maj, min) \ (__GNUC__ > (maj) || (__GNUC__ == (maj) && __GNUC_MINOR__ >= (min))) @@ -57,258 +59,677 @@ #endif #if GCC_VERSION_P(2, 5) || CLANG_VERSION_P(3, 3) + # define NORETURN __attribute__((__noreturn__)) + /* Mark a function as not returning. */ + # define PRINTF_LIKE(fix, aix) __attribute__((__format__(printf, fix, aix))) + /* Mark a function as accepting a printf(3)-like format string as + * argument FIX, with arguments to be substituted starting at AIX. + */ #endif #if GCC_VERSION_P(4, 0) || CLANG_VERSION_P(3, 3) + # define EXECL_LIKE(ntrail) __attribute__((__sentinel__(ntrail))) + /* Mark a function as expecting a variable number of arguments + * terminated by a null pointer, followed by NTRAIL further + * arguments. + */ + +#endif + +/* Couldn't detect fancy compiler features. We'll have to make do + * without. + */ +#ifndef NORETURN +# define NORETURN +#endif +#ifndef PRINTF_LIKE +# define PRINTF_LIKE(fix, aix) +#endif +#ifndef EXECL_LIKE +# define EXECL_LIKE(ntrail) #endif +#define DISCARD(x) do if (x); while (0) + /* Discard the result of evaluating expression X, without upsetting + * the compiler. + */ + +#define END ((const char *)0) + /* A null pointer to terminate the argument tail to an `EXECL_LIKE' + * function. (Note that `NULL' is /not/ adequate for this purpose, + * since it might expand simply to `0', which is an integer, not a + * pointer, and might well be the wrong size and/or value.) + */ + +/* Wrap up macros with explicit conversions to `unsigned char'. */ #define CTYPE_HACK(func, ch) (func((unsigned char)(ch))) #define ISSPACE(ch) CTYPE_HACK(isspace, ch) #define ISALNUM(ch) CTYPE_HACK(isalnum, ch) +#define TOLOWER(ch) CTYPE_HACK(tolower, ch) +#define TOUPPER(ch) CTYPE_HACK(toupper, ch) +/* Wrap up comparison functions to take an ordering relation as part of their + * syntax. This makes it much harder to screw up. + */ #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*/); + /* The largest value that can be stored in an object of type + * `size_t'. A proper setting would be a preprocessor- + * time constant, but we don't actually need that. + */ /*----- Diagnostic utilities ----------------------------------------------*/ extern const char *progname; + /* Our program name, for use in error messages. */ extern void set_progname(const char */*prog*/); + /* Set `progname' from the pathname in PROG (typically from + * `argv[0]'). + */ + extern void vmoan(const char */*msg*/, va_list /*ap*/); + /* Report an error or warning in Unix style, given a captured + * argument cursor. + */ + extern PRINTF_LIKE(1, 2) void moan(const char */*msg*/, ...); + /* Issue a warning message. */ + extern NORETURN PRINTF_LIKE(1, 2) void lose(const char */*msg*/, ...); + /* Issue a fatal error message and exit unsuccessfully. */ /*----- Memory allocation -------------------------------------------------*/ extern void *xmalloc(size_t /*n*/); + /* Allocate and return a pointer to N bytes, or report a fatal error. + * + * Release the pointer using `free' as usual. If N is zero, returns + * null (but you are not expected to check for this). + */ + extern void *xrealloc(void */*p*/, size_t /*n*/); + /* Resize the block at P (from `malloc' or `xmalloc') to be N bytes + * long. + * + * The block might (and probably will) move, so it returns the new + * address. If N is zero, then the block is freed (if necessary) and + * a null pointer returned; otherwise, if P is null then a fresh + * block is allocated. If allocation fails, then a fatal error is + * reported. + */ + extern char *xstrndup(const char */*p*/, size_t /*n*/); + /* Allocate and return a copy of the N-byte string starting at P. + * + * The new string is null-terminated, though P need not be. If + * allocation fails, then a fatal error is reported. + */ + extern char *xstrdup(const char */*p*/); + /* Allocate and return a copy of the null-terminated string starting + * at P. + * + * If allocation fails, then a fatal error is reported. + */ /*----- Dynamic strings ---------------------------------------------------*/ +/* A dynamic string. + * + * Note that the string might not be null-terminated. + */ struct dstr { - char *p; - size_t len, sz; + char *p; /* string base address */ + size_t len; /* current string length */ + size_t sz; /* allocated size of buffer */ }; #define DSTR_INIT { 0, 0, 0 } extern void dstr_init(struct dstr */*d*/); + /* Initialize the string D. + * + * Usually you'd use the static initializer `DSTR_INIT'. + */ + extern void dstr_reset(struct dstr */*d*/); + /* Reset string D so it's empty again. */ + extern void dstr_ensure(struct dstr */*d*/, size_t /*n*/); + /* Ensure that D has at least N unused bytes available. */ + extern void dstr_release(struct dstr */*d*/); + /* Release the memory held by D. + * + * It must be reinitialized (e.g., by `dstr_init') before it can be + * used again. + */ + extern void dstr_putm(struct dstr */*d*/, const void */*p*/, size_t /*n*/); + /* Append the N-byte string at P to D. + * + * P need not be null-terminated. D will not be null-terminated + * afterwards. + */ + extern void dstr_puts(struct dstr */*d*/, const char */*p*/); + /* Append the null-terminated string P to D. + * + * D /is/ guaranteed to be null-terminated after this. + */ + extern void dstr_putc(struct dstr */*d*/, int /*ch*/); + /* Append the single character CH to D. + * + * D will not be null-terminated afterwards. + */ + +extern void dstr_putcn(struct dstr */*d*/, int /*ch*/, size_t /*n*/); + /* Append N copies of the character CH to D. + * + * D will not be null-terminated afterwards. + */ + extern void dstr_putz(struct dstr */*d*/); + /* Null-terminate the string D. + * + * This doesn't change the length of D. If further stuff is appended + * then the null terminator will be overwritten. + */ + extern void dstr_vputf(struct dstr */*d*/, const char */*p*/, va_list /*ap*/); + /* Append stuff to D, determined by printf(3) format string P and + * argument tail AP. + * + * D will not be null-terminated afterwards. + */ + extern PRINTF_LIKE(2, 3) void dstr_putf(struct dstr */*d*/, const char */*p*/, ...); + /* Append stuff to D, determined by printf(3) format string P and + * arguments. + * + * D will not be null-terminated afterwards. + */ + extern int dstr_readline(struct dstr */*d*/, FILE */*fp*/); + /* Append the next input line from FP to D. + * + * Return 0 on success, or -1 if reading immediately fails or + * encounters end-of-file (call ferror(3) to distinguish). Any + * trailing newline is discarded: it is not possible to determine + * whether the last line was ended with a newline. D is guaranteed + * to be null-terminated afterwards. + */ /*----- Dynamic vectors of strings ----------------------------------------*/ +/* A dynamic vector of strings. + * + * This machinery only actually tracks character pointers. It assumes that + * the caller will manage the underlying storage for the strings. + * + * Note that `v' always points to the first element in the vector. The + * underlying storage starts `o' slots before this. +*/ struct argv { - const char **v; - size_t o, n, sz; + char **v; /* pointer the first element */ + size_t n; /* length of the vector */ + size_t o; /* number of spare slots at start */ + size_t sz; /* allocated size (in slots) */ }; #define ARGV_INIT { 0, 0, 0, 0 } extern void argv_init(struct argv */*a*/v); + /* Initialize the vector AV. + * + * Usually you'd use the static initializer `ARGV_INIT'. + */ + extern void argv_reset(struct argv */*av*/); + /* Reset the vector AV so that it's empty again. */ + extern void argv_ensure(struct argv */*av*/, size_t /*n*/); + /* Ensure that AV has at least N unused slots at the end. */ + extern void argv_ensure_offset(struct argv */*av*/, size_t /*n*/); + /* Ensure that AV has at least N unused slots at the /start/. */ + extern void argv_release(struct argv */*av*/); -extern void argv_append(struct argv */*av*/, const char */*p*/); + /* Release the memory held by AV. + * + * It must be reinitialized (e.g., by `argv_init') before it can be + * used again. + */ + +extern void argv_append(struct argv */*av*/, char */*p*/); + /* Append the pointer P to AV. */ + extern void argv_appendz(struct argv */*av*/); + /* Append a null pointer to AV, without extending the vactor length. + * + * The null pointer will be overwritten when the next string is + * appended. + */ + extern void argv_appendn(struct argv */*av*/, - const char *const */*v*/, size_t /*n*/); + char *const */*v*/, size_t /*n*/); + /* Append a N-element vector V of pointers to AV. */ + extern void argv_appendav(struct argv */*av*/, const struct argv */*bv*/); + /* Append the variable-length vector BV to AV. */ + extern void argv_appendv(struct argv */*av*/, va_list /*ap*/); + /* Append the pointers from a variable-length argument list AP to AV. + * + * The list is terminated by a null pointer. + */ + extern EXECL_LIKE(0) void argv_appendl(struct argv */*av*/, ...); -extern void argv_prepend(struct argv */*av*/, const char */*p*/); + /* Append the argument pointers, terminated by a null pointer, to + * AV. + */ + +extern void argv_prepend(struct argv */*av*/, char */*p*/); + /* Prepend the pointer P to AV. */ + extern void argv_prependn(struct argv */*av*/, - const char *const */*v*/, size_t /*n*/); + char *const */*v*/, size_t /*n*/); + /* Prepend a N-element vector V of pointers to AV. */ + extern void argv_prependav(struct argv */*av*/, const struct argv */*bv*/); + /* Prepend the variable-length vector BV to AV. */ + extern void argv_prependv(struct argv */*av*/, va_list /*ap*/); + /* Prepend the pointers from a variable-length argument list AP to + * AV. + * + * The list is terminated by a null pointer. + */ + extern EXECL_LIKE(0) void argv_prependl(struct argv */*av*/, ...); + /* Prepend the argument pointers, terminated by a null pointer, to + * AV. + */ /*----- Treaps ------------------------------------------------------------*/ +/* A `treap' is a data structure for associating values with keys. This + * implementation assumes that keys are simply text strings. + */ struct treap { struct treap_node *root; }; #define TREAP_INIT { 0 } +/* A treap is a combination of a binary search tree and a binary heap. The + * nodes are ordered according to the search keys, in the usual way, so that + * all the keys in a node's left subtree precede that node's key, and all of + * the keys in its right subtree follow the node's key. The trick is that + * the tree must /also/ satisfy the heap condition regarding randomly + * assigned `weights' attached to each node: so a node's weight must not be + * less than their weight of either of its children. + * + * This combination uniquely determines the structure of the tree, except for + * nodes whose weights exactly match one (or both) of their children. (The + * root must be the heaviest node in the tree. The root's key splits the + * remaining nodes into left and right subtrees, whose structure is then + * uniquely determined by induction.) + * + * This is an /intrusive/ data structure. A caller is expected to include a + * `struct treap_node' as (probably) the initial part of a larger structure. + */ struct treap_node { - unsigned wt; - struct treap_node *left, *right; - char *k; size_t kn; + unsigned wt; /* weight (randomly assigned) */ + struct treap_node *left, *right; /* left and right subtrees */ + char *k; size_t kn; /* key pointer and length */ }; #define TREAP_NODE_KEY(n) (((const struct treap_node *)(n))->k + 0) #define TREAP_NODE_KEYLEN(n) (((const struct treap_node *)(n))->kn + 0) +/* We can't allocate nodes ourselves, because only the caller knows how. + * Instead, insertion is split into two operations: `treap_probe' looks to + * see whether a matching node is already in the treap, and returns it if so; + * otherwise, it flls in this `treap_path' structure, which is passed back to + * `treap_insert' to help it add the fresh node into the treap. (See the + * commentary in `treap_probe' and `treap_insert' for the details.) + */ #define TREAP_PATHMAX 64 struct treap_path { struct treap_node **path[TREAP_PATHMAX]; unsigned nsteps; }; +/* An external iterator for a treap. (See the commentary for + * `treap_start_iter' and `treap_next' for the details.) + */ struct treap_iter { struct treap_node *stack[TREAP_PATHMAX]; unsigned sp; }; extern void treap_init(struct treap */*t*/); + /* Initialize the treap T. + * + * Usually you'd use the static initializer `TREAP_INIT'. + */ + extern void *treap_lookup(const struct treap */*t*/, const char */*k*/, size_t /*kn*/); + /* Look up the KN-byte key K in the treap T. + * + * Return a pointer to the matching node if one was found, or null + * otherwise. + */ + extern void *treap_probe(struct treap */*t*/, const char */*k*/, size_t /*kn*/, struct treap_path */*p*/); + /* Look up the KN-byte K in the treap T, recording a path in P. + * + * This is similar to `treap_lookup', in that it returns the + * requested node if it already exists, or null otherwise, but it + * also records in P information to be used by `treap_insert' to + * insert a new node with the given key it's not there already. + */ + extern void treap_insert(struct treap */*t*/, const struct treap_path */*p*/, struct treap_node */*n*/, const char */*k*/, size_t /*kn*/); + /* Insert a new node N into T, associating it with the KN-byte key K. + * + * Use the path data P, from `treap_probe', to help with insertion. + */ + extern void *treap_remove(struct treap */*t*/, const char */*k*/, size_t /*kn*/); + /* Remove the node with the KN-byte K from T. + * + * Return the address of the node we removed, or null if it couldn't + * be found. + */ + extern void treap_start_iter(struct treap */*t*/, struct treap_iter */*i*/); + /* Initialize an iterator I over T's nodes. */ + extern void *treap_next(struct treap_iter */*i*/); + /* Return the next node from I, in ascending order by key. + * + * If there are no more nodes, then return null. + */ + extern void treap_check(struct treap */*t*/); + /* Check the treap structure rules for T. */ + extern void treap_dump(struct treap */*t*/); + /* Dump the treap T to standard output, for debugging purposes. */ /*----- Configuration file parsing ----------------------------------------*/ +/* A configuration file. */ struct config { - struct treap sections; - struct config_section *head, **tail; - struct config_section *fallback; + struct treap sections; /* treap of sections */ + struct config_section *head, **tail; /* section list, in creation order */ + struct config_section *fallback; /* default parent section */ }; #define CONFIG_INIT { TREAP_INIT, 0, 0 } +/* A configuration section. */ struct config_section { - struct treap_node _node; - struct config_section *next; - struct config_section **parents; size_t nparents; - struct treap vars; - struct treap cache; + struct treap_node _node; /* treap intrustion */ + struct config_section *next; /* next section in creation order */ + struct config_section **parents; size_t nparents; /* vector of parents */ + struct treap vars; /* treap of variables */ + struct treap cache; /* inheritance cache */ }; #define CONFIG_SECTION_NAME(sect) TREAP_NODE_KEY(sect) #define CONFIG_SECTION_NAMELEN(sect) TREAP_NODE_KEYLEN(sect) +/* An entry in a section's inheritance cache: see `search_recursive' for + * details. + */ struct config_cache_entry { - struct treap_node _node; - unsigned f; -#define CF_OPEN 1u - struct config_var *var; + struct treap_node _node; /* treap intrusion */ + unsigned f; /* flags */ +#define CF_OPEN 1u /* traps inheritance cycles */ + struct config_var *var; /* pointer to inherited variable */ }; +/* A configuration variable. */ struct config_var { - struct treap_node _node; - char *file; unsigned line; - char *val; size_t n; - unsigned f; + struct treap_node _node; /* treap intrusion */ + char *file; unsigned line; /* source location, or null/0 */ + char *val; size_t n; /* value pointer and length */ + unsigned f; /* flags */ +#define CF_LITERAL 1u /* value should not be expanded */ +#define CF_EXPAND 2u /* traps expansion cycles */ +#define CF_OVERRIDE 4u /* override settings from files */ }; #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 +/* A section iterator. + * + * (Sections are visited in the order in which they were created.) + */ struct config_section_iter { - struct config_section *sect; + struct config_section *sect; /* next section to return */ }; +/* A variable iterator. + * + * (Variables are visited in lexicographical order.) + */ struct config_var_iter { struct treap_iter i; }; +/* Common flags. */ +#define CF_CREAT 1u /* create section or variable */ +#define CF_INHERIT 2u /* look up variable in parents */ + extern void config_init(struct config */*conf*/); + /* Initialize the configuration state CONF. + * + * Usually you'd use the static initializer `CONFIG_INIT'. + */ extern struct config_section *config_find_section(struct config */*conf*/, unsigned /*f*/, const char */*name*/); + /* Find and return the section with null-terminated NAME in CONF. + * + * If no section is found, the behaviour depends on whether + * `CF_CREAT' is set in F: if so, an empty section is created and + * returned; otherwise, a null pointer is returned. + */ + extern struct config_section *config_find_section_n(struct config */*conf*/, unsigned /*f*/, const char */*name*/, size_t /*sz*/); -#define CF_CREAT 1u + /* Find and return the section with the given SZ-byte NAME in CONF. + * + * This works like `config_find_section', but with an explicit length + * for the NAME rather than null-termination. + */ extern void config_set_fallback(struct config */*conf*/, struct config_section */*sect*/); + /* Set the fallback section for CONF to be SECT. + * + * That is, if a section has no explicit parents, then by default it + * will have a single parent which is SECT. If SECT is null then + * there is no fallback section, and sections which don't have + * explicitly specified parents have no parents at all. (This is the + * default situation.) + */ + extern void config_set_parent(struct config_section */*sect*/, struct config_section */*parent*/); + /* Arrange that SECT has PARENT as its single parent section. + * + * If PARENT is null, then arrange that SECT has no parents at all. + * In either case, any `@parents' setting will be ignored. + */ extern void config_start_section_iter(struct config */*conf*/, struct config_section_iter */*i*/); + /* Initialize I to iterate over the sections defined in CONF. */ + extern struct config_section *config_next_section (struct config_section_iter */*i*/); + /* Return the next section from I, in order of creation. + * + * If there are no more sections, then return null. + */ extern struct config_var *config_find_var(struct config */*conf*/, struct config_section */*sect*/, unsigned /*f*/, const char */*name*/); + /* Find and return the variable with null-terminated NAME in SECT. + * + * If `CF_INHERIT' is set in F, then the function searches the + * section's parents recursively; otherwise, it only checks to see + * whether the variable is set directly in SECT. + * + * If no variable is found, the behaviour depends on whether + * `CF_CREAT' is set in F: if so, an empty variable is created and + * returned; otherwise, a null pointer is returned. + * + * Setting both `CF_INHERIT' and `CF_CREAT' is not useful. + */ + 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 + /* Find and return the variable with the given SZ-byte NAME in SECT. + * + * This works like `config_find_var', but with an explicit length for + * the NAME rather than null-termination. + */ extern void config_set_var(struct config */*conf*/, struct config_section */*sect*/, unsigned /*f*/, const char */*name*/, const char */*value*/); + /* Set variable NAME to VALUE in SECT, with associated flags F. + * + * The names are null-terminated. The flags are variable flags: see + * `struct config_var' for details. + * + * If the variable is already set and has the `CF_OVERRIDE' flag, + * then this function does nothing unless `CF_OVERRIDE' is /also/ set + * in F. + */ + 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*/, + /* As `config_set_var', except that the variable NAME and VALUE have + * explicit lengths (NAMELEN and VALUELEN, respectively) rather than + * being null- terminated. + */ + +extern void config_start_var_iter(struct config */*conf*/, + struct config_section */*sect*/, struct config_var_iter */*i*/); + /* Initialize I to iterate over the variables directly defined in + * SECT. + */ + extern struct config_var *config_next_var(struct config_var_iter */*i*/); + /* Return next variable from I, in ascending lexicographical order. + * + * If there are no more variables, then return null. + */ 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*/); +#define CF_NOENTOK 1u + /* Read and parse configuration FILE, applying its settings to CONF. + * + * If all goes well, the function returns 0. If the file is not + * found, then the behaviour depends on whether `CF_NOENTOK' is set + * in F: if so, then the function simply returns -1. Otherwise, a + * fatal error is reported. Note that this /only/ applies if the + * file does not exist (specifically, opening it fails with `ENOENT') + * -- any other problems are reported as fatal errors regardless of + * the flag setting. + */ + extern void config_read_env(struct config */*conf*/, struct config_section */*sect*/); -#define CF_NOENTOK 1u + /* Populate SECT with environment variables. + * + * Environment variables are always set with `CF_LITERAL'. + */ extern void config_subst_string(struct config */*config*/, struct config_section */*home*/, const char */*what*/, const char */*p*/, struct dstr */*d*/); + /* Expand substitutions in a string. + * + * Expand the null-terminated string P relative to the HOME section, + * using configuration CONFIG, and appending the result to dynamic + * string D. Blame WHAT in any error messages. + */ + extern char *config_subst_string_alloc(struct config */*config*/, struct config_section */*home*/, const char */*what*/, const char */*p*/); + /* Expand substitutions in a string. + * + * Expand the null-terminated string P relative to the HOME section, + * using configuration CONFIG, returning the result as a freshly + * malloc(3)ed string. Blame WHAT in any error messages. + */ + extern void config_subst_var(struct config */*config*/, struct config_section */*home*/, struct config_var */*var*/, struct dstr */*d*/); + /* Expand substitutions in a variable. + * + * Expand the value of the variable VAR relative to the HOME section, + * using configuration CONFIG, appending the result to dynamic string + * D. + */ + extern char *config_subst_var_alloc(struct config */*config*/, struct config_section */*home*/, struct config_var */*var*/); + /* Expand substitutions in a variable. + * + * Expand the value of the variable VAR relative to the HOME section, + * using configuration CONFIG, returning the result as a freshly + * malloc(3)ed string. + */ + extern void config_subst_split_var(struct config */*config*/, struct config_section */*home*/, struct config_var */*var*/, struct argv */*av*/); + /* Expand substitutions in a variable and split into words. + * + * Expand and word-split the value of the variable VAR relative to + * the HOME section, using configuration CONFIG, appending the + * resulting words into the vector AV. + */ /*----- That's all, folks -------------------------------------------------*/ diff --git a/old-runlisp.c b/old-runlisp.c index 2557dc3..eea8c42 100644 --- a/old-runlisp.c +++ b/old-runlisp.c @@ -298,8 +298,8 @@ static void try_exec(const struct argstate *arg, struct argv *av) dstr_release(&d); } -static const char *getenv_or_default(const char *var, const char *dflt) - { const char *p = getenv(var); return (p ? p : dflt); } +static char *getenv_or_default(const char *var, char *dflt) + { char *p = getenv(var); return (p ? p : dflt); } /*----- Invoking Lisp systems ---------------------------------------------*/ @@ -760,7 +760,7 @@ static void scan_options_from_string(char *p, struct argstate *arg, if (st) lose("unfinished `%c' string in %s `%s'", st, what, file); } - i = 0; parse_arguments(arg, av.v, av.n, &i); + i = 0; parse_arguments(arg, (const char **)av.v, av.n, &i); if (i < av.n) lose("positional argument `%s' in %s `%s'", av.v[i], what, file); argv_release(&av); @@ -871,7 +871,7 @@ int main(int argc, char *argv[]) if (!script) script = DATADIR "/eval.lisp"; argv_append(&arg.av, "--"); } - argv_appendn(&arg.av, (const char *const *)argv + i, argc - i); + argv_appendn(&arg.av, argv + i, argc - i); n = arg.av.n; /* Find the user's home directory. (Believe them if they set something diff --git a/query-runlisp-config.1 b/query-runlisp-config.1 new file mode 100644 index 0000000..48bf0dd --- /dev/null +++ b/query-runlisp-config.1 @@ -0,0 +1,164 @@ +.\" -*-nroff-*- +.\" +.\" Manual for `query-runlisp-config' +.\" +.\" (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 . +.. +.ie t \{\ +. ds o \(bu +. if \n(.g \{\ +. fam P +. ev an-1 +. fam P +. ev +. \} +.\} +.el \{\ +. ds o o +.\} +. +.de hP +.IP +\h'-\w'\fB\\$1\ \fP'u'\fB\\$1\ \fP\c +.. +. +.\"-------------------------------------------------------------------------- +.TH query-runlisp-config 1 "2 August 2020" "Mark Wooding" +.SH NAME +query-runlisp-config \- inspect and debug runlisp configuration files +. +.\"-------------------------------------------------------------------------- +.SH SYNOPSIS +. +.B query-runlisp-config +.RB [ \-Lqv ] +.RB [ \-c +.IR conf ] +.RB [ \-o +.RI [ sect \c +.BR : ] \c +.IB var = \c +.IR value ] +.br + +.RB [ \-l +.IR sect ] +.RB [ \-p +.RI [ sect \c +.BR : ] \c +.IR var ] +.RB [ \-w +.RI [ sect \c +.BR : ] \c +.IR var ] +.RB [ \-x +.RI [ sect \c +.BR : ] \c +.IR var ] +. +.\"-------------------------------------------------------------------------- +.SH DESCRIPTION +. +The +.B query-runlisp-config +program assists with understanding and debugging +.BR runlisp.conf (5) +files. +. +.SS "Options" +The command-line options are as follows. +. +.TP +.BR "\-h" ", " "\-\-help" +Write a synopsis of +.BR query-runlisp-config 's +command-line syntax +and a description of the command-line options +to standard output +and immediately exit with status 0. +. +.TP +.BR "\-V" ", " "\-\-version" +Write +.BR query-runlisp-config 's +version number +to standard output +and immediately exit with status 0. +. +.TP +.BR "\-L" ", " "\-\-list-sections" +List all of the known section names to standard output. +. +.TP +.BI "\-c" "\fR, " "\-\-config-file=" conf +Read configuration from +.IR conf . +If +.I conf +is a directory, then all of the files within +whose names end with +.RB ` .conf ', +are loaded, in ascending lexicographical order; +otherwise, +.I conf +is opened as a file. +All of the files are expected to as described in +.BR runlisp.conf (5). +. +.TP +.BI "\-l" "\fR, " "\-\-list-variables=" sect +List all of the variables assigned in section +.I sect +to standard output. +. +.TP +.BI "\-o" "\fR, " "\-\-set-option=\fR[" sect :\fR] var = value +Assign +.I value +to the variable +.I var +in configuration section +.IR sect , +or +.B @CONFIG +if no section is specified. +The value is unexpandable, +and overrides any similarly named setting +from the configuration file(s). +. + + +. +.\"-------------------------------------------------------------------------- +. +.SH BUGS +.hP \*o +. +.SH SEE ALSO +.BR dump-runlisp-image (1), +.BR query-runlisp-config (1), +.BR runlisp (1). +. +.SH AUTHOR +Mark Wooding, +. +. +.\"----- That's all, folks -------------------------------------------------- diff --git a/query-runlisp-config.c b/query-runlisp-config.c new file mode 100644 index 0000000..bbfb150 --- /dev/null +++ b/query-runlisp-config.c @@ -0,0 +1,263 @@ +/* -*-c-*- + * + * Explore and debug `runlisp' configration + * + * (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 "common.h" +#include "lib.h" +#include "mdwopt.h" + +/*----- Static data -------------------------------------------------------*/ + +/* Query operations. */ +enum { + OP_LISTSEC, /* list all sections */ + OP_LISTVAR, /* list variables in a section */ + OP_RAW, /* print a variable's value */ + OP_SUBST, /* print variable's expansion */ + OP_SPLIT, /* print word-split variable */ + OP_LIMIT +}; + +/* A node in the list of queued-up operations. */ +struct op { + struct op *next; /* link to next op in the list */ + unsigned code; /* operation code (`OP_...') */ + const char *arg; /* argument (from command-line) */ +}; + +static struct op *oplist; /* list of queued-up operations */ + +static unsigned flags = 0; /* flags for the application */ +#define AF_BOGUS 0x0001u /* invalid command-line syntax */ +#define AF_SETCONF 0x0002u /* explicit configuration */ + +/*----- Main code ---------------------------------------------------------*/ + +/* Append a new node to the list of delayed operations, with CODE and ARG. + * + * The address of the final link (initially, the list head) is in + * *TAIL_INOUT: make this point to the new node, and then update it to point + * to the link in the new node. + */ +static void add_op(struct op ***tail_inout, unsigned code, const char *arg) +{ + struct op *op = xmalloc(sizeof(*op)); + op->code = code; op->arg = arg; **tail_inout = op; *tail_inout = &op->next; +} + +/* Given an ARG of the form `[SECT:]VAR', set *SECT_OUT and *VAR_OUT to the + * requested home section and variable. Leave these null if they can't be + * found. + */ +static void find_var(const char *arg, + struct config_section **sect_out, + struct config_var **var_out) +{ + struct config_section *sect; + const char *p; + + p = strchr(arg, ':'); + if (!p) + { sect = toplevel; p = arg; } + else + { sect = config_find_section_n(&config, 0, arg, p - arg); p++; } + *sect_out = sect; + if (!sect) *var_out = 0; + else *var_out = config_find_var(&config, sect, 0, p); +} + +/* Help and related functions. */ +static void version(FILE *fp) + { fprintf(fp, "%s, runlisp version %s\n", progname, PACKAGE_VERSION); } + +static void usage(FILE *fp) +{ + fprintf(fp, "\ +usage: %s [-Lqv] [-c CONF] [-o [SECT:]VAR=VAL]\n\ + [-l SECT] [-p [SECT:]VAR] [-w [SECT:]VAR] [-x [SECT:]VAR]\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\ + -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\ +Output:\n\ + -L, --list-sections List all known section names in order.\n\ + -l, --list-variables=SECTION List all defined variables in SECTION.\n\ + -p, --print-variable=[SECT:]VAR Print the raw (unexpanded) value of VAR.\n\ + -w, --split-variable=[SECT:]VAR Expand and word-split VAR and print.\n\ + -x, --expand-variable=[SECT:]VAR Expand VAR and print the result.\n", fp); +} + +/* Main program. */ +int main(int argc, char *argv[]) +{ + struct config_section_iter si; + struct config_section *sect; + struct config_var_iter vi; + struct config_var *var; + struct op *op, **tail = &oplist; + struct dstr d = DSTR_INIT; + struct argv av = ARGV_INIT; + int i; + + /* Command-line options. */ + static const struct option opts[] = { + { "help", 0, 0, 'h' }, + { "version", 0, 0, 'V' }, + { "list-sections", 0, 0, 'L' }, + { "config-file", OPTF_ARGREQ, 0, 'c' }, + { "list-variables", OPTF_ARGREQ, 0, 'l' }, + { "set-option", OPTF_ARGREQ, 0, 'o' }, + { "print-variable", OPTF_ARGREQ, 0, 'p' }, + { "quiet", 0, 0, 'q' }, + { "verbose", 0, 0, 'v' }, + { "split-variable", OPTF_ARGREQ, 0, 'w' }, + { "expand-variable", OPTF_ARGREQ, 0, 'x' }, + { 0, 0, 0, 0 } + }; + + /* Initial setup. */ + set_progname(argv[0]); + init_config(); + + /* Parse the options. + * + * We must delay the query operations until the configuration is loaded, + * but we won't know whether to load the default configuration until we're + * sure that that there are no `-c' options. So just stash the queries in + * a list until later. + */ + optprog = (/*unconst*/ char *)progname; + for (;;) { + i = mdwopt(argc - 1, argv + 1, "hVLc:l:o:p:qvw:x:", opts, 0, 0, + OPTF_NOPROGNAME); + if (i < 0) break; + switch (i) { + case 'h': help(stdout); exit(0); + case 'V': version(stdout); exit(0); + case 'L': add_op(&tail, OP_LISTSEC, 0); break; + case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break; + case 'l': add_op(&tail, OP_LISTVAR, optarg); break; + case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break; + case 'p': add_op(&tail, OP_RAW, optarg); break; + case 'q': if (verbose) verbose--; break; + case 'v': verbose++; break; + case 'w': add_op(&tail, OP_SPLIT, optarg); break; + case 'x': add_op(&tail, OP_SUBST, optarg); break; + default: flags |= AF_BOGUS; break; + } + } + + /* Check that everything worked. */ + optind++; + if (optind < argc) flags |= AF_BOGUS; + if (flags&AF_BOGUS) { usage(stderr); exit(127); } + *tail = 0; if (!oplist) lose("nothing to do"); + + /* Load default configuration if no explicit files were requested. */ + if (!(flags&AF_SETCONF)) load_default_config(); + + /* Work through the operations we stashed earlier. */ + for (op = oplist; op; op = op->next) + switch (op->code) { + + case OP_LISTSEC: + printf("sections:\n"); + for (config_start_section_iter(&config, &si); + (sect = config_next_section(&si)); ) + printf("\t%s\n", CONFIG_SECTION_NAME(sect)); + break; + + case OP_LISTVAR: + sect = config_find_section(&config, 0, op->arg); + if (!sect) + printf("section `%s' not found\n", op->arg); + else { + printf("section `%s' variables:\n", CONFIG_SECTION_NAME(sect)); + for (config_start_var_iter(&config, sect, &vi); + (var = config_next_var(&vi)); ) + printf("\t%s\n", CONFIG_VAR_NAME(var)); + } + break; + + case OP_RAW: + find_var(op->arg, §, &var); + if (!var) printf("%s not found\n", op->arg); + else printf("%s = %s\n", op->arg, var->val); + break; + + case OP_SUBST: + find_var(op->arg, §, &var); + if (!var) + printf("%s not found\n", op->arg); + else { + dstr_reset(&d); config_subst_var(&config, sect, var, &d); + printf("%s = %s\n", op->arg, d.p); + } + break; + + case OP_SPLIT: + find_var(op->arg, §, &var); + if (!var) + printf("%s not found\n", op->arg); + else { + argv_reset(&av); config_subst_split_var(&config, sect, var, &av); + dstr_reset(&d); argv_string(&d, &av); + printf("%s = %s\n", op->arg, d.p); + } + break; + + default: + assert(0); + } + + /* All done. */ + return (0); +} + +/*----- That's all, folks -------------------------------------------------*/ diff --git a/runlisp-base.conf b/runlisp-base.conf new file mode 100644 index 0000000..692faa7 --- /dev/null +++ b/runlisp-base.conf @@ -0,0 +1,303 @@ +;;; -*-conf-windows-*- + +;; This file contains essential definitions for `runlisp'. You are +;; encouraged to put your local changes in the main `runlisp.conf', or in +;; other files alongside this one in `runlisp.d/', rather then editing this +;; file. + +;; 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 = ${@image-dir}/${image-file} + +;;;-------------------------------------------------------------------------- +[sbcl] + +command = ${@ENV:SBCL?sbcl} +image-file = ${@name}+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-new|q}\")" + +;;;-------------------------------------------------------------------------- +[ccl] + +command = ${@ENV:CCL?ccl} +image-file = ${@name}+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-new|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 = ${@name}+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-new|q}\" :norc t :script t)" + +;;;-------------------------------------------------------------------------- +[ecl] + +command = ${@ENV:ECL?ecl} +image-file = ${@name}+asdf + +run-script = + $?@image{"${image-path}" -s "${@script}" | + ${@ENV:ECL?ecl} "${@ecl-opt}norc" + "${@ecl-opt}eval" "(progn + ${run-script-prelude} + ${clear-cl-user})" + "${@ecl-opt}shell" "${@script}"} + -- + +dump-image = + "${@data-dir}/dump-ecl" + "${@image-new}" "${command}" "${@ecl-opt}" "${@tmp-dir}" + +;;;-------------------------------------------------------------------------- +[cmucl] + +command = ${@ENV:CMUCL?cmucl} +image-file = ${@name}+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-new|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 -------------------------------------------------- diff --git a/runlisp.1 b/runlisp.1 index 35143f4..51d470a 100644 --- a/runlisp.1 +++ b/runlisp.1 @@ -716,7 +716,7 @@ variable, respectively. . .\"-------------------------------------------------------------------------- . -.SH "BUGS" +.SH BUGS .hP \*o Loading ASDF systems is irritatingly noisy with some Lisp implementations. @@ -742,10 +742,12 @@ interface to the same information. I don't know how to fix this: suggestions are welcome. . -.SH "SEE ALSO" -.BR dump-runlisp-image (1). +.SH SEE ALSO +.BR dump-runlisp-image (1), +.BR query-runlisp-config (1), +.BR runlisp.conf (5). . -.SH "AUTHOR" +.SH AUTHOR Mark Wooding, . .\"----- That's all, folks -------------------------------------------------- diff --git a/runlisp.c b/runlisp.c index c555f13..9ef809c 100644 --- a/runlisp.c +++ b/runlisp.c @@ -39,89 +39,52 @@ /*----- Static data -------------------------------------------------------*/ +/* The state we need for a Lisp system. */ struct lispsys { - struct treap_node _node; - struct lispsys *next_lisp, *next_accept, *next_prefer, *next_order; - unsigned f; -#define LF_KNOWN 1u -#define LF_ACCEPT 2u -#define LF_PREFER 4u - struct config_section *sect; - struct config_var *var; + struct treap_node _node; /* treap intrusion */ + struct lispsys *next_lisp, /* link in all-Lisps list */ + *next_accept, /* link acceptable-Lisps list */ + *next_prefer, /* link in preferred-Lisps list */ + *next_order; /* link in overall-order list */ + unsigned f; /* flags */ +#define LF_KNOWN 1u /* this is actually a Lisp */ +#define LF_ACCEPT 2u /* this is an acceptable Lisp */ +#define LF_PREFER 4u /* this is a preferred Lisp */ + struct config_section *sect; /* configuration section */ + struct config_var *var; /* `run-script variable */ }; #define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp) #define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp) +/* Pick out a link from a `struct lispsys' object given its offset. */ +#define LISP_LINK(lisp, linkoff) \ + ((struct lispsys **)((unsigned char *)(lisp) + (linkoff))) + +/* A list of Lisp systems. */ struct lispsys_list { - struct lispsys *head, **tail; + struct lispsys *head, **tail; /* list head and tail */ }; -static struct argv argv_tail = ARGV_INIT; -const char *script = 0; - -static unsigned flags = 0; -#define AF_CMDLINE 0x0000u -#define AF_EMBED 0x0001u -#define AF_ENV 0x0002u -#define AF_CONF 0x0003u -#define AF_STATEMASK 0x000fu -#define AF_BOGUS 0x0010u -#define AF_SETCONF 0x0020u -#define AF_NOEMBED 0x0040u -#define AF_DRYRUN 0x0080u -#define AF_VANILLA 0x0100u - -struct treap lispsys = TREAP_INIT; -static struct lispsys_list - lisps = { 0, &lisps.head }, - accept = { 0, &accept.head }, - prefer = { 0, &prefer.head }; +static struct argv argv_tail = ARGV_INIT; /* accumulates eval-mode args */ +struct treap lispsys = TREAP_INIT; /* track duplicate Lisp systems */ +static struct lispsys_list /* lists of Lisp systems */ + lisps = { 0, &lisps.head }, /* all known */ + accept = { 0, &accept.head }, /* acceptable */ + prefer = { 0, &prefer.head }; /* preferred */ + +static unsigned flags = 0; /* flags for the application */ +#define AF_CMDLINE 0x0000u /* options are from command-line */ +#define AF_EMBED 0x0001u /* reading embedded options */ +#define AF_STATEMASK 0x000fu /* mask of option origin codes */ +#define AF_BOGUS 0x0010u /* invalid command-line syntax */ +#define AF_SETCONF 0x0020u /* explicit configuration */ +#define AF_NOEMBED 0x0040u /* don't read embedded options */ +#define AF_DRYRUN 0x0080u /* don't actually do it */ +#define AF_VANILLA 0x0100u /* don't use custom images */ /*----- Main code ---------------------------------------------------------*/ -static void version(FILE *fp) - { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); } - -static void usage(FILE *fp) -{ - fprintf(fp, "\ -usage:\n\ - %s [OPTIONS] [--] SCRIPT [ARGUMENTS ...]\n\ - %s [OPTIONS] [-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n\ -OPTIONS:\n\ - [-CDEnqv] [+DEn] [-L SYS,SYS,...] [-c CONF] [-o [SECT:]VAR=VAL]\n", - progname, progname); -} - -static void help(FILE *fp) -{ - version(fp); fputc('\n', fp); usage(fp); - fputs("\n\ -Help options:\n\ - -h, --help Show this help text and exit successfully.\n\ - -V, --version Show version number and exit successfully.\n\ -\n\ -Diagnostics:\n\ - -n, --dry-run Don't run run anything (useful with `-v').\n\ - -q, --quiet Don't print warning messages.\n\ - -v, --verbose Print informational messages (repeatable).\n\ -\n\ -Configuration:\n\ - -E, --command-line-only Don't read embedded options from script.\n\ - -c, --config-file=CONF Read configuration from CONF (repeatable).\n\ - -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\ -\n\ -Lisp implementation selection:\n\ - -D, --vanilla-image Run vanilla Lisp images, not custom ones.\n\ - -L, --accept-lisp=SYS,SYS,... Only use the listed Lisp systems.\n\ -\n\ -Evaluation mode:\n\ - -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\ - -l, --load-file=FILE Load FILE (repeatable).\n\ - -p, --print-expression=EXPR Print (`prin1') EXPR (repeatable).\n", - fp); -} - +/* Return the `struct lispsys' entry for the given N-byte NAME. */ static struct lispsys *ensure_lispsys(const char *name, size_t n) { struct lispsys *lisp; @@ -136,9 +99,11 @@ static struct lispsys *ensure_lispsys(const char *name, size_t n) return (lisp); } -#define LISP_LINK(lisp, linkoff) \ - ((struct lispsys **)((unsigned char *)(lisp) + (linkoff))) - +/* Add Lisp systems from the comma- or space-sparated list P to LIST. + * + * WHAT is an adjective describing the list flavour; FLAG is a bit to set in + * the node's flags word; LINKOFF is the offset of the list's link member. + */ static void add_lispsys(const char *p, const char *what, struct lispsys_list *list, unsigned flag, size_t linkoff) @@ -148,8 +113,9 @@ static void add_lispsys(const char *p, const char *what, if (!*p) return; for (;;) { + while (ISSPACE(*p)) p++; if (!*p) break; - q = p; while (*p && *p != ',') p++; + q = p; while (*p && !ISSPACE(*p) && *p != ',') p++; lisp = ensure_lispsys(q, p - q); if (lisp->f&flag) { if (verbose >= 1) @@ -159,11 +125,16 @@ static void add_lispsys(const char *p, const char *what, lisp->f |= flag; *link = 0; *list->tail = lisp; list->tail = link; } + while (ISSPACE(*p)) p++; if (!*p) break; - p++; + if (*p == ',') p++; } } +/* Check that the Lisp systems on LIST (linked through LINKOFF) are real. + * + * That is, `LF_KNOWN' is set in their flags. + */ static void check_lisps(const char *what, struct lispsys_list *list, size_t linkoff) { @@ -174,6 +145,10 @@ static void check_lisps(const char *what, lose("unknown Lisp implementation `%s'", LISPSYS_NAME(lisp)); } +/* Dump the names of the Lisp systems on LIST (linked through LINKOFF). + * + * WHAT is an adjective describing the list. + */ static void dump_lisps(const char *what, struct lispsys_list *list, size_t linkoff) { @@ -185,7 +160,7 @@ static void dump_lisps(const char *what, for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff)) { if (first) first = 0; else dstr_puts(&d, ", "); - dstr_putf(&d, "`%s'", LISPSYS_NAME(lisp)); + dstr_puts(&d, LISPSYS_NAME(lisp)); } if (first) dstr_puts(&d, "(none)"); dstr_putz(&d); @@ -193,6 +168,11 @@ static void dump_lisps(const char *what, dstr_release(&d); } +/* Add an eval-mode operation to the `argv_tail' vector. + * + * OP is the operation character (see `eval.lisp' for these) and `val' is the + * argument (filename or expression). + */ static void push_eval_op(char op, const char *val) { char *p; @@ -210,6 +190,51 @@ static void push_eval_op(char op, const char *val) argv_append(&argv_tail, p); } +/* Help and related functions. */ +static void version(FILE *fp) + { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); } + +static void usage(FILE *fp) +{ + fprintf(fp, "\ +usage:\n\ + %s [OPTIONS] [--] SCRIPT [ARGUMENTS ...]\n\ + %s [OPTIONS] [-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n\ +OPTIONS:\n\ + [-CDEnqv] [+DEn] [-L SYS,SYS,...] [-c CONF] [-o [SECT:]VAR=VAL]\n", + progname, progname); +} + +static void help(FILE *fp) +{ + version(fp); fputc('\n', fp); usage(fp); + fputs("\n\ +Help options:\n\ + -h, --help Show this help text and exit successfully.\n\ + -V, --version Show version number and exit successfully.\n\ +\n\ +Diagnostics:\n\ + -n, --dry-run Don't run run anything (useful with `-v').\n\ + -q, --quiet Don't print warning messages.\n\ + -v, --verbose Print informational messages (repeatable).\n\ +\n\ +Configuration:\n\ + -E, --command-line-only Don't read embedded options from script.\n\ + -c, --config-file=CONF Read configuration from CONF (repeatable).\n\ + -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\ +\n\ +Lisp implementation selection:\n\ + -D, --vanilla-image Run vanilla Lisp images, not custom ones.\n\ + -L, --accept-lisp=SYS,SYS,... Only use the listed Lisp systems.\n\ +\n\ +Evaluation mode:\n\ + -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\ + -l, --load-file=FILE Load FILE (repeatable).\n\ + -p, --print-expression=EXPR Print (`prin1') EXPR (repeatable).\n", + fp); +} + +/* Parse the options in the argument vector. */ static void parse_options(int argc, char *argv[]) { int i; @@ -261,6 +286,7 @@ static void parse_options(int argc, char *argv[]) } } +/* Extract and process the embedded options from a SCRIPT. */ static void handle_embedded_args(const char *script) { struct dstr d = DSTR_INIT; @@ -270,17 +296,40 @@ static void handle_embedded_args(const char *script) int qstate = 0; FILE *fp = 0; + /* Open the script. If this doesn't work, then we have no hope. */ fp = fopen(script, "r"); if (!fp) lose("can't read script `%s': %s", script, strerror(errno)); + /* Read the second line. */ if (dstr_readline(&d, fp)) goto end; dstr_reset(&d); if (dstr_readline(&d, fp)) goto end; + /* Check to find the magic marker. */ p = strstr(d.p, "@RUNLISP:"); if (!p) goto end; p += 9; q = p; l = d.p + d.len; + + /* Split the line into words. + * + * Do this by hand because we have strange things to support, such as Emacs + * turds and the early `--' exit. + * + * We work in place: `p' is the input cursor and advances through the + * string as we parse, until it meets the limit pointer `l'; `q' is the + * output cursor which will always be no further forward than `p'. + */ for (;;) { + /* Iterate over the words. */ + + /* Skip spaces. */ while (p < l && ISSPACE(*p)) p++; + + /* If we've reached the end then we're done. */ if (p >= l) break; + + /* Check for an Emacs local-variables `-*-' turd. + * + * If we find one, find the matching end marker and move past it. + */ if (l - p >= 3 && p[0] == '-' && p[1] == '*' && p[2] == '-') { p = strstr(p + 3, "-*-"); if (!p || p + 3 > l) @@ -288,31 +337,60 @@ static void handle_embedded_args(const char *script) p += 3; continue; } + + /* If we find a `--' marker then stop immediately. */ if (l - p >= 2 && p[0] == '-' && p[1] == '-' && (l == p + 2 || ISSPACE(p[2]))) break; + /* Push the output cursor position onto the output, because this is where + * the next word will start. + */ argv_append(&av, q); + + /* Collect characters until we find an unquoted space. */ while (p < l && (qstate || !ISSPACE(*p))) { - if (*p == '"') { p++; qstate = !qstate; } + + if (*p == '"') + /* A quote. Skip past, and toggle quotedness. */ + + { p++; qstate = !qstate; } + else if (*p == '\\') { + /* A backslash. Just emit the following character. */ + p++; if (p >= l) lose("%s:2: unfinished `\\' escape", script); *q++ = *p++; + } else if (*p == '\'') { + /* A single quote. Find its matching end quote, and emit everything + * in between. + */ + p++; r = strchr(p, '\''); if (!r || r > l) lose("%s:2: missing `''", script); n = r - p; memmove(q, p, n); q += n; p = r + 1; + } else { + /* An ordinary constituent. Gather a bunch of these up and emit them + * all. + */ n = strcspn(p, qstate ? "\"\\" : "\"'\\ \f\n\r\t\v"); if (n > l - p) n = l - p; memmove(q, p, n); q += n; p += n; } } + + /* Check that we're not still inside quotes. */ if (qstate) lose("%s:2: missing `\"'", script); - if (p < l) p++; - *q++ = 0; + + /* Finish off this word and prepare to start the next. */ + *q++ = 0; if (p < l) p++; } + /* Parse the arguments we've collected as options. Object if we find + * positional arguments. + */ flags = (flags&~AF_STATEMASK) | AF_EMBED; parse_options(av.n, (char * /*unconst*/*)av.v); if (optind < av.n) @@ -320,6 +398,7 @@ static void handle_embedded_args(const char *script) script, av.v[optind]); end: + /* Tidy up. */ if (fp) { if (ferror(fp)) lose("error reading script `%s': %s", script, strerror(errno)); @@ -328,6 +407,7 @@ end: dstr_release(&d); argv_release(&av); } +/* Main program. */ int main(int argc, char *argv[]) { struct config_section_iter si; @@ -335,51 +415,97 @@ int main(int argc, char *argv[]) struct config_var *var; struct lispsys_list order; struct lispsys *lisp, **tail; + const char *p; + const char *script; struct dstr d = DSTR_INIT; struct argv av = ARGV_INIT; + /* initial setup. */ set_progname(argv[0]); - init_config(); - config_set_var(&config, toplevel, 0, "prefer", "${@ENV:RUNLISP_PREFER?}"); + /* Parse the command-line options. */ flags = (flags&~AF_STATEMASK) | AF_CMDLINE; parse_options(argc - 1, argv + 1); optind++; - if (argv_tail.n) - flags |= AF_NOEMBED; - else if (!script && !argv_tail.n) { - if (optind < argc) script = argv[optind]++; - else flags |= AF_BOGUS; - } - + /* We now know enough to decide whether we're in eval or script mode. In + * the former case, don't check for embedded options (it won't work because + * we don't know where the `eval.lisp' script is yet, and besides, there + * aren't any). In the latter case, pick out the script name, leaving the + * remaining positional arguments for later. + */ + if (argv_tail.n) { flags |= AF_NOEMBED; script = 0; } + else if (optind < argc) script = argv[optind++]; + else flags |= AF_BOGUS; + + /* Check that everything worked. */ + if (flags&AF_BOGUS) { usage(stderr); exit(127); } + + /* Reestablish ARGC/ARGV to refer to the tail of positional arguments to be + * passed onto the eventual script. For eval mode, that includes the + * operations already queued up, so we'll have to accumulate everything in + * `argv_tail'. + */ argc -= optind; argv += optind; if (argv_tail.n) { argv_append(&argv_tail, "--"); - argv_appendn(&argv_tail, (const char *const *)argv, argc); - argc = argv_tail.n; argv = (/*unconst*/ char */*unconst*/ *)argv_tail.v; + argv_appendn(&argv_tail, argv, argc); + argc = argv_tail.n; argv = argv_tail.v; } - if (flags&AF_BOGUS) { usage(stderr); exit(2); } + /* Fetch embedded options. */ if (!(flags&AF_NOEMBED)) handle_embedded_args(script); + + /* Load default configuration if no explicit files were requested. */ if (!(flags&AF_SETCONF)) load_default_config(); - if (verbose >= 5) dump_config(); - dstr_reset(&d); - var = config_find_var(&config, toplevel, CF_INHERIT, "prefer"); - config_subst_var(&config, toplevel, var, &d); - add_lispsys(d.p, "preferred", &prefer, LF_PREFER, - offsetof(struct lispsys, next_prefer)); + /* Determine the preferred Lisp systems. Check the environment first; + * otherwise use the configuration file. + */ + p = my_getenv("RUNLISP_PREFER", 0); + if (!p) { + var = config_find_var(&config, toplevel, CF_INHERIT, "prefer"); + if (var) { + dstr_reset(&d); + config_subst_var(&config, toplevel, var, &d); p = d.p; + } + } + if (p) + add_lispsys(p, "preferred", &prefer, LF_PREFER, + offsetof(struct lispsys, next_prefer)); + /* If we're in eval mode, then find the `eval.lisp' script. */ if (!script) script = config_subst_string_alloc (&config, common, "", - "${@ENV:RUNLISP_EVAL?${@CONFIG:data-dir}/eval.lisp}"); - + "${@ENV:RUNLISP_EVAL?" + "${@CONFIG:eval-script?" + "${@data-dir}/eval.lisp}}"); + + /* We now have the script name, so publish it for `uiop'. + * + * As an aside, this is a terrible interface. It's too easy to forget to + * set it. (To illustrate this, `cl-launch -x' indeed forgets to set it.) + * If you're lucky, the script just thinks that its argument is `nil', in + * which case maybe it can use `*load-pathname*' as a fallback. If you're + * unlucky, your script was invoked (possibly indirectly) by another + * script, and now you've accidentally inherited the calling script's name. + * + * It would have been far better simply to repeat the script name as the + * first user argument, if nothing else had come readily to mind. + */ if (setenv("__CL_ARGV0", script, 1)) lose("failed to set script-name environment variable"); - config_set_var(&config, builtin, CF_LITERAL, "@SCRIPT", script); + /* And publish it in the configuration for the `run-script' commands. */ + config_set_var(&config, builtin, CF_LITERAL, "@script", script); + + /* Dump the final configuration if we're being very verbose. */ + if (verbose >= 5) dump_config(); + + /* Identify the configuration sections which correspond to actual Lisp + * system definitions, and gather them into the `known' list. + */ tail = lisps.tail; for (config_start_section_iter(&config, &si); (sect = config_next_section(&si)); ) { @@ -392,9 +518,11 @@ int main(int argc, char *argv[]) } *tail = 0; lisps.tail = tail; + /* Make sure that the acceptable and preferred Lisps actually exist. */ check_lisps("acceptable", &accept, offsetof(struct lispsys, next_accept)); check_lisps("preferred", &prefer, offsetof(struct lispsys, next_prefer)); + /* If there are no acceptable Lisps, then we'll take all of them. */ if (!accept.head) { if (verbose >= 2) moan("no explicitly acceptable implementations: allowing all"); @@ -404,6 +532,10 @@ int main(int argc, char *argv[]) *tail = 0; accept.tail = tail; } + /* Build the final list of Lisp systems in the order in which we'll try + * them: first, preferred Lisps which are acceptable, and then acceptable + * Lisps which aren't preferred. + */ tail = &order.head; for (lisp = prefer.head; lisp; lisp = lisp->next_prefer) if (lisp->f&LF_ACCEPT) { *tail = lisp; tail = &lisp->next_order; } @@ -411,6 +543,7 @@ int main(int argc, char *argv[]) if (!(lisp->f&LF_PREFER)) { *tail = lisp; tail = &lisp->next_order; } *tail = 0; + /* Maybe dump out the various lists of Lisp systems we've collected. */ if (verbose >= 4) dump_lisps("known Lisps", &lisps, offsetof(struct lispsys, next_lisp)); if (verbose >= 3) { @@ -422,26 +555,40 @@ int main(int argc, char *argv[]) offsetof(struct lispsys, next_order)); } + /* Try to actually run the script. */ for (lisp = order.head; lisp; lisp = lisp->next_order) { - if (config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) { + /* Try each of the selected systems in turn. */ + + /* See whether there's a custom image file. If so, set `@image' in the + * system's configuration section. + */ + if (!(flags&AF_VANILLA) && + config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) { var = config_find_var(&config, lisp->sect, CF_INHERIT, "image-path"); dstr_reset(&d); config_subst_var(&config, lisp->sect, var, &d); if (file_exists_p(d.p, verbose >= 2 ? FEF_VERBOSE : 0)) - config_set_var(&config, lisp->sect, CF_LITERAL, "@IMAGE", "t"); + config_set_var(&config, lisp->sect, CF_LITERAL, "@image", "t"); } + + /* Build the command line from `run-script'. */ argv_reset(&av); config_subst_split_var(&config, lisp->sect, lisp->var, &av); if (!av.n) { moan("empty command for Lisp implementation `%s'", LISPSYS_NAME(lisp)); continue; } - argv_appendn(&av, (const char *const *)argv, argc); + + /* Append our additional positional arguments. */ + argv_appendn(&av, argv, argc); + + /* Try to run the Lisp system. */ if (!try_exec(&av, (flags&AF_DRYRUN ? TEF_DRYRUN : 0) | (verbose >= 2 ? TEF_VERBOSE : 0))) return (0); } + /* No. Much errors. So failure. Very sadness. */ lose("no acceptable Lisp systems found"); } diff --git a/runlisp.conf b/runlisp.conf index d2bad4e..78fc5b7 100644 --- a/runlisp.conf +++ b/runlisp.conf @@ -1,299 +1,27 @@ ;;; -*-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} +;;; Top-level configuration. -dump-image = - ${command} --noinform --no-userinit --no-sysinit --disable-debugger - --eval "${dump-image-prelude}" - --eval "(sb-ext:save-lisp-and-die \"${@IMAGE|q}\")" +;; Lisp implementations for which custom images should be dumped by +;; `dump-runlisp-image -a'. Defaults to all installed Lisp implementations. +; dump = sbcl, cmucl, ccl, clisp +;; Lisp implementations to use by preference. Defaults to the order read +;; from the configuration file. Overridden by `$RUNLISP_PREFER' in +;; environment. +; prefer = sbcl, ccl, clisp, ecl, cmucl, sbcl -;;;-------------------------------------------------------------------------- -[ccl] - -command = ${@ENV:CCL?ccl} -image-file = ccl+asdf.image +;; Directory to look for or dump custom images. Defaults to hardcoded +;; directory; overridden by `$RUNLISP_IMAGEDIR' in environment. +; image-dir = /path/to/things -run-script = - ${command} -b -n -Q - $?@IMAGE{-I "${image-path}" -e "${image-restore}" | - -e "${run-script-prelude}"} - -l ${@SCRIPT} -e "(ccl:quit)" -- +;; Directory to look for additional scripts. Defaults to hardcoded +;; directory; overridden by `$RUNLISP_DATADIR' in environment. +; data-dir = /path/to/things -;; 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)" +;; Script to support eval-mode operation. Defaults to +;; `${data-dir}/eval.lisp'; opverridden by `$RUNLISP_EVAL' in environment. +; eval-script = /path/to/script ;;;-------------------------------------------------------------------------- -[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 -------------------------------------------------- diff --git a/runlisp.conf.5 b/runlisp.conf.5 new file mode 100644 index 0000000..e7773de --- /dev/null +++ b/runlisp.conf.5 @@ -0,0 +1,546 @@ +.\" -*-nroff-*- +.\" +.\" Manual for `runlisp' configuration files +.\" +.\" (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 . +. +.ie t \{\ +. ds o \(bu +. if \n(.g \{\ +. fam P +. ev an-1 +. fam P +. ev +. \} +.\} +.el \{\ +. ds o o +.\} +. +.de hP +.IP +\h'-\w'\fB\\$1\ \fP'u'\fB\\$1\ \fP\c +.. +.ds , \h'.16667m' +. +.\"-------------------------------------------------------------------------- +.TH runlisp.conf 5 "27 August 2020" "Mark Wooding" +.SH NAME +runlisp.conf \- configuration files for runlisp +. +.\"-------------------------------------------------------------------------- +.SH DESCRIPTION +. +.SS "General syntax" +In summary, +a configuration file is structured as a collection of assignments +.I variable +.B = +.IR value , +gathered into named sections by header lines +.BI [ section ]\fR. +.PP +Comments are indicated by a semicolon +.RB ` ; ' +in the leftmost column, +and extend to the end of the line; +comments and lines consisting only of whiteapace are ignored +and have no effect whatever. +Semicolons not in the first column do +.I not +introduce comments, +and have no special meaning. +.PP +A +.I name +is a non-empty sequence of ASCII alphanumeric characters, +or the special constituent characters +.RB ` \- ', +.RB ` _ ', +.RB ` . ', +.RB ` / ', +.RB ` * ', +.RB ` + ', +.RB ` *% ', +or +.RB ` @ '. +For example, +.RB ` foo ', +.RB ` 12345 ', +.RB ` \-2.718 ', +.RB ` 113/355 ', +.RB ` image-dir ', +.RB ` @%IMAGEDIR ', +and +.RB ` *organa-solo* ' +are all names, but +.RB ` foo:bar ' +.RB ` happy? ' +and +.RB ` $3.95 ' +are not. +Names beginning with +.RB ` @ ' +are reserved for use by the +.B runlisp +programs; +names beginning with +.RB ` % ' +or +.RB ` @% ' +are by convention private. +.PP +A +.I section header +is a line of the form +.IP +.BI [ section ] +.PP +where +.I section +is a name, as defined above. +There may be whitespace before and after the +.I name +or after the +.RB ` ] '. +Section headers need not have distinct names. +Subsequent assignments are applied to the section called +.IR name , +up until the next section header, or the end of the file. +Assignments prior to the first section header in a file +are applied to the +.B @CONFIG +section. +.PP +An +.I assignment +begins with a line of the form +.IP +.I variable +.B = +.I rest +.PP +where +.I variable +is a name, as defined above, +and it includes all subsequent +(non-empty, non-comment) +lines up to, but not including, +the next line which does +.I not +begin with whitespace or a semicolon, +or the end of the input file. +There may be space before or after the +.RB ` = '. +The +.I value +assigned consists of the text of the initial line following the +.RB ` = ' +character +(shown as +.I rest +above), +together with the contents of the subsequent lines; +initial and trailing whitespace is removed from each piece, +and the (nonempty) pieces are joined, +separated by single spaces. +We say that a assignment +assigns a value to the variable +in some section \(en +namely, the section in which the assignment is applied. +.PP +For example, +consider the following file. +.IP +.ft B +.nf +long = + one + + two +; this line is a comment + ; not a comment + three + +short = just a quick note +.fi +.ft P +.PP +Then +.B long +is assigned the value +.RB ` "one two ; not a comment three" ', +and +.B short is assigned +.RB ` "just a quick note" '. +.PP +The assignments applied to a section +need not have distinct variable names. +Only the last assignment to a particular variable name in a section is +.IR effective ; +the earlier assignments are simply ignored. +If an effective assignment assigns a value to a variable in a section, +we say that the variable is +.I set +to that value in the section. +. +.SS "Lookup and inheritance" +A section may have zero or more +.I parent +sections. +.PP +The +.BR @BUILTIN , +.BR @CONFIG , +and +.B @ENV +sections have no parents. +The +.B @CONFIG +section has one parent, namely +.BR @BUILTIN . +.PP +If the variable +.B @parents +is set in a section other than one of those named above, +then it must consist of a space- or comma-separated list +of names, +which name the section's parents. +Currently, the parents need not be distinct, +though duplicates have no effect other than slowing down lookup. +The order in which parents are listed is not significant. +If +.B @parents +is not set in a section other than one of those named above, +then by default it has one parent, namely +.BR @COMMON . +.PP +It is currently possible to build a cyclic structure of parent links. +This is not recommended. +If lookup (explained below) detects a cycle +then it will report a fatal error, +but cycles may exist without being detected. +.PP +A variable is +.I "looked up" +in a section as follows. +.hP 1. +If there is an effective assignment +of a value to that variable in the section +then lookup finds that assignment. +.hP 2. +If the section has no parents, +then lookup fails. +.hP 3. +Otherwise, the variable is looked up in each of the section's parents. +If none of these lookups succeeds, then the lookup fails. +If all of the successful lookups found the +.I "same assignment" +(not just the same value!) +then lookup finds that assignment. +Otherwise, the lookup reports an error. +. +.SS "Expansion and word-splitting" +A value can be +.I expanded +relative to some home section, +and optionally split into words. +.PP +Not all values are +.IR expandable . +Values set by assignments in a configuration file are always expandable. +Values set on the command line \(en in +.B \-o +options \(en are not expandable. +Values in the +.B @ENV +section from environment variables (see below) are not expandable. +Some values set in the +.B @BUILTIN +section are expandable and some are not. +Applying expansion to a value that is not expandable +simply results in that same value, unchanged. +.PP +Applying expansion to an expandable value +produces a result string as follows. +The value is scanned from start to end. +.hP \*o +A backslash +.RB ` \e ' +is discarded, but the immediately following character +is copied to the output without further inspection. +.hP \*o +A +.I variable substitution +takes the form +.BR ${ [ \c +.IB sect : \c +.RI ] var \c +.RB [ | \c +.IR filter ]... \c +.RB [ ? \c +.IR alt ] \c +.BR } . +A variable named +.I var +is looked up in the section named +.IR sect , +or, if omitted, in the home section. +If the lookup succeeds, +then the value is expanded, +processed by the +.IR filter s +(explained below), +and appended to the output. +If the lookup failed, +and +.BI ? alt +is present, +then +.I alt +is expanded and appended to the output. +Otherwise, +if the lookup fails and there is no +.I alt +text, then an error is reported. +.IP +A filter +.B u +causes the expanded value to be converted to uppercase; +similarly, +.B l +causes the expanded value to be converted to lowercase. +A filter +.B q +causes a backslash to be inserted before each +backslash or double-quote character in the expanded value, +so that this can be used as part of a quoted Common Lisp string. +.hP \*o +A +.I conditional +takes the form +.BR $? [ \c +.IB sect : \c +.RI ] var \c +.BI { conseq \c +.RB [ | \c +.IR alt ] \c +.BR } . +A variable named +.I var +is looked up in the section named +.IR sect , +or, if omitted, in the home section. +If the lookup succeeds, then +.I conseq +is expanded and appended to the output; +otherwise, if +.I alt +is present, then it is expanded and appended to the output; +otherwise, nothing happens. +.hP \*o +A dollar sign which doesn't introduce one of the forms above +is invalid, and a fatal error is reported. +.hP \*o +Any other characters are simply appended to the output. +.PP +Word-splitting is similar but more complex. +The result is not a string, but a sequence of strings. +At any given point in this procedure, +there may be a partially constructed word, +or there might not. +.hP \*o +Outside of quotes (see below), +whitespace serves to separate words. +When a whitespace character is encountered, +if there is a word under construction, +then it is finished and added to the output list; +otherwise it is simply ignored. +.hP \*o +If a backslash is encountered, +then a word is started if there is none currently under construction, +and the character following the backslash is added to the current word. +.hP \*o +If a single-quote character +.RB ` ' ' +is encountered, +then a word is started if there is none currently under construction, +and +.I all +characters up to the next single quote +are added to the current word. +This includes double quotes, dollar signs, and backslashes. +(Neither of the two single quotes is appended to the current word.) +.hP \*o +If a double-quote character +.RB ` """" ' +is encountered, +then a word is started if there is none currently under construction. +Until the next double quote is encountered, +whitespace and single quotes treated literally, +and simply added to the current word; +backslashes can be used to escape characters, +such as double quotes, +as usual. +.hP \*o +If a +.BR $ -expansion +\(en a variable substitution or conditional (as described above) \(en +is encountered +and there is a current word under construction, +then the result of the +.BR $ -expansion +is appended to the current word. +If there is no current word, +then the variable value, or consequent or alternative text, +is subjected to word splitting in addition to expansion, +and the resulting words appended to the output sequence. +.hP \*o +If any other character is encountered, +then a word is started if there is none currently under construction, +and the character is appended to the current word. +.PP +One case which deserves attention: +if a +.BR $ -expansion +is encountered outside of a word, +so that the result is subject to word splitting, +then an error is reported if a new word is started +without there being whitespace between the closing brace of the +.B $ -expansion +and the character which started the new word. +For example, +.IP +.B "bad = one ${x}two" +.PP +would be invalid in a word-splitting context. +. +.SS "Predefined variables in @BUILTIN" +The +.B @BULITIN +Section has no parents. +You should not override its settings in configuration files. +it holds a number of variables set by the +.B runlisp +programs. +.TP +.B @data-dir +The directory in which +.BR runlisp 's +auxiliary data files and scripts are located. +This is determined by the +.B RUNLISP_DATADIR +environment variable, +the +.B data-dir +variable in the +.B @CONFIG +section, +or a value determined at compile time. +.TP +.B @ecl-opt +The preferred option prefix for ECL, either +.RB ` \- ' +or +.RB ` \-\- '. +(For some reason, +the ECL developers are changing +the way ECL recognizes command-line options, +because they think that the minor aesthetic improvement +is worth breaking everyone's scripts.) +This is determined by the +.B ecl-opt +variable in the +.B @CONFIG +section, +or a value determined at compile time. +.TP +.B @image-dir +The directory in which +.B runlisp +looks for, and +.B dump-runlisp-image +stores, custom Lisp images. +This is determined by the +.B RUNLISP_IMAGEDIR +environment variable, +the +.B image-dir +variable in the +.B @CONFIG +section, +or a value determined at compile time. +.TP +.B @image-new +Set by +.BR dump-runlisp-image (1) +to the filename that a +.B dump-image +command should create. +.RB ( dump-runlisp-image +will rename the image into place itself, +if the command completes successfully.) +.TP +.B @image-out +Set by +.BR dump-runlisp-image (1) +to the filename of the intended output image. +(Don't use this in +.B dump-image +commands: use +.B @image-new +instread.) +.TP +.B @script +Set by +.BR runlisp (1) +to the name of the script being invoked. +.TP +.B @tmp-dir +Set by +.BR dump-runlisp-image (1) +to be the name of a directory in which a +.B dump-image +command can put temporary files. +. +.SS "Other special variables" +In every section, the section's name +is automatically assigned to the variable +.BR @name . +This variable +.I can +be overridden by an explicit assignment, +but this is not recommended. +. +.\"-------------------------------------------------------------------------- +. +.SH BUGS +.hP \*o +. +.SH SEE ALSO +.BR dump-runlisp-image (1), +.BR query-runlisp-config (1), +.BR runlisp (1). +. +.SH AUTHOR +Mark Wooding, +. +.\"----- That's all, folks -------------------------------------------------- diff --git a/tests.at b/tests.at index 3eee970..8c5d0c6 100644 --- a/tests.at +++ b/tests.at @@ -40,19 +40,24 @@ m4_define([LISP_SYSTEMS], cmucl, cmucl/noimage, abcl, abcl/noimage]) +m4_define([SETUP_RUNLISP_ENV], +[RUNLISP_SYSCONFIG=$abs_top_srcdir/runlisp-base.conf; export RUNLISP_SYSCONFIG +RUNLISP_SYSCONFIG_DIR=/notexist; export RUNLISP_SYSCONFIG_DIR +RUNLISP_IMAGEDIR=$abs_top_builddir; export RUNLISP_IMAGEDIR +RUNLISP_EVAL=$abs_top_srcdir/eval.lisp; export RUNLISP_EVAL +unset RUNLISP_USERCONFIG +]) + m4_define([PREPARE_LISP_TEST], -[lisp=$1 +[SETUP_RUNLISP_ENV +lisp=$1 LISP=$m4_translit(m4_bregexp([$1], [/.*$], []), [a-z], [A-Z]) AT_SKIP_IF([test "x$LISP" = x]) case $lisp in */*) opt=${lisp#*/} lisp=${lisp%%/*} ;; *) opt="" ;; esac -case /$opt/ in - */noimage/*) RUNLISP_IMAGEDIR=./notexist ;; - *) RUNLISP_IMAGEDIR=$abs_top_builddir ;; -esac -export RUNLISP_IMAGEDIR]) +case /$opt/ in */noimage/*) RUNLISP_IMAGEDIR=./notexist ;; esac]) m4_define([WHICH_LISP], [(or #+sbcl "sbcl" #+ccl "ccl" #+clisp "clisp" @@ -62,12 +67,6 @@ m4_define([WHICH_LISP], m4_define([NL], [ ]) -m4_define([SETUP_RUNLISP_IMAGEDIR], -[RUNLISP_IMAGEDIR=$abs_top_builddir; export RUNLISP_IMAGEDIR]) - -m4_define([SETUP_RUNLISP_EVAL], -[RUNLISP_EVAL=$abs_top_srcdir/eval.lisp; export RUNLISP_EVAL]) - ###-------------------------------------------------------------------------- ### A basic smoke test. @@ -119,7 +118,8 @@ cat >test-script <$conf <$@.new $< && mv $@.new $@ +.5.pdf:; $(v_man)$(MAN) -Tpdf -l >$@.new $< && mv $@.new $@ + +###-------------------------------------------------------------------------- ### List of Lisp systems. LISPS =