// Core functions -- the main scm-to-C interface
//
// This file is part of Beastie <https://purl.org/nxg/dist/beastie>
// SPDX-FileCopyrightText: 2023 Norman Gray <https://nxg.me.uk>
// SPDX-License-Identifier: BSD-2-Clause

#if __GNUC__
#undef _XOPEN_SOURCE
#ifndef _GNU_SOURCE
#define _GNU_SOURCE
#endif
#endif

#ifndef ALL_FUNCTIONS
// define as zero to exclude functions which depend on other modules
// (allows us to build beastie0)
#define ALL_FUNCTIONS 1
#endif /* ALL_FUNCTIONS */

#include <stdio.h>
#include <stdlib.h>

#include <unistd.h>
#include <string.h>
#include <sys/wait.h>
#include <sys/errno.h>
#include <sys/param.h>          // for MAXPATHLEN
#include <ctype.h>
#include <regex.h>
#include <assert.h>
#if HAVE_ALLOCA_H
#include <alloca.h>
#endif

#include "config.h"

#include "core.h"
#include "util.h"
#include "unicode-scm.h"

#if ALL_FUNCTIONS

#include "util-extra.h"
#include "uniprops.h"
#if HAVE_ICU
#include "unicode/uvernum.h"
#endif

#include "parse-authors.h"
#include "parse-fmtstring.h"
#include "parse-bst.h"
#include "parse-aux.h"
#include "parse-markdown.h"
#include "parse-mdinline.h"
#include "parse-mdblock.h"
#include "parse-json.h"
#include "lex-bib2.h"

#if HAVE_SYS_UTSNAME_H
#include <sys/utsname.h>
#endif

static s7_pointer parse_bst_source_proc(s7_scheme* sc, s7_pointer args)
{
    // (parse-bst-source** #t (or/c string? #f)) : parse from file
    // (parse-bst-source** #f string?)           : parse string contents
    char is_file_p = s7_boolean(sc, s7_car(args));
    s7_pointer input = s7_cadr(args);
    // presume that the caller has checked types OK:
    // if IS_FILE_P is true, then INPUT is string or #f;
    // if false, then INPUT is a string

    const char* input_string;
    if (is_file_p && !s7_boolean(sc, input)) {
        input_string = NULL; // means stdin
    } else {
        input_string = s7_string(input);
    }
    //fprintf(stderr, "parse_bst_source_proc: %s %s...\n", (is_file_p ? "file" : "string"), input_string);

    yyscan_t scanner;
    struct bst_extra_s S;
    if (is_file_p) {
        scanner = parse_bst_setup_file(&S, input_string);
    } else {
        scanner = parse_bst_setup_string(&S, input_string);
    }

    if (scanner == NULL) {
        // warning or error?  #f or '()?
        scheme_eval("print-warning",
                    s7_make_string(sc, "parse-bst-input*: can't open source ~a to read"),
                    input, NULL);
        return s7_nil(sc);  // JUMP OUT
    }

    s7_pointer result;
    int status = bstparse(&S, &result, scanner);
    // fprintf(stderr, "parse_bst_input_proc: %s <%s> -> status=%d\n",
    //         (is_file_p ? "file" : "string"), input_string, status);

    parse_bst_finish(&S, scanner);

    return status == 0 ? result : s7_f(sc);
}

static s7_pointer parse_aux_source_proc(s7_scheme* sc, s7_pointer args)
{
    // (parse-aux-source** #t (or/c string? #f)) : parse from file
    // (parse-aux-source** #f string?)           : parse string contents
    char is_file_p = s7_boolean(sc, s7_car(args));
    s7_pointer input = s7_cadr(args);
    // presume that the caller has checked types OK:
    // if IS_FILE_P is true, then INPUT is string or #f;
    // if false, then INPUT is a string

    int error_status = 1;             // error unless reset

    const char* input_string = NULL;
    FILE *infile = NULL;
    if (is_file_p) {
        if (s7_boolean(sc, input)) {
            infile = fopen(s7_string(input), "r");
            if (infile == NULL) {
                // warning or error?  #f or '()?
                scheme_eval("print-warning",
                            s7_make_string(sc, "parse-aux-file: can't open file '~a' to read"),
                            input, NULL);
                goto tidyup;  // JUMP OUT
            }
        } else {
            infile = NULL; // means stdin
        }
    } else {
        input_string = s7_string(input);
    }

    yyscan_t scanner;
    struct aux_extra_s S;
    if (is_file_p) {
        scanner = parse_aux_setup_file(&S, infile);
    } else {
        scanner = parse_aux_setup_string(&S, input_string);
    }

    if (scanner == NULL) {
        // warning or error?  #f or '()?
        scheme_eval("print-warning",
                    s7_make_string(sc, "parse-aux-input*: can't open source ~a to read"),
                    input, NULL);
        goto tidyup;            // JUMP OUT
    }

    s7_pointer result;
    error_status = auxparse(&S, &result, scanner); // returns 1 on error
    // fprintf(stderr, "parse_aux_input_proc: %s <%s> -> status=%d\n",
    //         (is_file_p ? "file" : "string"), s7_string(input), error_status);

    parse_aux_finish(&S, scanner);

 tidyup:
    if (is_file_p && infile) fclose(infile);

    return error_status ? s7_f(sc) : result;
}

static s7_pointer parse_markdown_source_proc(s7_scheme* sc, s7_pointer args)
{
    // (parse-markdown-input* #t accumulator? (or/c string? #f)) : parse from file
    // (parse-markdown-input* #f accumulator? string?)           : parse string contents
    char is_file_p = s7_boolean(sc, s7_car(args));
    s7_pointer accumulator = s7_cadr(args);
    s7_pointer input = s7_caddr(args);
    // presume that the caller has checked types OK:
    // if IS_FILE_P is true, then INPUT is string or #f;
    // if false, then INPUT is a string

    int error_status = 1;       // error unless reset

    s7_pointer source_label;
    const char* input_source;
    if (is_file_p) {
        if (s7_boolean(sc, input)) {
            input_source = s7_string(input); // filename
            source_label = input;
        } else {
            input_source = NULL; // means stdin
            source_label = s7_make_string(sc, "<stdin>");
        }
    } else {
        input_source = s7_string(input);

        const size_t slen = 20;
        const char fmt[] = "<string:%.*s...>";
        const size_t buflen = slen + sizeof(fmt);
        char* buf = alloca(buflen+1);
        int eol = 0; // end of first line or slen, whichever comes first
        while (eol<slen && input_source[eol]!='\n') eol++;
        snprintf(buf, buflen, fmt, eol, input_source);
        source_label = s7_make_string(sc, buf);
        s7_gc_protect_via_stack(sc, source_label);
    }
    // fprintf(stderr, "parse_markdown_source_proc: %s %s\n",
    //         (is_file_p ? "file" : "string"), s7_string(source_label));

    yyscan_t scanner;
    struct markdown_extra_s S;
    if (is_file_p) {
        scanner = parse_markdown_setup_file(&S, input_source);
    } else {
        scanner = parse_markdown_setup_string(&S, input_source, s7_string_length(input));
    }

    s7_pointer result;
    if (scanner != NULL) {
        error_status = markdownparse(&S, &result, accumulator, source_label, scanner);
        // returns 0 on success
        parse_markdown_finish(&S, scanner);
    }

    return (error_status == 0 ? result : s7_f(sc));
}

static s7_pointer parse_authorlist_proc(s7_scheme* sc, s7_pointer args)
{
    // (parse-author-list** author-string location)
    // The AUTHOR-STRING is the BibTeX-style author list to be parsed.
    //
    // The LOCATION is intended to be a string with an
    // indication of location, for error messages.
    // Note: this second argument is currently never present because,
    // after implementing it, I realised that we are short of the sort
    // of provenance information, regarding strings, that would fill
    // it in.  But I intend to add that before long, so keep this in.
    // Right now, therefore, it should always be passed as #f.
    s7_pointer authorlist = s7_car(args);
    s7_pointer location = s7_cadr(args);

    if (! s7_is_string(authorlist)) {
        return s7_wrong_type_arg_error(sc, "parse-author-list**", 1, authorlist, "a string");
    }
    if (s7_boolean(sc, location)) {
        return s7_wrong_type_arg_error(sc, "parse-author-list**", 2, location, "#f (currently)");
    }

    s7_pointer result;
    struct authors_extra_s S;
    yyscan_t scanner = parse_authors_setup_string(&S, s7_string(authorlist));
    S.location = NULL; //location;

    int status = authorsparse(&S, &result, scanner);

    parse_authors_finish(&S, scanner);

    return status == 0 ? result : s7_f(sc);
}

static s7_pointer parse_fmtstring_proc(s7_scheme* sc, s7_pointer args)
{
    // (parse-fmtstring** string?) parses the BibTeX-style format
    // string, and returns a structure which needs a little bit of
    // post-processinging, in authors.scm.

    s7_pointer fmtstring = s7_car(args);

    if (! s7_is_string(fmtstring)) {
        s7_wrong_type_arg_error(sc, "parse-fmtstring**", 1, fmtstring, "a string");
    }

    s7_pointer result;
    struct fmtstring_extra_s S;
    yyscan_t scanner = parse_fmtstring_setup_string(&S, s7_string(fmtstring));

    int status = fmtstringparse(&S, &result, scanner);

    parse_fmtstring_finish(&S, scanner);

    return status == 0 ? result : s7_f(sc);
}

// parse-mdinline*: unlike the other parsing functions, this is not
// expected to be called from user scheme code (which should simply
// call parse-markdown-string): it's a helper for the markdown parser.
//
// Returns a list of paragraph elements.
s7_pointer parse_mdinline_string_proc(s7_scheme* sc, s7_pointer args)
{
    s7_pointer text = s7_car(args);
    s7_pointer metadata = s7_cadr(args);
    s7_pointer input_source = s7_caddr(args);
    s7_pointer linenumber = s7_cadddr(args);

    if (! s7_is_string(text)) {
        return s7_wrong_type_arg_error(sc, "parse-mdinline*", 1, text, "a string");
    }
    if (! s7_is_procedure(metadata)) {
        return s7_wrong_type_arg_error(sc, "parse-mdinline*", 2, metadata, "a procedure");
    }
    if (! s7_is_string(input_source)) {
        return s7_wrong_type_arg_error(sc, "parse-mdinline*", 3, linenumber, "a string");
    }
    if (! s7_is_number(linenumber)) {
        return s7_wrong_type_arg_error(sc, "parse-mdinline*", 4, linenumber, "a number");
    }

    s7_pointer result;
    struct mdinline_extra_s S;
    yyscan_t scanner = parse_mdinline_setup_string(&S,
                                                   s7_string(input_source),
                                                   s7_integer(linenumber),
                                                   s7_string(text));
    int status = mdinlineparse(&S, &result, metadata, scanner);
    parse_mdinline_finish(&S, scanner);

    if (status != 0) {
        scheme_eval("print-warning",
                    s7_make_string(sc, "inline-markdown error scanning paragraph before line ~a"),
                    linenumber, NULL);
        result = s7_list(sc, 1, text);
    }

    return result;
}

static s7_pointer parse_json_source_proc(s7_scheme* sc, s7_pointer args)
{
    // (parse-json-source** #t (or/c string? #f)) : parse from file
    // (parse-json-source** #f string?)           : parse string contents
    char is_file_p = s7_boolean(sc, s7_car(args));
    s7_pointer input = s7_cadr(args);
    // presume that the caller has checked types OK:
    // if IS_FILE_P is true, then INPUT is string or #f;
    // if false, then INPUT is a string

    const char* input_string;
    if (is_file_p && !s7_boolean(sc, input)) {
        input_string = NULL; // means stdin
    } else {
        input_string = s7_string(input);
    }
    // fprintf(stderr, "parse_json_source_proc: %s %s...\n", (is_file_p ? "file" : "string"), input_string);

    yyscan_t scanner;
    struct json_extra_s S;
    if (is_file_p) {
        scanner = parse_json_setup_file(&S, input_string);
    } else {
        scanner = parse_json_setup_string(&S, input_string);
    }

    if (scanner == NULL) {
        // warning or error?  #f or '()?
        scheme_eval("print-warning",
                    s7_make_string(sc, "parse-json-input*: can't open source ~a to read"),
                    input, NULL);
        return s7_f(sc);  // JUMP OUT
    }

    s7_pointer result = NULL;
    // fprintf(stderr, "parse_json_input_proc: entering...\n");
    int status = jsonparse(&S, &result, scanner);
    // fprintf(stderr, "parse_json_input_proc: %s <%s> -> status=%d\n",
    //         (is_file_p ? "file" : "string"), input_string, status);

    parse_json_finish(&S, scanner);

    if (status == 0) {
        return result;
    } else if (result == NULL) {
        // not sure what happened here
        return s7_cons(sc, s7_f(sc), s7_make_string(sc, "(unknown JSON parsing error!)"));
    } else {
        // the 'result' should be an error message
        return s7_cons(sc, s7_f(sc), result);
    }
}

// Hash a string into an unsigned 32-bit integer.
// This is an _unsophisticated_ hash function,
// merely using the K&R/Java hash function
//
// This isn't used in the main program, but it is used in doc/assemble.docs.scm
static s7_pointer string_to_hash_proc(s7_scheme* sc, s7_pointer args)
{
    s7_pointer str = s7_car(args);
    if (! s7_is_string(str)) {
        return s7_wrong_type_arg_error(sc, "string->hash", 1, str, "a string");
    }

    const unsigned char* s = (const unsigned char*)s7_string(str);
    const unsigned char* s_end = s + s7_string_length(str);
    uint32_t h = 0;
    for (const unsigned char* p = s; p < s_end; p++) {
        h = h * 31 + *p;
    }
    return s7_make_integer(sc, h);
}

#endif /* ALL_FUNCTIONS */

// implement subprocess
// I don't much like the way that (system ...) is implemented in s7,
// so here's a better way.
//
//     (subprocess cmd arg ...)
//
// cmd and args must be string?
//
// Normally, this returns the stdout of the command as a string.
//
// If the command fails (returns a non-zero exit status), then return
// #f, possibly also calling print-warning.
//
// If we fail to set up the subprocess (pipe fails, or the command
// isn't found), then raise an error tagged 'subprocess, with extra
// information containing the errno, or errno+128 if the exec fails.
//
// There is currently no implemented way of redirecting stdin.
static s7_pointer subprocess_proc(s7_scheme* sc, s7_pointer args)
{
    s7_pointer cmd = s7_car(args);
    if (! s7_is_string(cmd)) {
        // JUMP OUT
        return s7_wrong_type_arg_error(sc, "subprocess", 0, cmd, "a string");
    }
    const char* command_name = s7_string(cmd);

    s7_int nargs = s7_list_length(sc, args);
    const char** cargs = alloca((nargs+1) * sizeof(char*));
    for (int i=0; i<nargs; i++) {
        s7_pointer argn = s7_list_ref(sc, args, i);
        if (s7_is_string(argn)) {
            cargs[i] = s7_string(argn);
        } else {
            // JUMP OUT
            return s7_wrong_type_arg_error(sc, "subprocess", i, argn, "a string");
        }
    }
    cargs[nargs] = NULL;

    s7_pointer result;

    int filedes[2];             // [read-end, write-end]
    if (pipe(filedes) != 0) {
        s7_error(sc,
                 s7_make_symbol(sc, "subprocess"),
                 scheme_make_list(s7_make_string(sc, "error creating pipe (errno ~s)"),
                                  s7_make_integer(sc, errno),
                                  NULL));
        assert(0);              // s7_error doesn't return
    }

    pid_t child = fork();

    if (child < 0) {
        // error creating the process
        s7_error(sc,
                 s7_make_symbol(sc, "subprocess"),
                 scheme_make_list(s7_make_string(sc, "unable to create process for command ~a (errno ~s)"),
                                  cmd,
                                  s7_make_integer(sc, errno),
                                  NULL));
        assert(0);

    } else if (child == 0) {
        // in child
        close(filedes[0]);
        dup2(filedes[1], 1);

        if (command_name[0] == '/') {
            execv(command_name, (char*const*)cargs);
        } else {
            // find the command using the path
            execvp(command_name, (char*const*)cargs);
        }

        // failed to exec!
        exit(errno+128);

    } else {
        // in parent
        close(filedes[1]);

        char buf[BUFSIZ];
        int nread;
        s7_pointer rvals = s7_nil(sc);
        while ((nread = read(filedes[0], buf, BUFSIZ)) > 0) {
            s7_pointer s = s7_make_string_with_length(sc, buf, nread);
            rvals = s7_cons(sc, s, rvals);
        }
        close(filedes[0]);

        int status;
        wait(&status);

        if (WIFEXITED(status)) {
            if (WEXITSTATUS(status) == 0) {
                s7_int llen = s7_list_length(sc, rvals);
                if (llen == 0) {
                    result = s7_make_string(sc, "");
                } else if (llen == 1) {
                    result = s7_car(rvals);
                } else {
                    s7_pointer string_append = scheme_name_to_value("string-append");
                    result = s7_call(sc, string_append, s7_reverse(sc, rvals));
                }
            } else if (WEXITSTATUS(status) < 128) {
                scheme_eval("print-trace",
                            s7_make_string(sc, "subprocess: command ~a failed (exit status ~a)"),
                            args,
                            s7_make_integer(sc, WEXITSTATUS(status)), NULL);
                // not useful to show rvals, too?
                result = s7_f(sc);
            } else {
                s7_error(sc,
                         s7_make_symbol(sc, "subprocess"),
                         scheme_make_list(s7_make_string(sc, "unable to exec for command ~a (errno ~s)"),
                                          cmd,
                                          s7_make_integer(sc, WEXITSTATUS(status)-128),
                                          NULL));
                assert(0);
            }
        } else {
            s7_error(sc,
                     s7_make_symbol(sc, "subprocess"),
                     scheme_make_list(s7_make_string(sc, "process for command ~a exited abnormally (status ~x)"),
                                      cmd,
                                      s7_make_integer(sc, status),
                                      NULL));
            assert(0);
        }
    }

    return result;
}

static s7_pointer command_line_getopt_proc(s7_scheme* sc, s7_pointer scheme_args)
{
    opterr = 0;                 // suppress stderr warning of unexpected options
#if HAVE_DECL_OPTRESET
    // BSD getopt
    optind = 1;                 // reset (in case we're being called a second time)
    optreset  = 1;              // (ditto)
#else
    // GNU getopt
    optind = 0;
#endif

    s7_pointer optspec = s7_car(scheme_args);
    s7_pointer command_line = s7_cadr(scheme_args);
    char silent_opterr = s7_boolean(sc, s7_caddr(scheme_args));

    if (! s7_is_string(optspec)) {
        return s7_wrong_type_arg_error(sc, "getopt*", 1, optspec, "a string");
    }
    if (! s7_is_list(sc, command_line)) {
        return s7_wrong_type_arg_error(sc, "getopt*", 2, command_line, "a list of strings");
    }

    s7_int argc = s7_list_length(sc, command_line);
    char** argv = malloc(argc * sizeof(char*));
    if (argv == NULL) {
        error_exit("Can't allocate " S7INT_PRINTF " bytes for command-line in command_line_getopt",
                   argc * sizeof(char*));
    }

    // Assemble an argv list.
    // Note that getopt() wants an array of pointers to char*, not
    // 'const char*'; I'm not sure what it plans to do with the
    // strings, but it seems safest, therefore, to pass it an array of
    // pointers to copies.
    {
        s7_pointer cl = command_line;
        for (int i=0; i<argc; i++, cl=s7_cdr(cl)) {
            s7_pointer nextarg = s7_car(cl);
            if (! s7_is_string(nextarg)) {
                // since beastie sets *command-line* this shouldn't happen
                argv[i] = strdup("?");
            } else {
                argv[i] = strdup(s7_string(nextarg));
            }
        }
    }

#if 0
    printf("Command-line:\n");
    for (int i=0; i<argc; i++) {
        printf("  %d: %s\n", i, argv[i]);
    }
    printf("...with optspec %s\n", s7_string(optspec));
#endif

    int ch;
    s7_pointer option_list = s7_nil(sc);
    while ((ch = getopt(argc, argv, s7_string(optspec))) != -1) {
        if (ch == '?') {
            // unrecognised option
            s7_pointer ch_s = s7_make_character(sc, optopt);
            if (silent_opterr) {
                option_list = s7_cons(sc,
                                      s7_cons(sc, s7_make_character(sc, '?'), ch_s),
                                      option_list);
            } else {
                scheme_eval("print-warning",
                            s7_make_string(sc, "~s: unexpected option: -~a (ignored)"),
                            s7_car(command_line),
                            ch_s,
                            NULL);
            }

        } else {
            option_list = s7_cons(sc,
                                  s7_cons(sc,
                                          s7_make_character(sc, ch),
                                          s7_make_string(sc, optarg)),
                                  option_list);
        }
    }

    s7_pointer new_argv = s7_nil(sc);
    for (int i=optind; i<argc; i++) {
        new_argv = s7_cons(sc,
                           s7_make_string(sc, argv[i]),
                           new_argv);
    }

    for (int i=0; i<argc; i++) free(argv[i]);
    free(argv);

    return s7_cons(sc, option_list, s7_reverse(sc, new_argv));
}

// regular expression handling
struct re_s {
    s7_pointer pattern;
    regex_t re;
    regmatch_t* m;
    char empty_pattern_p;
};
typedef struct re_s* re_t;

static int re_type_tag = 0;

static int is_re_p(s7_pointer obj)
{
    return s7_is_c_object(obj)
        && s7_c_object_type(obj) == re_type_tag;
}

static s7_pointer is_re_proc(s7_scheme* sc, s7_pointer args)
{
    // args is of length 1
    return s7_make_boolean(sc, is_re_p(s7_car(args)));
}

static s7_pointer free_re_object(s7_scheme* sc, s7_pointer obj)
{
    // I think this will only be called when s7 knows that the object is indeed the right type
    re_t p = s7_c_object_value(obj);
    //fprintf(stderr, "GCing regexp \"%s\"\n", s7_string(p->pattern));
    if (p->m != NULL) {
        free(p->m);
        p->m = NULL;
    }
    // p->re will always be a compiled RE,
    // since the object won't be successfully created otherwise
    regfree(&p->re);
    free(p);

    return NULL;
}

static s7_pointer mark_re(s7_scheme *sc, s7_pointer obj)
{
    re_t p = (re_t)s7_c_object_value(obj);
    s7_mark(p->pattern);
    return NULL;
}

static s7_pointer re_to_string(s7_scheme *sc, s7_pointer args)
{
    re_t p = (re_t)s7_c_object_value(s7_car(args));

    const char* fmt = "<regexp:%s>";
    const size_t slen = s7_string_length(p->pattern) + strlen(fmt) + 1;
    char* s = alloca(slen);
    snprintf(s, slen, fmt, s7_string(p->pattern));
    return s7_make_string(sc, s);
}

#define H_make_re \
    "`(regexp \"pattern\" [flag ...])` : compile the pattern (extended RE syntax).\n" \
    "\n"                                                                \
    "Flags:\n"                                                          \
    "  * `'ignore-case` : the pattern is compiled\n"                    \
    "    so that it ignores case when matching.\n"                      \
    "  * `'no-substitute` : the pattern\n"                              \
    "    is compiled so that the matching functions will report only success/fail,\n" \
    "    and not record subexpressions (a mild optimisation, where appropriate).\n" \
    "  * `'newline` : use alternate newline processing, as described for\n" \
    "    the `REG_NEWLINE` flag in regcomp(3)."
static s7_pointer make_re_proc(s7_scheme *sc, s7_pointer args)
{
    // args is of length at least 1
    s7_pointer pattern = s7_car(args);
    // flags is a list of symbols adjusting how the pattern is compiled;
    // the only one currently defined is 'ignore-case
    s7_pointer rest = s7_cdr(args);

    if (! s7_is_string(pattern)) {
        return s7_wrong_type_arg_error(sc, "regexp", 1, pattern, "a string (pattern)");
    }

    re_t p = malloc(sizeof(struct re_s));
    if (p == NULL) {
        error_exit("Can't allocate memory for regexp!");
    }

    if (s7_string_length(pattern) == 0) {
        // Special case.
        //
        // This is the 'empty regexp', "".  The regcomp function doesn't regard
        // this as a valid regexp, and returns an error in this case.  But we
        // want to handle this, so we can split on empty regexps.  The
        // function will happily compile "()", so supply that instead.
        //
        // This means that we do end up with the compiled regexp
        // wanting to save a pattern.  I was tempted to hack this away
        // by adjusting re_nsub post-compilation, but that seems
        // fragile.  Instead, we flag this case, and special-case it
        // in re_match_positions, below.
        pattern = s7_make_string(sc, "()");
        p->empty_pattern_p = 1;
    } else {
        p->empty_pattern_p = 0;
    }

    int compile_flags = REG_EXTENDED;

    for (int flagn = 2; !s7_is_null(sc, rest); flagn++, rest=s7_cdr(rest)) {
        // The various regcomp() flags defined are:
        //
        // REG_EXTENDED
        //     Use Extended Regular Expressions.
        // REG_ICASE
        //     Ignore case in match (see XBD Regular Expressions).
        // REG_NOSUB
        //     Report only success/fail in regexec().
        // REG_NEWLINE
        //     Change the handling of <newline> characters
        s7_pointer flag1 = s7_car(rest);
        if (! s7_is_symbol(flag1)) {
            return s7_wrong_type_arg_error(sc, "regexp", flagn, flag1, "a symbol");
        }

        const char* flag1_string = s7_symbol_name(flag1);
        if (strcmp(flag1_string, "ignore-case") == 0) {
            compile_flags |= REG_ICASE;

        } else if (strcmp(flag1_string, "no-substitute") == 0) {
            compile_flags |= REG_NOSUB;

        } else if (strcmp(flag1_string, "newline") == 0) {
            compile_flags |= REG_NEWLINE;

        } else {
            scheme_eval("print-warning",
                        s7_make_string(sc, "regexp: compiling \"~a\": unrecognised flag symbol '~s (ignored)"),
                        pattern,
                        flag1,
                        NULL);
        }
    }

    p->pattern = pattern;

    s7_pointer result;
    int regcomp_status;
    if ((regcomp_status = regcomp(&p->re, s7_string(pattern), compile_flags)) == 0) {
        if (compile_flags & REG_NOSUB) {
            p->m = NULL;
        } else {
            //fprintf(stderr, "pattern \"%s\" has %zu submatches\n", s7_string(pattern), p->re.re_nsub);
            size_t nmatch = p->re.re_nsub + 1;
            p->m = malloc(nmatch * sizeof(regmatch_t));
            if (p->m == NULL) {
                error_exit("Can't allocate memory for %zu matches for re \"%s\"",
                           nmatch, s7_string(pattern));
            }
        }

        result = s7_make_c_object(sc, re_type_tag, (void*)p);

    } else {
        char buf[BUFSIZ];
        regerror(regcomp_status, &p->re, buf, BUFSIZ);
        scheme_eval("print-warning",
                    s7_make_string(sc, "Error compiling regexp pattern \"~a\": ~a"),
                    pattern,
                    s7_make_string(sc, buf),
                    NULL);
        free(p); p = NULL;
        result = s7_f(sc);

    }

    if (regcomp_status == 0) {
        assert(p->pattern != NULL);
        assert((compile_flags & REG_NOSUB) ? (p->m == NULL) : (p->m != NULL));
        assert(p->empty_pattern_p == 0 || p->empty_pattern_p == 1);
        assert(s7_boolean(sc, result));
    } else {
        assert(p == NULL);
        assert(! s7_boolean(sc, result));
    }

    return result;
}

static s7_pointer re_is_equal_proc(s7_scheme* sc, s7_pointer args)
{
    s7_pointer o1 = s7_car(args);
    s7_pointer o2 = s7_cadr(args);

    if (o1 == o2) return s7_t(sc);

    if (!s7_is_c_object(o2)
        || (s7_c_object_type(o2) != re_type_tag)) return s7_f(sc);

    re_t p1 = (re_t)s7_c_object_value(o1);
    re_t p2 = (re_t)s7_c_object_value(o2);
    return s7_make_boolean(sc, s7_is_equivalent(sc, p1->pattern, p2->pattern));
}

// Until revision 07d99b2a9127, this function supported an
// end-of-range parameter, to limit the part of the string scanned by
// the regexp (this was added only a few revisions before then).
// However that was done using a function regnexec, which extends
// POSIX and is standard on macOS, but seems not to be present in GNU
// libc.  I could work around that, but it would create configuration
// and code-path complications for a feature I actually never use.
#define H_re_match_positions                                            \
    "`(regexp-match** re s start flags)` : "                            \
    "to be called only internally.  "                                   \
    "Arguments\n"                                                       \
    "\n"                                                                \
    "   re     : a compiled re?\n"                                      \
    "   string : a string? to be matched\n"                             \
    "   start  : character number to start the match\n"                 \
    "   flags  : flags adjusting the way the search is done\n"          \
    "            (the only flags at present are 1 (ie, bit 1 set)\n"    \
    "            which avoids storing the matches,\n"                   \
    "            and 2, which returns strings rather than a\n"          \
    "            position pair)\n"                                      \
    "\n"                                                                \
    "Returns a list of cons pairs indicating the start and end\n"       \
    "characters of a match, where the first is the whole string\n"      \
    "which matches the regexp, and the successive ones correspond to\n" \
    "parenthesised matches in the regexp.\n"                            \
    "\n"                                                                \
    "If the regexp doesn't match, then return #f.\n"
static s7_pointer re_match_positions_proc(s7_scheme* sc, s7_pointer args)
{
    s7_pointer re_arg    = s7_car(args);
    s7_pointer s_arg     = s7_cadr(args);
    s7_pointer si_start  = s7_caddr(args);
    s7_pointer flags_arg = s7_cadddr(args);

    re_t re;
    const char* s;
    s7_int i_start = 0;
    s7_int flags = 0;

    if (is_re_p(re_arg)) {
        re = (re_t) s7_c_object_value(re_arg);
    } else {
        return s7_wrong_type_arg_error(sc, "regexp-match**", 1, re_arg, "a re? object");
    }
    if (s7_is_string(s_arg)) {
        s = s7_string(s_arg);
    } else {
        return s7_wrong_type_arg_error(sc, "regexp-match**", 2, s_arg, "a string?");
    }
    if (s7_is_integer(si_start)) {
        i_start = s7_integer(si_start);
        if (i_start < 0) {
            return return_beastie_error(sc, "regexp-match** \"%s\": start-index %lld is negative", s, i_start);
        } else if (i_start > s7_string_length(s_arg)) {
            //?or return_beastie_error(sc, "regexp-match** \"%s\": start-index %lld is beyond end of string", s, i_start);
            return s7_f(sc);
        }
    } else {
        return s7_wrong_type_arg_error(sc, "regexp-match**", 3, si_start, "a non-negative integer");
    }
    if (s7_is_integer(flags_arg)) {
        flags = s7_integer(flags_arg);
    } else {
        return s7_wrong_type_arg_error(sc, "regexp-match**", 4, flags_arg, "a non-negative integer");
    }

    char match_only_p = flags & 1;
    char return_strings_p = flags & 2;

    assert(i_start >= 0);

    s7_pointer result;
    if (i_start > s7_string_length(s_arg)) {
        // starting past the end of the string
        // (starting exactly at the end of the string is OK if the re
        // matches a zero length string)
        result = s7_f(sc);

    } else if (re->empty_pattern_p) {
        // special case this
        if (return_strings_p) {
            result = s7_list(sc, 1, s7_make_string(sc, ""));
        } else {
            result = s7_list(sc, 1, s7_cons(sc, si_start, si_start));
        }

    } else if (match_only_p || re->m == NULL) {
        // re->m is NULL if the regexp was compiled with REG_NOSUB
        if (regexec(&re->re, &s[i_start], 0, NULL, 0) == 0) {
            result = s7_t(sc);
        } else {
            result = s7_f(sc);
        }

    } else {
        assert(re->m != NULL);
        if (regexec(&re->re, &s[i_start], re->re.re_nsub + 1, re->m, 0) == 0) {
            result = s7_nil(sc);
            // re->m is re->re.re_nsub+1 items long
            for (int mi=re->re.re_nsub; mi>=0; mi--) {
                // Fields .rm_so and rm_eo are offsets from s[i_start],
                // so add that back in _unless_ there was no match,
                // in which case we must leave these as -1
                int so = re->m[mi].rm_so;
                if (so >= 0) so += i_start;

                int eo = re->m[mi].rm_eo;
                if (eo >= 0) eo += i_start;

                // fprintf(stderr, "  (" S7INT_PRINTF "," S7INT_PRINTF ") -> (%d,%d)\n",
                //         re->m[mi].rm_so, re->m[mi].rm_eo, so, eo);
                if (so < 0) {
                    // a subexpression which didn't participate in the match
                    result = s7_cons(sc, s7_f(sc), result);
                } else if (return_strings_p) {
                    result = s7_cons(sc,
                                     s7_make_string_with_length(sc, &s[so], eo-so),
                                     result);
                } else {
                    result = s7_cons(sc,
                                     s7_cons(sc,
                                             s7_make_integer(sc, so),
                                             s7_make_integer(sc, eo)),
                                     result);
                }
            }
        } else {
            result = s7_f(sc);
        }
    }

    return result;
}

void define_re_functions(s7_scheme* sc)
{
    re_type_tag = s7_make_c_type(sc, "re");
    s7_c_type_set_gc_free(sc, re_type_tag, free_re_object);
    s7_c_type_set_gc_mark(sc, re_type_tag, mark_re);
    s7_c_type_set_is_equal(sc, re_type_tag, re_is_equal_proc);
    s7_c_type_set_to_string(sc, re_type_tag, re_to_string);

    s7_define_function(sc,
                       "regexp?",
                       is_re_proc,
                       1, 0, false,
                       "`(regexp? x)` : return `#t` if X is a regular expression");
    s7_define_function(sc,
                       "regexp",
                       make_re_proc,
                       1, 0, true,
                       H_make_re);
    s7_define_function(sc,
                       "regexp=?",
                       re_is_equal_proc,
                       2, 0, false,
                       "(regexp=? re1 re2) : return #t if the two REs match the same pattern.");
    s7_define_function(sc,
                       "regexp-match**",
                       re_match_positions_proc,
                       4, 0, false,
                       H_re_match_positions);
}

// various filesystem things
static s7_pointer get_current_directory_proc(s7_scheme* sc, s7_pointer args)
{
    char* buf = alloca(MAXPATHLEN);
    return s7_make_string(sc, getcwd(buf, MAXPATHLEN));
}

static s7_pointer setenv_proc(s7_scheme* sc, s7_pointer args)
{
    s7_pointer env_name = s7_car(args);
    s7_pointer value = s7_cadr(args);
    if (! s7_is_string(env_name)) {
        return s7_wrong_type_arg_error(sc, "setenv", 1, env_name, "a string");
    }

    if (s7_is_string(value)) {
        setenv(s7_string(env_name), s7_string(value), 1);
    } else if (! s7_boolean(sc, value)) {
        // value is #f
        unsetenv(s7_string(env_name));
    } else {
        return s7_wrong_type_arg_error(sc, "setenv", 2, value, "a string or #f");
    }

    return s7_f(sc);
}

static s7_pointer symbol_lt_proc(s7_scheme* sc, s7_pointer args)
{
    // (symbol<?) trivially evaluates to #t.
    // (symbol<? 'foo) does, too, but if we jump out here
    // we can't catch error (symbol<? 1)
    if (s7_list_length(sc, args) == 0) return s7_t(sc);

    int idx = 1;
    const char* a1 = NULL;
    for (s7_pointer a = args; !s7_is_null(sc, a); a=s7_cdr(a), idx++) {
        s7_pointer sym = s7_car(a);
        if (!s7_is_symbol(sym)) {
            return s7_wrong_type_arg_error(sc, "symbol<?", idx, sym, "a symbol");
        }
        const char* a2 = s7_symbol_name(sym);
        if (a1 && strcmp(a1, a2) >= 0) return s7_f(sc);
        a1 = a2;
    }
    return s7_t(sc);
}

// ctype functions
// The list of ctype functions is those included in ISO-9899-2018, Sect 7.4.1
#define UNIPROP_PROC(c_func) uniprop_ ## c_func ## _proc
#define MAKE_UNIPROP_FUNCTION(c_func, scm_func) \
    MAKE_CHAR_FUNCTION(UNIPROP_PROC(c_func), UNIPROP_FUNC(c_func), scm_func)
#define MAKE_CHAR_FUNCTION(c_proc, c_func, scm_func)                     \
    static s7_pointer c_proc(s7_scheme* sc, s7_pointer args)  \
    {                                                                   \
        s7_pointer c = s7_car(args);                                    \
        s7_int ci;                                                      \
        if (s7_is_character(c)) {                                       \
            ci = s7_character(c);                                       \
        } else if (s7_is_integer(c)) {                                  \
            ci = s7_integer(c);                                         \
        } else {                                                        \
            return s7_f(sc); \
        }                                                               \
        return s7_make_boolean(sc, c_func(ci));           \
    }

#if HAVE_ICU
#define WRAPDOC(doc) doc
#else
#define WRAPDOC(doc) doc " (BMP only)"
#endif

// this is used in the list of delayed functions below
#define DEFINE_UNIPROP_FUNCTION(c_func, scm_func, doc) \
    DEFINE_CHAR_FUNCTION(UNIPROP_PROC(c_func), scm_func, WRAPDOC(doc))
#define DEFINE_CHAR_FUNCTION(c_func, scm_func, doc) \
    { scm_func,                                 \
      c_func,                                   \
      1, 0, false,                              \
      WRAPDOC("Return #t if the argument is character or integer, and is " doc ", and #f otherwise") }

#if ALL_FUNCTIONS

MAKE_UNIPROP_FUNCTION(alnum_p, "char-alnum?");
MAKE_UNIPROP_FUNCTION(letter_p, "char-alpha?");
MAKE_UNIPROP_FUNCTION(uppercase_letter_p, "char-upper?");
MAKE_UNIPROP_FUNCTION(lowercase_letter_p, "char-lower?");
// MAKE_UNIPROP_FUNCTION(other_letter_p, "char-other-letter?");

MAKE_UNIPROP_FUNCTION(number_p, "char-digit?");
MAKE_UNIPROP_FUNCTION(space_p, "char-space?");
MAKE_UNIPROP_FUNCTION(whitespace_p, "char-wordbreak?");
MAKE_UNIPROP_FUNCTION(nonbreakingspace_p, "char-nbsp?");
MAKE_UNIPROP_FUNCTION(punctuation_p, "char-punct?");
MAKE_UNIPROP_FUNCTION(cntrl_p, "char-space?");

// the following have no ctype analogues
MAKE_UNIPROP_FUNCTION(symbol_p, "char-symbol?");
MAKE_UNIPROP_FUNCTION(mark_p, "char-mark?");
MAKE_UNIPROP_FUNCTION(alphabetic_p, "uchar-alphabetic?");
MAKE_UNIPROP_FUNCTION(wordcharacter_p, "uchar-word-character?");

// the following don't have Unicode cases
MAKE_CHAR_FUNCTION(isblank_proc, isblank, "char-blank?");
MAKE_CHAR_FUNCTION(isgraph_proc, isgraph, "char-graph?");
MAKE_CHAR_FUNCTION(isprint_proc, isprint, "char-print?");
MAKE_CHAR_FUNCTION(isxdigit_proc, isxdigit, "char-xdigit?");

// The mycu_*case_character functions return 0 if the character has no
// corresponding mapping.  Here, return the original character in that case.
#define MAKE_CASECHANGE_FUNCTION(c_func)                                \
    static s7_pointer UNIPROP_PROC(c_func)(s7_scheme* sc, s7_pointer args) \
    {                                                                   \
        s7_pointer c = s7_car(args);                                    \
        s7_int ci;                                                      \
        if (s7_is_character(c)) {                                       \
            ci = s7_character(c);                                       \
        } else if (s7_is_integer(c)) {                                  \
            ci = s7_integer(c);                                         \
        } else {                                                        \
            return c;                                                   \
        }                                                               \
        s7_int newc = UNIPROP_FUNC(c_func)(ci);                         \
        return s7_make_integer(sc, (newc == 0 ? ci : newc));            \
    }
MAKE_CASECHANGE_FUNCTION(uppercase_character);
MAKE_CASECHANGE_FUNCTION(lowercase_character);
MAKE_CASECHANGE_FUNCTION(titlecase_character);

#define DEFINE_CASECHANGE_FUNCTION(c_func, scm_func, doc) \
    { scm_func,                                           \
      UNIPROP_PROC(c_func),                               \
      1, 0, false,                                        \
      WRAPDOC(doc) }


static s7_pointer load_builtin_module_by_name(s7_scheme* sc, s7_pointer args)
{
    s7_pointer module_name = s7_car(args);
    s7_pointer target_env = s7_cadr(args);
    // this is an internal-only function

    if (! s7_is_symbol(module_name)) {
        return s7_wrong_type_arg_error(sc, "load-builtin-module/name*", 1, module_name, "a symbol");
    }
    if (! s7_is_let(target_env)) {
        return s7_wrong_type_arg_error(sc, "load-builtin-module/name*", 2, target_env, "a let");
    }

    const char* module_name_c = s7_symbol_name(module_name);
    size_t module_content_len;
    const char* module_content = get_module_content(module_name_c, &module_content_len);

    // fprintf(stderr, "module_content[%lu] = <%.40s...%d>\n", module_content_len, module_content,
    //         module_content[module_content_len]);
    if (module_content) {
        s7_load_c_string_with_environment(sc,
                                          module_content, module_content_len,
                                          target_env);
        return target_env;
    } else {
        return s7_f(sc);
    }
};
#endif /* ALL_FUNCTIONS */

struct delayed_functions_s {
    const char *name;
    s7_function fnc;
    s7_int required_args;
    s7_int optional_args;
    bool rest_arg;
    const char *doc;
} delayed_functions[] = {
    // These aren't in any particular order -- we work through them with a linear search.

#if ALL_FUNCTIONS

    { "parse-author-list**",
      parse_authorlist_proc,
      2, 0, false,
      "(parse-author-list** author-string #f) : "
      "The AUTHOR-STRING is the BibTeX-style author list to be parsed. "
      "The LOCATION is intended to be a string with an indication of location, "
      "for error messages, but this is currently unimplmented, "
      "and must be passed as #f." },

    { "parse-aux-source**",
      parse_aux_source_proc,
      2, 0, false,
      "(parse-aux-source** file? source) : "
      "if FILE?, then SOURCE is a filename or #f (indicating stdin); "
      "if (not FILE?) then SOURCE is a string to be parsed." },

    { "parse-bst-source**",
      parse_bst_source_proc,
      2, 0, false,
      "(parse-bst-source** file? source) : "
      "if FILE?, then SOURCE is a filename or #f (indicating stdin); "
      "if (not FILE?) then SOURCE is a string to be parsed." },

    { "parse-fmtstring**",
      parse_fmtstring_proc,
      1, 0, false,
      "(parse-fmtstring* str) : Parse the BibTeX format string, for format-names" },

    { "parse-markdown-source/metadata**",
      parse_markdown_source_proc,
      3, 0, false,
      "(parse-markdown-source/metadata** file? accumulator source) : "
      "if FILE?, then SOURCE is a filename or #f (indicating stdin); "
      "if (not FILE?) then it is a string to be parsed. "
      "In both cases, parse the input, returning the parse tree, "
      "and putting metadata into the accumulator." },

    { "parse-mdinline**",
      parse_mdinline_string_proc,
      4, 0, false,
      "(parse-mdinline** str metadata source lineno) : "
      "Parse the given inline .md content; return an xexpr." },

    { "parse-json-source**",
      parse_json_source_proc,
      2, 0, false,
      "(parse-json-source** file? source) : "
      "if FILE?, then SOURCE is a filename or #f (indicating stdin); "
      "if (not FILE?) then SOURCE is a string to be parsed." },

#endif /* ALL_FUNCTIONS */

    // The Unicode functions are defined in unicode-scm.c

    // the first lot should be available in the ALL_FUNCTIONS=0 case
    // (ie, within beastie0, because they're used in readermacros.scm)
    { "make-ustring",
      make_ustring_proc,
      0, 0, true,
      "`(make-ustring [codepoint/string/ustring ...])` :\n"
      "make a ustring, optionally adding content.\n\n"
      "The list of arguments is the same as that for ustring-append, qv." },
    { "ustring?",
      is_ustring_proc,
      1, 0, false,
      "`(ustring? x)` : return `#t` if x is a ustring" },
    { "unicode-decode1/port/utf8",
      unicode_decode1_port_utf8_proc,
      0, 1, false,
      "`(unicode-decode1/port/utf8 [p])` : "
      "decode a single unicode character from the input port,\n"
      "which should be UTF-8 encoded.\n"
      "If no argument is supplied, it defaults to `(current-input-port)`.\n"
      "This function isn't (currently) particularly robust against malformed UTF-8 input.\n"
      "It shouldn't collapse, but may skip characters when recovering.\n\n"
      "Returns the next codepoint from the input, or `#<eof>`;\n"
      "returns Unicode replacement character on malformed input." },
    { "ustring-append!",
      ustring_append_inplace_proc,
      1, 0, true,
      "`(ustring-append! ustring char|codepoint|... ...)` :\n"
      "append the arguments to the ustring.\n"
      "The replacement happens in place – the initial `ustring` argument is modified\n"
      "(cf ustring-append).\n"
      "The list of possible argument types is the same as for `ustring-append`."},

#if ALL_FUNCTIONS
    { "unicode-reader?",
      is_unicode_reader_proc,
      1, 0, false,
      "`(unicode-reader? x)` : return `#t` if x is a unicode-reader" },
    { "make-unicode-reader/file*",
      make_unicode_reader_file_proc,
      2, 0, false,
      "`(make-unicode-reader/file* fn ascii-characters?)` :\n"
      "make a unicode reader from a file FN.\n"
      "If ASCII-CHARACTERS? is true, then the reader will return codepoints\n"
      "below 0x80 as characters rather than integers\n"
      "(this is sometimes convenient for debugging, but is unnecessary\n"
      "in general use)." },
    { "make-unicode-reader/string*",
      make_unicode_reader_string_proc,
      2, 0, false,
      "`(make-unicode-reader/string* str ascii-characters?)` :\n"
      "make a unicode reader from a string, STR.\n"
      "If ASCII-CHARACTERS? is true, then the reader will return codepoints\n"
      "below 0x80 as characters rather than integers." },
    { "unicode-reader-read",
      unicode_reader_read_proc,
      1, 0, false,
      "`(unicode-reader-read unicode-reader)` : "
      "return a single codepoint from the stream.\n"
      "Returns `#<eof>` at the end of the stream.\n\n"
      "The unicode-reader object can also be called directly,\n"
      "as a no-argument function, to return the codepoint,\n"
      "and it can be called with argument `'location` to give the current\n"
      "location, as an alternative to `unicode-reader-location`." },
    { "unicode-decode/utf8",
      unicode_decode_utf8_proc,
      1, 0, false,
      "`(unicode-decode/utf8 s)` : "
      "decode the UTF8 string\n"
      "(an s7 string, regarded as a sequence of bytes encoded in UTF-8)\n"
      "into a ustring" },
    { "unicode-encode/utf8",
      unicode_encode_utf8_proc,
      1, 0, false,
      "`(unicode-encode/utf8 l)` : "
      "given a list or iterator of Unicode codepoints, convert it to a UTF8 string\n"
      "(an s7 string, regarded as a sequence of bytes)"},
    { "unicode-encode1/utf8",
      unicode_encode1_utf8_proc,
      1, 0, false,
      "`(unicode-encode1/utf8 i)` : "
      "given a single character or integer, convert it to a UTF8 string\n"
      "(an s7 string, regarded as a sequence of bytes)" },
    { "unicode-reader-source",
      unicode_reader_source_proc,
      1, 0, false,
      "`(unicode-reader-source rdr)` :\n"
      "show the source from which the reader draws its content,\n"
      "either as a filename, or as a \"string\", enclosed in quotes.\n"
      "The output is intended to be printable."},
    { "unicode-reader-location",
      unicode_reader_location_proc,
      1, 0, false,
      "`(unicode-reader-location rdr)` :\n"
      "show the current location within the reader's source." },
    { "ustring-length",
      ustring_length_proc,
      1, 0, false,
      "`(ustring-length us)` : return the number of characters (ie, codepoints) in the ustring" },
    { "ustring=?",
      ustring_is_equal_proc,
      2, 0, true,
      "`(ustring=? s1 s2 [flags...])` : "
      "return true if the two arguments are ustrings or strings, and equal.\n"
      "Arguments of type `string?` are converted to `ustring?` before comparison.\n\n"
#if HAVE_ICU
      "There are no flags defined at present."
#else
      "If the flag `:collapse-replacements` is present, then sequences of\n"
      "unicode replacement characters, U+fffd, will compare equal even if\n"
      "they contain different numbers of these characters."
#endif
    },
    { "ustring->hash",
      ustring_hash_proc,
      1, 0, false,
      "`(ustring->hash u)` : return a hash integer for the ustring"
    },
    { "ustring-cache-object-get*",
      ustring_cache_object_get_proc,
      1, 0, false,
      "`(ustring-cache-object-get* us)` : retrieve the cache-object for the ustring.\n"
      "The procedure evaluates to the stored object, or `#f` if nothing has been stored." },
    { "ustring-cache-object-set!*",
      ustring_cache_object_set_proc,
      2, 0, false,
      "`(ustring-cache-object-set!* us obj)` : store the cache-object for the ustring.\n"
      "The procedure will store any object as the cache-object:\n"
      "it is up to the caller to add key-value semantics.\n"
      "The procedure evaluates to the newly-stored cache-object."},
    { "string->hash",
      string_to_hash_proc,
      1, 0, false,
      "`string->hash : string? -> integer?` : Given a string, return an integer hash for it. "
      "This is an _unsophisticated_ hash function, "
      "merely using the K&R/Java hash function" },
    { "ustring<?",
      ustring_lt_proc,
      2, 0, false,
      "`(ustring<? u1 u2)` : return `#t` if both arguments are of type `ustring?`,\n"
      "and `u1` should be ordered before `u2`.\n\n"
#if HAVE_ICU
      "This is sensitive to the current locale/language."
#else
      "Note: this is _not_ a Unicode-sensitive ordering."
#endif
    },
    { "unicode-set-locale!",
      unicode_set_locale_proc,
      1, 0, false,
      "`(unicode-set-locale! \"locale\")` :\n"
      "set the preferred locale for string comparisons.\n"
#if HAVE_ICU
      "Passing a locale of `#f` resets this to the default.\n"
      "If the environment variable `$BEASTIE_LOCALE` is set,\n"
      "then that is the initially preferred value.\n"
      "Returns the name of the previously-set locale,\n"
      "or `#f` if the locale initialisation isn't aligned with a locale\n"
      "(for example if it is based on (default) rules)."
#else
      "(This version of beastie is built without access to ICU, so this is a no-op)."
#endif
    },
    { "unicode-get-locale",
      unicode_get_locale_proc,
      0, 2, false,
      "`(unicode-get-locale [locale-name] [info])` : get information about the given locale.\n\n"
      "With no arguments, returns an alist for the currently preferred locale.\n"
      "With one locale (string) argument, returns an alist of keys and values\n"
      "describing the locale.\n"
      "With two arguments, returns the (symbol) key information about the\n"
      "(string) locale, returning `#f` if the information is not available.\n"
      "\n"
      "If the locale is given as `#f`, rather than a string,\n"
      "this is equivalent to the no-args case.\n"
      "\n"
      "There is more information about Unicode locales in the\n"
      "[ICU user guide](https://unicode-org.github.io/icu/userguide/locale/)."
#if !HAVE_ICU
      "\n(This version of beastie is built without access to ICU,\n"
      "so returns `()`, `()` or `#f` in the three cases)."
#endif
    },
    { "unicode-get-locales",
      unicode_get_locale_list_proc,
      0, 0, false,
      "`(unicode-get-locales)` : return a list of the available locales.\n"
#if !HAVE_ICU
      "(This version of beastie is built without access to ICU,\n"
      "so returns `()`)."
#endif
    },
    { "ustring-append",
      ustring_append_new_proc,
      1, 0, true,
      "`(ustring-append character|codepoint|string|ustring|list ...)` :\n"
      "append the arguments to the ustring.\n"
      "The procedure can take characters, codepoints, strings, ustrings,\n"
      "or a list of these.\n"
      "The result is a new ustring (cf ustring-append!)." },
    { "ustring-car",
      ustring_car_proc,
      1, 0, false,
      "`(ustring-car us)` : return the first codepoint in the string, as an integer."},
    { "ustring-ref",
      ustring_ref_proc,
      2, 0, false,
      "`(ustring-ref ustring idx)` : return the codepoint (as an integer) at index `idx` (zero offset).\n"
      "Throws an `out-of-range` error if appropriate."},
    { "ustring-substring",
      ustring_substring_proc,
      2, 3, false,
      "`(ustring-substring ustring start [end])` : return a copy of a substring of `ustring`,\n"
      "starting at index `start` and not including index `end`.\n"
      "Both `start` and `end` are zero-offset indexes of codepoints within the string.\n"
      "If `end` is absent or `#f`, then copy to the end of the string.\n" },
    { "ustring-index*",
      ustring_index_proc,
      4, 0, false,
      "`(ustring-index* us cp start end)` : return the index of the ustring `us`,\n"
      "between `start` and `end`,\n"
      "where integer `cp` appears (see `ustring-index`)." },
    { "ustring->string",
      ustring_to_string_proc,
      1, 1, false,
      "`(ustring->string ustr [:display/:write/:readable/#t/#f])` \n"
      ": returns the ustring `str` converted to a (normal) UTF-8 string.\n"
      "If the second argument is `:display` or `#f`, then the string is suitable for display\n"
      "rather than for subsequent reading; otherwise, it is in a form which can be\n"
      "re-read to produce an equivalent object."},
    { "ustring->symbol",
      ustring_to_symbol_proc,
      1, 0, false,
      "`(ustring->symbol ustr)` : returns the ustring `str` converted to a symbol." },
    { "symbol->ustring",
      symbol_to_ustring_proc,
      1, 0, false,
      "`(symbol->ustring sym)` : returns the symbol `sym` converted to a new ustring" },
    { "ustring-map-internal*",
      ustring_map_internal_proc,
      2, 0, false,
      "`(ustring-map-internal* ustring sym)` : map a ustring with an internal function (internal use only)."},

    // { "make-ustring-iterator*",
    //   make_ustring_iterator_proc,
    //   1, 0, false,
    //   "`(make-ustring-iterator* ustring?)` : make a ustring iterator (internal only)" },

    { "unicode-load-hook*",
      unicode_load_hook,
      3, 0, false,
      "Defines unicode C-implemented functions (internal only!)" },

    // see mdblock-parse.lex
    { "mdblock-load-hook*",
      mdblock_load_hook,
      3, 0, false,
      "Define mdblock C-implemented functions (internal only!)" },

    // see lex-bib2.c
    { "make-biblex*",
      make_biblex_proc,
      1, 0, false,
      "`(make-biblex* unicode-reader?)` :create a lexer for .bib files, reading from the given reader" },
    { "biblex?",
      is_biblex_proc,
      1, 0, false,
      "`(biblex? x)` : return `#t` if `x` is a .bib file lexer"},
    { "biblex-load-hook*",
      // this also defines make-biblex/file* and make-biblex/string*
      biblex_load_hook,
      3, 0, false,
      "Define biblex C-implemented functions (internal only!)" },

#endif /* ALL_FUNCTIONS */

    { "getopt*",
      command_line_getopt_proc,
      3, 0, false,
      // don't document the command-line keyword argument -- used for testing
      "(getopt* optspec command-line silent-opterr) : "
      "a helper function for the (getopt ... ) macro.\n"
      "Parse the list of strings in the command-line using the\n"
      "given option-specification (see getopt(3)).  "
      "The result is a list (unspecified order) where the car is an alist of\n"
      "`(#\\optchar . argument)`, and the cdr is the non-option arguments;\n"
      "if an option takes no argument, the 'argument' is unspecified.\n"
      "Unexpected options are reported on stderr, unless `silent-opterr` non-#f,\n"
      "in which case they are returned as `(#\\? . #\\optchar)`" },

    { "subprocess",
      subprocess_proc,
      1, 0, true,
      "`subprocess : string? ... -> (or string? #f)`"
      "(subprocess \"program\" ...) : "
      "Call the first argument, as a command, "
      "passing the others as arguments.  Returns stdout as a string, "
      "or #f if the command returns non-zero, or raise 'subprocess if the command can't be run. "
      "\n\n"
      "If the PROGRAM doesn't start with a slash, '/', it is looked up in the path." },

    { "current-directory",
      get_current_directory_proc,
      0, 0, false,
      "`(current-directory)` : return the current working directory, as a string." },

    { "setenv",
      setenv_proc,
      2, 0, false,
      "`(setenv envvar (or/c string? #f))` :\n"
      "set the environment variable `envvar` to the given value.\n"
      "If the value is `#f`, the environment variable is deleted."},

    { "symbol<?",
      symbol_lt_proc,
      0, 0, true,
      "`symbol<? : symbol? ... -> boolean?` : "
      "true if the symbols `s1`... are strictly ordered.  "
      "The comparison is equivalent to that which would arise from using `symbol->string`." },

#if ALL_FUNCTIONS
    // for this macro, see above
    DEFINE_UNIPROP_FUNCTION(alnum_p,
                         "char-alnum?",
                         "alphanumeric (Unicode L or N)"),
    DEFINE_UNIPROP_FUNCTION(letter_p,
                         "char-alpha?",
                         "alphabetic (Unicode L)"),
    DEFINE_UNIPROP_FUNCTION(uppercase_letter_p,
                         "char-upper?",
                         "upper-case alphabetic (Unicode Lu or Lt)"),
    DEFINE_UNIPROP_FUNCTION(lowercase_letter_p,
                         "char-lower?",
                         "lower-case alphabetic (Unicode Ll)"),
    // DEFINE_UNIPROP_FUNCTION(other_letter_p,
    //                      "char-other-letter?",
    //                      "other alphabetic letter (Unicode L other than Lu, Lt or Ll; BMP only)"),
    DEFINE_UNIPROP_FUNCTION(number_p,
                         "char-digit?",
                         "a digit (Unicode N)"),
    DEFINE_UNIPROP_FUNCTION(space_p,
                            "char-space?",
                            "a space (Unicode Z, but including the ASCII whitespace\n"
                            "characters below U+20)."
#if HAVE_ICU
                            "\n\nThere is more than one reasonable definition of whitespace.\n"
                            "The whitespace characters below U+20, such as newline and tab,\n"
                            "are _not_ whitespace in Unicode terms, but we include them here\n"
                            "in order to match POSIX/ctype isspace; this also includes\n"
                            "non-breaking spaces as whitespace\n"
                            "(though, eg, Java's whitespace definition doesn't)."
#endif
                            ),
    DEFINE_UNIPROP_FUNCTION(whitespace_p,
                            "char-wordbreak?",
                            "true if the specified code point is a whitespace character\n"
                            "according to Java/ICU.\n\n"
                            "This is similar to `char-space?`, except that it does\n"
                            "_not_ include the non-breaking space codepoints\n"
                            "(U+00A0 NBSP, or U+2007 Figure Space or U+202F Narrow NBSP).\n"
                            "It is therefore defined to match the Java\n"
                            "`Character.isWhitespace` function;\n"
                            "See [Unicode ICU docs u_isWhitespace function](https://unicode-org.github.io/icu-docs/apidoc/dev/icu4c/uchar_8h.html)\n"
                            "for further discussion."),
    DEFINE_UNIPROP_FUNCTION(nonbreakingspace_p,
                            "char-nbsp?",
                            "true if the specified codepoint is a non-breaking space,\n"
                            "and specifically whether it is\n"
                            "U+00A0 NBSP, or U+2007 Figure Space or U+202F Narrow NBSP.\n"
                            "Compare `char-wordbreak?`."),
    DEFINE_UNIPROP_FUNCTION(punctuation_p,
                         "char-punct?",
                         "punctuation (Unicode P)"),
    DEFINE_UNIPROP_FUNCTION(cntrl_p,
                         "char-cntrl?",
                         "control (ctype iscntrl, plus Unicode Cc & Cf)"),
    // the following two have no ctype analogues
    DEFINE_UNIPROP_FUNCTION(symbol_p,
                         "char-symbol?",
                         "symbol (Unicode S)"),
    DEFINE_UNIPROP_FUNCTION(mark_p,
                         "char-mark?",
                         "mark (Unicode M)"),
    { "uchar-alphabetic?",
      UNIPROP_PROC(alphabetic_p),
      1, 0, false,
      "Returns `#t` if the character has the Unicode ‘Alphabetic’ property.\n"
      "That is, it is lowercase, uppercase, of classes  Lt, Lm, Lo, or Nl,\n"
      "or is ‘other alphabetic’.  See the Unicode Character Database for details.\n"
      "\n"
      "The induced set of characters is a superset of that induced by `char-letter?`.\n"
      "This function is also distinct from the s7 `char-alphabetic?` function,\n"
      "which is defined only for ASCII characters\n"
      "(but it overlaps with that function in that range).\n"
    },
    { "uchar-word-character?",
      // There is a general discussion of the question of what should and
      // shouldn't be included as a 'word character' in a 2018
      // thread on the Unicode mailing list.  See before and after the
      // message at https://www.unicode.org/mail-arch/unicode-ml/y2018-m05/0104.html
      // and specifically
      // https://www.unicode.org/mail-arch/unicode-ml/y2018-m05/0117.html
      UNIPROP_PROC(wordcharacter_p),
      1, 0, false,
      "Returns `#t` if the character argument should be regarded as a part of a word.\n"
      "The induced character set includes `uchar-alphabetic?` (and thus `char-alpha?`),\n"
      "but includes (the Unicode categories)\n"
      "diacritics, extender characters and join-control characters.\n"
      "\n"
      "There isn't a formal definition of this set within Unicode,\n"
      "but this set has been\n"
      "[described](https://www.unicode.org/mail-arch/unicode-ml/y2018-m05/0117.html)\n"
      "as ‘a decent approximation of what is (naively) expected to fall\n"
      "within an “alphabetic” string for most scripts’." },

    DEFINE_CHAR_FUNCTION(isblank_proc,  "char-blank?",  "blank (in terms of ctype.h)"),
    DEFINE_CHAR_FUNCTION(isgraph_proc,  "char-graph?",  "graphic (in terms of ctype.h)"),
    DEFINE_CHAR_FUNCTION(isprint_proc,  "char-print?",  "printing (in terms of ctype.h)"),
    DEFINE_CHAR_FUNCTION(isxdigit_proc, "char-xdigit?", "a hex-digit (in terms of ctype.h)"),

    DEFINE_CASECHANGE_FUNCTION(uppercase_character,
                               "uchar-upcase",
                               "`(uchar-upcase c)` : \n"
                               "change the given character to uppercase.\n\n"
#if HAVE_ICU
                               "This matches `char-upcase` for ASCII characters,\n"
                               "but it also works correctly for other Unicode characters.\n"
#else
                               "This matches `char-upcase` for ASCII characters,\n"
                               "but it also works correctly for the majority of cases\n"
                               "within the Unicode BMP (there are number of Unicode\n"
                               "edge-cases which we evade at present).\n"
                               "\n"
#endif
                               "The function accepts either\n"
                               "a character or an integer argument,\n"
                               "and returns an integer.\n"
                               "If given an argument of another type,\n"
                               "including string types,\n"
                               "it returns the argument unchanged."),
    DEFINE_CASECHANGE_FUNCTION(lowercase_character,
                               "uchar-downcase",
                               "Change the given character to lowercase.\n"
                               "Analogous to `uchar-upcase`, qv."),
    DEFINE_CASECHANGE_FUNCTION(titlecase_character,
                               "uchar-titlecase",
                               "Change the given character to titlecase.\n"
                               "Analogous to `uchar-upcase`, qv."),

#endif /* ALL_FUNCTIONS */
};
size_t delayed_functions_len = sizeof(delayed_functions)/sizeof(delayed_functions[0]);

static s7_pointer delayed_define_function_into_env(s7_scheme* sc, s7_pointer args)
{
    s7_pointer function_name = s7_car(args);
    s7_pointer env = s7_cadr(args);
    if (! s7_is_symbol(function_name)) {
        s7_wrong_type_arg_error(sc, "define-function/delayed/env*",
                                1, function_name, "a symbol");
    }
    if (! s7_is_let(env)) {
        s7_wrong_type_arg_error(sc, "define-function/delayed/env*",
                                2, env, "a let");
    }
    const char* required_name = s7_symbol_name(function_name);

    for (int i=0; i<delayed_functions_len; i++) {
        if (strcmp(required_name, delayed_functions[i].name) == 0) {
#if ALL_FUNCTIONS
            scheme_eval("print-info",
                        s7_make_string(sc, "found delayed function ~a"),
                        s7_make_string(sc, delayed_functions[i].name),
                        NULL);
#endif
            s7_pointer f = s7_make_function(sc,
                                            delayed_functions[i].name,
                                            delayed_functions[i].fnc,
                                            delayed_functions[i].required_args,
                                            delayed_functions[i].optional_args,
                                            delayed_functions[i].rest_arg,
                                            delayed_functions[i].doc);

            // Between s7 2026-04 and 2026-07, lets created by let-ref became immutable,
            // so we can't call s7_varlet on a binding that already exists.
            // We could call s7_let_set, but it seems easier to simply log
            // the collision and move on.
            // The place where this occurred was in parse-bib2.scm,
            // which both requires and provides make-biblex*, which
            // results in that function being added twice, by
            // runtime.scm:get-builtin-module/name*, when it calls
            // this present function.
            if (s7_let_ref(sc, env, function_name) == s7_undefined(sc)) {
                s7_varlet(sc, env, function_name, f);
            } else {
#if ALL_FUNCTIONS
                scheme_eval("print-info",
                            s7_make_string(sc, "(function ~a already present; not redefining)"),
                            s7_make_string(sc, delayed_functions[i].name),
                            NULL);
#endif
            }
            return f;
        }
    }
    return s7_f(sc);
}

void initialise_runtime(s7_scheme* sc)
{
#if ALL_FUNCTIONS
    // load runtime.scm, from the version serialised into util-extra.c;
    // this includes the procedure initialise-runtime!
    load_runtime();

    s7_define_function(sc,
                       "load-builtin-module/name*",
                       load_builtin_module_by_name,
                       2, 0, false,
                       "(load-builtin-module/name* name/symbol? env/let?) : "
                       "load the builtin module into the given let.\n"
                       "Returns its second argument, modified.");

    s7_define_function(sc,
                       "define-function/delayed/env*",
                       delayed_define_function_into_env,
                       2, 0, false,
                       "(define-function/delayed/env* fn env) : "
                       "Searches for an implementation function\n"
                       "with the name FN,\n"
                       "and loads it in to the given env/let.  "
                       "Returns the new function, or `#f` if it isn't found.");
#endif /* ALL_FUNCTIONS */

    define_re_functions(sc);

#if ALL_FUNCTIONS
    s7_pointer beastie_info = s7_name_to_value(sc, "*beastie*");

#if HAVE_ICU
    s7_varlet(sc, beastie_info,
              s7_make_symbol(sc, "icu-version"),
              s7_list(sc, 3,
                      s7_make_integer(sc, U_ICU_VERSION_MAJOR_NUM),
                      s7_make_integer(sc, U_ICU_VERSION_MINOR_NUM),
                      s7_make_integer(sc, U_ICU_VERSION_PATCHLEVEL_NUM)));
    char* icu_version_string;
    int iculen = asprintf(&icu_version_string, "%d.%d.%d",
                          U_ICU_VERSION_MAJOR_NUM,
                          U_ICU_VERSION_MINOR_NUM,
                          U_ICU_VERSION_PATCHLEVEL_NUM);
    s7_varlet(sc, beastie_info,
              s7_make_symbol(sc, "icu-version-string"),
              s7_make_string_with_length(sc, icu_version_string, iculen));
    free(icu_version_string);

#else
    s7_varlet(sc, beastie_info,
              s7_make_symbol(sc, "icu-version"),
              s7_f(sc));
    s7_varlet(sc, beastie_info,
              s7_make_symbol(sc, "icu-version-string"),
              s7_f(sc));
#endif

    s7_varlet(sc, beastie_info,
              s7_make_symbol(sc, "unicode-version"),
              s7_make_string(sc, unicode_version()));

    {
        // 512 is generous, but if it's too short in practice, it doesn't matter
#define TEMPBUF 512
        char* platform = "?";

#if HAVE_SYS_UTSNAME_H
        char buf[TEMPBUF];
        struct utsname U;
        // Would this be better as an alist?
        // No, I don't think so, since it's intended to be for
        // detailed debugging/reporting, rather than version testing.
        if (uname(&U) == 0) {
            // the U.version string seems to be the prolix one of `uname -v`,
            // which is less useful;
            // this is the analogue of `uname -orm` (cf, configure.ac).
            snprintf(buf, TEMPBUF, "%s %s %s", U.sysname, U.release, U.machine);
            platform = buf;
            // if the uname() call fails for some reason, then...
            // we don't really care that much,
            // and the value will end up as "?"
        }
#endif

        s7_varlet(sc, beastie_info,
                  s7_make_symbol(sc, "run-platform"),
                  s7_make_string(sc, platform));
#undef TEMPBUF
    }

    scheme_eval("initialise-runtime!",
                s7_curlet(sc),
                NULL);
#else
    // beastie0 initialisation
    unicode_load_hook(sc, s7_nil(sc));
    const char* funcs[] = {
        "make-ustring",
        "unicode-decode1/port/utf8",
        "ustring-append!"
    };
    const size_t nfuncs = sizeof(funcs)/sizeof(funcs[0]);

    for (int i=0; i<nfuncs; i++) {
        delayed_define_function_into_env(sc,
                                         s7_list(sc, 2,
                                                 s7_make_symbol(sc, funcs[i]),
                                                 s7_curlet(sc)));
    }
#endif /* ALL_FUNCTIONS */
}