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.
 */

#include <unistd.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <time.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);
}

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