MODULE Dev0CPC486; (* THIS IS TEXT COPY OF CPC486.odc *) (* DO NOT EDIT *) (** project = "BlackBox" organization = "www.oberon.ch" contributors = "Oberon microsystems" version = "System/Rsrc/AboutBB" copyright = "System/Rsrc/AboutBB" license = "Docu/BB-License" references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" changes = "" issues = "" **) IMPORT SYSTEM, DevCPM := Dev0CPM, DevCPT := Dev0CPT, DevCPE := Dev0CPE, DevCPL486 := Dev0CPL486; 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.errorMes := DevCPM.errorMes + " AX" END; IF BX IN reg THEN DevCPM.errorMes := DevCPM.errorMes +" BX" END; IF CX IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " CX" END; IF DX IN reg THEN DevCPM.errorMes := DevCPM.errorMes +" DX" END; IF SI IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " SI" END; IF DI IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " 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 IF x.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.form IN {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 Dev0CPC486.