/* 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 <stddef.h>
#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;
}


/* Copy an environment variable's value into a descriptor. */
long m2getenv(long *name, long *desc, long cap)
{
    const char *v = getenv((char *)(name + 1));
    long n;

    if (v == NULL) {
        if (cap > 0) ((char *)(desc + 1))[0] = 0;
        return 0;
    }
    n = (long)strlen(v);
    if (cap > 0 && n >= cap) n = cap - 1;
    if (n < 0) n = 0;
    memcpy((char *)(desc + 1), v, (size_t)n);
    if (n < cap) ((char *)(desc + 1))[n] = 0;
    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));
}

/* Test helpers for the foreign-call boundary: these expect real C
   buffers, not V3 descriptors. */
long m2_c_strlen(const char *s)
{
    return s ? (long)strlen(s) : -1;
}

long m2_c_fill(char *buf, long cap, int ch)
{
    long i;
    if (!buf || cap <= 0) return -1;
    for (i = 0; i < cap - 1; i++) buf[i] = (char)ch;
    buf[cap - 1] = 0;
    return cap - 1;
}

/* Copy a C string into a V3 CHAR-array descriptor. */
long m2_cstr_copy(long *dst, const char *src)
{
    char *d = (char *)(dst + 1);
    long cap = dst[0];
    size_t n;

    if (cap <= 0) return 0;
    if (!src) {
        d[0] = 0;
        return 0;
    }
    n = strlen(src);
    if (n > (size_t)(cap - 1)) n = (size_t)(cap - 1);
    if (n > 0) memcpy(d, src, n);
    d[n] = 0;
    return (long)n;
}

/* Test helpers for CString returns and char ** outputs. */
const char *m2_cstr_hello(void)
{
    return "hello";
}

void m2_cstr_out(const char **p)
{
    if (p) *p = "world";
}

long m2_cstr_fill(char *buf, long cap)
{
    static const char text[] = "buffer";
    size_t n = sizeof text - 1;

    if (!buf || cap <= 0) return -1;
    if (n > (size_t)(cap - 1)) n = (size_t)(cap - 1);
    memcpy(buf, text, n);
    buf[n] = 0;
    return (long)n;
}

/* Deliberately longer than the old 64-character V3 symbol limit. */
long m2_this_is_a_very_long_c_symbol_name_for_link_alias_test_0123456789(
    long a, long b)
{
    return a + b;
}

/* C ABI scalar tests: 4-byte float and 1-byte _Bool. */
float m2_f32_add(float a, float b)
{
    return a + b;
}

_Bool m2_cbool_not(_Bool b)
{
    return !b;
}

/* C callback test: call a V3 top-level procedure with C arguments. */
int m2_c_call_add(void *fn, int a, int b)
{
    int (*f)(int, int) = (int (*)(int, int))fn;
    return f(a, b);
}

void m2_c_call_two(void *fn, void *a, void *b)
{
    void (*f)(void *, void *) = (void (*)(void *, void *))fn;
    f(a, b);
}

/* C struct-layout audit helpers. */
typedef struct {
    int x, y, w, h;
} M2C_Rect;

typedef struct {
    float x, y, w, h;
} M2C_FRect;

typedef struct {
    float r, g, b, a;
} M2C_RGBA;

typedef struct {
    _Bool b;
    float f;
    double d;
    int i;
    void *p;
} M2C_Mixed;

long m2_c_layout_rect_size(void) { return (long)sizeof(M2C_Rect); }
long m2_c_layout_frect_size(void) { return (long)sizeof(M2C_FRect); }
long m2_c_layout_rgba_size(void) { return (long)sizeof(M2C_RGBA); }
long m2_c_layout_mixed_size(void) { return (long)sizeof(M2C_Mixed); }

long m2_c_layout_offset(void *base, void *field, int which)
{
    const char *b = (const char *)base;
    const char *f = (const char *)field;
    long want;
    switch (which) {
    case 0: want = offsetof(M2C_Mixed, b); break;
    case 1: want = offsetof(M2C_Mixed, f); break;
    case 2: want = offsetof(M2C_Mixed, d); break;
    case 3: want = offsetof(M2C_Mixed, i); break;
    case 4: want = offsetof(M2C_Mixed, p); break;
    default: return 0;
    }
    return (long)(f - b) == want;
}

/* 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);
}

/* ---------------- sorted range sets (SET OF CARDINAL/INTEGER) ----------------
 * A value is a pointer to a sorted list of inclusive uint32 ranges.
 * The list is empty when the pointer is NULL.  Values from INTEGER use a
 * sign-bit flip so ordinary CARDINAL ordering is preserved.
 */
#include <stdint.h>

typedef struct M2BSRange {
    uint32_t lo;
    uint32_t hi;
    struct M2BSRange *next;
} M2BSRange;

static uint32_t m2bs_key(long v, long sign)
{
    uint32_t x = (uint32_t)v;
    if (sign) x ^= 0x80000000UL;
    return x;
}

static void m2bs_free(M2BSRange *p)
{
    M2BSRange *q;
    while (p != NULL) { q = p->next; free(p); p = q; }
}

static M2BSRange *m2bs_copy(M2BSRange *p)
{
    M2BSRange head, *tail = &head, *n;
    head.next = NULL;
    while (p != NULL) {
        n = (M2BSRange *)malloc(sizeof *n);
        if (n == NULL) break;
        n->lo = p->lo; n->hi = p->hi; n->next = NULL;
        tail->next = n; tail = n; p = p->next;
    }
    return head.next;
}

static void m2bs_add(M2BSRange **head, uint32_t lo, uint32_t hi)
{
    M2BSRange **pp = head;
    M2BSRange *n;
    if (lo > hi) { uint32_t t = lo; lo = hi; hi = t; }
    while (*pp != NULL && (uint64_t)(*pp)->hi + 1 < (uint64_t)lo) {
        pp = &(*pp)->next;
    }
    if (*pp != NULL && (uint64_t)(*pp)->hi + 1 >= (uint64_t)lo
                   && (uint64_t)hi + 1 >= (uint64_t)(*pp)->lo) {
        n = *pp;
        if (lo < n->lo) n->lo = lo;
        if (hi > n->hi) n->hi = hi;
        /* absorb following overlapping/adjacent nodes */
        while (n->next != NULL
               && (uint64_t)n->hi + 1 >= (uint64_t)n->next->lo) {
            M2BSRange *m = n->next;
            if (m->hi > n->hi) n->hi = m->hi;
            n->next = m->next;
            free(m);
        }
        return;
    }
    n = (M2BSRange *)malloc(sizeof *n);
    if (n == NULL) return;
    n->lo = lo; n->hi = hi; n->next = *pp; *pp = n;
}

static void m2bs_remove(M2BSRange **head, uint32_t x)
{
    M2BSRange **pp = head;
    while (*pp != NULL && (*pp)->hi < x) pp = &(*pp)->next;
    if (*pp == NULL || (*pp)->lo > x) return;
    {
        M2BSRange *n = *pp;
        if (n->lo == n->hi) {
            *pp = n->next; free(n);
        } else if (x == n->lo) {
            n->lo++;
        } else if (x == n->hi) {
            n->hi--;
        } else {
            M2BSRange *m = (M2BSRange *)malloc(sizeof *m);
            if (m == NULL) return;
            m->lo = x + 1; m->hi = n->hi; m->next = n->next;
            n->hi = x - 1; n->next = m;
        }
    }
}

long m2bs_incl(long *slot, long v, long sign)
{
    if (slot != NULL) m2bs_add((M2BSRange **)slot, m2bs_key(v, sign), m2bs_key(v, sign));
    return 0;
}

long m2bs_excl(long *slot, long v, long sign)
{
    if (slot != NULL) m2bs_remove((M2BSRange **)slot, m2bs_key(v, sign));
    return 0;
}

long m2bs_incl_range(long *slot, long a, long b, long sign)
{
    if (slot != NULL) m2bs_add((M2BSRange **)slot, m2bs_key(a, sign), m2bs_key(b, sign));
    return 0;
}

long m2bs_in(long *slot, long v, long sign)
{
    M2BSRange *p;
    uint32_t x;
    if (slot == NULL) return 0;
    x = m2bs_key(v, sign);
    p = (M2BSRange *)*slot;
    while (p != NULL && p->hi < x) p = p->next;
    return (p != NULL && p->lo <= x);
}

long m2bs_equal(long *a, long *b)
{
    M2BSRange *p = (a == NULL) ? NULL : (M2BSRange *)*a;
    M2BSRange *q = (b == NULL) ? NULL : (M2BSRange *)*b;
    while (p != NULL && q != NULL) {
        if (p->lo != q->lo || p->hi != q->hi) return 0;
        p = p->next; q = q->next;
    }
    return (p == NULL && q == NULL);
}

long m2bs_copy_to(long *dst, long *src)
{
    M2BSRange *p;
    if (dst == NULL) return 0;
    p = (M2BSRange *)*dst;
    if (src != NULL && *src == *dst) return 0;
    m2bs_free(p);
    *dst = (long)((src == NULL) ? NULL : m2bs_copy((M2BSRange *)*src));
    return 0;
}

static void m2bs_diff_into(M2BSRange **out, M2BSRange *a, M2BSRange *b)
{
    M2BSRange *p, *q;
    for (p = a; p != NULL; p = p->next) {
        uint32_t lo = p->lo, hi = p->hi;
        int done = 0;
        for (q = b; q != NULL && !done; q = q->next) {
            if (q->hi < lo) continue;
            if (q->lo > hi) break;
            if (q->lo > lo) m2bs_add(out, lo, q->lo - 1);
            if (q->hi >= hi) { done = 1; break; }
            lo = q->hi + 1;
            if (lo > hi) done = 1;
        }
        if (!done && lo <= hi) m2bs_add(out, lo, hi);
    }
}

long m2bs_bin(long *dst, long *la, long *lb, long sel)
{
    M2BSRange *a, *b, *p, *q, *res = NULL;
    if (dst == NULL) return 0;
    a = (la == NULL) ? NULL : (M2BSRange *)*la;
    b = (lb == NULL) ? NULL : (M2BSRange *)*lb;
    if (sel == 0) {                 /* union */
        res = m2bs_copy(a);
        for (q = b; q != NULL; q = q->next) m2bs_add(&res, q->lo, q->hi);
    } else if (sel == 1) {          /* intersection */
        for (p = a; p != NULL; p = p->next)
            for (q = b; q != NULL && q->lo <= p->hi; q = q->next)
                if (q->hi >= p->lo)
                    m2bs_add(&res,
                        (q->lo > p->lo) ? q->lo : p->lo,
                        (q->hi < p->hi) ? q->hi : p->hi);
    } else if (sel == 2) {          /* left difference */
        m2bs_diff_into(&res, a, b);
    } else {                        /* symmetric difference */
        M2BSRange *t = NULL;
        m2bs_diff_into(&t, a, b);
        m2bs_diff_into(&res, b, a);
        for (q = t; q != NULL; q = q->next) m2bs_add(&res, q->lo, q->hi);
        m2bs_free(t);
    }
    m2bs_free((M2BSRange *)*dst);
    *dst = (long)res;
    return 0;
}