kolibrios-gitea/programs/develop/oberon07/source/ARITH.ob07

(*
    BSD 2-Clause License

    Copyright (c) 2018-2021, Anton Krotov
    All rights reserved.
*)

MODULE ARITH;

IMPORT STRINGS, UTILS, LISTS;


CONST

    tINTEGER* = 1;  tREAL* = 2;  tSET*    = 3;
    tBOOLEAN* = 4;  tCHAR* = 5;  tWCHAR*  = 6;
    tSTRING*  = 7;

    opEQ* = 0; opNE* = 1; opLT* = 2; opLE* = 3; opGT* = 4; opGE* = 5;
    opIN* = 6; opIS* = 7;


TYPE

    VALUE* = RECORD

        typ*:      INTEGER;

        int:       INTEGER;
        float:     REAL;
        set:       SET;
        bool:      BOOLEAN;

        string*:   LISTS.ITEM

    END;


VAR

    digit: ARRAY 256 OF INTEGER;


PROCEDURE Int* (v: VALUE): INTEGER;
VAR
    res: INTEGER;

BEGIN

    CASE v.typ OF
    |tINTEGER, tCHAR, tWCHAR:
        res := v.int
    |tSET:
        res := UTILS.Long(ORD(v.set))
    |tBOOLEAN:
        res := ORD(v.bool)
    END

    RETURN res
END Int;


PROCEDURE getBool* (v: VALUE): BOOLEAN;
BEGIN
    ASSERT(v.typ = tBOOLEAN);

    RETURN v.bool
END getBool;


PROCEDURE Float* (v: VALUE): REAL;
BEGIN
    ASSERT(v.typ = tREAL);

    RETURN v.float
END Float;


PROCEDURE range* (i: VALUE; a, b: INTEGER): BOOLEAN;
    RETURN (a <= i.int) & (i.int <= b)
END range;


PROCEDURE check* (v: VALUE): BOOLEAN;
VAR
    res: BOOLEAN;

BEGIN
    CASE v.typ OF
    |tINTEGER: res := range(v, UTILS.target.minInt, UTILS.target.maxInt)
    |tCHAR:    res := range(v, 0, 255)
    |tWCHAR:   res := range(v, 0, 65535)
    |tREAL:    res := (-UTILS.target.maxReal <= v.float) & (v.float <= UTILS.target.maxReal)
    END

    RETURN res
END check;


PROCEDURE isZero* (v: VALUE): BOOLEAN;
VAR
    res: BOOLEAN;

BEGIN
    CASE v.typ OF
    |tINTEGER: res := v.int = 0
    |tREAL:    res := v.float = 0.0
    END

    RETURN res
END isZero;


PROCEDURE iconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
    value: INTEGER;
    i:     INTEGER;
    d:     INTEGER;

BEGIN
    error := 0;
    value := 0;

    i := 0;
    WHILE STRINGS.digit(s[i]) & (error = 0) DO
        d := digit[ORD(s[i])];
        IF value <= (UTILS.maxint - d) DIV 10 THEN
            value := value * 10 + d;
            INC(i)
        ELSE
            error := 1
        END
    END;

    IF error = 0 THEN
        v.int := value;
        v.typ := tINTEGER;
        IF ~check(v) THEN
            error := 1
        END
    END

END iconv;


PROCEDURE hconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
    value: INTEGER;
    i:     INTEGER;
    n:     INTEGER;
    d:     INTEGER;

BEGIN
    ASSERT(STRINGS.digit(s[0]));

    error := 0;
    value := 0;

    n := -1;
    i := 0;
    WHILE (s[i] # "H") & (s[i] # "X") & (s[i] # "h") & (s[i] # "x") & (error = 0) DO

        d := digit[ORD(s[i])];
        IF (n = -1) & (d # 0) THEN
            n := i
        END;

        IF (n # -1) & (i - n + 1 > UTILS.target.maxHex) THEN
            error := 2
        ELSE
            value := value * 16 + d;
            INC(i)
        END

    END;

    value := UTILS.Long(value);

    IF ((s[i] = "X") OR (s[i] = "x")) & (n # -1) & (i - n > 4) THEN
        error := 3
    END;

    IF error = 0 THEN
        v.int := value;
        IF (s[i] = "X") OR (s[i] = "x") THEN
            v.typ := tCHAR;
            IF ~check(v) THEN
                v.typ := tWCHAR;
                IF ~check(v) THEN
                    error := 3
                END
            END
        ELSE
            v.typ := tINTEGER;
            IF ~check(v) THEN
                error := 2
            END
        END
    END

END hconv;


PROCEDURE opFloat2 (VAR a: REAL; b: REAL; op: CHAR): BOOLEAN;
BEGIN
    CASE op OF
    |"+": a := a + b
    |"-": a := a - b
    |"*": a := a * b
    |"/": a := a / b
    END

    RETURN (-UTILS.maxreal <= a) & (a <= UTILS.maxreal) (* +inf > UTILS.maxreal *)
END opFloat2;


PROCEDURE fconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
    value:    REAL;
    frac:     REAL;
    exp10:    REAL;
    i, n, d:  INTEGER;
    minus:    BOOLEAN;

BEGIN
    error := 0;
    value := 0.0;
    frac  := 0.0;
    exp10 := 1.0;
    minus := FALSE;
    n := 0;

    i := 0;
    WHILE (error = 0) & STRINGS.digit(s[i]) DO
        IF opFloat2(value, 10.0, "*") & opFloat2(value, FLT(digit[ORD(s[i])]), "+") THEN
            INC(i)
        ELSE
            error := 4
        END
    END;

    INC(i);

    WHILE (error = 0) & STRINGS.digit(s[i]) DO
        IF opFloat2(frac, 10.0, "*") & opFloat2(frac, FLT(digit[ORD(s[i])]), "+") THEN
            exp10 := exp10 * 10.0;
            INC(i)
        ELSE
            error := 4
        END
    END;

    IF ~opFloat2(value, frac / exp10, "+") THEN
        error := 4
    END;

    IF (s[i] = "E") OR (s[i] = "e") THEN
        INC(i)
    END;

    IF (s[i] = "-") OR (s[i] = "+") THEN
        minus := s[i] = "-";
        INC(i)
    END;

    WHILE (error = 0) & STRINGS.digit(s[i]) DO
        d := digit[ORD(s[i])];
        IF n <= (UTILS.maxint - d) DIV 10 THEN
            n := n * 10 + d;
            INC(i)
        ELSE
            error := 5
        END
    END;

    exp10 := 1.0;
    WHILE (error = 0) & (n > 0) DO
        IF opFloat2(exp10, 10.0, "*") THEN
            DEC(n)
        ELSE
            error := 4
        END
    END;

    IF error = 0 THEN
        IF minus THEN
            IF ~opFloat2(value, exp10, "/") THEN
                error := 4
            END
        ELSE
            IF ~opFloat2(value, exp10, "*") THEN
                error := 4
            END
        END
    END;

    IF error = 0 THEN
        v.float := value;
        v.typ := tREAL;
        IF ~check(v) THEN
            error := 4
        END
    END

END fconv;


PROCEDURE setChar* (VAR v: VALUE; ord: INTEGER);
BEGIN
    v.typ := tCHAR;
    v.int := ord
END setChar;


PROCEDURE setWChar* (VAR v: VALUE; ord: INTEGER);
BEGIN
    v.typ := tWCHAR;
    v.int := ord
END setWChar;


PROCEDURE addInt (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
    error: BOOLEAN;

BEGIN
    IF (a > 0) & (b > 0) THEN
        error := a > UTILS.maxint - b
    ELSIF (a < 0) & (b < 0) THEN
        error := a < UTILS.minint - b
    ELSE
        error := FALSE
    END;

    IF ~error THEN
        a := a + b
    ELSE
        a := 0
    END

    RETURN ~error
END addInt;


PROCEDURE subInt (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
    error: BOOLEAN;

BEGIN
    IF (a > 0) & (b < 0) THEN
        error := a > UTILS.maxint + b
    ELSIF (a < 0) & (b > 0) THEN
        error := a < UTILS.minint + b
    ELSIF (a = 0) & (b < 0) THEN
        error := b = UTILS.minint
    ELSE
        error := FALSE
    END;

    IF ~error THEN
        a := a - b
    ELSE
        a := 0
    END

    RETURN ~error
END subInt;


PROCEDURE lg2 (x: INTEGER): INTEGER;
VAR
    n: INTEGER;

BEGIN
    ASSERT(x > 0);

    n := UTILS.Log2(x);
    IF n = -1 THEN
        n := 255
    END

    RETURN n
END lg2;


PROCEDURE mulInt* (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
    error:    BOOLEAN;
    min, max: INTEGER;

BEGIN
    min := UTILS.minint;
    max := UTILS.maxint;

    IF ((a > 1) & (b > 1)) OR ((a < 0) & (b < 0)) THEN
        error := (a = min) OR (b = min) OR (ABS(a) > max DIV ABS(b))

    ELSIF ((a > 1) & (b < 0)) OR ((a < 0) & (b > 1)) THEN
        error := (a = min) OR (b = min);
        IF ~error THEN
            IF lg2(ABS(a)) + lg2(ABS(b)) >= UTILS.bit_depth THEN
                error := ABS(a) > max DIV ABS(b)
            END
        END

    ELSE
        error := FALSE
    END;

    IF ~error THEN
        a := a * b
    ELSE
        a := 0
    END

    RETURN ~error
END mulInt;


PROCEDURE _ASR (x, n: INTEGER): INTEGER;
    RETURN ASR(UTILS.Long(x), n)
END _ASR;


PROCEDURE _LSR (x, n: INTEGER): INTEGER;
    RETURN UTILS.Long(LSR(UTILS.Short(x), n))
END _LSR;


PROCEDURE _LSL (x, n: INTEGER): INTEGER;
    RETURN UTILS.Long(LSL(x, n))
END _LSL;


PROCEDURE _ROR1_32 (x: INTEGER): INTEGER;
BEGIN
    x := UTILS.Short(x);
    x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 31)))
    RETURN UTILS.Long(x)
END _ROR1_32;


PROCEDURE _ROR1_16 (x: INTEGER): INTEGER;
BEGIN
    x := x MOD 65536;
    x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 15)))
    RETURN UTILS.Long(x)
END _ROR1_16;


PROCEDURE _ROR (x, n: INTEGER): INTEGER;
BEGIN

    CASE UTILS.bit_diff OF
    |0: x := ROR(x, n)
    |16, 48:
        n := n MOD 16;
        WHILE n > 0 DO
            x := _ROR1_16(x);
            DEC(n)
        END
    |32:
        n := n MOD 32;
        WHILE n > 0 DO
            x := _ROR1_32(x);
            DEC(n)
        END
    END

    RETURN x
END _ROR;


PROCEDURE opInt* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN;
VAR
    success: BOOLEAN;

BEGIN
    success := TRUE;

    CASE op OF
    |"+": success := addInt(a.int, b.int)
    |"-": success := subInt(a.int, b.int)
    |"*": success := mulInt(a.int, b.int)
    |"/": success := FALSE
    |"D": a.int := a.int DIV b.int
    |"M": a.int := a.int MOD b.int
    |"L": a.int := _LSL(a.int, b.int)
    |"A": a.int := _ASR(a.int, b.int)
    |"O": a.int := _ROR(a.int, b.int)
    |"R": a.int := _LSR(a.int, b.int)
    |"m": a.int := MIN(a.int, b.int)
    |"x": a.int := MAX(a.int, b.int)
    END;
    a.typ := tINTEGER

    RETURN success & check(a)
END opInt;


PROCEDURE charToStr* (c: VALUE; VAR s: ARRAY OF CHAR);
BEGIN
    s[0] := CHR(c.int);
    s[1] := 0X
END charToStr;


PROCEDURE opSet* (VAR a: VALUE; b: VALUE; op: CHAR);
BEGIN
    CASE op OF
    |"+": a.set := a.set + b.set
    |"-": a.set := a.set - b.set
    |"*": a.set := a.set * b.set
    |"/": a.set := a.set / b.set
    END;
    a.typ := tSET
END opSet;


PROCEDURE opFloat* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN;
BEGIN
    a.typ := tREAL
    RETURN opFloat2(a.float, b.float, op) & check(a)
END opFloat;


PROCEDURE ord* (VAR v: VALUE);
BEGIN
    CASE v.typ OF
    |tCHAR, tWCHAR:
    |tBOOLEAN: v.int := ORD(v.bool)
    |tSET:     v.int := UTILS.Long(ORD(v.set))
    END;
    v.typ := tINTEGER
END ord;


PROCEDURE odd* (VAR v: VALUE);
BEGIN
    v.typ := tBOOLEAN;
    v.bool := ODD(v.int)
END odd;


PROCEDURE bits* (VAR v: VALUE);
BEGIN
    v.typ := tSET;
    v.set := BITS(v.int)
END bits;


PROCEDURE abs* (VAR v: VALUE): BOOLEAN;
VAR
    res: BOOLEAN;

BEGIN
    res := FALSE;

    CASE v.typ OF
    |tREAL:
        v.float := ABS(v.float);
        res := TRUE
    |tINTEGER:
        IF v.int # UTILS.minint THEN
            v.int := ABS(v.int);
            res := TRUE
        END
    END

    RETURN res
END abs;


PROCEDURE floor* (VAR v: VALUE): BOOLEAN;
VAR
    res: BOOLEAN;

BEGIN
    v.typ := tINTEGER;
    res := (FLT(UTILS.minint) <= v.float) & (v.float <= FLT(UTILS.maxint));
    IF res THEN
        v.int := FLOOR(v.float)
    END

    RETURN res
END floor;


PROCEDURE flt* (VAR v: VALUE);
BEGIN
    v.typ := tREAL;
    v.float := FLT(v.int)
END flt;


PROCEDURE neg* (VAR v: VALUE): BOOLEAN;
VAR
    z: VALUE;
    res: BOOLEAN;

BEGIN
    res := TRUE;

    z.typ := tINTEGER;
    z.int := 0;

    CASE v.typ OF
    |tREAL:     v.float := -v.float
    |tSET:      v.set := -v.set
    |tINTEGER:  res := opInt(z, v, "-"); v := z
    |tBOOLEAN:  v.bool := ~v.bool
    END

    RETURN res
END neg;


PROCEDURE setbool* (VAR v: VALUE; b: BOOLEAN);
BEGIN
    v.bool := b;
    v.typ := tBOOLEAN
END setbool;


PROCEDURE opBoolean* (VAR a: VALUE; b: VALUE; op: CHAR);
BEGIN
    CASE op OF
    |"&": a.bool := a.bool & b.bool
    |"|": a.bool := a.bool OR b.bool
    END;
    a.typ := tBOOLEAN
END opBoolean;


PROCEDURE less (v, v2: VALUE; VAR error: INTEGER): BOOLEAN;
VAR
    res: BOOLEAN;

BEGIN
    res := FALSE;

    IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN
        CASE v.typ OF
        |tINTEGER,
         tWCHAR,
         tCHAR:     res := v.int < v2.int
        |tREAL:     res := v.float < v2.float
        |tBOOLEAN,
         tSET:      error := 1
        END
    ELSE
        error := 1
    END

    RETURN res
END less;


PROCEDURE equal (v, v2: VALUE; VAR error: INTEGER): BOOLEAN;
VAR
    res: BOOLEAN;

BEGIN
    res := FALSE;

    IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN
        CASE v.typ OF
        |tINTEGER,
         tWCHAR,
         tCHAR:     res := v.int = v2.int
        |tREAL:     res := v.float = v2.float
        |tBOOLEAN:  res := v.bool = v2.bool
        |tSET:      res := v.set = v2.set
        END
    ELSE
        error := 1
    END

    RETURN res
END equal;


PROCEDURE relation* (VAR v: VALUE; v2: VALUE; op: INTEGER; VAR error: INTEGER);
VAR
    res: BOOLEAN;

BEGIN
    error := 0;

    res := FALSE;

    CASE op OF

    |opEQ:
        res := equal(v, v2, error)

    |opNE:
        res := ~equal(v, v2, error)

    |opLT:
        res := less(v, v2, error)

    |opLE:
        res := less(v, v2, error);
        IF error = 0 THEN
            res := equal(v, v2, error) OR res
        END

    |opGE:
        res := ~less(v, v2, error)

    |opGT:
        res := less(v, v2, error);
        IF error = 0 THEN
            res := equal(v, v2, error) OR res
        END;
        res := ~res

    |opIN:
        IF (v.typ = tINTEGER) & (v2.typ = tSET) THEN
            IF range(v, 0, UTILS.target.maxSet) THEN
                res := v.int IN v2.set
            ELSE
                error := 2
            END
        ELSE
            error := 1
        END

    END;

    IF error = 0 THEN
        v.bool := res;
        v.typ  := tBOOLEAN
    END

END relation;


PROCEDURE emptySet* (VAR v: VALUE);
BEGIN
    v.typ := tSET;
    v.set := {}
END emptySet;


PROCEDURE constrSet* (VAR v: VALUE; a, b: VALUE);
BEGIN
    v.typ := tSET;
    v.set := {a.int .. b.int}
END constrSet;


PROCEDURE getInt* (v: VALUE): INTEGER;
BEGIN
    ASSERT(check(v))

    RETURN v.int
END getInt;


PROCEDURE setInt* (VAR v: VALUE; i: INTEGER): BOOLEAN;
BEGIN
    v.int := i;
    v.typ := tINTEGER

    RETURN check(v)
END setInt;


PROCEDURE concat* (VAR s: ARRAY OF CHAR; s1: ARRAY OF CHAR): BOOLEAN;
VAR
    res: BOOLEAN;

BEGIN
    res := LENGTH(s) + LENGTH(s1) < LEN(s);
    IF res THEN
        STRINGS.append(s, s1)
    END

    RETURN res
END concat;


PROCEDURE init;
VAR
    i: INTEGER;

BEGIN
    FOR i := 0 TO LEN(digit) - 1 DO
        digit[i] := -1
    END;

    FOR i := ORD("0") TO ORD("9") DO
        digit[i] := i - ORD("0")
    END;

    FOR i := ORD("A") TO ORD("F") DO
        digit[i] := i - ORD("A") + 10
    END
END init;


BEGIN
    init
END ARITH.