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