MODULE DevCPC486;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
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 SYSTEM, DevCPM, DevCPT, DevCPE, DevCPL486;
CONST
initializeAll = FALSE; (* initialize all local variable to zero *)
initializeOut = FALSE; (* initialize all OUT parameters to zero *)
initializeDyn = FALSE; (* initialize all open array OUT parameters to zero *)
initializeStr = FALSE; (* initialize rest of string value parameters to zero *)
FpuControlRegister = 33EH; (* value for fpu control register initialization *)
(* 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; Guid = 23;
VString16to8 = 29; VString8 = 30; VString16 = 31;
intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64};
(* composite structure forms *)
Basic = 1; Array = 2; DynArr = 3; Record = 4;
(* item base modes (=object modes) *)
Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13;
(* item modes for i386 *)
Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19;
(* symbol values and 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;
adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
getrfn = 26; putrfn = 27;
min = 34; max = 35; typ = 36;
(* procedure flags (conval.setval) *)
hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isGuarded = 30; isCallback = 31;
(* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
false = 0; true = 1; nil = 0;
(* registers *)
AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7;
stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; wreg = {AX, BX, CX, DX, SI, DI};
(* GenShiftOp *)
ROL = 0; ROR = 8H; SHL = 20H; SHR = 28H; SAR = 38H;
(* GenBitOp *)
BT = 20H; BTS = 28H; BTR = 30H;
(* GenFDOp *)
FADD = 0; FMUL = 8H; FCOM = 10H; FCOMP = 18H; FSUB = 20H; FSUBR = 28H; FDIV = 30H; FDIVR = 38H;
(* GenFMOp *)
FABS = 1E1H; FCHS = 1E0H; FTST = 1E4H; FSTSW = 7E0H; FUCOM = 2E9H;
(* GenCode *)
SAHF = 9EH; WAIT = 9BH;
(* condition codes *)
ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *)
ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *)
ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1;
ccAlways = -1; ccNever = -2; ccCall = -3;
(* sysflag *)
untagged = 1; callback = 2; noAlign = 3; union = 7;
interface = 10; ccall = -10; guarded = 10; noframe = 16;
nilBit = 1; enumBits = 8; new = 1; iid = 2;
stackArray = 120;
(* system trap numbers *)
withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4;
recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8;
(* module visibility of objects *)
internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
(* pointer init limits *)
MaxPtrs = 10; MaxPush = 4;
Tag0Offset = 12;
Mth0Offset = -4;
ArrDOffs = 8;
numPreIntProc = 2;
stackAllocLimit = 2048;
VAR
imLevel*: ARRAY 64 OF BYTE;
intHandler*: DevCPT.Object;
inxchk, ovflchk, ranchk, typchk, ptrinit, hints: BOOLEAN;
WReg, BReg, AllReg: SET; FReg: INTEGER;
ptrTab: ARRAY MaxPtrs OF INTEGER;
stkAllocLbl: DevCPL486.Label;
procedureUsesFpu: BOOLEAN;
PROCEDURE Init* (opt: SET);
CONST chk = 0; achk = 1; hint = 29;
BEGIN
inxchk := chk IN opt; ovflchk := achk IN opt; ranchk := achk IN opt; typchk := chk IN opt; ptrinit := chk IN opt;
hints := hint IN opt;
stkAllocLbl := DevCPL486.NewLbl
END Init;
PROCEDURE Reversed (cond: BYTE): BYTE; (* reversed condition *)
BEGIN
IF cond = lss THEN RETURN gtr
ELSIF cond = gtr THEN RETURN lss
ELSIF cond = leq THEN RETURN geq
ELSIF cond = geq THEN RETURN leq
ELSE RETURN cond
END
END Reversed;
PROCEDURE Inverted (cc: INTEGER): INTEGER; (* inverted sense of condition code *)
BEGIN
IF ODD(cc) THEN RETURN cc-1 ELSE RETURN cc+1 END
END Inverted;
PROCEDURE setCC* (VAR x: DevCPL486.Item; rel: BYTE; reversed, signed: BOOLEAN);
BEGIN
IF reversed THEN rel := Reversed(rel) END;
CASE rel OF
false: x.offset := ccNever
| true: x.offset := ccAlways
| eql: x.offset := ccE
| neq: x.offset := ccNE
| lss: IF signed THEN x.offset := ccL ELSE x.offset := ccB END
| leq: IF signed THEN x.offset := ccLE ELSE x.offset := ccBE END
| gtr: IF signed THEN x.offset := ccG ELSE x.offset := ccA END
| geq: IF signed THEN x.offset := ccGE ELSE x.offset := ccAE END
END;
x.mode := Cond; x.form := Bool; x.reg := 0;
IF reversed THEN x.reg := 1 END;
IF signed THEN INC(x.reg, 2) END
END setCC;
PROCEDURE StackAlloc*; (* pre: len = CX bytes; post: len = CX words *)
BEGIN
DevCPL486.GenJump(ccCall, stkAllocLbl, FALSE)
END StackAlloc;
PROCEDURE^ CheckAv* (reg: INTEGER);
PROCEDURE AdjustStack (val: INTEGER);
VAR c, sp: DevCPL486.Item;
BEGIN
IF val < -stackAllocLimit THEN
CheckAv(CX);
DevCPL486.MakeConst(c, -val, Int32); DevCPL486.MakeReg(sp, CX, Int32); DevCPL486.GenMove(c, sp);
StackAlloc
ELSIF val # 0 THEN
DevCPL486.MakeConst(c, val, Int32); DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenAdd(c, sp, FALSE)
END
END AdjustStack;
PROCEDURE DecStack (form: INTEGER);
BEGIN
IF form IN {Real64, Int64} THEN AdjustStack(-8) ELSE AdjustStack(-4) END
END DecStack;
PROCEDURE IncStack (form: INTEGER);
BEGIN
IF form IN {Real64, Int64} THEN AdjustStack(8) ELSE AdjustStack(4) END
END IncStack;
(*-----------------register handling------------------*)
PROCEDURE SetReg* (reg: SET);
BEGIN
AllReg := reg; WReg := reg; BReg := reg * {0..3} + SYSTEM.LSH(reg * {0..3}, 4); FReg := 8
END SetReg;
PROCEDURE CheckReg*;
VAR reg: SET;
BEGIN
reg := AllReg - WReg;
IF reg # {} THEN
DevCPM.err(-777); (* register not released *)
IF AX IN reg THEN DevCPM.LogWStr(" AX") END;
IF BX IN reg THEN DevCPM.LogWStr(" BX") END;
IF CX IN reg THEN DevCPM.LogWStr(" CX") END;
IF DX IN reg THEN DevCPM.LogWStr(" DX") END;
IF SI IN reg THEN DevCPM.LogWStr(" SI") END;
IF DI IN reg THEN DevCPM.LogWStr(" DI") END;
WReg := AllReg; BReg := AllReg * {0..3} + SYSTEM.LSH(AllReg * {0..3}, 4)
END;
IF FReg < 8 THEN DevCPM.err(-778); FReg := 8 (* float register not released *)
ELSIF FReg > 8 THEN DevCPM.err(-779); FReg := 8
END
END CheckReg;
PROCEDURE CheckAv* (reg: INTEGER);
BEGIN
ASSERT(reg IN WReg)
END CheckAv;
PROCEDURE GetReg (VAR x: DevCPL486.Item; f: BYTE; hint, stop: SET);
VAR n: INTEGER; s, s1: SET;
BEGIN
CASE f OF
| Byte, Bool, Char8, Int8:
s := BReg * {0..3} - stop;
IF (high IN stop) OR (high IN hint) & (s - hint# {}) THEN n := 0;
IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END;
IF s - hint # {} THEN s := s - hint END;
WHILE ~(n IN s) DO INC(n) END
ELSE
s := BReg - (stop * {0..3}) - SYSTEM.LSH(stop * {0..3}, 4); n := 0;
IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END;
s1 := s - (hint * {0..3}) - SYSTEM.LSH(hint * {0..3}, 4);
IF s1 # {} THEN s := s1 END;
WHILE ~(n IN s) & ~(n + 4 IN s) DO INC(n) END;
IF ~(n IN s) THEN n := n + 4 END
END;
EXCL(BReg, n); EXCL(WReg, n MOD 4)
| Int16, Int32, Set, String8, NilTyp, Pointer, ProcTyp, Comp, Char16, String16:
s := WReg - stop;
IF high IN stop THEN s := s * {0..3} END;
IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := wreg END;
s1 := s - hint;
IF high IN hint THEN s1 := s1 * {0..3} END;
IF s1 # {} THEN s := s1 END;
IF 0 IN s THEN n := 0
ELSIF 2 IN s THEN n := 2
ELSIF 6 IN s THEN n := 6
ELSIF 7 IN s THEN n := 7
ELSIF 1 IN s THEN n := 1
ELSE n := 3
END;
EXCL(WReg, n);
IF n < 4 THEN EXCL(BReg, n); EXCL(BReg, n + 4) END
| Real32, Real64:
IF (FReg = 0) OR (float IN stop) THEN DevCPM.err(216); FReg := 99 END;
DEC(FReg); n := 0
END;
DevCPL486.MakeReg(x, n, f);
END GetReg;
PROCEDURE FreeReg (n, f: INTEGER);
BEGIN
IF f <= Int8 THEN
INCL(BReg, n);
IF (n + 4) MOD 8 IN BReg THEN INCL(WReg, n MOD 4) END
ELSIF f IN realSet THEN
INC(FReg)
ELSIF n IN AllReg THEN
INCL(WReg, n);
IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END
END
END FreeReg;
PROCEDURE FreeWReg (n: INTEGER);
BEGIN
IF n IN AllReg THEN
INCL(WReg, n);
IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END
END
END FreeWReg;
PROCEDURE Free* (VAR x: DevCPL486.Item);
BEGIN
CASE x.mode OF
| Var, VarPar, Abs: IF x.scale # 0 THEN FreeWReg(x.index) END
| Ind: FreeWReg(x.reg);
IF x.scale # 0 THEN FreeWReg(x.index) END
| Reg: FreeReg(x.reg, x.form);
IF x.form = Int64 THEN FreeWReg(x.index) END
ELSE
END
END Free;
PROCEDURE FreeHi (VAR x: DevCPL486.Item); (* free hi byte of word reg *)
BEGIN
IF x.mode = Reg THEN
IF x.form = Int64 THEN FreeWReg(x.index)
ELSIF x.reg < 4 THEN INCL(BReg, x.reg + 4)
END
END
END FreeHi;
PROCEDURE Fits* (VAR x: DevCPL486.Item; stop: SET): BOOLEAN; (* x.mode = Reg *)
BEGIN
IF (short IN stop) & (x.form <= Int8) THEN RETURN FALSE END;
IF x.form <= Int8 THEN RETURN ~(x.reg MOD 4 IN stop) & ((x.reg < 4) OR ~(high IN stop))
ELSIF x.form IN realSet THEN RETURN ~(float IN stop)
ELSIF x.form = Int64 THEN RETURN ~(x.reg IN stop) & ~(x.index IN stop)
ELSE RETURN ~(x.reg IN stop) & ((x.reg < 4) OR ~(high IN stop))
END
END Fits;
PROCEDURE Pop* (VAR r: DevCPL486.Item; f: BYTE; hint, stop: SET);
VAR rh: DevCPL486.Item;
BEGIN
IF f = Int64 THEN
GetReg(r, Int32, hint, stop); DevCPL486.GenPop(r);
GetReg(rh, Int32, hint, stop); DevCPL486.GenPop(rh);
r.form := Int64; r.index := rh.reg
ELSE
IF f < Int16 THEN INCL(stop, high) END;
GetReg(r, f, hint, stop); DevCPL486.GenPop(r)
END
END Pop;
PROCEDURE^ LoadLong (VAR x: DevCPL486.Item; hint, stop: SET);
PROCEDURE Load* (VAR x: DevCPL486.Item; hint, stop: SET); (* = Assert(x, hint, stop + {mem, stk}) *)
VAR r: DevCPL486.Item; f: BYTE;
BEGIN
f := x.typ.form;
IF x.mode = Con THEN
IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN f := Int32; x.form := Int32 END;
IF con IN stop THEN
IF f = Int64 THEN LoadLong(x, hint, stop)
ELSE
GetReg(r, f, hint, stop); DevCPL486.GenMove(x, r);
x.mode := Reg; x.reg := r.reg; x.form := f
END
END
ELSIF x.mode = Stk THEN
IF f IN realSet THEN
GetReg(r, f, hint, stop); DevCPL486.GenFLoad(x); IncStack(x.form)
ELSE
Pop(r, f, hint, stop)
END;
x.mode := Reg; x.reg := r.reg; x.index := r.index; x.form := f
ELSIF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN
Free(x); GetReg(r, Int32, hint, stop); DevCPL486.GenExtMove(x, r);
x.mode := Reg; x.reg := r.reg; x.form := Int32
ELSIF (x.mode # Reg) OR ~Fits(x, stop) THEN
IF f = Int64 THEN LoadLong(x, hint, stop)
ELSE
Free(x); GetReg(r, f, hint, stop);
IF f IN realSet THEN DevCPL486.GenFLoad(x) ELSE DevCPL486.GenMove(x, r) END;
x.mode := Reg; x.reg := r.reg; x.form := f
END
END
END Load;
PROCEDURE Push* (VAR x: DevCPL486.Item);
VAR y: DevCPL486.Item;
BEGIN
IF x.form IN realSet THEN
Load(x, {}, {}); DecStack(x.form);
Free(x); x.mode := Stk;
IF x.typ = DevCPT.intrealtyp THEN x.form := Int64 END;
DevCPL486.GenFStore(x, TRUE)
ELSIF x.form = Int64 THEN
Free(x); x.form := Int32; y := x;
IF x.mode = Reg THEN y.reg := x.index ELSE INC(y.offset, 4) END;
DevCPL486.GenPush(y); DevCPL486.GenPush(x);
x.mode := Stk; x.form := Int64
ELSE
IF x.form < Int16 THEN Load(x, {}, {high})
ELSIF x.form = Int16 THEN Load(x, {}, {})
END;
Free(x); DevCPL486.GenPush(x); x.mode := Stk
END
END Push;
PROCEDURE Assert* (VAR x: DevCPL486.Item; hint, stop: SET);
VAR r: DevCPL486.Item;
BEGIN
IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) & (x.mode # Con) THEN
IF (wreg - stop = {}) & ~(stk IN stop) THEN Load(x, {}, {short}); Push(x)
ELSE Load(x, hint, stop);
END
ELSE
CASE x.mode OF
| Var, VarPar: IF ~(mem IN stop) THEN RETURN END
| Con: IF ~(con IN stop) THEN RETURN END
| Ind: IF ~(mem IN stop) & ~(x.reg IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END
| Abs: IF ~(mem IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END
| Stk: IF ~(stk IN stop) THEN RETURN END
| Reg: IF Fits(x, stop) THEN RETURN END
ELSE RETURN
END;
IF ((float IN stop) OR ~(x.typ.form IN realSet) & (wreg - stop = {})) & ~(stk IN stop) THEN Push(x)
ELSE Load(x, hint, stop)
END
END
END Assert;
(*------------------------------------------------*)
PROCEDURE LoadR (VAR x: DevCPL486.Item);
BEGIN
IF x.mode # Reg THEN
Free(x); DevCPL486.GenFLoad(x);
IF x.mode = Stk THEN IncStack(x.form) END;
GetReg(x, Real32, {}, {})
END
END LoadR;
PROCEDURE PushR (VAR x: DevCPL486.Item);
BEGIN
IF x.mode # Reg THEN LoadR(x) END;
DecStack(x.form);
Free(x); x.mode := Stk; DevCPL486.GenFStore(x, TRUE)
END PushR;
PROCEDURE LoadW (VAR x: DevCPL486.Item; hint, stop: SET);
VAR r: DevCPL486.Item;
BEGIN
IF x.mode = Stk THEN
Pop(x, x.form, hint, stop)
ELSE
Free(x); GetReg(r, x.form, hint, stop);
DevCPL486.GenMove(x, r);
x.mode := Reg; x.reg := r.reg
END
END LoadW;
PROCEDURE LoadL (VAR x: DevCPL486.Item; hint, stop: SET);
VAR r: DevCPL486.Item;
BEGIN
IF x.mode = Stk THEN
Pop(x, x.form, hint, stop);
IF (x.form < Int32) OR (x.form = Char16) THEN
r := x; x.form := Int32; DevCPL486.GenExtMove(r, x)
END
ELSE
Free(x);
IF (x.form < Int32) OR (x.form = Char16) THEN GetReg(r, Int32, hint, stop) ELSE GetReg(r, x.form, hint, stop) END;
IF x.mode = Con THEN x.form := r.form END;
IF x.form # r.form THEN DevCPL486.GenExtMove(x, r) ELSE DevCPL486.GenMove(x, r) END;
x.mode := Reg; x.reg := r.reg; x.form := r.form
END
END LoadL;
PROCEDURE LoadLong (VAR x: DevCPL486.Item; hint, stop: SET);
VAR r, rh, c: DevCPL486.Item; offs: INTEGER;
BEGIN
IF x.form = Int64 THEN
IFx.mode = Stk THEN
Pop(x, x.form, hint, stop)
ELSIF x.mode = Reg THEN
FreeReg(x.reg, Int32); GetReg(r, Int32, hint, stop);
FreeReg(x.index, Int32); GetReg(rh, Int32, hint, stop);
x.form := Int32; DevCPL486.GenMove(x, r);
x.reg := x.index; DevCPL486.GenMove(x, rh);
x.reg := r.reg; x.index := rh.reg
ELSE
GetReg(rh, Int32, hint, stop + {AX});
Free(x);
GetReg(r, Int32, hint, stop);
x.form := Int32; offs := x.offset;
IF x.mode = Con THEN x.offset := x.scale ELSE INC(x.offset, 4) END;
DevCPL486.GenMove(x, rh);
x.offset := offs;
DevCPL486.GenMove(x, r);
x.mode := Reg; x.reg := r.reg; x.index := rh.reg
END
ELSE
LoadL(x, hint, stop); GetReg(rh, Int32, hint, stop); DevCPL486.GenSignExt(x, rh);
x.index := rh.reg
END;
x.form := Int64
END LoadLong;
(*------------------------------------------------*)
PROCEDURE CopyReg* (VAR x, y: DevCPL486.Item; hint, stop: SET);
BEGIN
ASSERT(x.mode = Reg);
GetReg(y, x.form, hint, stop);
DevCPL486.GenMove(x, y)
END CopyReg;
PROCEDURE GetAdr* (VAR x: DevCPL486.Item; hint, stop: SET);
VAR r: DevCPL486.Item;
BEGIN
IF x.mode = DInd THEN
x.mode := Ind
ELSIF (x.mode = Ind) & (x.offset = 0) & (x.scale = 0) & (x.reg IN wreg) THEN
x.mode := Reg
ELSE
Free(x); GetReg(r, Pointer, hint, stop);
IF x.mode = Con THEN DevCPL486.GenMove(x, r) ELSE DevCPL486.GenLoadAdr(x, r) END;
x.mode := Reg; x.reg := r.reg; x.form := Pointer
END;
x.form := Pointer; x.typ := DevCPT.anyptrtyp;
Assert(x, hint, stop)
END GetAdr;
PROCEDURE PushAdr (VAR x: DevCPL486.Item; niltest: BOOLEAN);
VAR r, v: DevCPL486.Item;
BEGIN
IF (x.mode = Abs) & (x.scale = 0) THEN x.mode := Con; x.form := Pointer
ELSIF niltest THEN
GetAdr(x, {}, {mem, stk});
DevCPL486.MakeReg(r, AX, Int32);
v.mode := Ind; v.form := Int32; v.offset := 0; v.scale := 0; v.reg := x.reg;
DevCPL486.GenTest(r, v)
ELSIF x.mode = DInd THEN x.mode := Ind; x.form := Pointer
ELSE GetAdr(x, {}, {})
END;
Free(x); DevCPL486.GenPush(x)
END PushAdr;
PROCEDURE LevelBase (VAR a: DevCPL486.Item; lev: INTEGER; hint, stop: SET);
VAR n: BYTE;
BEGIN
a.mode := Ind; a.scale := 0; a.form := Int32; a.typ := DevCPT.int32typ;
IF lev = DevCPL486.level THEN a.reg := BP
ELSE
a.reg := BX; n := SHORT(SHORT(imLevel[DevCPL486.level] - imLevel[lev]));
WHILE n > 0 DO
a.offset := -4; LoadL(a, hint, stop); a.mode := Ind; DEC(n)
END
END
END LevelBase;
PROCEDURE LenDesc (VAR x, len: DevCPL486.Item; typ: DevCPT.Struct); (* set len to LEN(x, -typ.n) *)
BEGIN
IF x.tmode = VarPar THEN
LevelBase(len, x.obj.mnolev, {}, {}); len.offset := x.obj.adr;
ELSE ASSERT((x.tmode = Ind) & (x.mode = Ind));
len := x; len.offset := ArrDOffs; len.scale := 0; len.form := Int32
END;
INC(len.offset, typ.n * 4 + 4);
IF typ.sysflag = stackArray THEN len.offset := -4 END
END LenDesc;
PROCEDURE Tag* (VAR x, tag: DevCPL486.Item);
VAR typ: DevCPT.Struct;
BEGIN
typ := x.typ;
IF typ.form = Pointer THEN typ := typ.BaseTyp END;
IF (x.typ # DevCPT.sysptrtyp) & (typ.attribute = 0) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final type *)
DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ)
ELSIF x.typ.form = Pointer THEN
ASSERT(x.mode = Reg);
tag.mode := Ind; tag.reg := x.reg; tag.offset := -4;
IF x.typ.sysflag = interface THEN tag.offset := 0 END
ELSIF x.tmode = VarPar THEN
LevelBase(tag, x.obj.mnolev, {}, {}); tag.offset := x.obj.adr + 4;
Free(tag) (* ??? *)
ELSIF x.tmode = Ind THEN
ASSERT(x.mode = Ind);
tag := x; tag.offset := -4
ELSE
DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(x.typ)
END;
tag.scale := 0; tag.form := Pointer; tag.typ := DevCPT.sysptrtyp
END Tag;
PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER;
BEGIN
WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END;
IF typ # NIL THEN RETURN typ.n
ELSE RETURN 0
END
END NumOfIntProc;
PROCEDURE ContainsIPtrs* (typ: DevCPT.Struct): BOOLEAN;
VAR fld: DevCPT.Object;
BEGIN
WHILE typ.comp IN {DynArr, Array} DO typ := typ.BaseTyp END;
IF (typ.form = Pointer) & (typ.sysflag = interface) THEN RETURN TRUE
ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
REPEAT
fld := typ.link;
WHILE (fld # NIL) & (fld.mode = Fld) DO
IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName)
OR ContainsIPtrs(fld.typ) THEN RETURN TRUE END;
fld := fld.link
END;
typ := typ.BaseTyp
UNTIL typ = NIL
END;
RETURN FALSE
END ContainsIPtrs;
PROCEDURE GuidFromString* (str: DevCPT.ConstExt; VAR x: DevCPL486.Item);
VAR cv: DevCPT.Const;
BEGIN
IF ~DevCPM.ValidGuid(str^) THEN DevCPM.err(165) END;
cv := DevCPT.NewConst();
cv.intval := DevCPM.ConstNotAlloc; cv.intval2 := 16; cv.ext := str;
DevCPL486.AllocConst(x, cv, Guid); x.typ := DevCPT.guidtyp
END GuidFromString;
PROCEDURE IPAddRef* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest: BOOLEAN);
VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label;
BEGIN
ASSERT(x.mode IN {Reg, Ind, Abs});
ASSERT({AX, CX, DX} - WReg = {});
IF hints THEN
IF nilTest THEN DevCPM.err(-701) ELSE DevCPM.err(-700) END
END;
IF x.mode # Reg THEN
GetReg(r, Pointer, {}, {});
p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r);
ELSE r := x
END;
IF nilTest THEN
DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, r);
lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
END;
DevCPL486.GenPush(r); p := r;
IF x.mode # Reg THEN Free(r) END;
GetReg(r, Pointer, {}, {});
p.mode := Ind; p.offset := 0; p.scale := 0; p.form := Pointer; DevCPL486.GenMove(p, r);
p.offset := 4; p.reg := r.reg; Free(r); DevCPL486.GenCall(p);
IF nilTest THEN DevCPL486.SetLabel(lbl) END;
END IPAddRef;
PROCEDURE IPRelease* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest, nilSet: BOOLEAN);
VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label;
BEGIN
ASSERT(x.mode IN {Ind, Abs});
ASSERT({AX, CX, DX} - WReg = {});
IF hints THEN
IF nilTest THEN DevCPM.err(-703) ELSE DevCPM.err(-702) END
END;
GetReg(r, Pointer, {}, {});
p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r);
DevCPL486.MakeConst(c, 0, Pointer);
IF nilTest THEN
DevCPL486.GenComp(c, r);
lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
END;
IF nilSet THEN DevCPL486.GenMove(c, p) END;
DevCPL486.GenPush(r);
p.mode := Ind; p.reg := r.reg; p.offset := 0; p.scale := 0; DevCPL486.GenMove(p, r);
p.offset := 8; Free(r); DevCPL486.GenCall(p);
IF nilTest THEN DevCPL486.SetLabel(lbl) END;
END IPRelease;
PROCEDURE Prepare* (VAR x: DevCPL486.Item; hint, stop: SET);
VAR n, i, lev: INTEGER; len, y: DevCPL486.Item; typ: DevCPT.Struct;
BEGIN
IF (x.mode IN {Var, VarPar, Ind, Abs}) & (x.scale # 0) THEN
DevCPL486.MakeReg(y, x.index, Int32); typ := x.typ;
WHILE typ.comp = DynArr DO (* complete dynamic array iterations *)
LenDesc(x, len, typ); DevCPL486.GenMul(len, y, FALSE); typ := typ.BaseTyp;
IF x.tmode = VarPar THEN Free(len) END; (* ??? *)
END;
n := x.scale; i := 0;
WHILE (n MOD 2 = 0) & (i < 3) DO n := n DIV 2; INC(i) END;
IF n > 1 THEN (* assure scale factor in {1, 2, 4, 8} *)
DevCPL486.MakeConst(len, n, Int32); DevCPL486.GenMul(len, y, FALSE); x.scale := x.scale DIV n
END
END;
CASE x.mode OF
Var, VarPar:
lev := x.obj.mnolev;
IF lev <= 0 THEN
x.mode := Abs
ELSE
LevelBase(y, lev, hint, stop);
IF x.mode # VarPar THEN
x.mode := Ind
ELSIF (deref IN hint) & (x.offset = 0) & (x.scale = 0) THEN
x.mode := DInd; x.offset := x.obj.adr
ELSE
y.offset := x.obj.adr; Load(y, hint, stop); x.mode := Ind
END;
x.reg := y.reg
END;
x.form := x.typ.form
| LProc, XProc, IProc:
x.mode := Con; x.offset := 0; x.form := ProcTyp
| TProc, CProc:
x.form := ProcTyp
| Ind, Abs, Stk, Reg:
IF ~(x.typ.form IN {String8, String16}) THEN x.form := x.typ.form END
END
END Prepare;
PROCEDURE Field* (VAR x: DevCPL486.Item; field: DevCPT.Object);
BEGIN
INC(x.offset, field.adr); x.tmode := Con
END Field;
PROCEDURE DeRef* (VAR x: DevCPL486.Item);
VAR btyp: DevCPT.Struct;
BEGIN
x.mode := Ind; x.tmode := Ind; x.scale := 0;
btyp := x.typ.BaseTyp;
IF btyp.untagged OR (btyp.sysflag = stackArray) THEN x.offset := 0
ELSIF btyp.comp = DynArr THEN x.offset := ArrDOffs + btyp.size
ELSIF btyp.comp = Array THEN x.offset := ArrDOffs + 4
ELSE x.offset := 0
END
END DeRef;
PROCEDURE Index* (VAR x, y: DevCPL486.Item; hint, stop: SET); (* x[y] *)
VAR idx, len: DevCPL486.Item; btyp: DevCPT.Struct; elsize: INTEGER;
BEGIN
btyp := x.typ.BaseTyp; elsize := btyp.size;
IF elsize = 0 THEN Free(y)
ELSIF x.typ.comp = Array THEN
len.mode := Con; len.obj := NIL;
IF y.mode = Con THEN
INC(x.offset, y.offset * elsize)
ELSE
Load(y, hint, stop + {mem, stk, short});
IF inxchk THEN
DevCPL486.MakeConst(len, x.typ.n, Int32);
DevCPL486.GenComp(len, y); DevCPL486.GenAssert(ccB, inxTrap)
END;
IF x.scale = 0 THEN x.index := y.reg
ELSE
IF x.scale MOD elsize # 0 THEN
IF (x.scale MOD 4 = 0) & (elsize MOD 4 = 0) THEN elsize := 4
ELSIF (x.scale MOD 2 = 0) & (elsize MOD 2 = 0) THEN elsize := 2
ELSE elsize := 1
END;
DevCPL486.MakeConst(len, btyp.size DIV elsize, Int32);
DevCPL486.GenMul(len, y, FALSE)
END;
DevCPL486.MakeConst(len, x.scale DIV elsize, Int32);
DevCPL486.MakeReg(idx, x.index, Int32);
DevCPL486.GenMul(len, idx, FALSE); DevCPL486.GenAdd(y, idx, FALSE); Free(y)
END;
x.scale := elsize
END;
x.tmode := Con
ELSE (* x.typ.comp = DynArr *)
IF (btyp.comp = DynArr) & x.typ.untagged THEN DevCPM.err(137) END;
LenDesc(x, len, x.typ);
IF x.scale # 0 THEN
DevCPL486.MakeReg(idx, x.index, Int32);
DevCPL486.GenMul(len, idx, FALSE)
END;
IF (y.mode # Con) OR (y.offset # 0) THEN
IF (y.mode # Con) OR (btyp.comp = DynArr) & (x.scale = 0) THEN
Load(y, hint, stop + {mem, stk, con, short})
ELSE y.form := Int32
END;
IF inxchk & ~x.typ.untagged THEN
DevCPL486.GenComp(y, len); DevCPL486.GenAssert(ccA, inxTrap)
END;
IF (y.mode = Con) & (btyp.comp # DynArr) THEN
INC(x.offset, y.offset * elsize)
ELSIF x.scale = 0 THEN
WHILE btyp.comp = DynArr DO btyp := btyp.BaseTyp END;
x.index := y.reg; x.scale := btyp.size
ELSE
DevCPL486.GenAdd(y, idx, FALSE); Free(y)
END
END;
IF x.tmode = VarPar THEN Free(len) END; (* ??? *)
IF x.typ.BaseTyp.comp # DynArr THEN x.tmode := Con END
END
END Index;
PROCEDURE TypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct; guard, equal: BOOLEAN);
VAR tag, tdes, r: DevCPL486.Item; typ: DevCPT.Struct;
BEGIN
typ := x.typ;
IF typ.form = Pointer THEN testtyp := testtyp.BaseTyp; typ := typ.BaseTyp END;
IF ~guard & typ.untagged THEN DevCPM.err(139)
ELSIF ~guard OR typchk & ~typ.untagged THEN
IF testtyp.untagged THEN DevCPM.err(139)
ELSE
IF (x.typ.form = Pointer) & (x.mode # Reg) THEN
GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(x, r); Free(r); r.typ := x.typ; Tag(r, tag)
ELSE Tag(x, tag)
END;
IF ~guard THEN Free(x) END;
IF ~equal THEN
GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(tag, r); Free(r);
tag.mode := Ind; tag.reg := r.reg; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev
END;
DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp);
DevCPL486.GenComp(tdes, tag);
IF guard THEN
IF equal THEN DevCPL486.GenAssert(ccE, recTrap) ELSE DevCPL486.GenAssert(ccE, typTrap) END
ELSE setCC(x, eql, FALSE, FALSE)
END
END
END
END TypTest;
PROCEDURE ShortTypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct);
VAR tag, tdes: DevCPL486.Item;
BEGIN
(* tag must be in AX ! *)
IF testtyp.form = Pointer THEN testtyp := testtyp.BaseTyp END;
IF testtyp.untagged THEN DevCPM.err(139)
ELSE
tag.mode := Ind; tag.reg := AX; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev; tag.form := Pointer;
DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp);
DevCPL486.GenComp(tdes, tag);
setCC(x, eql, FALSE, FALSE)
END
END ShortTypTest;
PROCEDURE Check (VAR x: DevCPL486.Item; min, max: INTEGER);
VAR c: DevCPL486.Item;
BEGIN
ASSERT((x.mode # Reg) OR (max > 255) OR (max = 31) OR (x.reg < 4));
IF ranchk & (x.mode # Con) THEN
DevCPL486.MakeConst(c, max, x.form); DevCPL486.GenComp(c, x);
IF min # 0 THEN
DevCPL486.GenAssert(ccLE, ranTrap);
c.offset := min; DevCPL486.GenComp(c, x);
DevCPL486.GenAssert(ccGE, ranTrap)
ELSIF max # 0 THEN
DevCPL486.GenAssert(ccBE, ranTrap)
ELSE
DevCPL486.GenAssert(ccNS, ranTrap)
END
END
END Check;
PROCEDURE Floor (VAR x: DevCPL486.Item; useSt1: BOOLEAN);
VAR c: DevCPL486.Item; local: DevCPL486.Label;
BEGIN
IF useSt1 THEN DevCPL486.GenFMOp(5D1H); (* FST ST1 *)
ELSE DevCPL486.GenFMOp(1C0H); (* FLD ST0 *)
END;
DevCPL486.GenFMOp(1FCH); (* FRNDINT *)
DevCPL486.GenFMOp(0D1H); (* FCOM *)
CheckAv(AX);
DevCPL486.GenFMOp(FSTSW);
DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *)
(* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE);
DevCPL486.AllocConst(c, DevCPL486.one, Real32);
DevCPL486.GenFDOp(FSUB, c);
DevCPL486.SetLabel(local);
END Floor;
PROCEDURE Entier(VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET);
BEGIN
IF typ # DevCPT.intrealtyp THEN Floor(x, FALSE) END;
DevCPL486.GenFStore(x, TRUE);
IF (x.mode = Stk) & (stk IN stop) THEN Pop(x, x.form, hint, stop) END
END Entier;
PROCEDURE ConvMove (VAR x, y: DevCPL486.Item; sysval: BOOLEAN; hint, stop: SET); (* x := y *)
(* scalar values only, y.mode # Con, all kinds of conversions, x.mode = Undef => convert y only *)
VAR f, m: BYTE; s: INTEGER; z: DevCPL486.Item;
BEGIN
f := x.form; m := x.mode; ASSERT(m IN {Undef, Reg, Abs, Ind, Stk});
IF y.form IN {Real32, Real64} THEN
IF f IN {Real32, Real64} THEN
IF m = Undef THEN
IF (y.form = Real64) & (f = Real32) THEN
IF y.mode # Reg THEN LoadR(y) END;
Free(y); DecStack(Real32); y.mode := Stk; y.form := Real32; DevCPL486.GenFStore(y, TRUE)
END
ELSE
IF y.mode # Reg THEN LoadR(y) END;
IF m = Stk THEN DecStack(f) END;
IF m # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END;
END
ELSE (* x not real *)
IF sysval THEN
IF y.mode = Reg THEN Free(y);
IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int32) THEN
x.form := y.form; DevCPL486.GenFStore(x, TRUE); x.form := f
ELSE
ASSERT(y.form # Real64);
DecStack(y.form); y.mode := Stk; DevCPL486.GenFStore(y, TRUE); y.form := Int32;
IF m # Stk THEN
Pop(y, y.form, hint, stop);
IF f < Int16 THEN ASSERT(y.reg < 4) END;
y.form := f;
IF m # Undef THEN Free(y); DevCPL486.GenMove(y, x) END
END
END
ELSE (* y.mode # Reg *)
y.form := f;
IF m # Undef THEN LoadW(y, hint, stop); Free(y);
IF m = Stk THEN DevCPL486.GenPush(y) ELSE DevCPL486.GenMove(y, x) END
END
END
ELSE (* not sysval *)
IF y.mode # Reg THEN LoadR(y) END;
Free(y);
IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int16) & (f # Char16) THEN
Entier(x, y.typ, hint, stop);
ELSE
DecStack(f); y.mode := Stk;
IF (f < Int16) OR (f = Char16) THEN y.form := Int32 ELSE y.form := f END;
IF m = Stk THEN Entier(y, y.typ, {}, {})
ELSIF m = Undef THEN Entier(y, y.typ, hint, stop)
ELSE Entier(y, y.typ, hint, stop + {stk})
END;
IF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
ELSIF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
ELSIF f = Char16 THEN Check(y, 0, 65536); FreeHi(y)
END;
y.form := f;
IF (m # Undef) & (m # Stk) THEN
IF f = Int64 THEN
Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z);
IF z.mode = Reg THEN z.reg := z.index ELSE INC(z.offset, 4) END;
y.reg := y.index; DevCPL486.GenMove(y, z);
ELSE
Free(y); DevCPL486.GenMove(y, x);
END
END
END
END
END
ELSE (* y not real *)
IF sysval THEN
IF (y.form < Int16) & (f >= Int16) OR (y.form IN {Int16, Char16}) & (f >= Int32) & (f < Char16) THEN LoadL(y, hint, stop) END;
IF (y.form >= Int16) & (f < Int16) THEN FreeHi(y) END
ELSE
CASE y.form OF
| Byte, Bool:
IF f = Int64 THEN LoadLong(y, hint, stop)
ELSIF f >= Int16 THEN LoadL(y, hint, stop)
END
| Char8:
IF f = Int8 THEN Check(y, 0, 0)
ELSIF f = Int64 THEN LoadLong(y, hint, stop)
ELSIF f >= Int16 THEN LoadL(y, hint, stop)
END
| Char16:
IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
ELSIF f = Int16 THEN Check(y, 0, 0)
ELSIF f = Char16 THEN (* ok *)
ELSIF f = Int64 THEN LoadLong(y, hint, stop)
ELSIF f >= Int32 THEN LoadL(y, hint, stop)
END
| Int8:
IF f = Char8 THEN Check(y, 0, 0)
ELSIF f = Int64 THEN LoadLong(y, hint, stop)
ELSIF f >= Int16 THEN LoadL(y, hint, stop)
END
| Int16:
IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
ELSIF f = Char16 THEN Check(y, 0, 0)
ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
ELSIF f = Int64 THEN LoadLong(y, hint, stop)
ELSIF (f = Int32) OR (f = Set) THEN LoadL(y, hint, stop)
END
| Int32, Set, Pointer, ProcTyp:
IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
ELSIF f = Char16 THEN Check(y, 0, 65536)
ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
ELSIF f = Int16 THEN Check(y, -32768, 32767)
ELSIF f = Int64 THEN LoadLong(y, hint, stop)
END
| Int64:
IF f IN {Bool..Int32, Char16} THEN
(* make range checks !!! *)
FreeHi(y)
END
END
END;
IF f IN {Real32, Real64} THEN
IF sysval THEN
IF (m # Undef) & (m # Reg) THEN
IF y.mode # Reg THEN LoadW(y, hint, stop) END;
Free(y);
IF m = Stk THEN DevCPL486.GenPush(y)
ELSE x.form := Int32; DevCPL486.GenMove(y, x); x.form := f
END
ELSE
IF y.mode = Reg THEN Push(y) END;
y.form := f;
IF m = Reg THEN LoadR(y) END
END
ELSE (* not sysval *) (* int -> float *)
IF y.mode = Reg THEN Push(y) END;
IF m = Stk THEN
Free(y); DevCPL486.GenFLoad(y); s := -4;
IF f = Real64 THEN DEC(s, 4) END;
IF y.mode = Stk THEN
IF y.form = Int64 THEN INC(s, 8) ELSE INC(s, 4) END
END;
IF s # 0 THEN AdjustStack(s) END;
GetReg(y, Real32, {}, {});
Free(y); DevCPL486.GenFStore(x, TRUE)
ELSIF m = Reg THEN
LoadR(y)
ELSIF m # Undef THEN
LoadR(y); Free(y); DevCPL486.GenFStore(x, TRUE)
END
END
ELSE
y.form := f;
IF m = Stk THEN
IF ((f < Int32) OR (f = Char16)) & (y.mode # Reg) THEN LoadW(y, hint, stop) END;
Push(y)
ELSIF m # Undef THEN
IF f = Int64 THEN
IF y.mode # Reg THEN LoadLong(y, hint, stop) END;
Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z);
IF z.mode = Reg THEN ASSERT(z.reg # y.index); z.reg := z.index ELSE INC(z.offset, 4) END;
y.reg := y.index; DevCPL486.GenMove(y, z);
ELSE
IF y.mode # Reg THEN LoadW(y, hint, stop) END;
Free(y); DevCPL486.GenMove(y, x)
END
END
END
END
END ConvMove;
PROCEDURE Convert* (VAR x: DevCPL486.Item; f: BYTE; size: INTEGER; hint, stop: SET); (* size >= 0: sysval *)
VAR y: DevCPL486.Item;
BEGIN
ASSERT(x.mode # Con);
IF (size >= 0)
& ((size # x.typ.size) & ((size > 4) OR (x.typ.size > 4))
OR (f IN {Comp, Real64, Int64}) & (x.mode IN {Reg, Stk})) THEN DevCPM.err(220) END;
(*
IF sysval & ((x.form = Real64) & ~(f IN {Comp, Int64}) OR (f = Real64) & ~(x.formIN {Comp, Int64})) THEN DevCPM.err(220) END;
*)
y.mode := Undef; y.form := f; ConvMove(y, x, size >= 0, hint, stop)
END Convert;
PROCEDURE LoadCond* (VAR x, y: DevCPL486.Item; F, T: DevCPL486.Label; hint, stop: SET);
VAR end, T1: DevCPL486.Label; c, r: DevCPL486.Item;
BEGIN
IF mem IN stop THEN GetReg(x, Bool, hint, stop) END;
IF (F = DevCPL486.NewLbl) & (T = DevCPL486.NewLbl) THEN (* no label used *)
DevCPL486.GenSetCC(y.offset, x)
ELSE
end := DevCPL486.NewLbl; T1 := DevCPL486.NewLbl;
DevCPL486.GenJump(y.offset, T1, TRUE); (* T1 to enable short jump *)
DevCPL486.SetLabel(F);
DevCPL486.MakeConst(c, 0, Bool); DevCPL486.GenMove(c, x);
DevCPL486.GenJump(ccAlways, end, TRUE);
DevCPL486.SetLabel(T); DevCPL486.SetLabel(T1);
DevCPL486.MakeConst(c, 1, Bool); DevCPL486.GenMove(c, x);
DevCPL486.SetLabel(end)
END;
IF x.mode # Reg THEN Free(x) END
END LoadCond;
PROCEDURE IntDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN);
VAR local: DevCPL486.Label;
BEGIN
ASSERT((x.mode = Reg) OR (y.mode = Reg) OR (y.mode = Con));
CASE subcl OF
| eql..geq:
DevCPL486.GenComp(y, x); Free(x);
setCC(x, subcl, rev, x.typ.form IN {Int8..Int32})
| times:
IF x.form = Set THEN DevCPL486.GenAnd(y, x) ELSE DevCPL486.GenMul(y, x, ovflchk) END
| slash:
DevCPL486.GenXor(y, x)
| plus:
IF x.form = Set THEN DevCPL486.GenOr(y, x) ELSE DevCPL486.GenAdd(y, x, ovflchk) END
| minus, msk:
IF (x.form = Set) OR (subcl = msk) THEN (* and not *)
IF rev THEN DevCPL486.GenNot(x); DevCPL486.GenAnd(y, x) (* y and not x *)
ELSIF y.mode = Con THEN y.offset := -1 - y.offset; DevCPL486.GenAnd(y, x) (* x and y' *)
ELSIF y.mode = Reg THEN DevCPL486.GenNot(y); DevCPL486.GenAnd(y, x) (* x and not y *)
ELSE DevCPL486.GenNot(x); DevCPL486.GenOr(y, x); DevCPL486.GenNot(x) (* not (not x or y) *)
END
ELSE (* minus *)
IF rev THEN (* y - x *)
IF (y.mode = Con) & (y.offset = -1) THEN DevCPL486.GenNot(x)
ELSE DevCPL486.GenNeg(x, ovflchk); DevCPL486.GenAdd(y, x, ovflchk) (* ??? *)
END
ELSE (* x - y *)
DevCPL486.GenSub(y, x, ovflchk)
END
END
| min, max:
local := DevCPL486.NewLbl;
DevCPL486.GenComp(y, x);
IF subcl = min THEN
IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccBE, local, TRUE)
ELSE DevCPL486.GenJump(ccLE, local, TRUE)
END
ELSE
IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccAE, local, TRUE)
ELSE DevCPL486.GenJump(ccGE, local, TRUE)
END
END;
DevCPL486.GenMove(y, x);
DevCPL486.SetLabel(local)
END;
Free(y);
IF x.mode # Reg THEN Free(x) END
END IntDOp;
PROCEDURE LargeInc* (VAR x, y: DevCPL486.Item; dec: BOOLEAN); (* INC(x, y) or DEC(x, y) *)
BEGIN
ASSERT(x.form = Int64);
IF ~(y.mode IN {Reg, Con}) THEN LoadLong(y, {}, {}) END;
Free(x); Free(y); x.form := Int32; y.form := Int32;
IF dec THEN DevCPL486.GenSubC(y, x, TRUE, FALSE) ELSE DevCPL486.GenAddC(y, x, TRUE, FALSE) END;
INC(x.offset, 4);
IF y.mode = Reg THEN y.reg := y.index ELSE y.offset := y.scale END;
IF dec THEN DevCPL486.GenSubC(y, x, FALSE, ovflchk) ELSE DevCPL486.GenAddC(y, x, FALSE, ovflchk) END;
END LargeInc;
PROCEDURE FloatDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN);
VAR local: DevCPL486.Label; a, b: DevCPL486.Item;
BEGIN
ASSERT(x.mode = Reg);
IF y.form = Int64 THEN LoadR(y) END;
IF y.mode = Reg THEN rev := ~rev END;
CASE subcl OF
| eql..geq: DevCPL486.GenFDOp(FCOMP, y)
| times: DevCPL486.GenFDOp(FMUL, y)
| slash: IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END
| plus: DevCPL486.GenFDOp(FADD, y)
| minus: IF rev THEN DevCPL486.GenFDOp(FSUBR, y) ELSE DevCPL486.GenFDOp(FSUB, y) END
| min, max:
IF y.mode = Reg THEN
DevCPL486.GenFMOp(0D1H); (* FCOM ST1 *)
CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
local := DevCPL486.NewLbl;
IF subcl = min THEN DevCPL486.GenJump(ccAE, local, TRUE) ELSE DevCPL486.GenJump(ccBE, local, TRUE) END;
DevCPL486.GenFMOp(5D1H); (* FST ST1 *)
DevCPL486.SetLabel(local);
DevCPL486.GenFMOp(5D8H) (* FSTP ST0 *)
ELSE
DevCPL486.GenFDOp(FCOM, y);
CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
local := DevCPL486.NewLbl;
IF subcl = min THEN DevCPL486.GenJump(ccBE, local, TRUE) ELSE DevCPL486.GenJump(ccAE, local, TRUE) END;
DevCPL486.GenFMOp(5D8H); (* FSTP ST0 *)
DevCPL486.GenFLoad(y);
DevCPL486.SetLabel(local)
END
(* largeint support *)
| div:
IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END;
Floor(y, FALSE)
| mod:
IF y.mode # Reg THEN LoadR(y); rev := ~rev END;
IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END;
DevCPL486.GenFMOp(1F8H); (* FPREM *)
DevCPL486.GenFMOp(1E4H); (* FTST *)
CheckAv(AX);
DevCPL486.GenFMOp(FSTSW);
DevCPL486.MakeReg(a, AX, Int32); GetReg(b, Int32, {}, {AX});
DevCPL486.GenMove(a, b);
DevCPL486.GenFMOp(0D1H); (* FCOM *)
DevCPL486.GenFMOp(FSTSW);
DevCPL486.GenXor(b, a); Free(b);
(* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE);
DevCPL486.GenFMOp(0C1H); (* FADD ST1 *)
DevCPL486.SetLabel(local);
DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *)
| ash:
IF y.mode # Reg THEN LoadR(y); rev := ~rev END;
IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END;
DevCPL486.GenFMOp(1FDH); (* FSCALE *)
Floor(y, TRUE)
END;
IF y.mode = Stk THEN IncStack(y.form) END;
Free(y);
IF (subcl >= eql) & (subcl <= geq) THEN
Free(x); CheckAv(AX);
DevCPL486.GenFMOp(FSTSW);
(* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
setCC(x, subcl, rev, FALSE)
END
END FloatDOp;
PROCEDURE IntMOp* (VAR x: DevCPL486.Item; subcl: BYTE);
VAR L: DevCPL486.Label; c: DevCPL486.Item;
BEGIN
CASE subcl OF
| minus:
IF x.form = Set THEN DevCPL486.GenNot(x) ELSE DevCPL486.GenNeg(x, ovflchk) END
| abs:
L := DevCPL486.NewLbl; DevCPL486.MakeConst(c, 0, x.form);
DevCPL486.GenComp(c, x);
DevCPL486.GenJump(ccNS, L, TRUE);
DevCPL486.GenNeg(x, ovflchk);
DevCPL486.SetLabel(L)
| cap:
DevCPL486.MakeConst(c, -1 - 20H, x.form);
DevCPL486.GenAnd(c, x)
| not:
DevCPL486.MakeConst(c, 1, x.form);
DevCPL486.GenXor(c, x)
END;
IF x.mode # Reg THEN Free(x) END
END IntMOp;
PROCEDURE FloatMOp* (VAR x: DevCPL486.Item; subcl: BYTE);
BEGIN
ASSERT(x.mode = Reg);
IF subcl = minus THEN DevCPL486.GenFMOp(FCHS)
ELSE ASSERT(subcl = abs); DevCPL486.GenFMOp(FABS)
END
END FloatMOp;
PROCEDURE MakeSet* (VAR x: DevCPL486.Item; range, neg: BOOLEAN; hint, stop: SET);
(* range neg result
F F {x}
F T -{x}
T F {x..31}
T T -{0..x} *)
VAR c, r: DevCPL486.Item; val: INTEGER;
BEGIN
IF x.mode = Con THEN
IF range THEN
IF neg THEN val := -2 ELSE val := -1 END;
x.offset := SYSTEM.LSH(val, x.offset)
ELSE
val := 1; x.offset := SYSTEM.LSH(val, x.offset);
IF neg THEN x.offset := -1 - x.offset END
END
ELSE
Check(x, 0, 31);
IF neg THEN val := -2
ELSIF range THEN val := -1
ELSE val := 1
END;
DevCPL486.MakeConst(c, val, Set); GetReg(r, Set, hint, stop); DevCPL486.GenMove(c, r);
IF range THEN DevCPL486.GenShiftOp(SHL, x, r) ELSE DevCPL486.GenShiftOp(ROL, x, r) END;
Free(x); x.reg := r.reg
END;
x.typ := DevCPT.settyp; x.form := Set
END MakeSet;
PROCEDURE MakeCond* (VAR x: DevCPL486.Item);
VAR c: DevCPL486.Item;
BEGIN
IF x.mode = Con THEN
setCC(x, SHORT(SHORT(x.offset)), FALSE, FALSE)
ELSE
DevCPL486.MakeConst(c, 0, x.form);
DevCPL486.GenComp(c, x); Free(x);
setCC(x, neq, FALSE, FALSE)
END
END MakeCond;
PROCEDURE Not* (VAR x: DevCPL486.Item);
VAR a: INTEGER;
BEGIN
x.offset := Inverted(x.offset); (* invert cc *)
END Not;
PROCEDURE Odd* (VAR x: DevCPL486.Item);
VAR c: DevCPL486.Item;
BEGIN
IF x.mode = Stk THEN Pop(x, x.form, {}, {}) END;
Free(x); DevCPL486.MakeConst(c, 1, x.form);
IF x.mode = Reg THEN
IF x.form IN {Int16, Int64} THEN x.form := Int32; c.form := Int32 END;
DevCPL486.GenAnd(c, x)
ELSE
c.form := Int8; x.form := Int8; DevCPL486.GenTest(c, x)
END;
setCC(x, neq, FALSE, FALSE)
END Odd;
PROCEDURE In* (VAR x, y: DevCPL486.Item);
BEGIN
IF y.form = Set THEN Check(x, 0, 31) END;
DevCPL486.GenBitOp(BT, x, y); Free(x); Free(y);
setCC(x, lss, FALSE, FALSE); (* carry set *)
END In;
PROCEDURE Shift* (VAR x, y: DevCPL486.Item; subcl: BYTE); (* ASH, LSH, ROT *)
VAR L1, L2: DevCPL486.Label; c: DevCPL486.Item; opl, opr: INTEGER;
BEGIN
IF subcl = ash THEN opl := SHL; opr := SAR
ELSIF subcl = lsh THEN opl := SHL; opr := SHR
ELSE opl := ROL; opr := ROR
END;
IF y.mode = Con THEN
IF y.offset > 0 THEN
DevCPL486.GenShiftOp(opl, y, x)
ELSIF y.offset < 0 THEN
y.offset := -y.offset;
DevCPL486.GenShiftOp(opr, y, x)
END
ELSE
ASSERT(y.mode = Reg);
Check(y, -31, 31);
L1 := DevCPL486.NewLbl; L2 := DevCPL486.NewLbl;
DevCPL486.MakeConst(c, 0, y.form); DevCPL486.GenComp(c, y);
DevCPL486.GenJump(ccNS, L1, TRUE);
DevCPL486.GenNeg(y, FALSE);
DevCPL486.GenShiftOp(opr, y, x);
DevCPL486.GenJump(ccAlways, L2, TRUE);
DevCPL486.SetLabel(L1);
DevCPL486.GenShiftOp(opl, y, x);
DevCPL486.SetLabel(L2);
Free(y)
END;
IF x.mode # Reg THEN Free(x) END
END Shift;
PROCEDURE DivMod* (VAR x, y: DevCPL486.Item; mod: BOOLEAN);
VAR s: SET; r: DevCPL486.Item; pos: BOOLEAN;
BEGIN
ASSERT((x.mode = Reg) & (x.reg = AX)); pos := FALSE;
IF y.mode = Con THEN pos := (y.offset > 0) & (y.obj = NIL); Load(y, {}, {AX, DX, con}) END;
DevCPL486.GenDiv(y, mod, pos); Free(y);
IF mod THEN
r := x; GetReg(x, x.form, {}, wreg - {AX, DX}); Free(r) (* ax -> dx; al -> ah *) (* ??? *)
END
END DivMod;
PROCEDURE Mem* (VAR x: DevCPL486.Item; offset: INTEGER; typ: DevCPT.Struct); (* x := Mem[x+offset] *)
BEGIN
IF x.mode = Con THEN x.mode := Abs; x.obj := NIL; INC(x.offset, offset)
ELSE ASSERT(x.mode = Reg); x.mode := Ind; x.offset := offset
END;
x.scale := 0; x.typ := typ; x.form := typ.form
END Mem;
PROCEDURE SysMove* (VAR len: DevCPL486.Item); (* implementation of SYSTEM.MOVE *)
BEGIN
IF len.mode = Con THEN
IF len.offset > 0 THEN DevCPL486.GenBlockMove(1, len.offset) END
ELSE
Load(len, {}, wreg - {CX} + {short, mem, stk}); DevCPL486.GenBlockMove(1, 0); Free(len)
END;
FreeWReg(SI); FreeWReg(DI)
END SysMove;
PROCEDURE Len* (VAR x, y: DevCPL486.Item);
VAR typ: DevCPT.Struct; dim: INTEGER;
BEGIN
dim := y.offset; typ := x.typ;
IF typ.untagged THEN DevCPM.err(136) END;
WHILE dim > 0 DO typ := typ.BaseTyp; DEC(dim) END;
LenDesc(x, x, typ);
END Len;
PROCEDURE StringWSize (VAR x: DevCPL486.Item): INTEGER;
BEGIN
CASE x.form OF
| String8, VString8: RETURN 1
| String16, VString16: RETURN 2
| VString16to8: RETURN 0
| Comp: RETURN x.typ.BaseTyp.size
END
END StringWSize;
PROCEDURE CmpString* (VAR x, y: DevCPL486.Item; rel: BYTE; rev: BOOLEAN);
VAR sw, dw: INTEGER;
BEGIN
CheckAv(CX);
IF (x.typ = DevCPT.guidtyp) OR (y.typ = DevCPT.guidtyp) THEN
DevCPL486.GenBlockComp(4, 4)
ELSIF x.form = String8 THEN DevCPL486.GenBlockComp(1, x.index)
ELSIF y.form = String8 THEN DevCPL486.GenBlockComp(1, y.index)
ELSIF x.form = String16 THEN DevCPL486.GenBlockComp(2, x.index)
ELSIF y.form = String16 THEN DevCPL486.GenBlockComp(2, y.index)
ELSE DevCPL486.GenStringComp(StringWSize(y), StringWSize(x))
END;
FreeWReg(SI); FreeWReg(DI); setCC(x, rel, ~rev, FALSE);
END CmpString;
PROCEDURE VarParDynArr (ftyp: DevCPT.Struct; VAR y: DevCPL486.Item);
VAR len, z: DevCPL486.Item; atyp: DevCPT.Struct;
BEGIN
atyp := y.typ;
WHILE ftyp.comp = DynArr DO
IF ftyp.BaseTyp = DevCPT.bytetyp THEN
IF atyp.comp = DynArr THEN
IF atyp.untagged THEN DevCPM.err(137) END;
LenDesc(y, len, atyp);
IF y.tmode = VarPar THEN Free(len) END; (* ??? *)
GetReg(z, Int32, {}, {}); DevCPL486.GenMove(len, z);
len.mode := Reg; len.reg := z.reg; atyp := atyp.BaseTyp;
WHILE atyp.comp = DynArr DO
LenDesc(y, z, atyp); DevCPL486.GenMul(z, len, FALSE);
IF y.tmode = VarPar THEN Free(z) END; (* ??? *)
atyp := atyp.BaseTyp
END;
DevCPL486.MakeConst(z, atyp.size, Int32); DevCPL486.GenMul(z, len, FALSE);
Free(len)
ELSE
DevCPL486.MakeConst(len, atyp.size, Int32)
END
ELSE
IF atyp.comp = DynArr THEN LenDesc(y, len, atyp);
IF atyp.untagged THEN DevCPM.err(137) END;
IF y.tmode = VarPar THEN Free(len) END; (* ??? *)
ELSE DevCPL486.MakeConst(len, atyp.n, Int32)
END
END;
DevCPL486.GenPush(len);
ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp
END
END VarParDynArr;
PROCEDURE Assign* (VAR x, y: DevCPL486.Item); (* x := y *)
BEGIN
IF y.mode = Con THEN
IF y.form IN {Real32, Real64} THEN
DevCPL486.GenFLoad(y); GetReg(y, Real32, {}, {});
IF x.mode # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END (* ??? move const *)
ELSIF x.form = Int64 THEN
ASSERT(x.mode IN {Ind, Abs});
y.form := Int32; x.form := Int32; DevCPL486.GenMove(y, x);
y.offset := y.scale; INC(x.offset, 4); DevCPL486.GenMove(y, x);
DEC(x.offset, 4); x.form := Int64
ELSE
DevCPL486.GenMove(y, x)
END
ELSE
IF y.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *)
ASSERT(x.form = Pointer);
GetAdr(y, {}, {}); y.typ := x.typ; y.form := Pointer
END;
IF ~(x.form IN realSet) OR ~(y.form IN intSet) THEN Assert(y, {}, {stk}) END;
ConvMove(x, y, FALSE, {}, {})
END;
Free(x)
END Assign;
PROCEDURE ArrayLen* (VAR x, len: DevCPL486.Item; hint, stop: SET);
VAR c: DevCPL486.Item;
BEGIN
IF x.typ.comp = Array THEN DevCPL486.MakeConst(c, x.typ.n, Int32); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len)
ELSIF ~x.typ.untagged THEN LenDesc(x, c, x.typ); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len)
ELSE len.mode := Con
END;
len.typ := DevCPT.int32typ
END ArrayLen;
(*
src dest zero
sx = sy x b y b
SHORT(lx) = sy x b+ x w y b
SHORT(lx) = SHORT(ly) x b+ x w y b+
lx = ly x w y w
LONG(sx) = ly x b y w *
LONG(SHORT(lx)) = ly x b+ x w* y w *
sx := sy y b x b
sx := SHORT(ly) y b+ y w x b
lx := ly y w x w
lx := LONG(sy) y b x w *
lx := LONG(SHORT(ly)) y b+ y w* x w *
*)
PROCEDURE AddCopy* (VAR x, y: DevCPL486.Item; last: BOOLEAN); (* x := .. + y + .. *)
BEGIN
IF (x.typ.comp = DynArr) & x.typ.untagged THEN
DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), -1)
ELSE
DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), 0)
END;
FreeWReg(SI); FreeWReg(DI)
END AddCopy;
PROCEDURE Copy* (VAR x, y: DevCPL486.Item; short: BOOLEAN); (* x := y *)
VAR sx, sy, sy2, sy4: INTEGER; c, r: DevCPL486.Item;
BEGIN
sx := x.typ.size; CheckAv(CX);
IF y.form IN {String8, String16} THEN
sy := y.index * y.typ.BaseTyp.size;
IF x.typ.comp = Array THEN (* adjust size for optimal performance *)
sy2 := sy + sy MOD 2; sy4 := sy2 + sy2 MOD 4;
IF sy4 <= sx THEN sy := sy4
ELSIF sy2 <= sx THEN sy := sy2
ELSIF sy > sx THEN DevCPM.err(114); sy := 1
END
ELSIF inxchk & ~x.typ.untagged THEN (* check array length *)
Free(x); LenDesc(x, c, x.typ);
DevCPL486.MakeConst(y, y.index, Int32);
DevCPL486.GenComp(y, c); DevCPL486.GenAssert(ccAE, copyTrap);
Free(c)
END;
DevCPL486.GenBlockMove(1, sy)
ELSIF x.typ.comp = DynArr THEN
IF x.typ.untagged THEN
DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), -1)
ELSE
Free(x); LenDesc(x, c, x.typ); DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(c, r); Free(c);
DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), 0)
END
ELSIF y.form IN {VString16to8, VString8, VString16} THEN
DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n);
ASSERT(y.mode # Stk)
ELSIF short THEN (* COPY *)
sy := y.typ.size;
IF (y.typ.comp # DynArr) & (sy < sx) THEN sx := sy END;
DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n);
IF y.mode = Stk THEN AdjustStack(sy) END
ELSE (* := *)
IF sx > 0 THEN DevCPL486.GenBlockMove(1, sx) END;
IF y.mode = Stk THEN AdjustStack(sy) END
END;
FreeWReg(SI); FreeWReg(DI)
END Copy;
PROCEDURE StrLen* (VAR x: DevCPL486.Item; typ: DevCPT.Struct; incl0x: BOOLEAN);
VAR c: DevCPL486.Item;
BEGIN
CheckAv(AX); CheckAv(CX);
DevCPL486.GenStringLength(typ.BaseTyp.size, -1);
Free(x); GetReg(x, Int32, {}, wreg - {CX});
DevCPL486.GenNot(x);
IF ~incl0x THEN DevCPL486.MakeConst(c, 1, Int32); DevCPL486.GenSub(c, x, FALSE) END;
FreeWReg(DI)
END StrLen;
PROCEDURE MulDim* (VAR y, z: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct); (* z := z * y *)
VAR c: DevCPL486.Item;
BEGIN
IF y.mode = Con THEN fact := fact * y.offset
ELSE
IF ranchk OR inxchk THEN
DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenComp(c, y); DevCPL486.GenAssert(ccG, ranTrap)
END;
DevCPL486.GenPush(y);
IF z.mode = Con THEN z := y
ELSE DevCPL486.GenMul(y, z, ovflchk OR inxchk); Free(y)
END
END
END MulDim;
PROCEDURE SetDim* (VAR x, y: DevCPL486.Item; dimtyp: DevCPT.Struct); (* set LEN(x^, -dimtyp.n) *)
(* y const or on stack *)
VAR z: DevCPL486.Item; end: DevCPL486.Label;
BEGIN
ASSERT((x.mode = Reg) & (x.form = Pointer));
z.mode := Ind; z.reg := x.reg; z.offset := ArrDOffs + 4 + dimtyp.n * 4; z.scale := 0; z.form := Int32;
IF y.mode = Con THEN y.form := Int32
ELSE Pop(y, Int32, {}, {})
END;
end := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, end, TRUE); (* flags set in New *)
DevCPL486.GenMove(y, z);
DevCPL486.SetLabel(end);
IF y.mode = Reg THEN Free(y) END
END SetDim;
PROCEDURE SysNew* (VAR x: DevCPL486.Item);
BEGIN
DevCPM.err(141)
END SysNew;
PROCEDURE New* (VAR x, nofel: DevCPL486.Item; fact: INTEGER);
(* x.typ.BaseTyp.comp IN {Record, Array, DynArr} *)
VAR p, tag, c: DevCPL486.Item; nofdim, dlen, n: INTEGER; typ, eltyp: DevCPT.Struct; lbl: DevCPL486.Label;
BEGIN
typ := x.typ.BaseTyp;
IF typ.untagged THEN DevCPM.err(138) END;
IF typ.comp = Record THEN (* call to Kernel.NewRec(tag: Tag): ADDRESS *)
DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ);
IF ContainsIPtrs(typ) THEN INC(tag.offset) END;
DevCPL486.GenPush(tag);
p.mode := XProc; p.obj := DevCPE.KNewRec;
ELSE eltyp := typ.BaseTyp;
IF typ.comp = Array THEN
nofdim := 0; nofel.mode := Con; nofel.form := Int32; fact := typ.n
ELSE (* DynArr *)
nofdim := typ.n+1;
WHILE eltyp.comp = DynArr DO eltyp := eltyp.BaseTyp END
END ;
WHILE eltyp.comp = Array DO fact := fact * eltyp.n; eltyp := eltyp.BaseTyp END;
IF eltyp.comp = Record THEN
IF eltyp.untagged THEN DevCPM.err(138) END;
DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(eltyp);
IF ContainsIPtrs(eltyp) THEN INC(tag.offset) END;
ELSIF eltyp.form = Pointer THEN
IF ~eltyp.untagged THEN
DevCPL486.MakeConst(tag, 0, Pointer) (* special TDesc in Kernel for ARRAY OF pointer *)
ELSIF eltyp.sysflag = interface THEN
DevCPL486.MakeConst(tag, -1, Pointer) (* special TDesc in Kernel for ARRAY OF interface pointer *)
ELSE
DevCPL486.MakeConst(tag, 12, Pointer)
END
ELSE (* eltyp is pointerless basic type *)
CASE eltyp.form OF
| Undef, Byte, Char8: n := 1;
| Int16: n := 2;
| Int8: n := 3;
| Int32: n := 4;
| Bool: n := 5;
| Set: n := 6;
| Real32: n := 7;
| Real64: n := 8;
| Char16: n := 9;
| Int64: n := 10;
| ProcTyp: n := 11;
END;
DevCPL486.MakeConst(tag, n, Pointer)
(*
DevCPL486.MakeConst(tag, eltyp.size, Pointer)
*)
END;
IF nofel.mode = Con THEN nofel.offset := fact; nofel.obj := NIL
ELSE DevCPL486.MakeConst(p, fact, Int32); DevCPL486.GenMul(p, nofel, ovflchk OR inxchk)
END;
DevCPL486.MakeConst(p, nofdim, Int32); DevCPL486.GenPush(p);
DevCPL486.GenPush(nofel); Free(nofel); DevCPL486.GenPush(tag);
p.mode := XProc; p.obj := DevCPE.KNewArr;
END;
DevCPL486.GenCall(p); GetReg(x, Pointer, {}, wreg - {AX});
IF typ.comp = DynArr THEN (* set flags for nil test *)
DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x)
ELSIF typ.comp = Record THEN
n := NumOfIntProc(typ);
IF n > 0 THEN (* interface method table pointer setup *)
DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x);
lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE);
tag.offset := - 4 * (n + numPreIntProc);
p.mode := Ind; p.reg := AX; p.offset := 0; p.scale := 0; p.form := Pointer;
DevCPL486.GenMove(tag, p);
IF nofel.mode # Con THEN (* unk pointer setup *)
p.offset := 8;
DevCPL486.GenMove(nofel, p);
Free(nofel)
END;
DevCPL486.SetLabel(lbl);
END
END
END New;
PROCEDURE Param* (fp: DevCPT.Object; rec, niltest: BOOLEAN; VAR ap, tag: DevCPL486.Item); (* returns tag if rec *)
VAR f: BYTE; s, ss: INTEGER; par, a, c: DevCPL486.Item; recTyp: DevCPT.Struct;
BEGIN
par.mode := Stk; par.typ := fp.typ; par.form := par.typ.form;
IF ODD(fp.sysflag DIV nilBit) THEN niltest := FALSE END;
IF ap.typ = DevCPT.niltyp THEN
IF ((par.typ.comp = Record) OR (par.typ.comp = DynArr)) & ~par.typ.untagged THEN
DevCPM.err(142)
END;
DevCPL486.GenPush(ap)
ELSIF par.typ.comp = DynArr THEN
IF ap.form IN {String8, String16} THEN
IF ~par.typ.untagged THEN
DevCPL486.MakeConst(c, ap.index (* * ap.typ.BaseTyp.size *), Int32); DevCPL486.GenPush(c)
END;
ap.mode := Con; DevCPL486.GenPush(ap);
ELSIF ap.form IN {VString8, VString16} THEN
DevCPL486.MakeReg(a, DX, Pointer); DevCPL486.GenLoadAdr(ap, a);
IF ~par.typ.untagged THEN
DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenMove(a, c);
Free(ap); StrLen(c, ap.typ, TRUE);
DevCPL486.GenPush(c); Free(c)
END;
DevCPL486.GenPush(a)
ELSE
IF ~par.typ.untagged THEN
IF ap.typ.comp = DynArr THEN niltest := FALSE END; (* ap dereferenced for length descriptor *)
VarParDynArr(par.typ, ap)
END;
PushAdr(ap, niltest)
END
ELSIF fp.mode = VarPar THEN
recTyp := ap.typ;
IF recTyp.form = Pointer THEN recTyp := recTyp.BaseTyp END;
IF (par.typ.comp = Record) & (~fp.typ.untagged) THEN
Tag(ap, tag);
IF rec & (tag.mode # Con) THEN
GetReg(c, Pointer, {}, {}); DevCPL486.GenMove(tag, c); tag := c
END;
DevCPL486.GenPush(tag);
IF tag.mode # Con THEN niltest := FALSE END;
PushAdr(ap, niltest);
IF rec THEN Free(tag) END
ELSE PushAdr(ap, niltest)
END;
tag.typ := recTyp
ELSIF par.form = Comp THEN
s := par.typ.size;
IF initializeStr & (ap.form IN {String8, String16, VString8, VString16, VString16to8}) THEN
s := (s + 3) DIV 4 * 4; AdjustStack(-s);
IF ap.form IN {String8, String16} THEN
IF ap.index > 1 THEN (* nonempty string *)
ss := (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4;
DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
DevCPL486.GenBlockMove(1, ss);
ELSE
ss := 0;
DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c)
END;
IF s > ss THEN
DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a);
DevCPL486.GenBlockStore(1, s - ss)
END;
ELSE
DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
DevCPL486.GenStringMove(TRUE, StringWSize(ap), StringWSize(par), par.typ.n);
DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a);
DevCPL486.GenBlockStore(StringWSize(par), 0)
END
ELSE
IF (ap.form IN {String8, String16}) & (ap.index = 1) THEN (* empty string *)
AdjustStack((4 - s) DIV 4 * 4);
DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c)
ELSE
AdjustStack((-s) DIV 4 * 4);
DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
IF ap.form IN {String8, String16} THEN
DevCPL486.GenBlockMove(1, (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4)
ELSIF ap.form IN {VString8, VString16, VString16to8} THEN
DevCPL486.GenStringMove(FALSE, StringWSize(ap), StringWSize(par), par.typ.n)
ELSE
DevCPL486.GenBlockMove(1, (s + 3) DIV 4 * 4)
END
END
END
ELSIF ap.mode = Con THEN
IF ap.form IN {Real32, Real64} THEN (* ??? push const *)
DevCPL486.GenFLoad(ap); DecStack(par.typ.form); DevCPL486.GenFStore(par, TRUE)
ELSE
ap.form := Int32;
IF par.form = Int64 THEN DevCPL486.MakeConst(c, ap.scale, Int32); DevCPL486.GenPush(c) END;
DevCPL486.GenPush(ap)
END
ELSIF ap.typ.form = Pointer THEN
recTyp := ap.typ.BaseTyp;
IF rec THEN
Load(ap, {}, {}); Tag(ap, tag);
IF tag.mode = Con THEN (* explicit nil test needed *)
DevCPL486.MakeReg(a, AX, Int32);
c.mode := Ind; c.form := Int32; c.offset := 0; c.scale := 0; c.reg := ap.reg;
DevCPL486.GenTest(a, c)
END
END;
DevCPL486.GenPush(ap); Free(ap);
tag.typ := recTyp
ELSIF ap.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *)
ASSERT(par.form = Pointer);
PushAdr(ap, FALSE)
ELSE
ConvMove(par, ap, FALSE, {}, {high});
END
END Param;
PROCEDURE Result* (proc: DevCPT.Object; VAR res: DevCPL486.Item);
VAR r: DevCPL486.Item;
BEGIN
DevCPL486.MakeReg(r, AX, proc.typ.form); (* don't allocate AX ! *)
IF res.mode = Con THEN
IF r.form IN {Real32, Real64} THEN DevCPL486.GenFLoad(res);
ELSIF r.form = Int64 THEN
r.form := Int32; res.form := Int32; DevCPL486.GenMove(res, r);
r.reg := DX; res.offset := res.scale; DevCPL486.GenMove(res, r)
ELSE DevCPL486.GenMove(res, r);
END
ELSIF res.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *)
ASSERT(r.form = Pointer);
GetAdr(res, {}, wreg - {AX})
ELSE
r.index := DX; (* for int64 *)
ConvMove(r, res, FALSE, wreg - {AX} + {high}, {});
END;
Free(res)
END Result;
PROCEDURE InitFpu;
VAR x: DevCPL486.Item;
BEGIN
DevCPL486.MakeConst(x, FpuControlRegister, Int32); DevCPL486.GenPush(x);
DevCPL486.GenFMOp(12CH); DevCPL486.GenCode(24H); (* FLDCW 0(SP) *)
DevCPL486.MakeReg(x, CX, Int32); DevCPL486.GenPop(x); (* reset stack *)
END InitFpu;
PROCEDURE PrepCall* (proc: DevCPT.Object);
VAR lev: BYTE; r: DevCPL486.Item;
BEGIN
lev := proc.mnolev;
IF (slNeeded IN proc.conval.setval) & (imLevel[lev] > 0) & (imLevel[DevCPL486.level] > imLevel[lev]) THEN
DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r)
END
END PrepCall;
PROCEDURE Call* (VAR x, tag: DevCPL486.Item); (* TProc: tag.typ = actual receiver type *)
VAR i, n: INTEGER; r, y: DevCPL486.Item; typ: DevCPT.Struct; lev: BYTE; saved: BOOLEAN; p: DevCPT.Object;
BEGIN
IF x.mode IN {LProc, XProc, IProc} THEN
lev := x.obj.mnolev; saved := FALSE;
IF (slNeeded IN x.obj.conval.setval) & (imLevel[lev] > 0) THEN (* pass static link *)
n := imLevel[DevCPL486.level] - imLevel[lev];
IF n > 0 THEN
saved := TRUE;
y.mode := Ind; y.scale := 0; y.form := Pointer; y.reg := BX; y.offset := -4;
DevCPL486.MakeReg(r, BX, Pointer);
WHILE n > 0 DO DevCPL486.GenMove(y, r); DEC(n) END
END
END;
DevCPL486.GenCall(x);
IF x.obj.sysflag = ccall THEN (* remove parameters *)
p := x.obj.link; n := 0;
WHILE p # NIL DO
IF p.mode = VarPar THEN INC(n, 4)
ELSE INC(n, (p.typ.size + 3) DIV 4 * 4)
END;
p := p.link
END;
AdjustStack(n)
END;
IF saved THEN DevCPL486.GenPop(r) END;
ELSIF x.mode = TProc THEN
IF x.scale = 1 THEN (* super *)
DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(tag.typ.BaseTyp)
ELSIF x.scale = 2 THEN (* static call *)
DevCPL486.MakeConst(tag, 0, Pointer); typ := x.obj.link.typ;
IF typ.form = Pointer THEN typ := typ.BaseTyp END;
tag.obj := DevCPE.TypeObj(typ)
ELSIF x.scale = 3 THEN (* interface method call *)
DevCPM.err(200)
END;
IF tag.mode = Con THEN
y.mode := Abs; y.offset := tag.offset; y.obj := tag.obj; y.scale := 0
ELSIF (x.obj.conval.setval * {absAttr, empAttr, extAttr} = {}) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final method *)
y.mode := Abs; y.offset := 0; y.obj := DevCPE.TypeObj(tag.typ); y.scale := 0;
IF tag.mode = Ind THEN (* nil test *)
DevCPL486.MakeReg(r, AX, Int32); tag.offset := 0; DevCPL486.GenTest(r, tag)
END
ELSE
IF tag.mode = Reg THEN y.reg := tag.reg
ELSE GetReg(y, Pointer, {}, {}); DevCPL486.GenMove(tag, y)
END;
y.mode := Ind; y.offset := 0; y.scale := 0
END;
IF (tag.typ.sysflag = interface) & (y.mode = Ind) THEN y.offset := 4 * x.offset
ELSIF tag.typ.untagged THEN DevCPM.err(140)
ELSE
IF x.obj.link.typ.sysflag = interface THEN (* correct method number *)
x.offset := numPreIntProc + NumOfIntProc(tag.typ) - 1 - x.offset
END;
INC(y.offset, Mth0Offset - 4 * x.offset)
END;
DevCPL486.GenCall(y); Free(y)
ELSIF x.mode = CProc THEN
IF x.obj.link # NIL THEN (* tag = first param *)
IF x.obj.link.mode = VarPar THEN
GetAdr(tag, {}, wreg - {AX} + {stk, mem, con}); Free(tag)
ELSE
(* Load(tag, {}, wreg - {AX} + {con}); Free(tag) *)
Result(x.obj.link, tag) (* use result load for first parameter *)
END
END;
i := 1; n := ORD(x.obj.conval.ext^[0]);
WHILE i <= n DO DevCPL486.GenCode(ORD(x.obj.conval.ext^[i])); INC(i) END
ELSE (* proc var *)
DevCPL486.GenCall(x); Free(x);
IF x.typ.sysflag = ccall THEN (* remove parameters *)
p := x.typ.link; n := 0;
WHILE p # NIL DO
IF p.mode = VarPar THEN INC(n, 4)
ELSE INC(n, (p.typ.size + 3) DIV 4 * 4)
END;
p := p.link
END;
AdjustStack(n)
END;
x.typ := x.typ.BaseTyp
END;
IF procedureUsesFpu & (x.mode = XProc) & (x.obj.mnolev < 0) & (x.obj.mnolev > -128)
& ((x.obj.library # NIL) OR (DevCPT.GlbMod[-x.obj.mnolev].library # NIL)) THEN (* restore fpu *)
InitFpu
END;
CheckReg;
IF x.typ.form = Int64 THEN
GetReg(x, Int32, {}, wreg - {AX}); GetReg(y, Int32, {}, wreg - {DX});
x.index := y.reg; x.form := Int64
ELSIF x.typ.form # NoTyp THEN GetReg(x, x.typ.form, {}, wreg - {AX} + {high})
END
END Call;
PROCEDURE CopyDynArray* (adr: INTEGER; typ: DevCPT.Struct); (* needs CX, SI, DI *)
VAR len, ptr, c, sp, src, dst: DevCPL486.Item; bt: DevCPT.Struct;
BEGIN
IF typ.untagged THEN DevCPM.err(-137) END;
ptr.mode := Ind; ptr.reg := BP; ptr.offset := adr+4; ptr.scale := 0; ptr.form := Pointer;
DevCPL486.MakeReg(len, CX, Int32); DevCPL486.MakeReg(sp, SP, Int32);
DevCPL486.MakeReg(src, SI, Int32); DevCPL486.MakeReg(dst, DI, Int32);
DevCPL486.GenMove(ptr, len); bt := typ.BaseTyp;
WHILE bt.comp = DynArr DO
INC(ptr.offset, 4); DevCPL486.GenMul(ptr, len, FALSE); bt := bt.BaseTyp
END;
ptr.offset := adr; DevCPL486.GenMove(ptr, src);
DevCPL486.MakeConst(c, bt.size, Int32); DevCPL486.GenMul(c, len, FALSE);
(* CX = length in bytes *)
StackAlloc;
(* CX = length in 32bit words *)
DevCPL486.GenMove(sp, dst); DevCPL486.GenMove(dst, ptr);
DevCPL486.GenBlockMove(4, 0)(* 32bit moves *)
END CopyDynArray;
PROCEDURE Sort (VAR tab: ARRAY OF INTEGER; VAR n: INTEGER);
VAR i, j, x: INTEGER;
BEGIN
(* align *)
i := 1;
WHILE i < n DO
x := tab[i]; j := i-1;
WHILE (j >= 0) & (tab[j] < x) DO tab[j+1] := tab[j]; DEC(j) END;
tab[j+1] := x; INC(i)
END;
(* eliminate equals *)
i := 1; j := 1;
WHILE i < n DO
IF tab[i] # tab[i-1] THEN tab[j] := tab[i]; INC(j) END;
INC(i)
END;
n := j
END Sort;
PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; VAR num: INTEGER);
VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
BEGIN
IF typ.form IN {Pointer, ProcTyp} THEN
IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 END;
INC(num);
IF adr MOD 4 # 0 THEN
IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 + 4 END;
INC(num)
END
ELSIF typ.comp = Record THEN
btyp := typ.BaseTyp;
IF btyp # NIL THEN FindPtrs(btyp, adr, num) END ;
fld := typ.link;
WHILE (fld # NIL) & (fld.mode = Fld) DO
IF (fld.name^ = DevCPM.HdPtrName) OR
(fld.name^ = DevCPM.HdUtPtrName) OR
(fld.name^ = DevCPM.HdProcName) THEN
FindPtrs(DevCPT.sysptrtyp, fld.adr + adr, num)
ELSE FindPtrs(fld.typ, fld.adr + adr, num)
END;
fld := fld.link
END
ELSIF typ.comp = Array THEN
btyp := typ.BaseTyp; n := typ.n;
WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN
i := num; FindPtrs(btyp, adr, num);
IF num # i THEN i := 1;
WHILE (i < n) & (num <= MaxPtrs) DO
INC(adr, btyp.size); FindPtrs(btyp, adr, num); INC(i)
END
END
END
END
END FindPtrs;
PROCEDURE InitOutPar (par: DevCPT.Object; VAR zreg: DevCPL486.Item);
VAR x, y, c, len: DevCPL486.Item; lbl: DevCPL486.Label; size, s: INTEGER; bt: DevCPT.Struct;
BEGIN
x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := par.adr;
DevCPL486.MakeReg(y, DI, Int32);
IF par.typ.comp # DynArr THEN
DevCPL486.GenMove(x, y);
lbl := DevCPL486.NewLbl;
IF ODD(par.sysflag DIV nilBit) THEN
DevCPL486.GenComp(zreg, y);
DevCPL486.GenJump(ccE, lbl, TRUE)
END;
size := par.typ.size;
IF size <= 16 THEN
x.mode := Ind; x.reg := DI; x.form := Int32; x.offset := 0;
WHILE size > 0 DO
IF size = 1 THEN x.form := Int8; s := 1
ELSIF size = 2 THEN x.form := Int16; s := 2
ELSE x.form := Int32; s := 4
END;
zreg.form := x.form; DevCPL486.GenMove(zreg, x); INC(x.offset, s); DEC(size, s)
END;
zreg.form := Int32
ELSE
DevCPL486.GenBlockStore(1, size)
END;
DevCPL486.SetLabel(lbl)
ELSIF initializeDyn & ~par.typ.untagged THEN (* untagged open arrays not initialized !!! *)
DevCPL486.GenMove(x, y);
DevCPL486.MakeReg(len, CX, Int32);
INC(x.offset, 4); DevCPL486.GenMove(x, len); (* first len *)
bt := par.typ.BaseTyp;
WHILE bt.comp = DynArr DO
INC(x.offset, 4); DevCPL486.GenMul(x, len, FALSE); bt := bt.BaseTyp
END;
size := bt.size;
IF size MOD 4 = 0 THEN size := size DIV 4; s := 4
ELSIF size MOD 2 = 0 THEN size := size DIV 2; s := 2
ELSE s := 1
END;
DevCPL486.MakeConst(c, size, Int32); DevCPL486.GenMul(c, len, FALSE);
DevCPL486.GenBlockStore(s, 0)
END
END InitOutPar;
PROCEDURE AllocAndInitAll (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER);
VAR x, y, z, zero: DevCPL486.Item; par: DevCPT.Object; op: INTEGER;
BEGIN
op := 0; par := proc.link;
WHILE par # NIL DO (* count out parameters [with COM pointers] *)
IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN INC(op) END;
par := par.link
END;
DevCPL486.MakeConst(zero, 0, Int32);
IF (op = 0) & (size <= 8) THEN (* use PUSH 0 *)
WHILE size > 0 DO DevCPL486.GenPush(zero); DEC(size, 4) END
ELSE
DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z);
IF size <= 32 THEN (* use PUSH reg *)
WHILE size > 0 DO DevCPL486.GenPush(z); DEC(size, 4) END
ELSE (* use string store *)
AdjustStack(-size);
DevCPL486.MakeReg(x, SP, Int32); DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y);
DevCPL486.GenBlockStore(1, size)
END;
IF op > 0 THEN
par := proc.link;
WHILE par # NIL DO (* init out parameters [with COM pointers] *)
IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN InitOutPar(par, z) END;
par := par.link
END
END
END
END AllocAndInitAll;
PROCEDURE AllocAndInitPtrs1 (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); (* needs AX *)
VAR i, base, a, gaps: INTEGER; x, z: DevCPL486.Item; obj: DevCPT.Object;
BEGIN
IF ptrinit & (proc.scope # NIL) THEN
nofptrs := 0; obj := proc.scope.scope; (* local variables *)
WHILE (obj # NIL) & (nofptrs <= MaxPtrs) DO
FindPtrs(obj.typ, obj.adr, nofptrs);
obj := obj.link
END;
IF (nofptrs > 0) & (nofptrs <= MaxPtrs) THEN
base := proc.conval.intval2;
Sort(ptrTab, nofptrs); i := 0; a := size + base; gaps := 0;
WHILE i < nofptrs DO
DEC(a, 4);
IF a # ptrTab[i] THEN a := ptrTab[i]; INC(gaps) END;
INC(i)
END;
IF a # base THEN INC(gaps) END;
IF (gaps <= (nofptrs + 1) DIV 2) & (size < stackAllocLimit) THEN
DevCPL486.MakeConst(z, 0, Pointer);
IF (nofptrs > 4) THEN x := z; DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z) END;
i := 0; a := size + base;
WHILE i < nofptrs DO
DEC(a, 4);
IF a # ptrTab[i] THEN AdjustStack(ptrTab[i] - a); a := ptrTab[i] END;
DevCPL486.GenPush(z); INC(i)
END;
IF a # base THEN AdjustStack(base - a) END
ELSE
AdjustStack(-size);
DevCPL486.MakeConst(x, 0, Pointer); DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z);
x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; i := 0;
WHILE i < nofptrs DO
x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i)
END
END
ELSE
AdjustStack(-size)
END
ELSE
nofptrs := 0;
AdjustStack(-size)
END
END AllocAndInitPtrs1;
PROCEDURE InitPtrs2 (proc: DevCPT.Object; adr, size, nofptrs: INTEGER); (* needs AX, CX, DI *)
VAR x, y, z, zero: DevCPL486.Item; obj: DevCPT.Object; zeroed: BOOLEAN; i: INTEGER; lbl: DevCPL486.Label;
BEGIN
IF ptrinit THEN
zeroed := FALSE; DevCPL486.MakeConst(zero, 0, Pointer);
IF nofptrs > MaxPtrs THEN
DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE;
x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := adr;
DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenLoadAdr(x, y);
DevCPL486.GenStrStore(size)
END;
obj := proc.link; (* parameters *)
WHILE obj # NIL DO
IF (obj.mode = VarPar) & (obj.vis = outPar) THEN
nofptrs := 0;
IF obj.typ.comp = DynArr THEN (* currently not initialized *)
ELSE FindPtrs(obj.typ, 0, nofptrs)
END;
IF nofptrs > 0 THEN
IF ~zeroed THEN
DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE
END;
x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := obj.adr;
DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y);
IF ODD(obj.sysflag DIV nilBit) THEN
DevCPL486.GenComp(zero, y);
lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
END;
IF nofptrs > MaxPtrs THEN
DevCPL486.GenStrStore(obj.typ.size)
ELSE
Sort(ptrTab, nofptrs);
x.reg := DI; i := 0;
WHILE i < nofptrs DO
x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i)
END
END;
IF ODD(obj.sysflag DIV nilBit) THEN DevCPL486.SetLabel(lbl) END
END
END;
obj := obj.link
END
END
END InitPtrs2;
PROCEDURE NeedOutPtrInit (proc: DevCPT.Object): BOOLEAN;
VAR obj: DevCPT.Object; nofptrs: INTEGER;
BEGIN
IF ptrinit THEN
obj := proc.link;
WHILE obj # NIL DO
IF (obj.mode = VarPar) & (obj.vis = outPar) THEN
nofptrs := 0;
IF obj.typ.comp = DynArr THEN (* currently not initialized *)
ELSE FindPtrs(obj.typ, 0, nofptrs)
END;
IF nofptrs > 0 THEN RETURN TRUE END
END;
obj := obj.link
END
END;
RETURN FALSE
END NeedOutPtrInit;
PROCEDURE Enter* (proc: DevCPT.Object; empty, useFpu: BOOLEAN);
VAR sp, fp, r, r1: DevCPL486.Item; par: DevCPT.Object; adr, size, np: INTEGER;
BEGIN
procedureUsesFpu := useFpu;
SetReg({AX, CX, DX, SI, DI});
DevCPL486.MakeReg(fp, BP, Pointer); DevCPL486.MakeReg(sp, SP, Pointer);
IF proc # NIL THEN (* enter proc *)
DevCPL486.SetLabel(proc.adr);
IF (~empty OR NeedOutPtrInit(proc)) & (proc.sysflag # noframe) THEN
DevCPL486.GenPush(fp);
DevCPL486.GenMove(sp, fp);
adr := proc.conval.intval2; size := -adr;
IF isGuarded IN proc.conval.setval THEN
DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r);
DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r);
DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r);
r1.mode := Con; r1.form := Int32; r1.offset := proc.conval.intval - 8; r1.obj := NIL;
DevCPL486.GenPush(r1);
intHandler.used := TRUE;
r1.mode := Con; r1.form := Int32; r1.offset := 0; r1.obj := intHandler;
DevCPL486.GenPush(r1);
r1.mode := Abs; r1.form := Int32; r1.offset := 0; r1.scale := 0; r1.obj := NIL;
DevCPL486.GenCode(64H); DevCPL486.GenPush(r1);
DevCPL486.GenCode(64H); DevCPL486.GenMove(sp, r1);
DEC(size, 24)
ELSE
IF imVar IN proc.conval.setval THEN (* set down pointer *)
DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); DEC(size, 4)
END;
IF isCallback IN proc.conval.setval THEN
DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r);
DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); DEC(size, 8)
END
END;
ASSERT(size >= 0);
IF initializeAll THEN
AllocAndInitAll(proc, adr, size, np)
ELSE
AllocAndInitPtrs1(proc, adr, size, np); (* needs AX *)
InitPtrs2(proc, adr, size, np); (* needs AX, CX, DI *)
END;
par := proc.link; (* parameters *)
WHILE par # NIL DO
IF (par.mode = Var) & (par.typ.comp = DynArr) THEN
CopyDynArray(par.adr, par.typ)
END;
par := par.link
END;
IF imVar IN proc.conval.setval THEN
DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenMove(fp, r)
END
END
ELSIF ~empty THEN (* enter module *)
DevCPL486.GenPush(fp);
DevCPL486.GenMove(sp, fp);
DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPush(r);
DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPush(r)
END;
IF useFpu THEN InitFpu END
END Enter;
PROCEDURE Exit* (proc: DevCPT.Object; empty: BOOLEAN);
VAR sp, fp, r, x: DevCPL486.Item; mode: SHORTINT; size: INTEGER;
BEGIN
DevCPL486.MakeReg(sp, SP, Pointer); DevCPL486.MakeReg(fp, BP, Pointer);
IF proc # NIL THEN (* exit proc *)
IF proc.sysflag # noframe THEN
IF ~empty OR NeedOutPtrInit(proc) THEN
IF isGuarded IN proc.conval.setval THEN (* remove exception frame *)
x.mode := Ind; x.reg := BP; x.offset := -24; x.scale := 0; x.form := Int32;
DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(x, r);
x.mode := Abs; x.offset := 0; x.scale := 0; x.form := Int32; x.obj := NIL;
DevCPL486.GenCode(64H); DevCPL486.GenMove(r, x);
size := 12
ELSE
size := 0;
IF imVar IN proc.conval.setval THEN INC(size, 4) END;
IF isCallback IN proc.conval.setval THEN INC(size, 8) END
END;
IF size > 0 THEN
x.mode := Ind; x.reg := BP; x.offset := -size; x.scale := 0; x.form := Int32;
DevCPL486.GenLoadAdr(x, sp);
IF size > 4 THEN
DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r);
DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r)
END;
IF size # 8 THEN
DevCPL486.MakeReg(r, BX, Int32); DevCPL486.GenPop(r)
END
ELSE
DevCPL486.GenMove(fp, sp)
END;
DevCPL486.GenPop(fp)
END;
IF proc.sysflag = ccall THEN DevCPL486.GenReturn(0)
ELSE DevCPL486.GenReturn(proc.conval.intval - 8)
END
END
ELSE (* exit module *)
IF ~empty THEN
DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r);
DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r);
DevCPL486.GenMove(fp, sp); DevCPL486.GenPop(fp)
END;
DevCPL486.GenReturn(0)
END
END Exit;
PROCEDURE InstallStackAlloc*;
VAR name: ARRAY 32 OF SHORTCHAR; ax, cx, sp, c, x: DevCPL486.Item; l1, l2: DevCPL486.Label;
BEGIN
IF stkAllocLbl # DevCPL486.NewLbl THEN
DevCPL486.SetLabel(stkAllocLbl);
DevCPL486.MakeReg(ax, AX, Int32);
DevCPL486.MakeReg(cx, CX, Int32);
DevCPL486.MakeReg(sp, SP, Int32);
DevCPL486.GenPush(ax);
DevCPL486.MakeConst(c, -5, Int32); DevCPL486.GenAdd(c, cx, FALSE);
l1 := DevCPL486.NewLbl; DevCPL486.GenJump(ccNS, l1, TRUE);
DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, cx);
DevCPL486.SetLabel(l1);
DevCPL486.MakeConst(c, -4, Int32); DevCPL486.GenAnd(c, cx);
DevCPL486.GenMove(cx, ax);
DevCPL486.MakeConst(c, 4095, Int32); DevCPL486.GenAnd(c, ax);
DevCPL486.GenSub(ax, sp, FALSE);
DevCPL486.GenMove(cx, ax);
DevCPL486.MakeConst(c, 12, Int32); DevCPL486.GenShiftOp(SHR, c, ax);
l2 := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, l2, TRUE);
l1 := DevCPL486.NewLbl; DevCPL486.SetLabel(l1);
DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c);
DevCPL486.MakeConst(c, 4092, Int32); DevCPL486.GenSub(c, sp, FALSE);
DevCPL486.MakeConst(c, -1, Int32); DevCPL486.GenAdd(c, ax, FALSE);
DevCPL486.GenJump(ccNE, l1, TRUE);
DevCPL486.SetLabel(l2);
DevCPL486.MakeConst(c, 8, Int32); DevCPL486.GenAdd(c, cx, FALSE);
x.mode := Ind; x.form := Int32; x.offset := -4; x.index := CX; x.reg := SP; x.scale := 1;
DevCPL486.GenMove(x, ax);
DevCPL486.GenPush(ax);
DevCPL486.GenMove(x, ax);
DevCPL486.MakeConst(c, 2, Int32); DevCPL486.GenShiftOp(SHR, c, cx);
DevCPL486.GenReturn(0);
name := "$StackAlloc"; DevCPE.OutRefName(name);
END
END InstallStackAlloc;
PROCEDURE Trap* (n: INTEGER);
BEGIN
DevCPL486.GenAssert(ccNever, n)
END Trap;
PROCEDURE Jump* (VAR L: DevCPL486.Label);
BEGIN
DevCPL486.GenJump(ccAlways, L, FALSE)
END Jump;
PROCEDURE JumpT* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label);
BEGIN
DevCPL486.GenJump(x.offset, L, FALSE);
END JumpT;
PROCEDURE JumpF* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label);
BEGIN
DevCPL486.GenJump(Inverted(x.offset), L, FALSE);
END JumpF;
PROCEDURE CaseTableJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR else: DevCPL486.Label);
VAR c: DevCPL486.Item; n: INTEGER;
BEGIN
n := high - low + 1;
DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenSub(c, x, FALSE);
DevCPL486.MakeConst(c, n, Int32); DevCPL486.GenComp(c, x);
DevCPL486.GenJump(ccAE, else, FALSE);
DevCPL486.GenCaseJump(x)
END CaseTableJump;
PROCEDURE CaseJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR this, else: DevCPL486.Label; tree, first: BOOLEAN);
VAR c: DevCPL486.Item;
BEGIN
IF high = low THEN
DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
IF tree THEN DevCPL486.GenJump(ccG, else, FALSE) END;
DevCPL486.GenJump(ccE, this, FALSE)
ELSIF first THEN
DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
DevCPL486.GenJump(ccL, else, FALSE);
DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x);
DevCPL486.GenJump(ccLE, this, FALSE);
ELSE
DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x);
DevCPL486.GenJump(ccG, else, FALSE);
DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
DevCPL486.GenJump(ccGE, this, FALSE);
END
END CaseJump;
BEGIN
imLevel[0] := 0
END DevCPC486.