M2compiler-V3/runtime/syslib/shim.c

/* m2compiler-V3 runtime shim (C).
 *
 * Bridges Modula-2 external procedures to the host. Memory layout
 * matches the compiler's: a STRING (ARRAY OF CHAR) value is a
 * descriptor [0] = LONGCARD element count, then the bytes; the
 * compiler passes the descriptor's address as an `l`.
 *
 * Linked with every V3 program image.
 */

#define _GNU_SOURCE
#include <unistd.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <time.h>
#include <ucontext.h>

/* Write the contents of a string descriptor to fd 1. Returns the
   number of bytes written. */
long m2write(long *desc)
{
    /* desc[0] is the capacity; the string is NUL-terminated. */
    char *s = (char *)(desc + 1);
    size_t n = strnlen(s, (size_t)desc[0] + 1);
    if (n > 0)
        write(1, s, n);
    return (long)n;
}

/* Write a newline to fd 1. */
long m2writeln(void)
{
    write(1, "\n", 1);
    return 0;
}

/* Read one character from stdin (0 at EOF). */
long m2readchar(void)
{
    int c = getchar();
    return (c == EOF) ? 0 : c;
}

/* Read a signed decimal integer from stdin, skipping leading
   whitespace. The first non-digit after the number is consumed. */
long m2readint(void)
{
    long v = 0;
    int c;
    int neg = 0;

    do { c = getchar(); } while (c == ' ' || c == '\t' ||
                                 c == '\n' || c == '\r');
    if (c == '-') { neg = 1; c = getchar(); }
    while (c >= '0' && c <= '9') {
        v = v * 10 + (c - '0');
        c = getchar();
    }
    return neg ? -v : v;
}

/* ---------------- sequential files (stdio) ---------------- */

/* Copy a descriptor string into a NUL-terminated buffer. */
static void m2cstr(long *desc, char *buf, size_t cap)
{
    char *s = (char *)(desc + 1);
    size_t n = strnlen(s, (size_t)desc[0] + 1);
    if (n >= cap) n = cap - 1;
    if (n > 0) memcpy(buf, s, n);
    buf[n] = 0;
}

long m2fopenread(long *desc)
{
    char buf[4096];
    m2cstr(desc, buf, sizeof buf);
    return (long)fopen(buf, "r");
}

long m2fopenwrite(long *desc)
{
    char buf[4096];
    m2cstr(desc, buf, sizeof buf);
    return (long)fopen(buf, "w");
}

long m2fclose(long h)
{
    if (h != 0) fclose((FILE *)h);
    return 0;
}

/* A handle of 0 means the open failed (Modula-2 NIL). Every file
   operation degrades to a safe no-op instead of dereferencing NULL. */

long m2fgetc(long h)
{
    int c;
    if (h == 0) return 0;
    c = fgetc((FILE *)h);
    return (c == EOF) ? 0 : c;
}

long m2fputc(long h, long c)
{
    if (h != 0) fputc((int)c, (FILE *)h);
    return 0;
}

long m2fputs(long h, long *desc)
{
    char *s = (char *)(desc + 1);
    size_t n = strnlen(s, (size_t)desc[0] + 1);
    if (h == 0) return 0;
    if (n > 0) fwrite(s, 1, n, (FILE *)h);
    return (long)n;
}

long m2freadint(long h)
{
    long v = 0;
    int c, neg = 0;
    if (h == 0) return 0;
    do { c = fgetc((FILE *)h); } while (c == ' ' || c == '\t' ||
                                        c == '\n' || c == '\r');
    if (c == '-') { neg = 1; c = fgetc((FILE *)h); }
    while (c >= '0' && c <= '9') {
        v = v * 10 + (c - '0');
        c = fgetc((FILE *)h);
    }
    return neg ? -v : v;
}

long m2fwriteint(long h, long v)
{
    char buf[32];
    int i = 0, neg = 0;
    unsigned long u;
    if (h == 0) return 0;
    if (v < 0) { neg = 1; u = (unsigned long)(-v); }
    else u = (unsigned long)v;
    do { buf[i++] = (char)('0' + u % 10); u /= 10; } while (u != 0);
    if (neg) buf[i++] = '-';
    while (i > 0) fputc(buf[--i], (FILE *)h);
    return 0;
}

long m2fwriteln(long h)
{
    if (h != 0) fputc('\n', (FILE *)h);
    return 0;
}

/* Read one line (up to and including '\n', or EOF) into the
   descriptor's data area, dropping the newline; NUL-terminated.
   The descriptor's capacity header is left intact (so a caller may
   keep using HIGH), and the number of bytes stored is returned.
   `max` is declared `int`: Modula-2 CARDINAL arguments arrive in a
   32-bit register (QBE `w`), so only the low 32 bits are defined. */
long m2freadline(long h, long *desc, int max)
{
    char *dst = (char *)(desc + 1);
    long n = 0;
    int c;
    if (max < 0) max = 0;
    if (h == 0) { if (max > 0) dst[0] = 0; return 0; }
    while (n < max) {
        c = fgetc((FILE *)h);
        if (c == EOF) break;
        if (c == '\n') break;
        if (c == '\r') continue;
        dst[n++] = (char)c;
    }
    dst[n] = 0;
    return n;
}

/* Bulk read: up to max bytes into the descriptor's data area; the
   descriptor's header is set to the number actually read. */
long m2fread(long h, long *desc, long max)
{
    long n;
    if (max < 0) max = 0;
    if (h == 0) { desc[0] = 0; return 0; }
    n = (long)fread((char *)(desc + 1), 1, (size_t)max, (FILE *)h);
    desc[0] = n;
    return n;
}

/* Write a signed integer right-justified in a field of width `wid`.
   wid = 0 means exactly one leading space (FileIO convention). */
long m2fwriteintw(long h, long v, long wid)
{
    char buf[64];
    int n;
    if (h == 0) return 0;
    if (wid == 0)
        n = snprintf(buf, sizeof buf, " %ld", v);
    else
        n = snprintf(buf, sizeof buf, "%*ld", (int)wid, v);
    if (n > 0) fwrite(buf, 1, (size_t)n, (FILE *)h);
    return 0;
}

/* Byte offset of the current position in h (-1 on error). */
long m2ftell(long h)
{
    if (h == 0) return -1;
    return (long)ftell((FILE *)h);
}

/* Seek h to absolute byte offset pos; 1 on success, 0 on failure.
   Rewinding also clears the stdio error/EOF state. */
long m2fseek(long h, long pos)
{
    if (h == 0) return 0;
    if (fseek((FILE *)h, (long)pos, SEEK_SET) != 0) return 0;
    clearerr((FILE *)h);
    return 1;
}

/* Standard streams as file handles. */
long m2stdout(void) { return (long)stdout; }
long m2stderr(void) { return (long)stderr; }
long m2stdin(void) { return (long)stdin; }

/* Command-line arguments, read from /proc/self/cmdline (Linux). */
static char *m2_args[1024];
static long m2_nargs = -1;

static void m2_argv_init(void)
{
    static char cmd[65536];
    FILE *f;
    long i, n;
    int c;

    if (m2_nargs >= 0) return;
    m2_nargs = 0;
    f = fopen("/proc/self/cmdline", "rb");
    if (f == NULL) return;
    n = (long)fread(cmd, 1, sizeof cmd - 1, f);
    fclose(f);
    if (n <= 0) return;
    cmd[n] = 0;
    i = 0;
    while (i < n && m2_nargs < 1024) {
        while (i < n && cmd[i] == 0) i++;      /* skip separators */
        if (i >= n) break;
        m2_args[m2_nargs++] = &cmd[i];
        while (i < n && cmd[i] != 0) i++;      /* to end of arg */
    }
}

long m2argc(void)
{
    m2_argv_init();
    return m2_nargs;
}

long m2arg(long i, long *desc, long cap)
{
    const char *a;
    long n;

    m2_argv_init();
    if (i < 0 || i >= m2_nargs) { ((char *)(desc + 1))[0] = 0; return 0; }
    a = m2_args[i];
    n = (long)strlen(a);
    if (cap > 0 && n >= cap) n = cap - 1;
    if (n < 0) n = 0;
    memcpy((char *)(desc + 1), a, (size_t)n);
    if (n < cap) ((char *)(desc + 1))[n] = 0;  /* NUL terminator */
    /* desc[0] (capacity) is left intact: length is derived by scanning */
    return 1;
}

/* Set a string descriptor's logical length (header). */
long m2setlen(long *desc, long n)
{
    desc[0] = n;
    return n;
}

/* Write a single character (byte) to fd 1. */
long m2writechar(long c)
{
    char ch = (char)c;
    write(1, &ch, 1);
    return 0;
}

/* Write a signed decimal integer to fd 1. */
long m2writeint(long v)
{
    char buf[32];
    int i = 0;
    int neg = 0;
    unsigned long u;

    if (v < 0) { neg = 1; u = (unsigned long)(-v); }
    else u = (unsigned long)v;

    do { buf[i++] = (char)('0' + (u % 10)); u /= 10; } while (u != 0);
    if (neg) buf[i++] = '-';
    while (i > 0)
        write(1, &buf[--i], 1);
    return 0;
}

/* Terminate the process. */
long m2exit(long code)
{
    exit((int)code);
    return 0;
}

/* ---------------- clock (SysClock) ---------------- */

/* Wall-clock time in seconds since the Unix epoch. */
long m2time(void)
{
    return (long)time(NULL);
}

/* Processor time used so far, in clock ticks (CLOCKS_PER_SEC per
   second).  The scaling is exposed as a constant by SysClock. */
long m2clock(void)
{
    return (long)clock();
}

/* String content equality: 1 when the NUL-terminated contents of the
   two descriptors match. */
long m2streq(long *a, long *b)
{
    return (strcmp((char *)(a + 1), (char *)(b + 1)) == 0) ? 1 : 0;
}

/* Number of characters before the NUL. */
long m2strlen(long *s)
{
    return (long)strlen((char *)(s + 1));
}

/* UString length: the codepoint count is the descriptor's header. */
long m2ustrlen(long *s)
{
    return s[0];
}

/* Build a 1-codepoint UString descriptor from a UCHAR value; returns
   its address.  A small rotating pool lets an expression supply both
   operands to m2ustrcat before it reads them. */
long m2ustrfrom(long cp)
{
    static struct { long count; int cp; } pool[16];
    static int next = 0;
    long *d = (long *)&pool[next];
    pool[next].count = 1;
    pool[next].cp = (int)cp;
    next = (next + 1) & 15;
    return (long)d;
}

/* Concatenate two UString descriptors into a static buffer; returns
   the result descriptor address.  The value is valid until the next
   m2ustrcat call. */
long m2ustrcat(long *a, long *b)
{
    static struct { long count; int cp[4096]; } buf;
    int *pa = (int *)(a + 1);
    int *pb = (int *)(b + 1);
    long na = a[0], nb = b[0], i;
    if (na < 0) na = 0;
    if (nb < 0) nb = 0;
    if (na > 4096) na = 4096;
    if (nb > 4096 - na) nb = 4096 - na;
    for (i = 0; i < na; i++) buf.cp[i] = pa[i];
    for (i = 0; i < nb; i++) buf.cp[na + i] = pb[i];
    buf.count = na + nb;
    return (long)&buf;
}

/* Copy a UString descriptor (count + 4-byte codepoints) into the
   UCHAR array at dst (capacity dst[0]): min(count, capacity)
   codepoints, followed by a 0 codepoint terminator.  Returns the
   number of codepoints copied. */
long m2uassign(long *dst, long *src)
{
    /* Both descriptors are { l count, w codepoints... }: the header is
       64-bit, each codepoint is 32-bit. */
    int *d = (int *)(dst + 1);
    int *s = (int *)(src + 1);
    long cap = dst[0];
    long n = src[0];
    long i;
    if (cap < 0) cap = 0;
    if (n > cap) n = cap;
    for (i = 0; i < n; i++) d[i] = s[i];
    d[n] = 0;
    return n;
}

/* Copy the content of src into the CHAR array at dst (capacity
   dst[0]); truncated to fit and NUL-terminated.  A CHAR array has
   `cap` content slots plus a reserved terminator slot at index `cap`,
   so up to `cap` characters fit.  Returns the length copied. */
long m2strassign(long *dst, long *src)
{
    char *d = (char *)(dst + 1);
    const char *s = (const char *)(src + 1);
    long cap = dst[0];
    size_t n;
    if (cap < 0) return 0;
    n = strlen(s);
    if (n > (size_t)cap) n = (size_t)cap;
    memmove(d, s, n);
    d[n] = 0;
    return (long)n;
}

/* Concatenate two string descriptors into a static buffer; returns the
   result descriptor address. The value is valid until the next
   m2strcat call (so copy it before concatenating again). */
long m2strcat(long *a, long *b)
{
    static struct { long count; char data[8192]; } buf;
    const char *sa = (const char *)(a + 1);
    const char *sb = (const char *)(b + 1);
    size_t na = strlen(sa), nb = strlen(sb);
    if (na > sizeof buf.data - 1) na = sizeof buf.data - 1;
    if (nb > sizeof buf.data - 1 - na)
        nb = sizeof buf.data - 1 - na;
    memmove(buf.data, sa, na);
    memmove(buf.data + na, sb, nb);
    buf.data[na + nb] = 0;
    buf.count = (long)(na + nb);
    return (long)&buf;
}

/* ---------------- reals (Conversions / RealIO) ---------------- */

/* Format a REAL into a descriptor string (6 significant digits,
   scientific). desc[0] is the capacity; on return it holds the
   length. Returns the number of characters written. */
long m2realstr(double x, long *desc)
{
    char buf[64];
    char *dst = (char *)(desc + 1);
    long cap = desc[0];
    int n = snprintf(buf, sizeof buf, "%.6E", x);
    if (n < 0) n = 0;
    if (cap > 0 && n >= (int)cap) n = (int)cap - 1;
    if (n > 0) memcpy(dst, buf, (size_t)n);
    if (cap > 0) { dst[n] = 0; desc[0] = n; }
    return (long)n;
}

/* Parse a REAL from a descriptor string; *ok := 1 on success. */
double m2strreal(long *desc, long *ok)
{
    char buf[4096];
    char *end;
    double v;
    m2cstr(desc, buf, sizeof buf);
    v = strtod(buf, &end);
    while (*end == ' ' || *end == '\t' || *end == '\n' || *end == '\r') end++;
    *ok = (end != buf && *end == 0) ? 1 : 0;
    return v;
}

/* Write a REAL right-justified in a field of width `wid` (0 => one
   leading space), matching the integer convention. */
long m2writerealf(double x, long wid)
{
    char buf[128];
    int n;
    if (wid == 0)
        n = snprintf(buf, sizeof buf, "%.6E", x);
    else
        n = snprintf(buf, sizeof buf, "%*.*E", (int)wid, 6, x);
    if (n > 0) write(1, buf, (size_t)n);
    return 0;
}

long m2writereal(double x)
{
    return m2writerealf(x, 0);
}

/* Write a REAL right-justified in `wid` with `dec` digits after the
   point (FpuIO.WriteReal/WriteLongReal). */
long m2writefix(double x, long wid, long dec)
{
    char buf[256];
    int n;
    if (wid <= 0) wid = 1;
    if (dec < 0) dec = 0;
    if (dec > 30) dec = 30;
    n = snprintf(buf, sizeof buf, "%*.*f", (int)wid, (int)dec, x);
    if (n > 0) write(1, buf, (size_t)n);
    return 0;
}

/* Read a REAL from stdin. */
double m2readreal(void)
{
    double v = 0.0;
    if (scanf("%lf", &v) != 1) v = 0.0;
    return v;
}

/* ---------------- PIM coroutines (SYSTEM.NEWPROCESS/TRANSFER/...) --------
 *
 * A PROCESS is a pointer to a ucontext_t.  NEWPROCESS builds a context
 * over the caller-supplied workspace; TRANSFER saves the running
 * context into *a and resumes *b.  Coroutine bodies are compiled with a
 * leading static-link argument; module-level bodies (the usual case for
 * NEWPROCESS) take 0.  */

void m2_newprocess(void *p, void *workspace, long size, void **c)
{
    ucontext_t *uc;
    if (c == NULL) return;
    uc = (ucontext_t *)malloc(sizeof(ucontext_t));
    if (uc == NULL) { *c = NULL; return; }
    if (getcontext(uc) != 0) { free(uc); *c = NULL; return; }
    uc->uc_stack.ss_sp = workspace;
    uc->uc_stack.ss_size = (size_t)size;
    uc->uc_link = NULL;
    makecontext(uc, (void (*)(void))p, 1, (int)0);
    *c = uc;
}

void m2_transfer(void **a, void **b)
{
    ucontext_t *save;
    ucontext_t *go;
    if ((a == NULL) || (b == NULL)) return;
    save = (ucontext_t *)*a;
    go = (ucontext_t *)*b;
    if (go == NULL) return;
    if (save == NULL) {
        save = (ucontext_t *)malloc(sizeof(ucontext_t));
        if (save == NULL) return;
        *a = save;
    }
    swapcontext(save, go);
}

/* IOTRANSFER: without a device-interrupt subsystem this degrades to a
   plain transfer to b (classic PIM resumes a when the interrupt
   fires).  The interrupt number is accepted and ignored. */
void m2_iotransfer(void **a, void **b, long interruptNo)
{
    (void)interruptNo;
    m2_transfer(a, b);
}

/* ---------------- text-IO library support ---------------- */

/* Read one line from stdin (newline dropped) into the string
   descriptor's data area; NUL-terminated.  Returns the length. */
long m2readline(long *desc, int max)
{
    char *dst = (char *)(desc + 1);
    long n = 0;
    int c;
    if (max < 0) max = 0;
    while (n < max) {
        c = getchar();
        if (c == EOF) break;
        if (c == '\n') break;
        if (c == '\r') continue;
        dst[n++] = (char)c;
    }
    dst[n] = 0;
    return n;
}

/* Write a signed integer right-justified in a field of width `wid`
   to fd 1 (wid = 0 => exactly one leading space). */
long m2writeintwidth(long v, int wid)
{
    char buf[64];
    int n;
    if (wid == 0)
        n = snprintf(buf, sizeof buf, " %ld", v);
    else
        n = snprintf(buf, sizeof buf, "%*ld", wid, v);
    if (n > 0) write(1, buf, (size_t)n);
    return 0;
}

/* Format a REAL into a descriptor: mode 0 = fixed (prec = decimal
   places), 1 = floating (prec = significant figures), 2 = engineering
   (prec = significant figures, exponent a multiple of three).
   desc[0] is the capacity; on return it holds the length. */
static long m2putstr(char *dst, long cap, const char *src)
{
    long n = (long)strlen(src);
    if (cap <= 0) return 0;
    if (n > cap - 1) n = cap - 1;
    memcpy(dst, src, (size_t)n);
    dst[n] = 0;
    return n;
}

long m2realconv(double x, int mode, int prec, long *desc)
{
    char buf[256];
    char *dst = (char *)(desc + 1);
    long cap = desc[0];
    int n = 0;
    if (prec < 0) prec = 0;
    if (prec > 40) prec = 40;
    if (mode == 0) {
        n = snprintf(buf, sizeof buf, "%.*f", prec, x);
    } else if (mode == 1) {
        n = snprintf(buf, sizeof buf, "%.*E",
                     prec > 0 ? prec - 1 : 0, x);
    } else {
        /* engineering: mantissa in [1,1000), exponent multiple of 3 */
        int e;
        double m = x;
        if (m != 0.0) {
            e = 0;
            while (m >= 1000.0) { m /= 1000.0; e += 3; }
            while (m < 1.0)     { m *= 1000.0; e -= 3; }
        } else {
            e = 0;
        }
        n = snprintf(buf, sizeof buf, "%.*fE%+d",
                     prec > 0 ? prec - 1 : 0, m, e);
    }
    if (n < 0) n = 0;
    return m2putstr(dst, cap, buf);
}

/* Termination flags: HALT aborts the image, so neither is ever
   observably TRUE; provided so TERMINATION links. */
long m2terminating(void) { return 0; }
long m2hashalted(void) { return 0; }

/* ---------------- DynamicStrings (heap C strings) ----------------
 *
 * A DynamicStrings.String is a malloc'd NUL-terminated char buffer.
 * Procedures that return a String return the buffer address; those
 * that take a String receive it in the first `long` argument. */

static char *m2dsdup(const char *s)
{
    size_t n;
    char *p;
    if (s == NULL) s = "";
    n = strlen(s);
    p = (char *)malloc(n + 1);
    if (p == NULL) return NULL;
    memcpy(p, s, n + 1);
    return p;
}

long m2dsinit(long *a) { return (long)m2dsdup((const char *)(a + 1)); }
long m2dskill(char *s) { free(s); return 0; }
long m2dslength(const char *s) { return s ? (long)strlen(s) : 0; }
long m2dsdupstr(const char *s) { return (long)m2dsdup(s); }

long m2dsconcat(char *a, const char *b)
{
    size_t na, nb;
    char *p;
    if (b == NULL) b = "";
    na = a ? strlen(a) : 0;
    nb = strlen(b);
    p = (char *)realloc(a, na + nb + 1);
    if (p == NULL) return (long)a;
    memcpy(p + na, b, nb + 1);
    return (long)p;
}

long m2dsconcatchar(char *a, int ch)
{
    size_t na = a ? strlen(a) : 0;
    char *p = (char *)realloc(a, na + 2);
    if (p == NULL) return (long)a;
    p[na] = (char)ch;
    p[na + 1] = 0;
    return (long)p;
}

long m2dsassign(char *a, const char *b)
{
    size_t nb;
    char *p;
    if (b == NULL) b = "";
    nb = strlen(b);
    p = (char *)realloc(a, nb + 1);
    if (p == NULL) return (long)a;
    memcpy(p, b, nb + 1);
    return (long)p;
}

long m2dseq(const char *a, const char *b)
{
    if (a == NULL) a = "";
    if (b == NULL) b = "";
    return strcmp(a, b) == 0;
}

/* EqualArray: the second operand arrives as the *descriptor* of a V3
   CHAR-array actual (V3 passes array actuals as their descriptor). */
long m2dseqarr(const char *s, long *a)
{
    return m2dseq(s, (const char *)(a + 1));
}

long m2dschar(const char *s, int i)
{
    int n;
    if (s == NULL) return 0;
    n = (int)strlen(s);
    if (i < 0) i = n + i;
    if (i < 0 || i >= n) return 0;
    return (unsigned char)s[i];
}

long m2dscopyout(long *dst, const char *s)
{
    char *d = (char *)(dst + 1);
    long cap = dst[0];
    size_t n;
    if (s == NULL) s = "";
    n = strlen(s);
    if (cap < 0) cap = 0;
    if (n > (size_t)cap) n = (size_t)cap;
    memcpy(d, s, n);
    d[n] = 0;
    return (long)n;
}

long m2dsslice(const char *s, int low, int high)
{
    int n, lo, hi;
    char *p;
    if (s == NULL) s = "";
    n = (int)strlen(s);
    lo = low;
    hi = high;
    if (lo < 0) lo = n + lo;
    if (lo < 0) lo = 0;
    if (hi == 0) hi = n;
    else if (hi < 0) hi = n + hi;
    if (hi > n) hi = n;
    if (hi < lo) hi = lo;
    p = (char *)malloc((size_t)(hi - lo) + 1);
    if (p == NULL) return 0;
    memcpy(p, s + lo, (size_t)(hi - lo));
    p[hi - lo] = 0;
    return (long)p;
}

long m2dsindex(const char *s, int ch, int o)
{
    int i;
    if (s == NULL) return -1;
    for (i = o; s[i] != 0; i++)
        if ((unsigned char)s[i] == (unsigned char)ch) return i;
    return -1;
}

long m2dsrindex(const char *s, int ch, int o)
{
    int n, i;
    if (s == NULL) return -1;
    n = (int)strlen(s);
    if (o >= n) o = n - 1;
    for (i = o; i >= 0; i--)
        if ((unsigned char)s[i] == (unsigned char)ch) return i;
    return -1;
}

long m2dsmult(const char *s, int n)
{
    size_t len, i;
    char *p;
    if (s == NULL) s = "";
    if (n <= 0) return (long)m2dsdup("");
    len = strlen(s);
    p = (char *)malloc(len * (size_t)n + 1);
    if (p == NULL) return 0;
    for (i = 0; i < (size_t)n; i++) memcpy(p + i * len, s, len);
    p[len * (size_t)n] = 0;
    return (long)p;
}

long m2dsreplacechar(char *s, int from, int to)
{
    int i;
    if (s == NULL) return 0;
    for (i = 0; s[i] != 0; i++)
        if ((unsigned char)s[i] == (unsigned char)from) s[i] = (char)to;
    return (long)s;
}

long m2dsupper(char *s)
{
    int i;
    if (s == NULL) return 0;
    for (i = 0; s[i] != 0; i++)
        if (s[i] >= 'a' && s[i] <= 'z') s[i] = (char)(s[i] - 32);
    return (long)s;
}

long m2dslower(char *s)
{
    int i;
    if (s == NULL) return 0;
    for (i = 0; s[i] != 0; i++)
        if (s[i] >= 'A' && s[i] <= 'Z') s[i] = (char)(s[i] + 32);
    return (long)s;
}

long m2dstrimprefix(char *s)
{
    char *p;
    if (s == NULL) return 0;
    p = s;
    while (*p == ' ' || *p == '\t' || *p == '\n' || *p == '\r') p++;
    if (p != s) memmove(s, p, strlen(p) + 1);
    return (long)s;
}

long m2dstrimpostfix(char *s)
{
    size_t n;
    if (s == NULL) return 0;
    n = strlen(s);
    while (n > 0 && (s[n-1] == ' ' || s[n-1] == '\t' ||
                     s[n-1] == '\n' || s[n-1] == '\r')) {
        s[--n] = 0;
    }
    return (long)s;
}

/* ---------------- TimeString / wrapclock / wraptime / wrapc -------- */

#include <sys/stat.h>
#include <sys/time.h>
#include <pwd.h>
#include <math.h>
#include <fcntl.h>

long m2timestring(long *desc)
{
    char buf[128];
    char *dst = (char *)(desc + 1);
    long cap = desc[0], n;
    time_t t = time(NULL);
    struct tm tmv;
    localtime_r(&t, &tmv);
    if (strftime(buf, sizeof buf, "%c", &tmv) == 0) buf[0] = 0;
    n = (long)strlen(buf);
    if (cap < 0) cap = 0;
    if (n > cap) n = cap;
    memcpy(dst, buf, (size_t)n);
    dst[n] = 0;
    return n;
}

long m2wctimezone(void)   { return (long)timezone; }
long m2wcistimezone(void) { return 1; }
long m2wcdaylight(void)   { return (long)daylight; }
long m2wcisdst(void)      { return 1; }
long m2wctzname(long d)   { return (long)(d ? tzname[1] : tzname[0]); }
void *m2wctsnew(void)     { return calloc(1, sizeof(struct timespec)); }
void *m2wctskill(void *ts){ free(ts); return NULL; }
long m2wctsget(void *ts, long *sec, long *nano)
{
    struct timespec *t = (struct timespec *)ts;
    if (t == NULL) return -1;
    *sec = (long)t->tv_sec; *nano = (long)t->tv_nsec; return 0;
}
long m2wctsset(void *ts, long sec, long nano)
{
    struct timespec *t = (struct timespec *)ts;
    if (t == NULL) return -1;
    t->tv_sec = (time_t)sec; t->tv_nsec = (long)nano; return 0;
}
long m2wctsrealtime(void *ts)
{ return clock_gettime(CLOCK_REALTIME, (struct timespec *)ts); }
long m2wctssetrealtime(void *ts)
{ return clock_settime(CLOCK_REALTIME, (struct timespec *)ts); }

void *m2wttvnew(void) { return calloc(1, sizeof(struct timeval)); }
void *m2wttvkill(void *p) { free(p); return NULL; }
void *m2wttznew(void) { return calloc(1, sizeof(struct timezone)); }
void *m2wttzkill(void *p) { free(p); return NULL; }
void *m2wttmnew(void) { return calloc(1, sizeof(struct tm)); }
void *m2wttmkill(void *p) { free(p); return NULL; }
long m2wtgettimeofday(void *tv, void *tz)
{ return gettimeofday((struct timeval *)tv, (struct timezone *)tz); }
long m2wtsettimeofday(void *tv, void *tz)
{ return settimeofday((struct timeval *)tv, (struct timezone *)tz); }
long m2wtfractions(void *tv)
{ struct timeval *t = (struct timeval *)tv; return t ? (long)t->tv_usec : 0; }
void *m2wtlocaltime(void *tv, void *tm)
{ struct timeval *t = (struct timeval *)tv; return localtime_r(&t->tv_sec, (struct tm *)tm); }
long m2wtyear(void *m)   { return ((struct tm *)m)->tm_year + 1900; }
long m2wtmonth(void *m)  { return ((struct tm *)m)->tm_mon + 1; }
long m2wtday(void *m)    { return ((struct tm *)m)->tm_mday; }
long m2wthour(void *m)   { return ((struct tm *)m)->tm_hour; }
long m2wtminute(void *m) { return ((struct tm *)m)->tm_min; }
long m2wtsecond(void *m) { return ((struct tm *)m)->tm_sec; }
void m2wttvset(void *tv, long sec, long usec)
{ struct timeval *t = (struct timeval *)tv; t->tv_sec = (time_t)sec; t->tv_usec = (long)usec; }
void m2wttzset(void *tz, long minuteswest, long dsttime)
{ struct timezone *z = (struct timezone *)tz; z->tz_minuteswest = (int)minuteswest; z->tz_dsttime = (int)dsttime; }

long m2cstrtime(void) { time_t t = time(NULL); return (long)ctime(&t); }
long m2cfilesize(long f, long *low, long *high)
{
    struct stat st;
    if (fstat((int)f, &st) != 0) { *low = 0; *high = 0; return -1; }
    *low = (long)(st.st_size & 0xffffffffL);
    *high = (long)((unsigned long long)st.st_size >> 32);
    return 0;
}
long m2cfileinode(long f, long *low, long *high)
{
    struct stat st;
    if (fstat((int)f, &st) != 0) { *low = 0; *high = 0; return -1; }
    *low = (long)(st.st_ino & 0xffffffffL);
    *high = (long)((unsigned long long)st.st_ino >> 32);
    return 0;
}
long m2cfilemtime(long f)
{ struct stat st; if (fstat((int)f, &st) != 0) return -1; return (long)st.st_mtime; }
long m2cgetrand(long n) { return n <= 0 ? 0 : (long)(random() % n); }
long m2cgetusername(void)
{ struct passwd *pw = getpwuid(getuid()); return pw ? (long)pw->pw_name : (long)""; }
void m2cgetnameuidgid(long name, long *uid, long *gid)
{ struct passwd *pw = getpwnam((const char *)name);
  if (pw == NULL) { *uid = -1; *gid = -1; } else { *uid = (long)pw->pw_uid; *gid = (long)pw->pw_gid; } }
long m2csignbit(double r)  { return signbit(r) ? 1 : 0; }
long m2cisfinite(double x) { return isfinite(x) ? 1 : 0; }
long m2cisnan(double x)    { return isnan(x) ? 1 : 0; }
long m2cseekset(void)      { return (long)SEEK_SET; }
long m2cseekend(void)      { return (long)SEEK_END; }
long m2creadonly(void)     { return (long)O_RDONLY; }
long m2cwriteonly(void)    { return (long)O_WRONLY; }

/* ---------------- ISO exceptions ---------------- */

#include <setjmp.h>
#include <signal.h>
#include <stdint.h>

#define M2_EXC_MAX      1024
#define M2_EXC_MSG_MAX  1024
#define M2_EXC_ENV_SIZE 512

_Static_assert(sizeof(sigjmp_buf) <= M2_EXC_ENV_SIZE,
               "sigjmp_buf does not fit the QBE exception environment");

typedef struct {
    int active;
    int language;
    void *source;
    unsigned number;
    char message[M2_EXC_MSG_MAX];
} m2_exc_state;

typedef struct {
    void *env;
    int in_handler;
    m2_exc_state saved;
} m2_exc_handler;

static m2_exc_state m2_cur;
static m2_exc_handler m2_handlers[M2_EXC_MAX];
static int m2_top;
static int m2_exc_inited;
static unsigned m2_source_seq;
static char m2_language_source;

void m2_exc_raise_lang(int code);

static const char *m2_exc_text[15] = {
    "array index out of range",
    "range check failed",
    "no matching CASE label",
    "invalid memory location",
    "function did not return a value",
    "integer overflow",
    "integer divide by zero",
    "real value error",
    "real divide by zero",
    "complex value error",
    "complex divide by zero",
    "protection error",
    "system error",
    "coroutine error",
    "exception handling error"
};

static void m2_exc_clear(void)
{
    m2_cur.active = 0;
    m2_cur.language = 0;
    m2_cur.source = NULL;
    m2_cur.number = 0;
    m2_cur.message[0] = 0;
}

static void m2_exc_copy_desc(char *dst, size_t cap, const long *desc)
{
    size_t n;

    if (cap == 0) return;
    dst[0] = 0;
    if (desc == NULL) return;
    n = (desc[0] < 0) ? 0 : (size_t)desc[0];
    if (n >= cap) n = cap - 1;
    if (n > 0) memcpy(dst, (const char *)(desc + 1), n);
    dst[n] = 0;
}

static void m2_exc_unhandled(void)
{
    const char *msg = m2_cur.message[0] ? m2_cur.message : "unhandled exception";
    fprintf(stderr, "unhandled Modula-2 exception %u: %s\n",
            m2_cur.number, msg);
    fflush(stderr);
    abort();
}

static void m2_exc_raise_state(const m2_exc_state *st)
{
    int i;

    for (i = m2_top - 1; i >= 0; --i) {
        if (!m2_handlers[i].in_handler) {
            m2_top = i + 1;
            m2_handlers[i].in_handler = 1;
            m2_cur = *st;
            siglongjmp(*(sigjmp_buf *)m2_handlers[i].env, 1);
        }
    }
    m2_cur = *st;
    m2_exc_unhandled();
}

static void m2_exc_fault(int sig, siginfo_t *info, void *ctx)
{
    int code;

    (void)ctx;
    if (sig == SIGSEGV || sig == SIGBUS) {
        code = 3;                       /* invalidLocation */
    } else if (sig == SIGFPE) {
        switch (info ? info->si_code : 0) {
        case FPE_INTDIV: code = 6; break;   /* wholeDivException */
        case FPE_INTOVF: code = 5; break;   /* wholeValueException */
        case FPE_FLTDIV: code = 8; break;   /* realDivException */
        case FPE_FLTOVF:
        case FPE_FLTUND:
        case FPE_FLTRES:
        case FPE_FLTINV: code = 7; break;   /* realValueException */
#ifdef FPE_FLTSUB
        case FPE_FLTSUB: code = 0; break;   /* indexException */
#endif
        default: code = 12; break;          /* sysException */
        }
    } else {
        code = 12;
    }
    m2_exc_raise_lang(code);
}

void m2_exc_init(void)
{
    struct sigaction sa;

    if (m2_exc_inited) return;
    m2_exc_inited = 1;
    memset(&sa, 0, sizeof sa);
    sa.sa_sigaction = m2_exc_fault;
    sa.sa_flags = SA_SIGINFO;
    sigemptyset(&sa.sa_mask);
    sigaction(SIGSEGV, &sa, NULL);
#ifdef SIGBUS
    sigaction(SIGBUS, &sa, NULL);
#endif
    sigaction(SIGFPE, &sa, NULL);
}

void m2_exc_push(void *env)
{
    if (m2_top >= M2_EXC_MAX) {
        fprintf(stderr, "Modula-2 exception handler stack overflow\n");
        abort();
    }
    m2_handlers[m2_top].env = env;
    m2_handlers[m2_top].in_handler = 0;
    m2_handlers[m2_top].saved = m2_cur;
    m2_top++;
    m2_exc_clear();
}

void m2_exc_leave(void)
{
    if (m2_top <= 0) return;
    m2_top--;
    m2_cur = m2_handlers[m2_top].saved;
}

void m2_exc_retry(void)
{
    if (m2_top <= 0) {
        fprintf(stderr, "RETRY without an exception handler\n");
        abort();
    }
    m2_handlers[m2_top - 1].in_handler = 0;
    m2_exc_clear();
    siglongjmp(*(sigjmp_buf *)m2_handlers[m2_top - 1].env, 2);
}

void m2_exc_raise_lang(int code)
{
    m2_exc_state st;

    if (code < 0 || code > 14) code = 14;   /* exException */
    memset(&st, 0, sizeof st);
    st.active = 1;
    st.language = 1;
    st.source = &m2_language_source;
    st.number = (unsigned)code;
    strncpy(st.message, m2_exc_text[code], M2_EXC_MSG_MAX - 1);
    st.message[M2_EXC_MSG_MAX - 1] = 0;
    m2_exc_raise_state(&st);
}

void m2_exc_raise_user(void *source, unsigned number, const long *msg_desc)
{
    m2_exc_state st;

    memset(&st, 0, sizeof st);
    st.active = 1;
    st.language = 0;
    st.source = source;
    st.number = number;
    m2_exc_copy_desc(st.message, sizeof st.message, msg_desc);
    m2_exc_raise_state(&st);
}

void m2_exc_throw(long code)
{
    if (code < 0 || code > 14) code = 14;
    m2_exc_raise_lang((int)code);
}

int m2_exc_active(void)
{
    return m2_cur.active;
}

int m2_exc_language(void)
{
    return m2_cur.active && m2_cur.language;
}

int m2_exc_is_source(void *source)
{
    return m2_cur.active && (m2_cur.source == source);
}

unsigned m2_exc_number(void)
{
    return m2_cur.number;
}

void m2_exc_copy_message(long *text_desc)
{
    size_t cap, n;

    if (text_desc == NULL) return;
    cap = (text_desc[0] < 0) ? 0 : (size_t)text_desc[0];
    if (cap == 0) return;
    {
        char *dst = (char *)(text_desc + 1);
        if (!m2_cur.active) {
            dst[0] = 0;
            return;
        }
        n = strlen(m2_cur.message);
        if (n >= cap) n = cap - 1;
        memcpy(dst, m2_cur.message, n);
        dst[n] = 0;
    }
}

void *m2_exc_new_source(void)
{
    return (void *)(uintptr_t)(++m2_source_seq);
}