Tigr-m2/modula2/microuiHelpers.mod

IMPLEMENTATION MODULE microuiHelpers;

FROM SYSTEM IMPORT ADDRESS, CAST, ADDADR, BYTE;

TYPE
    ADDRESSPTR = POINTER TO BYTE;

(*========================================================================*)
(*  Bitwise operations                                                     *)
(*========================================================================*)

PROCEDURE BITAND(a, b : CARDINAL) : CARDINAL;
    VAR sa, sb : BITSET;
BEGIN
    sa := CAST(BITSET, a);
    sb := CAST(BITSET, b);
    RETURN CAST(CARDINAL, sa * sb)
END BITAND;

PROCEDURE BITOR(a, b : CARDINAL) : CARDINAL;
    VAR sa, sb : BITSET;
BEGIN
    sa := CAST(BITSET, a);
    sb := CAST(BITSET, b);
    RETURN CAST(CARDINAL, sa + sb)
END BITOR;

PROCEDURE BITXOR(a, b : CARDINAL) : CARDINAL;
    VAR sa, sb : BITSET;
BEGIN
    sa := CAST(BITSET, a);
    sb := CAST(BITSET, b);
    RETURN CAST(CARDINAL, sa / sb)
END BITXOR;

PROCEDURE BITNOT(a : CARDINAL) : CARDINAL;
BEGIN
    RETURN BITXOR(a, MAX(CARDINAL))
END BITNOT;

PROCEDURE BITLSL(a, n : CARDINAL) : CARDINAL;
(* Logical shift left: returns a * 2^n, truncated to CARDINAL width. *)
    VAR result : CARDINAL;
        i      : CARDINAL;
BEGIN
    result := a;
    FOR i := 1 TO n DO
        result := result * 2
    END;
    RETURN result
END BITLSL;

PROCEDURE BITASR(a, n : CARDINAL) : CARDINAL;
(* Arithmetic shift right: returns a DIV 2^n (unsigned). *)
    VAR result : CARDINAL;
        i      : CARDINAL;
BEGIN
    result := a;
    FOR i := 1 TO n DO
        result := result DIV 2
    END;
    RETURN result
END BITASR;

PROCEDURE HasFlag(val, flag : CARDINAL) : BOOLEAN;
BEGIN
    RETURN CAST(BITSET, val) * CAST(BITSET, flag) # BITSET{}
END HasFlag;

PROCEDURE HasNoFlag(val, flag : CARDINAL) : BOOLEAN;
BEGIN
    RETURN CAST(BITSET, val) * CAST(BITSET, flag) = BITSET{}
END HasNoFlag;

(*========================================================================*)
(*  String / memory utilities                                              *)
(*========================================================================*)

PROCEDURE StrLen(s : ARRAY OF CHAR) : CARDINAL;
    VAR i : CARDINAL;
BEGIN
    i := 0;
    WHILE (i <= HIGH(s)) AND (s[i] # 0C) DO
        i := i + 1
    END;
    RETURN i
END StrLen;

PROCEDURE CopyBytes(src, dst : ADDRESS; len : CARDINAL);
    VAR sp, dp : ADDRESSPTR;
        i      : CARDINAL;
BEGIN
    sp := CAST(ADDRESSPTR, src);
    dp := CAST(ADDRESSPTR, dst);
    IF len > 0 THEN
        FOR i := 0 TO len - 1 DO
            dp^ := sp^;
            sp := ADDADR(sp, 1);
            dp := ADDADR(dp, 1)
        END
    END
END CopyBytes;

(*========================================================================*)
(*  Integer -> real conversions (work around SHORTREAL(x) on integers)     *)
(*========================================================================*)

PROCEDURE IntToReal(n : INTEGER) : SHORTREAL;
    VAR r : SHORTREAL;
BEGIN
    r := FLOAT(n);
    RETURN r
END IntToReal;

PROCEDURE CardToReal(n : CARDINAL) : SHORTREAL;
    VAR r : SHORTREAL;
BEGIN
    r := FLOAT(n);
    RETURN r
END CardToReal;

(*========================================================================*)
(*  Real-to-string formatting                                              *)
(*========================================================================*)

PROCEDURE PutChar(VAR buf : ARRAY OF CHAR; VAR pos : CARDINAL; ch : CHAR);
BEGIN
    IF pos <= HIGH(buf) THEN
        buf[pos] := ch
    END;
    pos := pos + 1
END PutChar;

PROCEDURE PutDigits(VAR buf : ARRAY OF CHAR; VAR pos : CARDINAL;
                     n : CARDINAL);
    VAR tmp  : ARRAY [0..19] OF CHAR;
        k, j : CARDINAL;
BEGIN
    IF n = 0 THEN
        PutChar(buf, pos, '0');
        RETURN
    END;
    k := 0;
    WHILE n > 0 DO
        tmp[k] := CHR(ORD('0') + n MOD 10);
        k := k + 1;
        n := n DIV 10
    END;
    j := k;
    WHILE j > 0 DO
        j := j - 1;
        PutChar(buf, pos, tmp[j])
    END
END PutDigits;

PROCEDURE IntToStr(VAR buf : ARRAY OF CHAR; val : INTEGER) : CARDINAL;
    VAR pos : CARDINAL;
BEGIN
    pos := 0;
    IF val < 0 THEN
        PutChar(buf, pos, '-');
        (* avoid literal negation: use 0 - val at runtime *)
        PutDigits(buf, pos, 0 - val)
    ELSE
        PutDigits(buf, pos, val)
    END;
    PutChar(buf, pos, 0C);
    RETURN pos - 1
END IntToStr;

PROCEDURE HexByte(VAR buf : ARRAY OF CHAR; val : CARDINAL) : CARDINAL;
    VAR pos : CARDINAL;
        i   : CARDINAL;
        d   : CARDINAL;
BEGIN
    pos := 0;
    FOR i := 1 TO 0 BY -1 DO   (* high nibble then low nibble *)
        d := val;
        IF i = 1 THEN
            d := d DIV 16
        END;
        d := d MOD 16;
        IF d < 10 THEN
            PutChar(buf, pos, CHR(ORD('0') + d))
        ELSE
            PutChar(buf, pos, CHR(ORD('A') + d - 10))
        END
    END;
    PutChar(buf, pos, 0C);
    RETURN 2
END HexByte;

PROCEDURE RealToStr(VAR buf : ARRAY OF CHAR; val : SHORTREAL; prec : INTEGER) : CARDINAL;
(* Formats val into buf.
   prec >= 0: fixed-point with prec decimal places (rounded).
   prec < 0 : %g style with |prec| significant digits (clamped to 1..6).
   Returns number of characters written (excluding NUL). *)
    VAR pos    : CARDINAL;
        v      : SHORTREAL;
        m      : SHORTREAL;
        whole  : CARDINAL;
        frac   : CARDINAL;
        scale  : SHORTREAL;
        neg    : BOOLEAN;
        i, digits, exp, decimals : INTEGER;
        pow, d, total : INTEGER;
        n, p   : CARDINAL;
BEGIN
    pos := 0;
    neg := val < 0.0;
    IF neg THEN v := 0.0 - val ELSE v := val END;

    IF prec >= 0 THEN
        (* fixed-point with `prec` decimals, rounded to nearest *)
        scale := 1.0;
        pow := 1;
        FOR i := 1 TO prec DO
            scale := scale * 10.0;
            pow := pow * 10
        END;
        total := TRUNC(v * scale + 0.5);
        whole := VAL(CARDINAL, total DIV pow);
        frac := VAL(CARDINAL, total MOD pow);
        IF neg THEN PutChar(buf, pos, '-') END;
        PutDigits(buf, pos, whole);
        IF prec > 0 THEN
            PutChar(buf, pos, '.');
            d := pow DIV 10;
            WHILE d > 1 DO
                IF frac < CARDINAL(d) THEN PutChar(buf, pos, '0') END;
                d := d DIV 10
            END;
            PutDigits(buf, pos, frac)
        END;
        PutChar(buf, pos, 0C);
        RETURN pos - 1
    END;

    (* %g style *)
    digits := 0 - prec;
    IF digits < 1 THEN digits := 1 END;
    IF digits > 6 THEN digits := 6 END;

    IF v = 0.0 THEN
        IF neg THEN PutChar(buf, pos, '-') END;
        PutChar(buf, pos, '0');
        PutChar(buf, pos, 0C);
        RETURN pos - 1
    END;

    (* exponent such that 10^exp <= v < 10^(exp+1) *)
    exp := 0;
    scale := 1.0;
    WHILE v >= scale * 10.0 DO
        scale := scale * 10.0;
        exp := exp + 1
    END;
    WHILE v < scale DO
        scale := scale / 10.0;
        exp := exp - 1
    END;

    IF (exp < -4) OR (exp >= digits) THEN
        (* scientific notation; the recursive call keeps the sign *)
        m := v / scale;
        IF neg THEN m := 0.0 - m END;
        n := RealToStr(buf, m, digits - 1);
        IF (n > 2) AND (buf[n - 1] = '0') THEN
            WHILE (n > 0) AND (buf[n - 1] = '0') DO n := n - 1 END;
            IF (n > 0) AND (buf[n - 1] = '.') THEN n := n - 1 END;
            buf[n] := 0C
        END;
        pos := n;
        PutChar(buf, pos, 'e');
        IF exp < 0 THEN
            PutChar(buf, pos, '-');
            PutDigits(buf, pos, CARDINAL(0 - exp))
        ELSE
            PutChar(buf, pos, '+');
            PutDigits(buf, pos, CARDINAL(exp))
        END;
        PutChar(buf, pos, 0C);
        RETURN pos - 1
    ELSE
        (* fixed notation with the right number of significant digits *)
        decimals := digits - 1 - exp;
        IF decimals < 0 THEN decimals := 0 END;
        n := RealToStr(buf, val, decimals);
        IF decimals > 0 THEN
            p := n;
            WHILE (p > 0) AND (buf[p - 1] = '0') DO p := p - 1 END;
            IF (p > 0) AND (buf[p - 1] = '.') THEN p := p - 1 END;
            buf[p] := 0C;
            n := p
        END;
        RETURN n
    END
END RealToStr;

(*========================================================================*)
(*  StrToReal: minimal strtod                                              *)
(*========================================================================*)

PROCEDURE StrToReal(s : ARRAY OF CHAR; endptr : ADDRESS) : SHORTREAL;
    VAR i   : CARDINAL;
        val : SHORTREAL;
        neg : BOOLEAN;
        dig : CARDINAL;
        haveDot : BOOLEAN;
        fracScale : SHORTREAL;
BEGIN
    val := 0.0;
    neg := FALSE;
    i := 0;
    haveDot := FALSE;
    fracScale := 1.0;

    (* skip leading whitespace *)
    WHILE (i <= HIGH(s)) AND (s[i] = ' ') DO
        i := i + 1
    END;

    (* optional sign *)
    IF (i <= HIGH(s)) AND (s[i] = '-') THEN
        neg := TRUE;
        i := i + 1
    ELSIF (i <= HIGH(s)) AND (s[i] = '+') THEN
        i := i + 1
    END;

    (* integer part *)
    WHILE (i <= HIGH(s)) AND (s[i] >= '0') AND (s[i] <= '9') DO
        val := val * 10.0 + CardToReal(ORD(s[i]) - ORD('0'));
        i := i + 1
    END;

    (* fractional part *)
    IF (i <= HIGH(s)) AND (s[i] = '.') THEN
        haveDot := TRUE;
        i := i + 1;
        WHILE (i <= HIGH(s)) AND (s[i] >= '0') AND (s[i] <= '9') DO
            fracScale := fracScale / 10.0;
            val := val + fracScale * CardToReal(ORD(s[i]) - ORD('0'));
            i := i + 1
        END
    END;

    IF neg THEN
        val := 0.0 - val
    END;

    (* Note: endptr handling is simplified — we don't write to endptr
       because it's an ADDRESS and we can't reliably dereference it
       without knowing the target type. Callers that need endptr
       should inspect the string position themselves. *)

    RETURN val
END StrToReal;

END microuiHelpers.