MODULE DevCPB;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems, Robert Campbell"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps"
changes = ""
issues = ""
**)
IMPORT DevCPT, DevCPM;
CONST
(* symbol values or ops *)
times = 1; slash = 2; div = 3; mod = 4;
and = 5; plus = 6; minus = 7; or = 8; eql = 9;
neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
in = 15; is = 16; ash = 17; msk = 18; len = 19;
conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
(*SYSTEM*)
adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
min = 34; max = 35; typfn = 36; size = 37;
(* object modes *)
Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
(* Structure forms *)
Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
Pointer = 13; ProcTyp = 14; Comp = 15;
Char16 = 16; String16 = 17; Int64 = 18;
intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; charSet = {Char8, Char16};
(* composite structure forms *)
Basic = 1; Array = 2; DynArr = 3; Record = 4;
(* nodes classes *)
Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
Nreturn = 26; Nwith = 27; Ntrap = 28;
(*function number*)
assign = 0;
haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
lchrfn = 33; lentierfcn = 34; bitsfn = 37; bytesfn = 38;
(*SYSTEM function number*)
adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31;
thisrecfn = 45; thisarrfn = 46;
(* COM function number *)
validfn = 40; iidfn = 41; queryfn = 42;
(* module visibility of objects *)
internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
(* procedure flags (conval.setval) *)
hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4;
(* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
(* case statement flags (conval.setval) *)
useTable = 1; useTree = 2;
(* sysflags *)
nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; jint = -11; jstr = -13;
AssertTrap = 0; (* default trap number *)
covarOut = FALSE;
VAR
typSize*: PROCEDURE(typ: DevCPT.Struct);
zero, one, two, dummy, quot: DevCPT.Const;
PROCEDURE err(n: SHORTINT);
BEGIN DevCPM.err(n)
END err;
PROCEDURE NewLeaf*(obj: DevCPT.Object): DevCPT.Node;
VAR node: DevCPT.Node; typ: DevCPT.Struct;
BEGIN
typ := obj.typ;
CASE obj.mode OF
Var:
node := DevCPT.NewNode(Nvar); node.readonly := (obj.vis = externalR) & (obj.mnolev < 0)
| VarPar:
node := DevCPT.NewNode(Nvarpar); node.readonly := obj.vis = inPar;
| Con:
node := DevCPT.NewNode(Nconst); node.conval := DevCPT.NewConst();
node.conval^ := obj.conval^ (* string is not copied, only its ref *)
| Typ:
node := DevCPT.NewNode(Ntype)
| LProc..IProc, TProc:
node := DevCPT.NewNode(Nproc)
ELSE err(127); node := DevCPT.NewNode(Nvar); typ := DevCPT.notyp
END ;
node.obj := obj; node.typ := typ;
RETURN node
END NewLeaf;
PROCEDURE Construct*(class: BYTE; VAR x: DevCPT.Node;y: DevCPT.Node);
VAR node: DevCPT.Node;
BEGIN
node := DevCPT.NewNode(class); node.typ := DevCPT.notyp;
node.left := x; node.right := y; x := node
END Construct;
PROCEDURE Link*(VAR x, last: DevCPT.Node; y: DevCPT.Node);
BEGIN
IF x = NIL THEN x := y ELSE last.link := y END ;
WHILE y.link # NIL DO y := y.link END ;
last := y
END Link;
PROCEDURE BoolToInt(b: BOOLEAN): INTEGER;
BEGIN
IF b THEN RETURN 1 ELSE RETURN 0 END
END BoolToInt;
PROCEDURE IntToBool(i: INTEGER): BOOLEAN;
BEGIN
IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END
END IntToBool;
PROCEDURE NewBoolConst*(boolval: BOOLEAN): DevCPT.Node;
VAR x: DevCPT.Node;
BEGIN
x := DevCPT.NewNode(Nconst); x.typ := DevCPT.booltyp;
x.conval := DevCPT.NewConst(); x.conval.intval := BoolToInt(boolval); RETURN x
END NewBoolConst;
PROCEDURE OptIf*(VAR x: DevCPT.Node); (* x.link = NIL *)
VAR if, pred: DevCPT.Node;
BEGIN
if := x.left;
WHILE if.left.class = Nconst DO
IF IntToBool(if.left.conval.intval) THEN x := if.right; RETURN
ELSIF if.link = NIL THEN x := x.right; RETURN
ELSE if := if.link; x.left := if
END
END ;
pred := if; if := if.link;
WHILE if # NIL DO
IF if.left.class = Nconst THEN
IF IntToBool(if.left.conval.intval) THEN
pred.link := NIL; x.right := if.right; RETURN
ELSE if := if.link; pred.link := if
END
ELSE pred := if; if := if.link
END
END
END OptIf;
PROCEDURE Nil*(): DevCPT.Node;
VAR x: DevCPT.Node;
BEGIN
x := DevCPT.NewNode(Nconst); x.typ := DevCPT.niltyp;
x.conval := DevCPT.NewConst(); x.conval.intval := 0; RETURN x
END Nil;
PROCEDURE EmptySet*(): DevCPT.Node;
VAR x: DevCPT.Node;
BEGIN
x := DevCPT.NewNode(Nconst); x.typ := DevCPT.settyp;
x.conval := DevCPT.NewConst(); x.conval.setval := {}; RETURN x
END EmptySet;
PROCEDURE MarkAsUsed (node: DevCPT.Node);
VAR c: BYTE;
BEGIN
c := node.class;
WHILE (c = Nfield) OR (c = Nindex) OR (c = Nguard) OR (c = Neguard) DO node := node.left; c := node.class END;
IF (c = Nvar) & (node.obj.mnolev > 0) THEN node.obj.used := TRUE END
END MarkAsUsed;
PROCEDURE GetTempVar* (name: ARRAY OF SHORTCHAR; typ: DevCPT.Struct; VAR obj: DevCPT.Object);
VAR n: DevCPT.Name; o: DevCPT.Object;
BEGIN
n := "@@"; DevCPT.Insert(n, obj); obj.name^ := name$; (* avoid err 1 *)
obj.mode := Var; obj.typ := typ;
o := DevCPT.topScope.scope;
IF o = NIL THEN DevCPT.topScope.scope := obj
ELSE
WHILE o.link # NIL DO o := o.link END;
o.link := obj
END
END GetTempVar;
(* ---------- constant operations ---------- *)
PROCEDURE Log (x: DevCPT.Node): INTEGER;
VAR val, exp: INTEGER;
BEGIN
exp := 0;
IF x.typ.form = Int64 THEN
RETURN -1
ELSE
val := x.conval.intval;
IF val > 0 THEN
WHILE ~ODD(val) DO val := val DIV 2; INC(exp) END
END;
IF val # 1 THEN exp := -1 END
END;
RETURN exp
END Log;
PROCEDURE Floor (x: REAL): REAL;
VAR y: REAL;
BEGIN
IF ABS(x) > 9007199254740992.0 (* 2^53 *) THEN RETURN x
ELSIF (x >= MAX(INTEGER) + 1.0) OR (x < MIN(INTEGER)) THEN
y := Floor(x / (MAX(INTEGER) + 1.0)) * (MAX(INTEGER) + 1.0);
RETURN SHORT(ENTIER(x - y)) + y
ELSE RETURN SHORT(ENTIER(x))
END
END Floor;
PROCEDURE SetToInt (s: SET): INTEGER;
VAR x, i: INTEGER;
BEGIN
i := 31; x := 0;
IF 31 IN s THEN x := -1 END;
WHILE i > 0 DO
x := x * 2; DEC(i);
IF i IN s THEN INC(x) END
END;
RETURN x
END SetToInt;
PROCEDURE IntToSet (x: INTEGER): SET;
VAR i: INTEGER; s: SET;
BEGIN
i := 0; s := {};
WHILE i < 32 DO
IF ODD(x) THEN INCL(s, i) END;
x := x DIV 2; INC(i)
END;
RETURN s
END IntToSet;
PROCEDURE GetConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT; VAR typ: DevCPT.Struct);
CONST MAXL = 9223372036854775808.0; (* 2^63 *)
BEGIN
IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER))
& (x.realval + x.intval <= MAX(INTEGER)) THEN
x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0
END;
IF form IN intSet THEN
IF x.realval = 0 THEN typ := DevCPT.int32typ
ELSIF (x.intval >= -MAXL - x.realval) & (x.intval < MAXL - x.realval) THEN typ := DevCPT.int64typ
ELSE err(errno); x.intval := 1; x.realval := 0; typ := DevCPT.int32typ
END
ELSIF form IN realSet THEN (* SR *)
typ := DevCPT.real64typ
ELSIF form IN charSet THEN
IF x.intval <= 255 THEN typ := DevCPT.char8typ
ELSE typ := DevCPT.char16typ
END
ELSE typ := DevCPT.undftyp
END
END GetConstType;
PROCEDURE CheckConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT);
VAR type: DevCPT.Struct;
BEGIN
GetConstType(x, form, errno, type);
IF~DevCPT.Includes(form, type.form)
& ((form # Int8) OR (x.realval # 0) OR (x.intval < -128) OR (x.intval > 127))
& ((form # Int16) OR (x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767))
& ((form # Real32) OR (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal)) THEN
err(errno); x.intval := 1; x.realval := 0
END
(*
IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER))
& (x.realval + x.intval <= MAX(INTEGER)) THEN
x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0
END;
IF (form = Int64) & ((x.intval < -MAXL - x.realval) OR (x.intval >= MAXL - x.realval))
OR (form = Int32) & (x.realval # 0)
OR (form = Int16) & ((x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767))
OR (form = Int8) & ((x.realval # 0) OR (x.intval < -128) OR (x.intval > 127))
OR (form = Char16) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 65535))
OR (form = Char8) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 255))
OR (form = Real32) & (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal) THEN
err(errno); x.intval := 1; x.realval := 0
END
*)
END CheckConstType;
PROCEDURE ConvConst (x: DevCPT.Const; from, to: INTEGER);
VAR sr: SHORTREAL;
BEGIN
IF from = Set THEN
x.intval := SetToInt(x.setval); x.realval := 0; x.setval := {};
ELSIF from IN intSet + charSet THEN
IF to = Set THEN CheckConstType(x, Int32, 203); x.setval := IntToSet(x.intval)
ELSIF to IN intSet THEN CheckConstType(x, to, 203)
ELSIF to IN realSet THEN x.realval := x.realval + x.intval; x.intval := DevCPM.ConstNotAlloc
ELSE (*to IN charSet*) CheckConstType(x, to, 220)
END
ELSIF from IN realSet THEN
IF to IN realSet THEN CheckConstType(x, to, 203);
IF to = Real32 THEN sr := SHORT(x.realval); x.realval := sr END (* reduce precision *)
ELSE x.realval := Floor(x.realval); x.intval := 0; CheckConstType(x, to, 203)
END
END
END ConvConst;
PROCEDURE Prepare (x: DevCPT.Const);
VAR r: REAL;
BEGIN
x.realval := x.realval + x.intval DIV 32768 * 32768;
x.intval := x.intval MOD 32768;
r := Floor(x.realval / 4096) * 4096;
x.intval := x.intval + SHORT(ENTIER(x.realval - r));
x.realval := r
(* ABS(x.intval) < 2^15&ABS(x.realval) MOD 2^12 = 0 *)
END Prepare;
PROCEDURE AddConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x + y *)
BEGIN
IF type.form IN intSet THEN
Prepare(x); Prepare(y);
z.intval := x.intval + y.intval; z.realval := x.realval + y.realval
ELSIF type.form IN realSet THEN
IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = - y.realval) THEN err(212)
ELSE z.realval := x.realval + y.realval
END
ELSE HALT(100)
END;
GetConstType(z, type.form, 206, type)
END AddConst;
PROCEDURE NegateConst (y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := - y *)
BEGIN
IF type.form IN intSet THEN Prepare(y); z.intval :=-y.intval; z.realval := -y.realval
ELSIF type.form IN realSet THEN z.realval := -y.realval
ELSE HALT(100)
END;
GetConstType(z, type.form, 207, type)
END NegateConst;
PROCEDURE SubConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x - y *)
BEGIN
IF type.form IN intSet THEN
Prepare(x); Prepare(y);
z.intval := x.intval - y.intval; z.realval := x.realval - y.realval
ELSIF type.form IN realSet THEN
IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval =y.realval) THEN err(212)
ELSE z.realval := x.realval - y.realval
END
ELSE HALT(100)
END;
GetConstType(z, type.form, 207, type)
END SubConst;
PROCEDURE MulConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x * y *)
BEGIN
IF type.form IN intSet THEN
Prepare(x); Prepare(y);
z.realval := x.realval * y.realval + x.intval * y.realval + x.realval * y.intval;
z.intval := x.intval * y.intval
ELSIF type.form IN realSet THEN
IF (ABS(x.realval) = DevCPM.InfReal) & ( y.realval = 0.0) THEN err(212)
ELSIF (ABS(y.realval) = DevCPM.InfReal) & (x.realval = 0.0) THEN err(212)
ELSE z.realval := x.realval * y.realval
END
ELSE HALT(100)
END;
GetConstType(z, type.form, 204, type)
END MulConst;
PROCEDURE DivConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x / y *)
BEGIN
IF type.form IN realSet THEN
IF (x.realval = 0.0) & (y.realval = 0.0) THEN err(212)
ELSIF (ABS(x.realval) =DevCPM.InfReal) & (ABS(y.realval) =DevCPM.InfReal) THEN err(212)
ELSE z.realval := x.realval / y.realval
END
ELSE HALT(100)
END;
GetConstType(z, type.form, 204, type)
END DivConst;
PROCEDURE DivModConst (x, y: DevCPT.Const; div: BOOLEAN; VAR type: DevCPT.Struct);
(* x := x DIV y | x MOD y *)
BEGIN
IF type.form IN intSet THEN
IF y.realval + y.intval # 0 THEN
Prepare(x); Prepare(y);
quot.realval := Floor((x.realval + x.intval) / (y.realval + y.intval));
quot.intval := 0; Prepare(quot);
x.realval := x.realval - quot.realval * y.realval - quot.realval * y.intval - quot.intval * y.realval;
x.intval := x.intval - quot.intval * y.intval;
IF y.realval + y.intval > 0 THEN
WHILE x.realval + x.intval > 0 DO SubConst(x, y, x, type); INC(quot.intval) END;
WHILE x.realval + x.intval < 0 DO AddConst(x, y, x, type); DEC(quot.intval) END
ELSE
WHILE x.realval + x.intval < 0 DO SubConst(x, y, x, type); INC(quot.intval) END;
WHILE x.realval + x.intval > 0 DO AddConst(x, y, x, type); DEC(quot.intval) END
END;
IF div THEN x.realval := quot.realval; x.intval := quot.intval END;
GetConstType(x, type.form, 204, type)
ELSE err(205)
END
ELSE HALT(100)
END
END DivModConst;
PROCEDURE EqualConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x = y *)
VAR res: BOOLEAN;
BEGIN
CASE form OF
| Undef: res := TRUE
| Bool, Byte, Char8..Int32, Char16: res := x.intval = y.intval
| Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) = 0
| Real32, Real64: res := x.realval = y.realval
| Set: res := x.setval = y.setval
| String8, String16, Comp (* guid *): res := x.ext^ = y.ext^
| NilTyp, Pointer, ProcTyp: res := x.intval = y.intval
END;
RETURN res
END EqualConst;
PROCEDURE LessConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < y *)
VAR res: BOOLEAN;
BEGIN
CASE form OF
| Undef: res := TRUE
| Byte, Char8..Int32, Char16: res := x.intval < y.intval
| Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) < 0
| Real32, Real64: res := x.realval < y.realval
| String8, String16: res := x.ext^ < y.ext^
| Bool, Set, NilTyp, Pointer, ProcTyp, Comp: err(108)
END;
RETURN res
END LessConst;
PROCEDURE IsNegConst (x: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < 0OR x = (-0.0) *)
VAR res: BOOLEAN;
BEGIN
CASE form OF
| Int8..Int32: res := x.intval < 0
| Int64: Prepare(x); res := x.realval + x.intval < 0
| Real32, Real64: res := (x.realval <= 0.) & (1. / x.realval <= 0.)
END;
RETURN res
END IsNegConst;
PROCEDURE NewIntConst*(intval: INTEGER): DevCPT.Node;
VAR x: DevCPT.Node;
BEGIN
x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
x.conval.intval := intval; x.conval.realval := 0; x.typ := DevCPT.int32typ; RETURN x
END NewIntConst;
PROCEDURE NewLargeIntConst* (intval: INTEGER; realval: REAL): DevCPT.Node;
VAR x: DevCPT.Node;
BEGIN
x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
x.conval.intval := intval; x.conval.realval := realval; x.typ := DevCPT.int64typ; RETURN x
END NewLargeIntConst;
PROCEDURE NewRealConst*(realval: REAL; typ: DevCPT.Struct): DevCPT.Node;
VAR x: DevCPT.Node;
BEGIN
x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
x.conval.realval := realval; x.conval.intval := DevCPM.ConstNotAlloc;
IF typ = NIL THEN typ := DevCPT.real64typ END;
x.typ := typ;
RETURN x
END NewRealConst;
PROCEDURE NewString*(str: DevCPT.String; lstr: POINTER TO ARRAY OF CHAR; len: INTEGER): DevCPT.Node;
VAR i, j, c: INTEGER; x: DevCPT.Node; ext: DevCPT.ConstExt;
BEGIN
x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
IF lstr # NIL THEN
x.typ := DevCPT.string16typ;
NEW(ext, 3 * len); i := 0; j := 0;
REPEAT c := ORD(lstr[i]); INC(i); DevCPM.PutUtf8(ext^, c, j) UNTIL c = 0;
x.conval.ext := ext
ELSE
x.typ := DevCPT.string8typ; x.conval.ext := str
END;
x.conval.intval := DevCPM.ConstNotAlloc; x.conval.intval2 := len;
RETURN x
END NewString;
PROCEDURE CharToString8(n: DevCPT.Node);
VAR ch: SHORTCHAR;
BEGIN
n.typ := DevCPT.string8typ; ch := SHORT(CHR(n.conval.intval)); NEW(n.conval.ext, 2);
IF ch = 0X THEN n.conval.intval2 := 1 ELSE n.conval.intval2 := 2; n.conval.ext[1] := 0X END ;
n.conval.ext[0] := ch; n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL
END CharToString8;
PROCEDURE CharToString16 (n: DevCPT.Node);
VAR ch, ch1: SHORTCHAR; i: INTEGER;
BEGIN
n.typ := DevCPT.string16typ; NEW(n.conval.ext, 4);
IF n.conval.intval = 0 THEN
n.conval.ext[0] := 0X; n.conval.intval2 := 1
ELSE
i := 0; DevCPM.PutUtf8(n.conval.ext^, n.conval.intval, i);
n.conval.ext[i] := 0X; n.conval.intval2 := 2
END;
n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL
END CharToString16;
PROCEDURE String8ToString16 (n: DevCPT.Node);
VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt;
BEGIN
n.typ := DevCPT.string16typ; ext := n.conval.ext;
NEW(new, 2 * n.conval.intval2); i := 0; j := 0;
REPEAT x := ORD(ext[i]); INC(i); DevCPM.PutUtf8(new^, x, j) UNTIL x = 0;
n.conval.ext := new; n.obj := NIL
END String8ToString16;
PROCEDURE String16ToString8 (n: DevCPT.Node);
VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt;
BEGIN
n.typ := DevCPT.string8typ; ext := n.conval.ext;
NEW(new, n.conval.intval2); i := 0; j := 0;
REPEAT DevCPM.GetUtf8(ext^, x, i); new[j] := SHORT(CHR(x MOD 256)); INC(j) UNTIL x = 0;
n.conval.ext := new; n.obj := NIL
END String16ToString8;
PROCEDURE StringToGuid (VAR n: DevCPT.Node);
BEGIN
ASSERT((n.class = Nconst) & (n.typ.form = String8));
IF ~DevCPM.ValidGuid(n.conval.ext^) THEN err(165) END;
n.typ := DevCPT.guidtyp
END StringToGuid;
PROCEDURE CheckString (n: DevCPT.Node; typ: DevCPT.Struct; e: SHORTINT);
VAR ntyp: DevCPT.Struct;
BEGIN
ntyp := n.typ;
IF (typ = DevCPT.guidtyp) & (n.class = Nconst) & (ntyp.form = String8) THEN StringToGuid(n)
ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char8) OR (typ.form = String8) THEN
IF (n.class = Nconst) & (ntyp.form = Char8) THEN CharToString8(n)
ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char8) OR (ntyp.form = String8) THEN (* ok *)
ELSE err(e)
END
ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char16) OR (typ.form = String16) THEN
IF (n.class = Nconst) & (ntyp.form IN charSet) THEN CharToString16(n)
ELSIF (n.class = Nconst) & (ntyp.form = String8) THEN String8ToString16(n)
ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char16) OR (ntyp.form = String16) THEN
(* ok *)
ELSE err(e)
END
ELSE err(e)
END
END CheckString;
PROCEDURE BindNodes(class: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node);
VAR node: DevCPT.Node;
BEGIN
node := DevCPT.NewNode(class); node.typ := typ;
node.left := x; node.right := y; x := node
END BindNodes;
PROCEDURE NotVar(x: DevCPT.Node): BOOLEAN;
BEGIN
RETURN (x.class >= Nconst) & ((x.class # Nmop) OR (x.subcl # val) OR (x.left.class >= Nconst))
OR (x.typ.form IN {String8, String16})
END NotVar;
PROCEDURE Convert(VAR x: DevCPT.Node; typ: DevCPT.Struct);
VAR node: DevCPT.Node; f, g: SHORTINT; k: INTEGER; r: REAL;
BEGIN f := x.typ.form; g := typ.form;
IF x.class = Nconst THEN
IF g = String8 THEN
IF f = String16 THEN String16ToString8(x)
ELSIF f IN charSet THEN CharToString8(x)
ELSE typ := DevCPT.undftyp
END
ELSIF g = String16 THEN
IF f = String8 THEN String8ToString16(x)
ELSIF f IN charSet THEN CharToString16(x)
ELSE typ := DevCPT.undftyp
END
ELSE ConvConst(x.conval, f, g)
END;
x.obj := NIL
ELSIF (x.class = Nmop) & (x.subcl = conv) & (DevCPT.Includes(f, x.left.typ.form) OR DevCPT.Includes(f, g))
THEN
(* don't create new node *)
IF x.left.typ.form = typ.form THEN (* and suppress existing node *) x := x.left END
ELSE
IF (x.class = Ndop) & (x.typ.form IN {String8, String16}) THEN (* propagate to leaf nodes *)
Convert(x.left, typ); Convert(x.right, typ)
ELSE
node := DevCPT.NewNode(Nmop); node.subcl := conv; node.left := x; x := node;
END
END;
x.typ := typ
END Convert;
PROCEDURE Promote (VAR left, right: DevCPT.Node; op: INTEGER); (* check expression compatibility *)
VAR f, g: INTEGER; new: DevCPT.Struct;
BEGIN
f := left.typ.form; g := right.typ.form; new := left.typ;
IF f IN intSet + realSet THEN
IF g IN intSet + realSet THEN
IF (f = Real32) & (right.class = Nconst) & (g IN realSet) & (left.class # Nconst)
(* & ((ABS(right.conval.realval) <= DevCPM.MaxReal32)
OR (ABS(right.conval.realval) = DevCPM.InfReal)) *)
OR (g = Real32) & (left.class = Nconst) & (f IN realSet) & (right.class # Nconst)
(* & ((ABS(left.conval.realval) <= DevCPM.MaxReal32)
OR (ABS(left.conval.realval) = DevCPM.InfReal)) *) THEN
new := DevCPT.real32typ (* SR *)
ELSIF (f = Real64) OR (g = Real64) THEN new := DevCPT.real64typ
ELSIF (f = Real32) OR (g = Real32) THEN new := DevCPT.real32typ (* SR *)
ELSIF op = slash THEN new := DevCPT.real64typ
ELSIF (f = Int64) OR (g = Int64) THEN new := DevCPT.int64typ
ELSE new := DevCPT.int32typ
END
ELSE err(100)
END
ELSIF (left.typ = DevCPT.guidtyp) OR (right.typ = DevCPT.guidtyp) THEN
IF f = String8 THEN StringToGuid(left) END;
IF g = String8 THEN StringToGuid(right) END;
IF left.typ # right.typ THEN err(100) END;
f := Comp
ELSIF f IN charSet + {String8, String16} THEN
IF g IN charSet + {String8, String16} THEN
IF (f = String16) OR (g = String16) OR (f = Char16) & (g = String8) OR (f = String8) & (g = Char16) THEN
new := DevCPT.string16typ
ELSIF (f = Char16) OR (g = Char16) THEN new := DevCPT.char16typ
ELSIF (f = String8) OR (g = String8) THEN new := DevCPT.string8typ
ELSIF op = plus THEN
IF (f = Char16) OR (g = Char16) THEN new := DevCPT.string16typ
ELSE new := DevCPT.string8typ
END
END;
IF (new.form IN {String8, String16})
& ((f IN charSet) & (left.class # Nconst) OR (g IN charSet) & (right.class # Nconst))
THEN
err(100)
END
ELSE err(100)
END
ELSIF (f IN {NilTyp, Pointer, ProcTyp}) & (g IN {NilTyp, Pointer, ProcTyp}) THEN
IF ~DevCPT.SameType(left.typ, right.typ) & (f # NilTyp) & (g # NilTyp)
& ~((f = Pointer) & (g = Pointer)
& (DevCPT.Extends(left.typ, right.typ) OR DevCPT.Extends(right.typ, left.typ))) THEN err(100) END
ELSIF f # g THEN err(100)
END;
IF ~(f IN {NilTyp, Pointer, ProcTyp, Comp}) THEN
IF g # new.form THEN Convert(right, new) END;
IF f # new.form THEN Convert(left, new) END
END
END Promote;
PROCEDURE CheckParameters* (fp, ap: DevCPT.Object; checkNames: BOOLEAN); (* checks par list match *)
VAR ft, at: DevCPT.Struct;
BEGIN
WHILE fp # NIL DO
IF ap # NIL THEN
ft := fp.typ; at := ap.typ;
IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *)
IF ap.ptyp # NIL THEN at := ap.ptyp END; (* get original formal type *)
IF ~DevCPT.EqualType(ft, at)
OR (fp.mode # ap.mode) OR (fp.sysflag # ap.sysflag) OR (fp.vis # ap.vis)
OR checkNames & (fp.name^ # ap.name^) THEN err(115) END ;
ap := ap.link
ELSE err(116)
END;
fp := fp.link
END;
IF ap # NIL THEN err(116) END
END CheckParameters;
PROCEDURE CheckNewParamPair* (newPar, iidPar: DevCPT.Node);
VAR ityp, ntyp: DevCPT.Struct;
BEGIN
ntyp := newPar.typ.BaseTyp;
IF (newPar.class = Nvarpar) & ODD(newPar.obj.sysflag DIV newBit) THEN
IF (iidPar.class = Nvarpar) & ODD(iidPar.obj.sysflag DIV iidBit) & (iidPar.obj.mnolev = newPar.obj.mnolev)
THEN (* ok *)
ELSE err(168)
END
ELSIF ntyp.extlev = 0 THEN (* ok *)
ELSIF (iidPar.class = Nconst) & (iidPar.obj # NIL) & (iidPar.obj.mode = Typ) THEN
IF ~DevCPT.Extends(iidPar.obj.typ, ntyp) THEN err(168) END
ELSE err(168)
END
END CheckNewParamPair;
PROCEDURE DeRef*(VAR x: DevCPT.Node);
VAR strobj, bstrobj: DevCPT.Object; typ, btyp: DevCPT.Struct;
BEGIN
typ := x.typ;
IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78)
ELSIF typ.form = Pointer THEN
btyp := typ.BaseTyp; strobj := typ.strobj; bstrobj := btyp.strobj;
IF (strobj # NIL) & (strobj.name # DevCPT.null) & (bstrobj # NIL) & (bstrobj.name # DevCPT.null) THEN
btyp.pbused := TRUE
END ;
BindNodes(Nderef, btyp, x, NIL); x.subcl := 0
ELSE err(84)
END
END DeRef;
PROCEDURE StrDeref*(VAR x: DevCPT.Node);
VAR typ, btyp: DevCPT.Struct;
BEGIN
typ := x.typ;
IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78)
ELSIF ((typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form IN charSet)) OR (typ.sysflag = jstr) THEN
IF (typ.BaseTyp # NIL) & (typ.BaseTyp.form = Char8) THEN btyp := DevCPT.string8typ
ELSE btyp := DevCPT.string16typ
END;
BindNodes(Nderef, btyp, x, NIL); x.subcl := 1
ELSE err(90)
END
END StrDeref;
PROCEDURE Index*(VAR x: DevCPT.Node; y: DevCPT.Node);
VAR f: SHORTINT; typ: DevCPT.Struct;
BEGIN
f := y.typ.form;
IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(79)
ELSIF ~(f IN intSet) OR (y.class IN {Nproc, Ntype}) THEN err(80); y.typ := DevCPT.int32typ END ;
IF f = Int64 THEN Convert(y, DevCPT.int32typ) END;
IF x.typ.comp = Array THEN typ := x.typ.BaseTyp;
IF (y.class = Nconst) & ((y.conval.intval < 0) OR (y.conval.intval >= x.typ.n)) THEN err(81) END
ELSIF x.typ.comp = DynArr THEN typ := x.typ.BaseTyp;
IF (y.class = Nconst) & (y.conval.intval < 0) THEN err(81) END
ELSE err(82); typ := DevCPT.undftyp
END ;
BindNodes(Nindex, typ, x, y); x.readonly := x.left.readonly
END Index;
PROCEDURE Field*(VAR x: DevCPT.Node; y: DevCPT.Object);
BEGIN (*x.typ.comp = Record*)
IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(77) END ;
IF (y # NIL) & (y.mode IN {Fld, TProc}) THEN
BindNodes(Nfield, y.typ, x, NIL); x.obj := y;
x.readonly := x.left.readonly OR ((y.vis = externalR) & (y.mnolev < 0))
ELSE err(83); x.typ := DevCPT.undftyp
END
END Field;
PROCEDURE TypTest*(VAR x: DevCPT.Node; obj: DevCPT.Object; guard: BOOLEAN);
PROCEDURE GTT(t0, t1: DevCPT.Struct);
VAR node: DevCPT.Node;
BEGIN
IF (t0 # NIL) & DevCPT.SameType(t0, t1) & (guard OR (x.class # Nguard)) THEN
IF ~guard THEN x := NewBoolConst(TRUE) END
ELSIF (t0 = NIL) OR DevCPT.Extends(t1, t0) OR (t0.sysflag = jint) OR (t1.sysflag = jint)
OR (t1.comp = DynArr) & (DevCPM.java IN DevCPM.options) THEN
IF guard THEN BindNodes(Nguard, NIL, x, NIL); x.readonly := x.left.readonly
ELSE node := DevCPT.NewNode(Nmop); node.subcl := is; node.left := x; node.obj := obj; x := node
END
ELSE err(85)
END
END GTT;
BEGIN
IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(112)
ELSIF x.typ.form = Pointer THEN
IF x.typ = DevCPT.sysptrtyp THEN
IF obj.typ.form = Pointer THEN GTT(NIL, obj.typ.BaseTyp)
ELSE err(86)
END
ELSIF x.typ.BaseTyp.comp # Record THEN err(85)
ELSIF obj.typ.form = Pointer THEN GTT(x.typ.BaseTyp, obj.typ.BaseTyp)
ELSE err(86)
END
ELSIF (x.typ.comp = Record) & (x.class = Nvarpar) & (x.obj.vis # outPar) & (obj.typ.comp = Record) THEN
GTT(x.typ, obj.typ)
ELSE err(87)
END ;
IF guard THEN x.typ := obj.typ ELSE x.typ := DevCPT.booltyp END
END TypTest;
PROCEDURE In*(VAR x: DevCPT.Node; y: DevCPT.Node);
VAR f: SHORTINT; k: INTEGER;
BEGIN f := x.typ.form;
IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)
ELSIF (f IN intSet) & (y.typ.form = Set) THEN
IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
IF x.class = Nconst THEN
k := x.conval.intval;
IF (k < 0) OR (k > DevCPM.MaxSet) THEN err(202)
ELSIF y.class = Nconst THEN x.conval.intval := BoolToInt(k IN y.conval.setval); x.obj := NIL
ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in
END
ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in
END
ELSE err(92)
END ;
x.typ := DevCPT.booltyp
END In;
PROCEDURE MOp*(op: BYTE; VAR x: DevCPT.Node);
VAR f: SHORTINT; typ: DevCPT.Struct; z: DevCPT.Node;
PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; z: DevCPT.Node): DevCPT.Node;
VAR node: DevCPT.Node;
BEGIN
node := DevCPT.NewNode(Nmop); node.subcl := op; node.typ := typ;
node.left := z; RETURN node
END NewOp;
BEGIN z := x;
IF ((z.class = Ntype) OR (z.class = Nproc)) & (op # adr) & (op # typfn) & (op # size) THEN err(126) (* !!! *)
ELSE
typ := z.typ; f := typ.form;
CASE op OF
| not:
IF f = Bool THEN
IF z.class = Nconst THEN
z.conval.intval := BoolToInt(~IntToBool(z.conval.intval)); z.obj := NIL
ELSE z := NewOp(op, typ, z)
END
ELSE err(98)
END
| plus:
IF ~(f IN intSet + realSet) THEN err(96) END
| minus:
IF f IN intSet + realSet + {Set} THEN
IF z.class = Nconst THEN
IF f = Set THEN z.conval.setval := -z.conval.setval
ELSE NegateConst(z.conval, z.conval, z.typ)
END;
z.obj := NIL
ELSE
IF f < Int32 THEN Convert(z, DevCPT.int32typ) END;
z := NewOp(op, z.typ, z)
END
ELSE err(97)
END
| abs:
IF f IN intSet + realSet THEN
IF z.class = Nconst THEN
IF IsNegConst(z.conval, f) THEN NegateConst(z.conval, z.conval, z.typ) END;
z.obj := NIL
ELSE
IF f < Int32 THEN Convert(z, DevCPT.int32typ) END;
z := NewOp(op, z.typ, z)
END
ELSE err(111)
END
| cap:
IF f IN charSet THEN
IF z.class = Nconst THEN
IF ODD(z.conval.intval DIV 32) THEN DEC(z.conval.intval, 32) END;
z.obj := NIL
ELSE z := NewOp(op, typ, z)
END
ELSE err(111); z.typ := DevCPT.char8typ
END
| odd:
IF f IN intSet THEN
IF z.class = Nconst THEN
DivModConst(z.conval, two, FALSE, z.typ); (* z MOD 2 *)
z.obj := NIL
ELSE z := NewOp(op, typ, z)
END
ELSE err(111)
END ;
z.typ := DevCPT.booltyp
| adr: (*ADR*)
IF z.class = Nproc THEN
IF z.obj.mnolev > 0 THEN err(73)
ELSIF z.obj.mode = LProc THEN z.obj.mode := XProc
END;
z := NewOp(op, typ, z)
ELSIF z.class = Ntype THEN
IF z.obj.typ.untagged THEN err(111) END;
z := NewOp(op, typ, z)
ELSIF (z.class < Nconst) OR (z.class = Nconst) & (f IN {String8, String16}) THEN
z := NewOp(op, typ, z)
ELSE err(127)
END ;
z.typ := DevCPT.int32typ
| typfn, size: (*TYP, SIZE*)
z := NewOp(op, typ, z);
z.typ := DevCPT.int32typ
| cc: (*SYSTEM.CC*)
IF (f IN intSet) & (z.class = Nconst) THEN
IF (0 <= z.conval.intval) & (z.conval.intval <= DevCPM.MaxCC) & (z.conval.realval = 0) THEN
z := NewOp(op, typ, z)
ELSE err(219)
END
ELSE err(69)
END;
z.typ := DevCPT.booltyp
END
END;
x := z
END MOp;
PROCEDURE ConstOp(op: SHORTINT; x, y: DevCPT.Node);
VAR f: SHORTINT; i, j: INTEGER; xval, yval: DevCPT.Const; ext: DevCPT.ConstExt; t: DevCPT.Struct;
BEGIN
f := x.typ.form;
IF f = y.typ.form THEN
xval := x.conval; yval := y.conval;
CASE op OF
| times:
IF f IN intSet + realSet THEN MulConst(xval, yval, xval, x.typ)
ELSIF f = Set THEN xval.setval := xval.setval * yval.setval
ELSIF f # Undef THEN err(101)
END
| slash:
IF f IN realSet THEN DivConst(xval, yval, xval, x.typ)
ELSIF f = Set THEN xval.setval := xval.setval / yval.setval
ELSIF f # Undef THEN err(102)
END
| div:
IF f IN intSet THEN DivModConst(xval, yval, TRUE, x.typ)
ELSIF f # Undef THEN err(103)
END
| mod:
IF f IN intSet THEN DivModConst(xval, yval, FALSE, x.typ)
ELSIF f # Undef THEN err(104)
END
| and:
IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) & IntToBool(yval.intval))
ELSE err(94)
END
| plus:
IF f IN intSet + realSet THEN AddConst(xval, yval, xval, x.typ)
ELSIF f = Set THEN xval.setval := xval.setval + yval.setval
ELSIF (f IN {String8, String16}) & (xval.ext # NIL) & (yval.ext # NIL) THEN
NEW(ext, LEN(xval.ext^) + LEN(yval.ext^));
i := 0; WHILE xval.ext[i] # 0X DO ext[i] := xval.ext[i]; INC(i) END;
j := 0; WHILE yval.ext[j] # 0X DO ext[i] := yval.ext[j]; INC(i); INC(j) END;
ext[i] := 0X; xval.ext := ext; INC(xval.intval2, yval.intval2 - 1)
ELSIF f # Undef THEN err(105)
END
| minus:
IF f IN intSet + realSet THEN SubConst(xval, yval, xval, x.typ)
ELSIF f = Set THEN xval.setval := xval.setval - yval.setval
ELSIF f # Undef THEN err(106)
END
| min:
IF f IN intSet + realSet THEN
IF LessConst(yval, xval, f) THEN xval^ := yval^ END
ELSIF f # Undef THEN err(111)
END
| max:
IF f IN intSet + realSet THEN
IF LessConst(xval, yval, f) THEN xval^ := yval^ END
ELSIF f # Undef THEN err(111)
END
| or:
IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) OR IntToBool(yval.intval))
ELSE err(95)
END
| eql: xval.intval := BoolToInt(EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp
| neq: xval.intval := BoolToInt(~EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp
| lss: xval.intval := BoolToInt(LessConst(xval, yval, f)); x.typ := DevCPT.booltyp
| leq: xval.intval := BoolToInt(~LessConst(yval, xval, f)); x.typ := DevCPT.booltyp
| gtr: xval.intval := BoolToInt(LessConst(yval, xval, f)); x.typ := DevCPT.booltyp
| geq: xval.intval := BoolToInt(~LessConst(xval, yval, f)); x.typ := DevCPT.booltyp
END
ELSE err(100)
END;
x.obj := NIL
END ConstOp;
PROCEDURE Op*(op: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node);
VAR f, g: SHORTINT; t, z: DevCPT.Node; typ: DevCPT.Struct; do: BOOLEAN; val: INTEGER;
PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node);
VAR node: DevCPT.Node;
BEGIN
node := DevCPT.NewNode(Ndop); node.subcl := op; node.typ := typ;
node.left := x; node.right := y; x := node
END NewOp;
BEGIN z := x;
IF (z.class = Ntype) OR (z.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)
ELSE
Promote(z, y, op);
IF (z.class = Nconst) & (y.class = Nconst) THEN ConstOp(op, z, y)
ELSE
typ := z.typ; f := typ.form; g := y.typ.form;
CASE op OF
| times:
do := TRUE;
IF f IN intSet THEN
IF z.class = Nconst THEN
IF EqualConst(z.conval, one, f) THEN do := FALSE; z := y
ELSIF EqualConst(z.conval, zero, f) THEN do := FALSE
ELSE val := Log(z);
IF val >= 0 THEN
t := y; y := z; z := t;
op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL
END
END
ELSIF y.class = Nconst THEN
IF EqualConst(y.conval, one, f) THEN do := FALSE
ELSIF EqualConst(y.conval, zero, f) THEN do := FALSE; z := y
ELSE val := Log(y);
IF val >= 0 THEN
op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL
END
END
END
ELSIF ~(f IN {Undef, Real32..Set}) THEN err(105); typ := DevCPT.undftyp
END ;
IF do THEN NewOp(op, typ, z, y) END;
| slash:
IF f IN realSet THEN (* OK *)
ELSIF (f # Set) & (f # Undef) THEN err(102); typ := DevCPT.undftyp
END ;
NewOp(op, typ, z, y)
| div:
do := TRUE;
IF f IN intSet THEN
IF y.class = Nconst THEN
IF EqualConst(y.conval, zero, f) THEN err(205)
ELSIF EqualConst(y.conval, one, f) THEN do := FALSE
ELSE val := Log(y);
IF val >= 0 THEN
op := ash; y.typ := DevCPT.int32typ; y.conval.intval := -val; y.obj := NIL
END
END
END
ELSIF f # Undef THEN err(103); typ := DevCPT.undftyp
END ;
IF do THEN NewOp(op, typ, z, y) END;
| mod:
IF f IN intSet THEN
IF y.class = Nconst THEN
IF EqualConst(y.conval, zero, f) THEN err(205)
ELSE val := Log(y);
IF val >= 0 THEN
op := msk; y.conval.intval := ASH(-1, val); y.obj := NIL
END
END
END
ELSIF f # Undef THEN err(104); typ := DevCPT.undftyp
END ;
NewOp(op, typ, z, y);
| and:
IF f = Bool THEN
IF z.class = Nconst THEN
IF IntToBool(z.conval.intval) THEN z := y END
ELSIF (y.class = Nconst) & IntToBool(y.conval.intval) THEN (* optimize z & TRUE -> z *)
ELSE NewOp(op, typ, z, y)
END
ELSIF f # Undef THEN err(94); z.typ := DevCPT.undftyp
END
| plus:
IF ~(f IN {Undef, Int8..Set, Int64, String8, String16}) THEN err(105); typ := DevCPT.undftyp END;
do := TRUE;
IF f IN intSet THEN
IF (z.class = Nconst) & EqualConst(z.conval, zero, f) THEN do := FALSE; z := y END ;
IF (y.class = Nconst) & EqualConst(y.conval, zero, f) THEN do := FALSE END
ELSIF f IN {String8, String16} THEN
IF (z.class = Nconst) & (z.conval.intval2 = 1) THEN do := FALSE; z := y END ;
IF (y.class = Nconst) & (y.conval.intval2 = 1) THEN do := FALSE END;
IF do THEN
IF z.class = Ndop THEN
t := z; WHILE t.right.class = Ndop DO t := t.right END;
IF (t.right.class = Nconst) & (y.class = Nconst) THEN
ConstOp(op, t.right, y); do := FALSE
ELSIF (t.right.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN
ConstOp(op, t.right, y.left); y.left := t.right; t.right := y; do := FALSE
ELSE
NewOp(op, typ, t.right, y); do := FALSE
END
ELSE
IF (z.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN
ConstOp(op, z, y.left); y.left := z; z := y; do := FALSE
END
END
END
END ;
IF do THEN NewOp(op, typ, z, y) END;
| minus:
IF ~(f IN {Undef, Int8..Set, Int64}) THEN err(106); typ := DevCPT.undftyp END;
IF ~(f IN intSet) OR (y.class # Nconst) OR ~EqualConst(y.conval, zero, f) THEN NewOp(op, typ, z, y)
END;
| min, max:
IF ~(f IN {Undef} + intSet + realSet + charSet) THEN err(111); typ := DevCPT.undftyp END;
NewOp(op, typ, z, y);
| or:
IF f = Bool THEN
IF z.class = Nconst THEN
IF ~IntToBool(z.conval.intval) THEN z := y END
ELSIF (y.class = Nconst) & ~IntToBool(y.conval.intval) THEN (* optimize z OR FALSE -> z *)
ELSE NewOp(op, typ, z, y)
END
ELSIF f # Undef THEN err(95); z.typ := DevCPT.undftyp
END
| eql, neq, lss, leq, gtr, geq:
IF f IN {String8, String16} THEN
IF (f = String16) & (z.class = Nmop) & (z.subcl = conv) & (y.class = Nmop) & (y.subcl = conv) THEN
z := z.left; y := y.left (* remove LONG on both sides *)
ELSIF (z.class = Nconst) & (z.conval.intval2 = 1) & (y.class = Nderef) THEN (* y$ = "" -> y[0] = 0X *)
y := y.left; Index(y, NewIntConst(0)); z.typ := y.typ; z.conval.intval := 0
ELSIF (y.class = Nconst) & (y.conval.intval2 = 1) & (z.class = Nderef) THEN (* z$ = "" -> z[0] = 0X *)
z := z.left; Index(z, NewIntConst(0)); y.typ := z.typ; y.conval.intval := 0
END;
typ := DevCPT.booltyp
ELSIF (f IN {Undef, Char8..Real64, Char16, Int64})
OR (op <= neq) & ((f IN {Bool, Set, NilTyp, Pointer, ProcTyp}) OR (typ = DevCPT.guidtyp)) THEN
typ := DevCPT.booltyp
ELSE err(107); typ := DevCPT.undftyp
END;
NewOp(op, typ, z, y)
END
END
END;
x := z
END Op;
PROCEDURE SetRange*(VAR x: DevCPT.Node; y: DevCPT.Node);
VAR k, l: INTEGER;
BEGIN
IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)
ELSIF (x.typ.form IN intSet) & (y.typ.form IN intSet) THEN
IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END;
IF y.typ.form = Int64 THEN Convert(y, DevCPT.int32typ) END;
IF x.class = Nconst THEN
k := x.conval.intval;
IF (0 > k) OR (k > DevCPM.MaxSet) OR (x.conval.realval # 0) THEN err(202) END
END ;
IF y.class = Nconst THEN
l := y.conval.intval;
IF (0 > l) OR (l > DevCPM.MaxSet) OR (y.conval.realval # 0) THEN err(202) END
END ;
IF (x.class = Nconst) & (y.class = Nconst) THEN
IF k <= l THEN
x.conval.setval := {k..l}
ELSE err(201); x.conval.setval := {l..k}
END ;
x.obj := NIL
ELSE BindNodes(Nupto, DevCPT.settyp, x, y)
END
ELSE err(93)
END ;
x.typ := DevCPT.settyp
END SetRange;
PROCEDURE SetElem*(VAR x: DevCPT.Node);
VAR k: INTEGER;
BEGIN
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END;
IF x.typ.form IN intSet THEN
IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END;
IF x.class = Nconst THEN
k := x.conval.intval;
IF (0 <= k) & (k <= DevCPM.MaxSet) & (x.conval.realval = 0) THEN x.conval.setval := {k}
ELSE err(202)
END ;
x.obj := NIL
ELSE BindNodes(Nmop, DevCPT.settyp, x, NIL); x.subcl := bit
END ;
ELSE err(93)
END;
x.typ := DevCPT.settyp
END SetElem;
PROCEDURE CheckAssign* (x: DevCPT.Struct; VAR ynode: DevCPT.Node);
(* x := y, checks assignment compatibility *)
VAR f, g: SHORTINT; y, b: DevCPT.Struct;
BEGIN
y := ynode.typ; f := x.form; g := y.form;
IF (ynode.class = Ntype) OR (ynode.class = Nproc) & (f # ProcTyp) THEN err(126) END ;
CASE f OF
| Undef, String8, String16, Byte:
| Bool, Set:
IF g # f THEN err(113) END
| Int8, Int16, Int32, Int64, Real32, Real64: (* SR *)
IF (g IN intSet) OR (g IN realSet) & (f IN realSet) THEN
IF ynode.class = Nconst THEN Convert(ynode, x)
ELSIF ~DevCPT.Includes(f, g) THEN err(113)
END
ELSE err(113)
END
(*
IF ~(g IN intSet + realSet) OR ~DevCPT.Includes(f, g) & (~(g IN intSet) OR (ynode.class # Nconst)) THEN
err(113)
ELSIF ynode.class = Nconst THEN Convert(ynode, x)
END
*)
| Char8, Char16:
IF ~(g IN charSet) OR ~DevCPT.Includes(f, g) THEN err(113)
ELSIF ynode.class = Nconst THEN Convert(ynode, x)
END
| Pointer:
b := x.BaseTyp;
IF DevCPT.Extends(y, x)
OR (g = NilTyp)
OR (g = Pointer)
& ((x = DevCPT.sysptrtyp) OR (DevCPM.java IN DevCPM.options) & (x = DevCPT.anyptrtyp))
THEN (* ok *)
ELSIF (b.comp = DynArr) & b.untagged THEN (* pointer to untagged open array *)
IF ynode.class = Nconst THEN CheckString(ynode, b, 113)
ELSIF ~(y.comp IN {Array, DynArr}) OR ~DevCPT.EqualType(b.BaseTyp, y.BaseTyp) THEN err(113)
END
ELSIF b.untagged & (ynode.class = Nmop) & (ynode.subcl = adr) THEN (* p := ADR(r) *)
IF (b.comp = DynArr) & (ynode.left.class = Nconst) THEN CheckString(ynode.left, b, 113)
ELSIF ~DevCPT.Extends(ynode.left.typ, b) THEN err(113)
END
ELSIF (b.sysflag = jstr) & ((g = String16) OR (ynode.class = Nconst) & (g IN {Char8, Char16, String8}))
THEN
IF g # String16 THEN Convert(ynode, DevCPT.string16typ) END
ELSE err(113)
END
| ProcTyp:
IF DevCPT.EqualType(x, y) OR (g = NilTyp) THEN (* ok *)
ELSIF (ynode.class = Nproc) & (ynode.obj.mode IN {XProc, IProc, LProc}) THEN
IF ynode.obj.mode = LProc THEN
IF ynode.obj.mnolev = 0 THEN ynode.obj.mode := XProc ELSE err(73) END
END;
IF (x.sysflag = 0) & (ynode.obj.sysflag >= 0) OR (x.sysflag = ynode.obj.sysflag) THEN
IF DevCPT.EqualType(x.BaseTyp, ynode.obj.typ) THEN CheckParameters(x.link, ynode.obj.link, FALSE)
ELSE err(117)
END
ELSE err(113)
END
ELSE err(113)
END
| NoTyp, NilTyp: err(113)
| Comp:
x.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *)
IF x.comp = Record THEN
IF ~DevCPT.EqualType(x, y) OR (x.attribute # 0) THEN err(113) END
ELSIF g IN {Char8, Char16, String8, String16} THEN
IF (x.BaseTyp.form = Char16) & (g = String8) THEN Convert(ynode, DevCPT.string16typ)
ELSE CheckString(ynode, x, 113);
END;
IF (x # DevCPT.guidtyp) & (x.comp = Array) & (ynode.class = Nconst) & (ynode.conval.intval2 > x.n) THEN
err(114)
END
ELSIF (x.comp = Array) & DevCPT.EqualType(x, y) THEN (* ok *)
ELSE err(113)
END
END
END CheckAssign;
PROCEDURE AssignString (VAR x: DevCPT.Node; str: DevCPT.Node); (* x := str or x[0] := 0X *)
BEGIN
ASSERT((str.class = Nconst) & (str.typ.form IN {String8, String16}));
IF (x.typ.comp IN {Array, DynArr}) & (str.conval.intval2 = 1) THEN (* x := "" -> x[0] := 0X *)
Index(x, NewIntConst(0));
str.typ := x.typ; str.conval.intval := 0;
END;
BindNodes(Nassign, DevCPT.notyp, x, str); x.subcl := assign
END AssignString;
PROCEDURE CheckLeaf(x: DevCPT.Node; dynArrToo: BOOLEAN);
BEGIN
IF (x.class = Nmop) & (x.subcl = val) THEN x := x.left END ;
IF x.class = Nguard THEN x := x.left END ; (* skip last (and unique) guard *)
IF (x.class = Nvar) & (dynArrToo OR (x.typ.comp # DynArr)) THEN x.obj.leaf := FALSE END
END CheckLeaf;
PROCEDURE CheckOldType (x: DevCPT.Node);
BEGIN
IF ~(DevCPM.oberon IN DevCPM.options)
& ((x.typ = DevCPT.lreal64typ) OR (x.typ = DevCPT.lint64typ) OR (x.typ = DevCPT.lchar16typ)) THEN
err(198)
END
END CheckOldType;
PROCEDURE StPar0*(VAR par0: DevCPT.Node; fctno: SHORTINT); (* par0: first param of standard proc *)
VAR f: SHORTINT; typ: DevCPT.Struct; x, t: DevCPT.Node;
BEGIN x := par0; f := x.typ.form;
CASE fctno OF
haltfn: (*HALT*)
IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN
IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN
BindNodes(Ntrap, DevCPT.notyp, x, x)
ELSE err(218)
END
ELSIF (DevCPM.java IN DevCPM.options)
& ((x.class = Ntype) OR (x.class = Nvar))
& (x.typ.form = Pointer)
THEN
BindNodes(Ntrap, DevCPT.notyp, x, x)
ELSE err(69)
END ;
x.typ := DevCPT.notyp
| newfn: (*NEW*)
typ := DevCPT.notyp;
IF NotVar(x) THEN err(112)
ELSIF f = Pointer THEN
IF DevCPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ;
IF x.readonly THEN err(76)
ELSIF (x.typ.BaseTyp.attribute = absAttr)
OR (x.typ.BaseTyp.attribute = limAttr) & (x.typ.BaseTyp.mno # 0) THEN err(193)
ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167)
END ;
MarkAsUsed(x);
f := x.typ.BaseTyp.comp;
IF f IN {Record, DynArr, Array} THEN
IF f = DynArr THEN typ := x.typ.BaseTyp END ;
BindNodes(Nassign, DevCPT.notyp, x, NIL); x.subcl := newfn
ELSE err(111)
END
ELSE err(111)
END ;
x.typ := typ
| absfn: (*ABS*)
MOp(abs, x)
| capfn: (*CAP*)
MOp(cap, x)
| ordfn: (*ORD*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f = Char8 THEN Convert(x, DevCPT.int16typ)
ELSIF f = Char16 THEN Convert(x, DevCPT.int32typ)
ELSIF f = Set THEN Convert(x, DevCPT.int32typ)
ELSE err(111)
END
| bitsfn: (*BITS*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN {Int8, Int16, Int32} THEN Convert(x, DevCPT.settyp)
ELSE err(111)
END
| entierfn: (*ENTIER*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ)
ELSE err(111)
END ;
x.typ := DevCPT.int64typ
| lentierfcn: (* LENTIER *)
IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ)
ELSE err(111)
END ;
x.typ := DevCPT.int64typ
| oddfn: (*ODD*)
MOp(odd, x)
| minfn: (*MIN*)
IF x.class = Ntype THEN
CheckOldType(x);
CASE f OF
Bool:x := NewBoolConst(FALSE)
| Char8:x := NewIntConst(0); x.typ := DevCPT.char8typ
| Char16:x := NewIntConst(0); x.typ := DevCPT.char8typ
| Int8:x := NewIntConst(-128)
| Int16:x := NewIntConst(-32768)
| Int32:x := NewIntConst(-2147483648)
| Int64:x := NewLargeIntConst(0, -9223372036854775808.0E0) (* -2^63 *)
| Set:x := NewIntConst(0) (*; x.typ := DevCPT.int16typ *)
| Real32:x := NewRealConst(DevCPM.MinReal32, DevCPT.real64typ)
| Real64: x := NewRealConst(DevCPM.MinReal64, DevCPT.real64typ)
ELSE err(111)
END;
x.hint := 1
ELSIF ~(f IN intSet + realSet + charSet) THEN err(111)
END
| maxfn: (*MAX*)
IF x.class = Ntype THEN
CheckOldType(x);
CASE f OF
Bool:x := NewBoolConst(TRUE)
| Char8:x := NewIntConst(0FFH); x.typ := DevCPT.char8typ
| Char16:x := NewIntConst(0FFFFH); x.typ := DevCPT.char16typ
| Int8:x := NewIntConst(127)
| Int16:x := NewIntConst(32767)
| Int32:x := NewIntConst(2147483647)
| Int64:x := NewLargeIntConst(-1, 9223372036854775808.0E0) (* 2^63 - 1 *)
| Set:x := NewIntConst(31) (*; x.typ := DevCPT.int16typ *)
| Real32:x := NewRealConst(DevCPM.MaxReal32, DevCPT.real64typ)
| Real64: x := NewRealConst(DevCPM.MaxReal64, DevCPT.real64typ)
ELSE err(111)
END;
x.hint := 1
ELSIF ~(f IN intSet + realSet + charSet) THEN err(111)
END
| chrfn: (*CHR*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ)
ELSE err(111); x.typ := DevCPT.char16typ
END
| lchrfn: (* LCHR *)
IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ)
ELSE err(111); x.typ := DevCPT.char16typ
END
| shortfn: (*SHORT*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSE
IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form
END;
IF f = Int16 THEN Convert(x, DevCPT.int8typ)
ELSIF f = Int32 THEN Convert(x, DevCPT.int16typ)
ELSIF f = Int64 THEN Convert(x, DevCPT.int32typ)
ELSIF f = Real64 THEN Convert(x, DevCPT.real32typ)
ELSIF f = Char16 THEN Convert(x, DevCPT.char8typ)
ELSIF f = String16 THEN Convert(x, DevCPT.string8typ)
ELSE err(111)
END
END
| longfn: (*LONG*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSE
IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form
END;
IF f = Int8 THEN Convert(x, DevCPT.int16typ)
ELSIF f = Int16 THEN Convert(x, DevCPT.int32typ)
ELSIF f = Int32 THEN Convert(x, DevCPT.int64typ)
ELSIF f = Real32 THEN Convert(x, DevCPT.real64typ)
ELSIF f = Char8 THEN Convert(x, DevCPT.char16typ)
ELSIF f = String8 THEN Convert(x, DevCPT.string16typ)
ELSE err(111)
END
END
| incfn, decfn: (*INC, DEC*)
IF NotVar(x) THEN err(112)
ELSIF ~(f IN intSet) THEN err(111)
ELSIF x.readonly THEN err(76)
END;
MarkAsUsed(x)
| inclfn, exclfn: (*INCL, EXCL*)
IF NotVar(x) THEN err(112)
ELSIF f # Set THEN err(111); x.typ := DevCPT.settyp
ELSIF x.readonly THEN err(76)
END;
MarkAsUsed(x)
| lenfn: (*LEN*)
IF (* (x.class = Ntype) OR *) (x.class = Nproc) THEN err(126) (* !!! *)
(* ELSIF x.typ.sysflag = jstr THEN StrDeref(x) *)
ELSE
IF x.typ.form = Pointer THEN DeRef(x) END;
IF x.class = Nconst THEN
IF x.typ.form = Char8 THEN CharToString8(x)
ELSIF x.typ.form = Char16 THEN CharToString16(x)
END
END;
IF ~(x.typ.comp IN {DynArr, Array}) & ~(x.typ.form IN {String8, String16}) THEN err(131) END
END
| copyfn: (*COPY*)
IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END
| ashfn: (*ASH*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN intSet THEN
IF f < Int32 THEN Convert(x, DevCPT.int32typ) END
ELSE err(111); x.typ := DevCPT.int32typ
END
| adrfn: (*ADR*)
IF x.class = Ntype THEN CheckOldType(x) END;
CheckLeaf(x, FALSE); MOp(adr, x)
| typfn: (*TYP*)
CheckLeaf(x, FALSE);
IF x.class = Ntype THEN
CheckOldType(x);
IF x.typ.form = Pointer THEN x := NewLeaf(x.typ.BaseTyp.strobj) END;
IF x.typ.comp # Record THEN err(111) END;
MOp(adr, x)
ELSE
IF x.typ.form = Pointer THEN DeRef(x) END;
IF x.typ.comp # Record THEN err(111) END;
MOp(typfn, x)
END
| sizefn: (*SIZE*)
IF x.class # Ntype THEN err(110); x := NewIntConst(1)
ELSIF (f IN {Byte..Set, Pointer, ProcTyp, Char16, Int64}) OR (x.typ.comp IN {Array, Record}) THEN
CheckOldType(x); x.typ.pvused := TRUE;
IF typSize # NIL THEN
typSize(x.typ); x := NewIntConst(x.typ.size)
ELSE
MOp(size, x)
END
ELSE err(111); x := NewIntConst(1)
END
| thisrecfn, (*THISRECORD*)
thisarrfn: (*THISARRAY*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN {Int8, Int16} THEN Convert(x, DevCPT.int32typ)
ELSIF f # Int32 THEN err(111)
END
| ccfn: (*SYSTEM.CC*)
MOp(cc, x)
| lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF ~(f IN intSet + charSet + {Byte, Set}) THEN err(111)
END
| getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ)
ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ
END
| getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*)
IF (f IN intSet) & (x.class = Nconst) THEN
IF (x.conval.intval < DevCPM.MinRegNr) OR (x.conval.intval > DevCPM.MaxRegNr) THEN err(220)
END
ELSE err(69)
END
| valfn: (*SYSTEM.VAL*)
IF x.class # Ntype THEN err(110)
ELSIF (f IN {Undef, String8, String16, NoTyp, NilTyp}) (* OR (x.typ.comp = DynArr) *) THEN err(111)
ELSE CheckOldType(x)
END
| assertfn: (*ASSERT*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := NewBoolConst(FALSE)
ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE)
ELSE MOp(not, x)
END
| validfn: (* VALID *)
IF (x.class = Nvarpar) & ODD(x.obj.sysflag DIV nilBit) THEN
MOp(adr, x); x.typ := DevCPT.sysptrtyp; Op(neq, x, Nil())
ELSE err(111)
END;
x.typ := DevCPT.booltyp
| iidfn: (* COM.IID *)
IF (x.class = Nconst) & (f = String8) THEN StringToGuid(x)
ELSE
typ := x.typ;
IF typ.form = Pointer THEN typ := typ.BaseTyp END;
IF (typ.sysflag = interface) & (typ.ext # NIL) & (typ.strobj # NIL) THEN
IF x.obj # typ.strobj THEN x := NewLeaf(typ.strobj) END
ELSE err(111)
END;
x.class := Nconst; x.typ := DevCPT.guidtyp
END
| queryfn: (* COM.QUERY *)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f # Pointer THEN err(111)
END
END ;
par0 := x
END StPar0;
PROCEDURE StPar1*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno: BYTE);
(* x: second parameter of standard proc *)
VAR f, n, L, i: INTEGER; typ, tp1: DevCPT.Struct; p, t: DevCPT.Node;
PROCEDURE NewOp(class, subcl: BYTE; left, right: DevCPT.Node): DevCPT.Node;
VAR node: DevCPT.Node;
BEGIN
node := DevCPT.NewNode(class); node.subcl := subcl;
node.left := left; node.right := right; RETURN node
END NewOp;
BEGIN p := par0; f := x.typ.form;
CASE fctno OF
incfn, decfn: (*INC DEC*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); p.typ := DevCPT.notyp
ELSE
IF f # p.typ.form THEN
IF f IN intSet THEN Convert(x, p.typ)
ELSE err(111)
END
END ;
p := NewOp(Nassign, fctno, p, x);
p.typ := DevCPT.notyp
END
| inclfn, exclfn: (*INCL, EXCL*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN intSet THEN
IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
IF (x.class = Nconst) & ((0 > x.conval.intval) OR (x.conval.intval > DevCPM.MaxSet)) THEN err(202)
END ;
p := NewOp(Nassign, fctno, p, x)
ELSE err(111)
END ;
p.typ := DevCPT.notyp
| lenfn: (*LEN*)
IF ~(f IN intSet) OR (x.class # Nconst) THEN err(69)
ELSE
IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
L := SHORT(x.conval.intval); typ := p.typ;
WHILE (L > 0) & (typ.comp IN {DynArr, Array}) DO typ := typ.BaseTyp; DEC(L) END ;
IF (L # 0) OR ~(typ.comp IN {DynArr, Array}) THEN err(132)
ELSE x.obj := NIL;
IF typ.comp = DynArr THEN
WHILE p.class = Nindex DO
p := p.left; INC(x.conval.intval) (* possible side effect ignored *)
END;
p := NewOp(Ndop, len, p, x); p.typ := DevCPT.int32typ
ELSE p := x; p.conval.intval := typ.n; p.typ := DevCPT.int32typ
END
END
END
| copyfn: (*COPY*)
IF NotVar(x) THEN err(112)
ELSIF x.readonly THEN err(76)
ELSE
CheckString(p, x.typ, 111); t := x; x := p; p := t;
IF (x.class = Nconst) & (x.typ.form IN {String8, String16}) THEN AssignString(p, x)
ELSE p := NewOp(Nassign, copyfn, p, x)
END
END ;
p.typ := DevCPT.notyp; MarkAsUsed(x)
| ashfn: (*ASH*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN intSet THEN
IF (x.class = Nconst) & ((x.conval.intval > 64) OR (x.conval.intval < -64)) THEN err(208)
ELSIF (p.class = Nconst) & (x.class = Nconst) THEN
n := x.conval.intval;
IF n > 0 THEN
WHILE n > 0 DO MulConst(p.conval, two, p.conval, p.typ); DEC(n) END
ELSE
WHILE n < 0 DO DivModConst(p.conval, two, TRUE, p.typ); INC(n) END
END;
p.obj := NIL
ELSE
IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
typ := p.typ; p := NewOp(Ndop, ash, p, x); p.typ := typ
END
ELSE err(111)
END
| minfn: (*MIN*)
IF p.class # Ntype THEN Op(min, p, x) ELSE err(64) END
| maxfn: (*MAX*)
IF p.class # Ntype THEN Op(max, p, x) ELSE err(64) END
| newfn: (*NEW(p, x...)*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF p.typ.comp = DynArr THEN
IF f IN intSet THEN
IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
IF (x.class = Nconst) & (x.conval.intval <= 0)
& (~(DevCPM.java IN DevCPM.options) OR (x.conval.intval < 0))THEN err(63) END
ELSE err(111)
END ;
p.right := x; p.typ := p.typ.BaseTyp
ELSIF (p.left # NIL) & (p.left.typ.form = Pointer) THEN
typ := p.left.typ;
WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END;
IF typ.sysflag = interface THEN
typ := x.typ;
WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END;
IF (f = Pointer) & (typ.sysflag = interface) THEN
p.right := x
ELSE err(169)
END
ELSE err(64)
END
ELSE err(111)
END
| thisrecfn, (*THISRECORD*)
thisarrfn: (*THISARRAY*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN {Int8, Int16, Int32} THEN
IF f < Int32 THEN Convert(x, DevCPT.int32typ) END;
p := NewOp(Ndop, fctno, p, x); p.typ := DevCPT.undftyp
ELSE err(111)
END
| lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF ~(f IN intSet) THEN err(111)
ELSE
IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ;
p.typ := p.left.typ
END
| getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN {Undef..Set, NilTyp, Pointer, ProcTyp, Char16, Int64} THEN
IF (fctno = getfn) OR (fctno = getrfn) THEN
IF NotVar(x) THEN err(112) END ;
t := x; x := p; p := t
END ;
p := NewOp(Nassign, fctno, p, x)
ELSE err(111)
END ;
p.typ := DevCPT.notyp
| bitfn: (*SYSTEM.BIT*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN intSet THEN
p := NewOp(Ndop, bit, p, x)
ELSE err(111)
END ;
p.typ := DevCPT.booltyp
| valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF x.typ.comp = DynArr THEN
IF x.typ.untagged & ((p.typ.comp # DynArr) OR p.typ.untagged) THEN (* ok *)
ELSIF (p.typ.comp = DynArr) & (x.typ.n = p.typ.n) THEN
typ := x.typ;
WHILE typ.comp = DynArr DO typ := typ.BaseTyp END;
tp1 := p.typ;
WHILE tp1.comp = DynArr DO tp1 := tp1.BaseTyp END;
IF typ.size # tp1.size THEN err(115) END
ELSE err(115)
END
ELSIF p.typ.comp = DynArr THEN err(115)
ELSIF (x.class = Nconst) & (f = String8) & (p.typ.form = Int32) & (x.conval.intval2 <= 5) THEN
i := 0; n := 0;
WHILE i < x.conval.intval2 - 1 DO n := 256 * n + ORD(x.conval.ext[i]); INC(i) END;
x := NewIntConst(n)
ELSIF (f IN {Undef, NoTyp, NilTyp}) OR (f IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) THEN err(111)
END ;
IF (x.class = Nconst) & (x.typ = p.typ) THEN (* ok *)
ELSIF (x.class >= Nconst) OR ((f IN realSet) # (p.typ.form IN realSet))
OR (DevCPM.options * {DevCPM.java, DevCPM.allSysVal} # {}) THEN
t := DevCPT.NewNode(Nmop); t.subcl := val; t.left := x; x := t
ELSE x.readonly := FALSE
END ;
x.typ := p.typ; p := x
| movefn: (*SYSTEM.MOVE*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ)
ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ
END ;
p.link := x
| assertfn: (*ASSERT*)
IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN
IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN
BindNodes(Ntrap, DevCPT.notyp, x, x);
Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
ELSE err(218)
END
ELSIF
(DevCPM.java IN DevCPM.options) & ((x.class = Ntype) OR (x.class = Nvar)) & (x.typ.form = Pointer)
THEN
BindNodes(Ntrap, DevCPT.notyp, x, x);
Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
ELSE err(69)
END;
IF p = NIL THEN (* ASSERT(TRUE) *)
ELSIF p.class = Ntrap THEN err(99)
ELSE p.subcl := assertfn
END
| queryfn: (* COM.QUERY *)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF x.typ # DevCPT.guidtyp THEN err(111); x.typ := DevCPT.guidtyp
END;
p.link := x
ELSE err(64)
END ;
par0 := p
END StPar1;
PROCEDURE StParN*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno, n: SHORTINT);
(* x: n+1-th param of standard proc *)
VAR node: DevCPT.Node; f: SHORTINT; p: DevCPT.Node; typ: DevCPT.Struct;
BEGIN p := par0; f := x.typ.form;
IF fctno = newfn THEN (*NEW(p, ..., x...*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF p.typ.comp # DynArr THEN err(64)
ELSIF f IN intSet THEN
IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
IF (x.class = Nconst) & (x.conval.intval <= 0) THEN err(63) END;
node := p.right; WHILE node.link # NIL DO node := node.link END;
node.link := x; p.typ := p.typ.BaseTyp
ELSE err(111)
END
ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF f IN intSet THEN
node := DevCPT.NewNode(Nassign); node.subcl := movefn; node.right := p;
node.left := p.link; p.link := x; p := node
ELSE err(111)
END ;
p.typ := DevCPT.notyp
ELSIF (fctno = queryfn) & (n = 2) THEN (* COM.QUERY *)
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF (x.class < Nconst) & (f = Pointer) & (x.typ.sysflag = interface) THEN
IF ~DevCPT.Extends(p.typ, x.typ) THEN err(164) END;
IF x.readonly THEN err(76) END;
CheckNewParamPair(x, p.link);
MarkAsUsed(x);
node := DevCPT.NewNode(Ndop); node.subcl := queryfn;
node.left := p; node.right := p.link; p.link := NIL; node.right.link := x; p := node
ELSE err(111)
END;
p.typ := DevCPT.booltyp
ELSE err(64)
END ;
par0 := p
END StParN;
PROCEDURE StFct*(VAR par0: DevCPT.Node; fctno: BYTE; parno: SHORTINT);
VAR dim: SHORTINT; x, p: DevCPT.Node;
BEGIN p := par0;
IF fctno <= ashfn THEN
IF (fctno = newfn) & (p.typ # DevCPT.notyp) THEN
IF p.typ.comp = DynArr THEN err(65) END ;
p.typ := DevCPT.notyp
ELSIF (fctno = minfn) OR (fctno = maxfn) THEN
IF (parno < 1) OR (parno = 1) & (p.hint # 1) THEN err(65) END;
p.hint := 0
ELSIF fctno <= sizefn THEN (* 1 param *)
IF parno < 1 THEN err(65) END
ELSE (* more than 1 param *)
IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*)
BindNodes(Nassign, DevCPT.notyp, p, NewIntConst(1)); p.subcl := fctno; p.right.typ := p.left.typ
ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*)
IF p.typ.form IN {String8, String16} THEN
IF p.class = Nconst THEN p := NewIntConst(p.conval.intval2 - 1)
ELSIF (p.class = Ndop) & (p.subcl = plus) THEN (* propagate to leaf nodes *)
StFct(p.left, lenfn, 1); StFct(p.right, lenfn, 1); p.typ := DevCPT.int32typ
ELSE
WHILE (p.class = Nmop) & (p.subcl = conv) DO p := p.left END;
IF DevCPM.errors = 0 THEN ASSERT(p.class = Nderef) END;
BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(0)); p.subcl := len
END
ELSIF p.typ.comp = DynArr THEN dim := 0;
WHILE p.class = Nindex DO p := p.left; INC(dim) END ; (* possible side effect ignored *)
BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(dim)); p.subcl := len
ELSE
p := NewIntConst(p.typ.n)
END
ELSIF parno < 2 THEN err(65)
END
END
ELSIF fctno = assertfn THEN
IF parno = 1 THEN x := NIL;
BindNodes(Ntrap, DevCPT.notyp, x, NewIntConst(AssertTrap));
Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
IF p = NIL THEN (* ASSERT(TRUE) *)
ELSIF p.class = Ntrap THEN err(99)
ELSE p.subcl := assertfn
END
ELSIF parno < 1 THEN err(65)
END
ELSIF (fctno >= lchrfn) & (fctno <= bytesfn) THEN
IF parno < 1 THEN err(65) END
ELSIF fctno < validfn THEN (*SYSTEM*)
IF (parno < 1) OR
(fctno > ccfn) & (parno < 2) OR
(fctno = movefn) & (parno < 3) THEN err(65)
END
ELSIF (fctno = thisrecfn) OR (fctno = thisarrfn) THEN
IF parno < 2 THEN err(65) END
ELSE (* COM *)
IF fctno = queryfn THEN
IF parno < 3 THEN err(65) END
ELSE
IF parno < 1 THEN err(65) END
END
END ;
par0 := p
END StFct;
PROCEDURE DynArrParCheck (ftyp: DevCPT.Struct; VAR ap: DevCPT.Node; fvarpar: BOOLEAN);
(* check array compatibility *)
VAR atyp: DevCPT.Struct;
BEGIN (* ftyp.comp = DynArr *)
atyp := ap.typ;
IF atyp.form IN {Char8, Char16, String8, String16} THEN
IF ~fvarpar & (ftyp.BaseTyp.form = Char16) & (atyp.form = String8) THEN Convert(ap, DevCPT.string16typ)
ELSE CheckString(ap, ftyp, 67)
END
ELSE
WHILE (ftyp.comp = DynArr) & ((atyp.comp IN {Array, DynArr}) OR (atyp.form IN {String8, String16})) DO
ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp
END;
IF ftyp.comp = DynArr THEN err(67)
ELSIF ~fvarpar & (ftyp.form = Pointer) & DevCPT.Extends(atyp, ftyp) THEN (* ok *)
ELSIF ~DevCPT.EqualType(ftyp, atyp) THEN err(66)
END
END
END DynArrParCheck;
PROCEDURE PrepCall*(VAR x: DevCPT.Node; VAR fpar: DevCPT.Object);
BEGIN
IF (x.obj # NIL) & (x.obj.mode IN {LProc, XProc, TProc, CProc}) THEN
fpar := x.obj.link;
IF x.obj.mode = TProc THEN
IF fpar.typ.form = Pointer THEN
IF x.left.class = Nderef THEN x.left := x.left.left (*undo DeRef*) ELSE err(71) END
END;
fpar := fpar.link
END
ELSIF (x.class # Ntype) & (x.typ # NIL) & (x.typ.form = ProcTyp) THEN
fpar := x.typ.link
ELSE err(121); fpar := NIL; x.typ := DevCPT.undftyp
END
END PrepCall;
PROCEDURE Param* (VAR ap: DevCPT.Node; fp: DevCPT.Object); (* checks parameter compatibilty *)
VAR at, ft: DevCPT.Struct;
BEGIN
at := ap.typ; ft := fp.typ;
IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *)
IF ft.form # Undef THEN
IF (ap.class = Ntype) OR (ap.class = Nproc) & (ft.form # ProcTyp) THEN err(126) END;
IF fp.mode = VarPar THEN
IF ODD(fp.sysflag DIV nilBit) & (at = DevCPT.niltyp) THEN (* ok *)
ELSIF (ft.comp = Record) & ~ft.untagged & (ap.class = Ndop) & (ap.subcl = thisrecfn) THEN (* ok *)
ELSIF (ft.comp = DynArr) & ~ft.untagged & (ft.n = 0) & (ap.class = Ndop) & (ap.subcl = thisarrfn) THEN
(* ok *)
ELSE
IF fp.vis = inPar THEN
IF (ft = DevCPT.guidtyp) & (ap.class = Nconst) & (at.form = String8) THEN
StringToGuid(ap); at := ap.typ
(*
ELSIF ((at.form IN charSet + {String8, String16}) OR (at = DevCPT.guidtyp))
& ((ap.class = Nderef) OR (ap.class = Nconst)) THEN (* ok *)
ELSIF NotVar(ap) THEN err(122)
*)
END;
IF ~NotVar(ap) THEN CheckLeaf(ap, FALSE) END
ELSE
IF NotVar(ap) THEN err(122)
ELSIF ap.readonly THEN err(76)
ELSIF (ap.obj # NIL) & ODD(ap.obj.sysflag DIV newBit) & ~ODD(fp.sysflag DIV newBit) THEN
err(167)
ELSE MarkAsUsed(ap); CheckLeaf(ap, FALSE)
END
END;
IF ft.comp = DynArr THEN DynArrParCheck(ft, ap, fp.vis # inPar)
ELSIF ODD(fp.sysflag DIV newBit) THEN
IF ~DevCPT.Extends(at, ft) THEN err(123) END
ELSIF (ft = DevCPT.sysptrtyp) & (at.form = Pointer) THEN (* ok *)
ELSIF (fp.vis # outPar) & (ft.comp = Record) & DevCPT.Extends(at, ft) THEN (* ok *)
ELSIF covarOut & (fp.vis = outPar) & (ft.form = Pointer) & DevCPT.Extends(ft, at) THEN (* ok *)
ELSIF fp.vis = inPar THEN CheckAssign(ft, ap)
ELSIF ~DevCPT.EqualType(ft, at) THEN err(123)
END
END
ELSIF ft.comp = DynArr THEN DynArrParCheck(ft, ap, FALSE)
ELSE CheckAssign(ft, ap)
END
END
END Param;
PROCEDURE StaticLink*(dlev: BYTE; var: BOOLEAN);
VAR scope: DevCPT.Object;
BEGIN
scope := DevCPT.topScope;
WHILE dlev > 0 DO DEC(dlev);
INCL(scope.link.conval.setval, slNeeded);
scope := scope.left
END;
IF var THEN INCL(scope.link.conval.setval, imVar) END (* !!! *)
END StaticLink;
PROCEDURE Call*(VAR x: DevCPT.Node; apar: DevCPT.Node; fp: DevCPT.Object);
VAR typ: DevCPT.Struct; p: DevCPT.Node; lev: BYTE;
BEGIN
IF x.class = Nproc THEN typ := x.typ;
lev := x.obj.mnolev;
IF lev > 0 THEN StaticLink(SHORT(SHORT(DevCPT.topScope.mnolev-lev)), FALSE) END ; (* !!! *)
IF x.obj.mode = IProc THEN err(121) END
ELSIF (x.class = Nfield) & (x.obj.mode = TProc) THEN typ := x.typ;
x.class := Nproc; p := x.left; x.left := NIL; p.link := apar; apar := p; fp := x.obj.link
ELSE typ := x.typ.BaseTyp
END ;
BindNodes(Ncall, typ, x, apar); x.obj := fp
END Call;
PROCEDURE Enter*(VAR procdec: DevCPT.Node; stat: DevCPT.Node; proc: DevCPT.Object);
VAR x: DevCPT.Node;
BEGIN
x := DevCPT.NewNode(Nenter); x.typ := DevCPT.notyp; x.obj := proc;
x.left := procdec; x.right := stat; procdec := x
END Enter;
PROCEDURE Return*(VAR x: DevCPT.Node; proc: DevCPT.Object);
VAR node: DevCPT.Node;
BEGIN
IF proc = NIL THEN (* return from module *)
IF x # NIL THEN err(124) END
ELSE
IF x # NIL THEN CheckAssign(proc.typ, x)
ELSIF proc.typ # DevCPT.notyp THEN err(124)
END
END ;
node := DevCPT.NewNode(Nreturn); node.typ := DevCPT.notyp; node.obj := proc; node.left := x; x := node
END Return;
PROCEDURE Assign*(VAR x: DevCPT.Node; y: DevCPT.Node);
VAR z: DevCPT.Node;
BEGIN
IF (x.class >= Nconst) OR (x.typ.form IN {String8, String16}) THEN err(56) END ;
CheckAssign(x.typ, y);
IF x.readonly THEN err(76)
ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167)
END ;
MarkAsUsed(x);
IF (y.class = Nconst) & (y.typ.form IN {String8, String16}) & (x.typ.form # Pointer) THEN AssignString(x, y)
ELSE BindNodes(Nassign, DevCPT.notyp, x, y); x.subcl := assign
END
END Assign;
PROCEDURE Inittd*(VAR inittd, last: DevCPT.Node; typ: DevCPT.Struct);
VAR node: DevCPT.Node;
BEGIN
node := DevCPT.NewNode(Ninittd); node.typ := typ;
node.conval := DevCPT.NewConst(); node.conval.intval := typ.txtpos;
IF inittd = NIL THEN inittd := node ELSE last.link := node END ;
last := node
END Inittd;
(* handling of temporary variables for string operations *)
PROCEDURE Overlap (left, right: DevCPT.Node): BOOLEAN;
BEGIN
IF right.class = Nconst THEN
RETURN FALSE
ELSIF (right.class = Ndop) & (right.subcl = plus) THEN
RETURN Overlap(left, right.left) OR Overlap(left, right.right)
ELSE
WHILE right.class = Nmop DO right := right.left END;
IF right.class = Nderef THEN right := right.left END;
IF left.typ.BaseTyp # right.typ.BaseTyp THEN RETURN FALSE END;
LOOP
IF left.class = Nvarpar THEN
WHILE (right.class = Nindex) OR (right.class = Nfield) OR (right.class = Nguard) DO
right := right.left
END;
RETURN (right.class # Nvar) OR (right.obj.mnolev < left.obj.mnolev)
ELSIF right.class = Nvarpar THEN
WHILE (left.class = Nindex) OR (left.class = Nfield) OR (left.class = Nguard) DO left := left.left END;
RETURN (left.class # Nvar) OR (left.obj.mnolev < right.obj.mnolev)
ELSIF (left.class = Nvar) & (right.class = Nvar) THEN
RETURN left.obj = right.obj
ELSIF (left.class = Nderef) & (right.class = Nderef) THEN
RETURN TRUE
ELSIF (left.class = Nindex) & (right.class = Nindex) THEN
IF (left.right.class = Nconst) & (right.right.class = Nconst)
& (left.right.conval.intval # right.right.conval.intval) THEN RETURN FALSE END;
left := left.left; right := right.left
ELSIF (left.class = Nfield) & (right.class = Nfield) THEN
IF left.obj # right.obj THEN RETURN FALSE END;
left := left.left; right := right.left;
WHILE left.class = Nguard DO left := left.left END;
WHILE right.class = Nguard DO right := right.left END
ELSE
RETURN FALSE
END
END
END
END Overlap;
PROCEDURE GetStaticLength (n: DevCPT.Node; OUT length: INTEGER);
VAR x: INTEGER;
BEGIN
IF n.class = Nconst THEN
length := n.conval.intval2 - 1
ELSIF (n.class = Ndop) & (n.subcl = plus) THEN
GetStaticLength(n.left, length); GetStaticLength(n.right, x);
IF (length >= 0) & (x >= 0) THEN length := length + x ELSE length := -1 END
ELSE
WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END;
IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END;
IF n.typ.comp = Array THEN
length := n.typ.n - 1
ELSIF n.typ.comp = DynArr THEN
length := -1
ELSE (* error case *)
length := 4
END
END
END GetStaticLength;
PROCEDURE GetMaxLength (n: DevCPT.Node; VAR stat, last: DevCPT.Node; OUT length: DevCPT.Node);
VAR x: DevCPT.Node; d: INTEGER; obj: DevCPT.Object;
BEGIN
IF n.class = Nconst THEN
length := NewIntConst(n.conval.intval2 - 1)
ELSIF (n.class = Ndop) & (n.subcl = plus) THEN
GetMaxLength(n.left, stat, last, length); GetMaxLength(n.right, stat, last, x);
IF (length.class = Nconst) & (x.class = Nconst) THEN ConstOp(plus, length, x)
ELSE BindNodes(Ndop, length.typ, length, x); length.subcl := plus
END
ELSE
WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END;
IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END;
IF n.typ.comp = Array THEN
length := NewIntConst(n.typ.n - 1)
ELSIF n.typ.comp = DynArr THEN
d := 0;
WHILE n.class = Nindex DO n := n.left; INC(d) END;
ASSERT((n.class = Nderef) OR (n.class = Nvar) OR (n.class = Nvarpar));
IF (n.class = Nderef) & (n.left.class # Nvar) & (n.left.class # Nvarpar) THEN
GetTempVar("@tmp", n.left.typ, obj);
x := NewLeaf(obj); Assign(x, n.left); Link(stat, last, x);
n.left := NewLeaf(obj); (* tree is manipulated here *)
n := NewLeaf(obj); DeRef(n)
END;
IF n.typ.untagged & (n.typ.comp = DynArr) & (n.typ.BaseTyp.form IN {Char8, Char16}) THEN
StrDeref(n);
BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len;
BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(1)); n.subcl := plus
ELSE
BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len;
END;
length := n
ELSE (* error case *)
length := NewIntConst(4)
END
END
END GetMaxLength;
PROCEDURE CheckBuffering* (
VAR n: DevCPT.Node; left: DevCPT.Node; par: DevCPT.Object; VAR stat, last: DevCPT.Node
);
VAR length, x: DevCPT.Node; obj: DevCPT.Object; typ: DevCPT.Struct; len, xlen: INTEGER;
BEGIN
IF (n.typ.form IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options)
& ((n.class = Ndop) & (n.subcl = plus) & ((left = NIL) OR Overlap(left, n.right))
OR (n.class = Nmop) & (n.subcl = conv) & (left = NIL)
OR (par # NIL) & (par.vis = inPar) & (par.typ.comp = Array)) THEN
IF (par # NIL) & (par.typ.comp = Array) THEN
len := par.typ.n - 1
ELSE
IF left # NIL THEN GetStaticLength(left, len) ELSE len := -1 END;
GetStaticLength(n, xlen);
IF (len = -1) OR (xlen # -1) & (xlen < len) THEN len := xlen END
END;
IF len # -1 THEN
typ := DevCPT.NewStr(Comp, Array); typ.n := len + 1; typ.BaseTyp := n.typ.BaseTyp;
GetTempVar("@str", typ, obj);
x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
n := NewLeaf(obj)
ELSE
IF left # NIL THEN GetMaxLength(left, stat, last, length)
ELSE GetMaxLength(n, stat, last, length)
END;
typ := DevCPT.NewStr(Pointer, Basic);
typ.BaseTyp := DevCPT.NewStr(Comp, DynArr); typ.BaseTyp.BaseTyp := n.typ.BaseTyp;
GetTempVar("@ptr", typ, obj);
x := NewLeaf(obj); Construct(Nassign, x, length); x.subcl := newfn; Link(stat, last, x);
x := NewLeaf(obj); DeRef(x); Assign(x, n); Link(stat, last, x);
n := NewLeaf(obj); DeRef(n)
END;
StrDeref(n)
ELSIF (n.typ.form = Pointer) & (n.typ.sysflag = interface) & (left = NIL)
& ((par # NIL) OR (n.class = Ncall))
& ((n.class # Nvar) OR (n.obj.mnolev <= 0)) THEN
GetTempVar("@cip", DevCPT.punktyp, obj);
x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
n := NewLeaf(obj)
END
END CheckBuffering;
PROCEDURE CheckVarParBuffering* (VAR n: DevCPT.Node; VAR stat, last: DevCPT.Node);
VAR x: DevCPT.Node; obj: DevCPT.Object;
BEGIN
IF (n.class # Nvar) OR (n.obj.mnolev <= 0) THEN
GetTempVar("@ptr", n.typ, obj);
x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
n := NewLeaf(obj)
END
END CheckVarParBuffering;
(* case optimization *)
PROCEDURE Evaluate (n: DevCPT.Node; VAR min, max, num, dist: INTEGER; VAR head: DevCPT.Node);
VAR a: INTEGER;
BEGIN
IF n.left # NIL THEN
a := MIN(INTEGER); Evaluate(n.left, min, a, num, dist, head);
IF n.conval.intval - a > dist THEN dist := n.conval.intval - a; head := n END
ELSIF n.conval.intval < min THEN
min := n.conval.intval
END;
IF n.right # NIL THEN
a := MAX(INTEGER); Evaluate(n.right, a, max, num, dist, head);
IF a - n.conval.intval2 > dist THEN dist := a - n.conval.intval2; head := n END
ELSIF n.conval.intval2 > max THEN
max := n.conval.intval2
END;
INC(num);
IF n.conval.intval < n.conval.intval2 THEN
INC(num);
IF n.conval.intval2 - n.conval.intval > dist THEN dist := n.conval.intval2 - n.conval.intval; head := n END
END
END Evaluate;
PROCEDURE Rebuild (VAR root: DevCPT.Node; head: DevCPT.Node);
VAR n: DevCPT.Node;
BEGIN
IF root # head THEN
IF head.conval.intval2 < root.conval.intval THEN
Rebuild(root.left, head);
root.left := head.right; head.right := root; root := head
ELSE
Rebuild(root.right, head);
root.right := head.left; head.left := root; root := head
END
END
END Rebuild;
PROCEDURE OptimizeCase* (VAR n: DevCPT.Node);
VAR min, max, num, dist, limit: INTEGER; head: DevCPT.Node;
BEGIN
IF n # NIL THEN
min := MAX(INTEGER); max := MIN(INTEGER); num := 0; dist := 0; head := n;
Evaluate(n, min, max, num, dist, head);
limit := 6 * num;
IF limit < 100 THEN limit := 100 END;
IF (num > 4) & ((min > MAX(INTEGER) - limit) OR (max < min + limit)) THEN
INCL(n.conval.setval, useTable)
ELSE
IF num > 4 THEN Rebuild(n, head) END;
INCL(n.conval.setval, useTree);
OptimizeCase(n.left);
OptimizeCase(n.right)
END
END
END OptimizeCase;
(*
PROCEDURE ShowTree (n: DevCPT.Node; opts: SET);
BEGIN
IF n # NIL THEN
IF opts = {} THEN opts := n.conval.setval END;
IF useTable IN opts THEN
IF n.left # NIL THEN ShowTree(n.left, opts); DevCPM.LogW(",") END;
DevCPM.LogWNum(n.conval.intval, 1);
IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
END;
IF n.right # NIL THEN DevCPM.LogW(","); ShowTree(n.right, opts) END
ELSIF useTree IN opts THEN
DevCPM.LogW("("); ShowTree(n.left, {}); DevCPM.LogW("|"); DevCPM.LogWNum(n.conval.intval, 1);
IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
END;
DevCPM.LogW("|"); ShowTree(n.right, {}); DevCPM.LogW(")")
ELSE
ShowTree(n.left, opts); DevCPM.LogW(" "); DevCPM.LogWNum(n.conval.intval, 1);
IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
END;
DevCPM.LogW(" "); ShowTree(n.right, opts)
END
END
END ShowTree;
*)
BEGIN
zero := DevCPT.NewConst(); zero.intval := 0; zero.realval := 0;
one := DevCPT.NewConst(); one.intval := 1; one.realval := 0;
two := DevCPT.NewConst(); two.intval := 2; two.realval := 0;
dummy := DevCPT.NewConst();
quot := DevCPT.NewConst()
END DevCPB.