|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 32250 (0x7dfa)
Types: TextFile
Names: »P435EOPR.PAS«
└─⟦037c0ce35⟧ Bits:30010524 DVBS1.SW2114.src.2.6-2 RTP compiler source SW2104+SW2114 Disk#2 30/1-92 HHA
└─⟦this⟧ »RTP\P435EOPR.PAS«
└─⟦828f0d3dd⟧ Bits:30010527 DVBS1.SW2114.src.2.6-5 RTP Compiler Source SW2104+SW2114 Disk 2 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\P435EOPR.PAS«
└─⟦891417be1⟧ Bits:30010519 DVBS1.SW2114.src.2-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
└─⟦this⟧ »RTP\P435EOPR.PAS«
{$O+,F+}\r
unit p435eopr;\r
interface\r
uses pscplm,mpaunit,sthunit,p4unit;\r
\r
\r
PROCEDURE MegaLoad(e : ESTelementRef);\r
Procedure MegaStore(size : Integer);\r
Procedure PushOperand;\r
Procedure PushOperands;\r
procedure MegaOperationOnStack(Inst : Instruction;commutativ : BOOLEAN);\r
PROCEDURE CMPTopelements(Inst : Instruction; neg : boolean);\r
PROCEDURE PushAddr(PtrSt : St_ElemPtr);\r
Function megaoffset(niv,offset : word) : word;\r
Procedure StoreStackToTemp(e : ESTElementRef);\r
Procedure MegaPointer;\r
Procedure MegaMakeAddr(e : ESTelementRef);\r
Function MegaAllign(e : ESTelementRef) : Boolean;\r
Procedure MegaMoveToTemp(e : ESTelementRef);\r
PROCEDURE PopPackedElement;\r
PROCEDURE PutPackedElement;\r
PROCEDURE GetPackedElement(e : ESTElementRef; TypeAddr : St_Address);\r
PROCEDURE LoadPacked(e : ESTElementRef);\r
Procedure MakeFreeReg(no : integer);\r
Procedure PushParam(paramkind : codes);\r
Procedure StartCall;\r
Procedure EndCall(ParamSize : Integer);\r
Procedure LoadFirstParams(ParamSize : Integer; Routinekind : st_DeclareMode);\r
Procedure InitParamList;\r
Procedure ExchangeTopElements;\r
Procedure AddOffsetToAddr(e: ESTElementRef;Offset : integer);\r
Procedure AllocDynamic(InSymbol : St_address;AddLength : Integer;\r
off : integer);\r
Procedure MakeCopyOfTop;\r
Procedure MakeSetOprReady;\r
PROCEDURE PushSetOnStack(TypeAddr : St_Address);\r
PROCEDURE MakeProgramDesc(ProgOffset : Word; ProgState : State;\r
PoolParam : boolean; lab : St_Address);\r
PROCEDURE MegaAllocTemp(No:Integer);\r
Procedure MegaAllocParam(No:Integer);\r
PROCEDURE LoadAbsAddr(e : ESTElementRef);\r
implementation\r
uses sthcom,sthp34,p4evalst,p435code,p435bool,p435stat;\r
\r
\r
(********************** PROCEDURE ESTOPR ****************)\r
(* This module impl. operations on the stack elements *)\r
\r
\r
(********************************************************)\r
TYPE\r
ParamType = (AReg,BReg,Stop,Loaded);\r
\r
ParamRecordType = ^RecordType;\r
\r
\r
RecordType =\r
RECORD\r
InOut : Boolean;\r
Kind : ParamType;\r
NextParamNo : integer;\r
TempOffset : Integer;\r
Next : ParamRecordType;\r
END;\r
\r
VAR\r
ParamList : ParamRecordType;\r
\r
(* ---------------------------------------------- *)\r
\r
\r
PROCEDURE ESTPushTemp (LOprType : st_address;\r
LIndVar : Boolean;\r
Offset : Word;\r
IndexSTL : Integer);\r
\r
BEGIN\r
\r
\r
MakeNewStackTop;\r
WITH ESTTop^ DO\r
BEGIN\r
Kind := O_Temp;\r
OprType := LOprType;\r
Par := P_Normal;\r
IndVar := LIndVar;\r
T_Offset := Offset;\r
T_IndexToSTL := IndexSTL;\r
T_address := false;\r
END;\r
\r
LastOnStack := ESTTop;\r
\r
\r
\r
END; (* ESTPushTemp *)\r
\r
Procedure StoreStackToTemp(e : ESTElementRef);\r
BEGIN\r
END;\r
\r
Procedure MakeFreeReg(no : integer);\r
VAR i : integer;\r
e: ESTElementRef;\r
BEGIN\r
i := 0;\r
e := ESTTop;\r
WHILE e <> Bottom_ESTTop DO\r
BEGIN\r
if ESTSort(e) = S_Stack then\r
BEGIN\r
i := i + 1;\r
if i > (3 - no) THEN\r
BEGIN\r
END;\r
END;\r
e := e^.backward;\r
END;\r
END;\r
\r
\r
Procedure PointerInDirect(E :ESTElementRef);\r
VAR offset,niv : word;\r
BEGIN\r
IF e^.Kind = O_Addr THEN\r
BEGIN\r
offset := E^.A_offset;\r
niv := E^.A_Niv;\r
E^.Kind := O_IndAddr;\r
E^.I_Offset := offset;\r
E^.I_Niv := Niv;\r
E^.I_ObjectOffset := 0;\r
E^.AccessCheck := true;\r
E^.I_Allign := true;\r
END\r
ELSE\r
BEGIN\r
E^.IndVar := true;\r
Megaload(E);\r
END;\r
END;\r
\r
\r
Procedure MegaPointer;\r
BEGIN\r
PointerIndirect(ESTTop);\r
END;\r
\r
\r
Function MegaAllign(e : ESTelementRef) : Boolean;\r
BEGIN\r
\r
Case e^.Kind OF\r
\r
O_Addr :\r
BEGIN\r
MegaAllign := (e^.A_Offset MOD 4 = 0);\r
END;\r
\r
O_IndAddr:\r
BEGIN\r
MegaAllign := e^.I_Allign and (e^.I_ObjectOffset MOD 4 = 0);\r
END;\r
\r
O_Temp,\r
O_Stack,\r
O_StackOrTemp :\r
BEGIN\r
IF e^.T_Address THEN\r
MegaAllign := e^.T_Allign AND\r
(e^.T_ObjectOffset MOD 4 = 0)\r
ELSE MegaAllign := True;\r
END;\r
\r
\r
O_CAddr : MegaAllign := (e^.C_ObjectOffset MOD 4 = 0);\r
\r
else MegaAllign := true;\r
END; (* end case *)\r
\r
END;\r
\r
Procedure MegaMakeaddr(e : ESTelementRef);\r
BEGIN\r
MegaLoad(e);\r
END; (* MegaMakeAddr *)\r
\r
Procedure Loadaddr(e : ESTelementRef);\r
VAR Offset : word;\r
OffsetI: Integer;\r
ObjectOffset : word;\r
Allign : boolean;\r
Typeaddr : St_Address;\r
indvar : boolean;\r
BEGIN\r
if e = bottom_esttop then\r
begin\r
writeln('not ok ',ord(e^.kind));\r
end;\r
IF e^.Par = P_Share THEN\r
BEGIN\r
e^.Par := P_Normal;\r
TypeAddr := e^.OprType;\r
AddOffsetToAddr(e,ReferenceSize);\r
indvar := e^.Indvar;\r
e^.OprType := PointerType;\r
PointerInDirect(e);\r
e^.Indvar := indvar;\r
e^.OprType := TypeAddr;\r
END;\r
\r
\r
\r
\r
ObjectOffset := 0;\r
\r
Case e^.Kind OF\r
\r
O_Addr :\r
BEGIN\r
If e^.A_Niv = CurrentNiv THEN\r
CodeConst(rREALD,e^.A_offset,e^.spix)\r
ELSE\r
If e^.A_Niv = Program_Level THEN\r
CodeConst(rREAGD,e^.A_offset,e^.spix)\r
ELSE\r
BEGIN\r
CodeConst(rREAID,CurrentNiv - e^.A_Niv,anonymousSpix);\r
ObjectOffset := e^.A_Offset;\r
END;\r
END;\r
\r
O_IndAddr:\r
BEGIN\r
If e^.I_Niv = Program_Level THEN\r
CodeConst(rREVGA,e^.I_offset,e^.spix)\r
ELSE\r
If e^.I_Niv = CurrentNiv THEN\r
CodeConst(rREVLA,e^.I_offset,e^.spix)\r
ELSE\r
BEGIN\r
CodeConst(rREAID,CurrentNiv - e^.I_Niv,anonymousSpix);\r
CodeConst(rREVSA,e^.I_Offset,e^.Spix);\r
END;\r
ObjectOffset := e^.I_ObjectOffset;\r
END;\r
\r
O_Stack :\r
BEGIN\r
ObjectOffset := e^.T_ObjectOffset;\r
END;\r
\r
O_StackOrTemp :\r
BEGIN\r
END;\r
\r
O_CAddr : BEGIN\r
CodeLoadEffAddr(e^.C_Label,e^.C_ObjectOffset);\r
END;\r
END; (* end case *)\r
\r
e^.Kind := O_Stack;\r
e^.T_ObjectOffset := ObjectOffset;\r
\r
END; (* LoadAddr *)\r
\r
\r
PROCEDURE LoadAbsAddr(e : ESTElementRef);\r
BEGIN\r
LoadAddr(e);\r
IF e^.T_ObjectOffset <> 0 THEN\r
CodeConst(rREASD,e^.T_ObjectOffset,AnonymousSpix);\r
e^.T_ObjectOffset := 0;\r
END;\r
\r
\r
Procedure NewParam(PInOut : Boolean;\r
PKind : ParamType;\r
PTempOffset : Integer);\r
VAR Ptr : ParamRecordType;\r
BEGIN\r
END;\r
Procedure InitParamList;\r
BEGIN\r
END;\r
Procedure StartCall;\r
BEGIN\r
END;\r
\r
Procedure EndCall(ParamSize : Integer);\r
VAR Ptr : ParamRecordType;\r
BEGIN\r
END;\r
\r
Procedure LoadFirstParams(ParamSize : Integer;routinekind : st_declaremode);\r
VAR Ptr : ParamRecordType;\r
VAR oldkind : ParamType;\r
BEGIN\r
END;\r
\r
PROCEDURE PushParam(ParamKind : codes);\r
VAR\r
Addr : Address;\r
St_AddrRef : St_elemptr;\r
offset : Integer;\r
LoadAdr : boolean;\r
Size : Integer;\r
e,CurE : ESTelementRef;\r
\r
Procedure Load(Ce : EstElementRef);\r
BEGIN\r
IF (Size > 0) AND (Size <= 4) THEN\r
CodeConst(Instruction(ord(rREVSB) - 1 + size),\r
CE^.T_ObjectOffset, CE^.Spix)\r
ELSE\r
BEGIN\r
LoadAbsAddr(Ce);\r
IF odd(size) THEN Size := Size + 1;\r
CodeConst(rRECHW,Size,AnonymousSpix);\r
GenCode(rREVSM);\r
END;\r
END;\r
\r
BEGIN\r
IF (ESTSort(ESTTop) <> S_Stack) AND\r
(ESTTop^.Backward <> Bottom_ESTTop) THEN MegaLoad(ESTTop^.Backward);\r
CurE := ESTTop;\r
St_RetrieveType(CurE^.OprType,St_AddrRef);\r
Size := ST_AddrRef^.St_Size;\r
LoadAdr := (ParamKind <> cValueParam) OR Is_Dynamic(St_AddrRef,Size);\r
IF ParamKind = cShared THEN\r
CodeConst(rRENHB,referencesize - 1,Anonymousspix);\r
IF Not LoadAdr THEN\r
BEGIN\r
IF (Size = 3) AND (St_AddrRef^.St_Kind <> CpointerType) THEN\r
Size := 4\r
ELSE\r
IF (Size = 1) AND (St_AddrRef^.St_Kind <> CSubrange) AND\r
(St_AddrRef^.St_Kind <> CBoolean) AND\r
(St_AddrRef^.St_Kind <> CChar) AND\r
(St_AddrRef^.St_Kind <> CScalar) THEN Size := 2;\r
END;\r
CASE CurE^.Kind OF\r
\r
O_Addr,O_IndAddr,O_CAddr :\r
BEGIN\r
IF (CurE^.Par = P_Normal) AND\r
(Not LoadAdr) AND\r
(CurE^.Kind = O_Addr) AND\r
( (CurrentNiv = CurE^.A_Niv) OR\r
(CurE^.A_Niv = Program_Level) ) AND\r
(Size > 0) AND (Size <= 4) THEN\r
BEGIN\r
IF CurE^.A_Niv = CurrentNiv THEN\r
CodeConst(Instruction(ord(rREVLB) - 1 + size),\r
CurE^.A_Offset, CurE^.Spix)\r
ELSE\r
IF CurE^.A_Niv = Program_Level THEN\r
CodeConst(Instruction(ord(rREVGB) - 1 + size),\r
CurE^.A_Offset, CurE^.Spix)\r
END\r
ELSE\r
BEGIN\r
IF Not LoadAdr THEN\r
BEGIN\r
LoadAddr(CurE);\r
Load(CurE);\r
END\r
ELSE\r
LoadAbsAddr(CurE);\r
END;\r
END;\r
\r
O_Stack :\r
BEGIN\r
IF LoadAdr THEN\r
LoadAbsAddr(CurE)\r
ELSE\r
IF CurE^.IndVar THEN\r
BEGIN\r
LoadAddr(CurE);\r
load(CurE);\r
END;\r
END;\r
\r
O_Const :\r
BEGIN\r
CodeConst(rRECHW,CurE^.Value,CurE^.spix);\r
END;\r
\r
O_Decode : ;\r
\r
END; (* END CASE *)\r
\r
\r
ESTPop;\r
END;\r
\r
PROCEDURE MegaLoadAssign;\r
\r
VAR\r
Addr : Address;\r
St_AddrRef : St_elemptr;\r
offset : Integer;\r
Loaded : boolean;\r
Size : Integer;\r
CurE : ESTelementRef;\r
\r
Procedure Load(Ce : EstElementRef);\r
BEGIN\r
CodeConst(Instruction(ord(rREVSB) - 1 + size),\r
CE^.T_ObjectOffset, CE^.Spix)\r
END;\r
\r
BEGIN\r
IF (ESTSort(ESTTop) <> S_Stack) AND\r
(ESTTop^.Backward <> Bottom_ESTTop) THEN MegaLoad(ESTTop^.Backward);\r
CurE := ESTTop;\r
Loaded := True;\r
St_RetrieveType(CurE^.OprType,St_AddrRef);\r
Size := ST_AddrRef^.St_Size;\r
\r
CASE CurE^.Kind OF\r
\r
O_Addr,O_IndAddr,O_CAddr :\r
BEGIN\r
IF (CurE^.Par = P_Normal) AND\r
(CurE^.Kind = O_Addr) AND\r
( (CurrentNiv = CurE^.A_Niv) OR\r
(CurE^.A_Niv = Program_Level) ) AND\r
(Size > 0) AND (Size <= 4) THEN\r
BEGIN\r
IF CurE^.IndVar = False THEN Loaded := false\r
ELSE\r
BEGIN\r
IF CurE^.A_Niv = CurrentNiv THEN\r
CodeConst(Instruction(ord(rREVLB) - 1 + size),\r
CurE^.A_Offset, CurE^.Spix)\r
ELSE\r
IF CurE^.A_Niv = Program_Level THEN\r
CodeConst(Instruction(ord(rREVGB) - 1 + size),\r
CurE^.A_Offset, CurE^.Spix)\r
END;\r
END\r
ELSE\r
BEGIN\r
LoadAddr(CurE);\r
IF CurE^.IndVar THEN\r
BEGIN\r
if (Size = 0) OR (Size > 4) THEN\r
LoadAbsAddr(CurE)\r
else\r
load(CurE);\r
END;\r
END;\r
END;\r
\r
O_Stack :\r
BEGIN\r
IF CurE^.IndVar THEN\r
BEGIN\r
if (Size = 0) OR (Size > 4) THEN\r
LoadAbsAddr(CurE)\r
else\r
load(CurE);\r
\r
END;\r
END;\r
\r
O_Const :\r
BEGIN\r
CodeConst(rRECHW,CurE^.Value,CurE^.spix);\r
END;\r
\r
O_Decode : Loaded := false;\r
\r
END; (* END CASE *)\r
\r
IF Loaded THEN\r
BEGIN\r
CurE^.Kind := O_Stack;\r
CurE^.IndVar := false;\r
END;\r
\r
LastOnStack := CurE;\r
\r
END; (* LoadRegister *)\r
\r
\r
PROCEDURE MegaStore(Size : Integer);\r
VAR Inst : Instruction;\r
PtrSt : St_elemptr;\r
\r
BEGIN\r
IF (Size >= 1) AND (Size <= 4) THEN\r
BEGIN\r
MegaLoadAssign;\r
ESTPop;\r
if (ESTTop^.kind = O_Addr) AND ( CurrentNIV = ESTTop^.A_Niv)\r
AND (ESTTop^.Par = P_Normal) THEN\r
BEGIN\r
Inst := Instruction(ord(rSTVLB) - 1 + Size);\r
CodeConst(Inst,ESTTop^.A_Offset,ESTTop^.Spix);\r
END\r
else\r
if (ESTTop^.kind = O_Addr) AND ( Program_Level = ESTTop^.A_Niv)\r
AND (ESTTop^.Par = P_Normal) THEN\r
BEGIN\r
Inst := Instruction(ord(rSTVGB) - 1 + Size);\r
CodeConst(Inst,ESTTop^.A_Offset,ESTTop^.Spix);\r
END\r
ELSE\r
BEGIN\r
Inst := Instruction(ord(rSTVSB) - 1 + Size);\r
CodeConst(Inst,ESTTop^.T_ObjectOffset,ESTTop^.Spix);\r
END;\r
END\r
ELSE (* Size > 4 *)\r
BEGIN\r
LoadAbsAddr(ESTTop^.BackWard);\r
LoadAbsAddr(ESTTop);\r
St_RetrieveType(ESTTop^.OprType,PtrSt);\r
IF is_dynamic(PtrSt,size) then\r
BEGIN\r
PushAddr(PtrSt);\r
MegaLoad(ESTTop);\r
ESTPop;\r
END\r
ELSE\r
CodeConst(rRECHW,Size,AnonymousSpix);\r
GenCode(rMOVEG);\r
ESTPop;\r
END;\r
ESTPop;\r
END;\r
\r
\r
\r
\r
PROCEDURE MegaLoad(e : ESTelementRef);\r
\r
VAR\r
Addr : Address;\r
St_AddrRef : St_elemptr;\r
offset : Integer;\r
Loaded : boolean;\r
Size : Integer;\r
CurE : ESTelementRef;\r
Arrayaddr : boolean;\r
\r
Procedure Load(Ce : EstElementRef);\r
BEGIN\r
CodeConst(Instruction(ord(rREVSB) - 1 + size),\r
CE^.T_ObjectOffset, CE^.Spix);\r
CurE^.T_ObjectOffset := 0;\r
END;\r
\r
BEGIN\r
CurE := LastOnStack;\r
IF (ESTSort(e) = S_Stack) OR\r
(CurE <> Bottom_ESTTop) THEN CurE := CurE^.Backward;\r
WHILE e <> CurE DO\r
BEGIN\r
Loaded := True;\r
CurE := CurE^.xForward;\r
IF CurE^.Par = P_Share THEN\r
LoadAddr(CurE);\r
\r
St_RetrieveType(CurE^.OprType,St_AddrRef);\r
\r
\r
Size := ST_AddrRef^.St_Size;\r
IF (Size = 3) AND (St_AddrRef^.St_Kind <> CpointerType)\r
THEN Size := 4;\r
ArrayAddr := (St_AddrRef^.St_Kind = cArrayType) OR\r
(St_AddrRef^.St_Kind = cSetType);\r
\r
St_Retrieve(CurE^.OprType,St_AddrRef);\r
\r
IF (((st_AddrRef^.Type_Mode = Bound_Fam) OR\r
(st_AddrRef^.Type_Mode = Named_Bound_Fam)) AND\r
Equal_addr(St_AddrRef^.St_Family_Ref,St_String_Type_Addr)) THEN\r
Size := 0; (* The address is always loaded *)\r
CASE CurE^.Kind OF\r
\r
O_Addr,O_IndAddr,O_CAddr :\r
BEGIN\r
IF (CurE^.Par = P_Normal) AND\r
(CurE^.Kind = O_Addr) AND\r
( (CurrentNiv = CurE^.A_Niv) OR\r
(CurE^.A_Niv = Program_Level) ) AND\r
( NOT ArrayAddr OR CurE^.IndVar) AND\r
( ( (Size > 0) AND (Size <= 3) AND (CurE^.IndVar) ) OR\r
( (Size > 0) AND (Size <= 4) AND (NOT CurE^.IndVar) ) )\r
THEN\r
BEGIN\r
IF CurE^.IndVar = False THEN Loaded := false\r
ELSE\r
BEGIN\r
IF CurE^.A_Niv = CurrentNiv THEN\r
CodeConst(Instruction(ord(rREVLB) - 1 + size),\r
CurE^.A_Offset, CurE^.Spix)\r
ELSE\r
IF CurE^.A_Niv = Program_Level THEN\r
CodeConst(Instruction(ord(rREVGB) - 1 + size),\r
CurE^.A_Offset, CurE^.Spix)\r
END;\r
END\r
ELSE\r
if (Size = 0) OR (Size >= 4) THEN\r
LoadAbsAddr(CurE)\r
ELSE\r
BEGIN\r
LoadAddr(CurE);\r
IF CurE^.IndVar THEN\r
BEGIN\r
load(CurE);\r
END;\r
END;\r
\r
\r
END;\r
\r
O_Stack :\r
BEGIN\r
IF (Size = 0) OR (Size >= 4) THEN\r
LoadAbsAddr(CurE)\r
ELSE\r
IF CurE^.IndVar THEN\r
load(CurE);\r
END;\r
\r
O_Const :\r
BEGIN\r
CodeConst(rRECHW,CurE^.Value,CurE^.spix);\r
END;\r
\r
O_Decode : Loaded := false;\r
\r
END; (* END CASE *)\r
\r
IF Loaded THEN\r
BEGIN\r
CurE^.Kind := O_Stack;\r
CurE^.IndVar := false;\r
END;\r
END;\r
\r
LastOnStack := CurE;\r
\r
END; (* LoadRegister *)\r
\r
\r
\r
PROCEDURE MegaMoveToTemp(e : ESTelementRef);\r
\r
VAR\r
Addr : Address;\r
St_AddrRef : St_elemptr;\r
Size : Integer;\r
\r
BEGIN\r
END;\r
\r
Procedure PushOperand;\r
BEGIN\r
LoadAbsAddr(ESTTop);\r
END;\r
\r
\r
\r
Procedure PushOperands;\r
BEGIN\r
\r
END;\r
\r
\r
Procedure MegaOperationOnStack(inst : Instruction; commutativ : boolean);\r
\r
BEGIN\r
MegaLoad(ESTTop^.Backward);\r
MegaLoad(ESTTop);\r
\r
Gencode(inst);\r
ESTPop;\r
END;\r
(* ---------------------------------------------- *)\r
\r
\r
PROCEDURE CMPTopelements(inst : instruction; neg : boolean);\r
(* The procedure generates code to compare the two topelements*)\r
\r
\r
\r
VAR\r
Value : word;\r
PtrSt : st_ElemPtr;\r
Length : Word;\r
FirstOpr : ESTelementRef;\r
helpbool : boolean;\r
BEGIN\r
\r
St_RetrieveType(ESTTop^.OprType,PtrSt);\r
Length := PtrSt^.St_Size;\r
\r
\r
IF (Length = 1) OR (Length = 2) THEN\r
BEGIN\r
IF (ESTSort(ESTTop) = S_Const) AND\r
(ESTTop^.Value = 1) AND\r
( (Inst = rLT) OR (Inst = rGE))\r
THEN\r
BEGIN\r
ESTTop^.Value := 0;\r
IF Inst = rLT THEN Inst := rLE ELSE Inst := rGT;\r
END;\r
\r
IF (ESTSort(ESTTop) = S_Const) AND\r
(ESTTop^.Value = 0) THEN\r
BEGIN\r
ESTPop;\r
MegaLoad(ESTTop);\r
ESTPop;\r
ESTPushDecode(St_NillAddr,St_NillAddr,Inst);\r
END\r
ELSE\r
BEGIN\r
MegaOperationOnStack(Inst,True);\r
ESTPop;\r
ESTPushStack(BooleanType,false);\r
END;\r
END\r
ELSE\r
IF PtrSt^.St_Kind = cPointerType THEN\r
BEGIN\r
MegaOperationOnStack(rTEQAD,True);\r
ESTPop;\r
IF Inst = rNE THEN Inst := rNOT ELSE Inst := rOR;\r
ESTPushDecode(St_NillAddr,St_NillAddr,Inst);\r
END\r
ELSE\r
BEGIN\r
MegaLoad(ESTTop);\r
IF is_dynamic(PtrSt,length) then\r
BEGIN\r
PushAddr(PtrSt);\r
MegaLoad(ESTTop);\r
ESTPop;\r
END\r
ELSE\r
CodeConst(rRECHW,Length,AnonymousSpix);\r
MegaOperationOnStack(rSTCEA,True);\r
ESTPop;\r
(*IF Inst = rNE THEN Inst := rNOT ELSE Inst := rOR;*)\r
ESTPushDecode(St_NillAddr,St_NillAddr,Inst);\r
END;\r
\r
END;\r
\r
Function megaoffset(niv,offset : word) : word;\r
var off : integer;\r
BEGIN\r
IF Niv = Program_Level then\r
BEGIN\r
MegaOffset := Offset - Prog_Descr_Size + Proc3502_Descr_Size;\r
END\r
ELSE\r
MegaOffset := Offset;\r
END;\r
\r
\r
PROCEDURE PushAddr(PtrSt : St_ElemPtr);\r
(* The procedure push the address given by the STH_node PtrSt\r
onto the evalstack *)\r
VAR Par : ParType;\r
AddrType : Address_Type;\r
TypeAddr : boolean;\r
Spix : SpixRange;\r
Ptr : ST_ElemPtr;\r
off,funclev : integer;\r
helpaddr : st_Address;\r
BEGIN\r
TypeAddr := false;\r
Par := P_Normal;\r
WITH PtrST^ DO\r
BEGIN\r
Spix := PtrST^.ST_Spix;\r
IF St_Kind = CType THEN\r
BEGIN\r
AddrType := Type_Address;\r
TypeAddr := true;\r
END\r
ELSE\r
IF St_Kind = CRecField THEN\r
BEGIN\r
AddrType := Field_Addr;\r
TypeAddr := true;\r
END\r
ELSE\r
IF (St_Kind = CSubrange) or (ST_Kind = CsetType) THEN\r
BEGIN\r
AddrType := Subr_Addr;\r
TypeAddr := true;\r
Spix := AnonymousSpix;\r
END\r
ELSE\r
IF St_Kind = CArrayType THEN\r
BEGIN\r
AddrType := Array_Addr;\r
TypeAddr := true;\r
Spix := AnonymousSpix;\r
END\r
ELSE\r
IF St_Kind = CRecordType THEN\r
BEGIN\r
AddrType := Record_Addr;\r
TypeAddr := true;\r
Spix := AnonymousSpix;\r
END;\r
\r
\r
\r
IF TypeAddr THEN\r
BEGIN\r
WITH AddrType DO\r
BEGIN\r
IF AddrType_Mode = direct THEN\r
ESTPushAddr(Spix,IntegerType,true,Par,\r
level,MegaOffset(level,Offset))\r
ELSE\r
IF AddrType_Mode = indirect THEN\r
BEGIN\r
ESTPushIndAddr(Spix,IntegerType,true,Par,\r
Level,MegaOffset(Level,Offset),dopeoffset);\r
ESTTop^.I_Allign := True;\r
END\r
ELSE\r
ESTPushCAddr(Spix,IntegerType,true,par,addr_label,\r
dopeoffset);\r
END;\r
END\r
ELSE\r
\r
IF ST_Kind = CFunction THEN\r
BEGIN\r
(* a Function *)\r
Off := Func_Result_offset;\r
funclev := st_Level;\r
HelpAddr := TypeRef;\r
St_Retrievetype(HelpAddr,Ptr);\r
\r
if not SimpelFuncRes(Ptr)\r
then\r
BEGIN\r
estpushindaddr(spix,HelpAddr,false,par,\r
funclev,MegaOffset(funclev,off),0);\r
ESTTop^.I_Allign := true;\r
END\r
else ESTPushAddr(Spix,HelpAddr,false,Par,\r
funclev,MegaOffset(funclev,Off));\r
END\r
ELSE\r
IF ST_Kind = CProgram THEN\r
(* a Program *)\r
ESTPushAddr(Spix,St_NillAddr,false,Par,\r
0,MegaOffset(0,Prog_descr_Offset))\r
ELSE\r
BEGIN\r
(* a variabel or a parameter *)\r
IF (( ST_Kind = cSharedParam) OR\r
( ST_Kind = cShared )) THEN Par := P_Share;\r
\r
\r
IF Var_Indir = false THEN\r
ESTPushAddr(Spix,TypeRef,false,Par,\r
Var_Level,MegaOffset(Var_level,Var_offset))\r
ELSE\r
BEGIN\r
ESTPushIndAddr(Spix,TypeRef,false,Par,\r
Var_Level,MegaOffset(Var_level,Var_Offset),0);\r
IF (St_Kind = cVarParam) OR (St_Kind =cInspectParam) THEN\r
BEGIN\r
St_RetrieveType(ESTTop^.OprType,Ptr);\r
IF St_Kind = cVarParam THEN\r
ESTTop^.I_Allign := ( (Ptr^.St_Size >=1) AND\r
(Ptr^.St_Size <= 4)) OR\r
((ShieldType * Ptr^.Spec_Struct) <> [] ) OR\r
((ShieldType * Spec_Struct) <> [] )\r
ELSE\r
ESTTop^.I_Allign :=\r
(ShieldType * Ptr^.Spec_Struct) <> [] ;\r
\r
END\r
\r
ELSE\r
IF (St_Kind = cWithVar) THEN ESTTop^.I_Allign := false\r
ELSE ESTTop^.I_Allign := true;\r
END;\r
END;\r
END;\r
\r
\r
END;\r
PROCEDURE PopPackedElement;\r
BEGIN\r
ESTPop;\r
END;\r
PROCEDURE PutPackedElement;\r
VAR e : ESTElementRef;\r
allign : boolean;\r
mask : integer;\r
BEGIN\r
MegaLoad(ESTTop);\r
GenCode(rSTVSF);\r
ESTPop;\r
ESTPop;\r
END;\r
\r
PROCEDURE GetPackedElement(e : ESTElementRef; TypeAddr : St_Address);\r
(* e holding the BitOffset. E^.BackWard holding the byte offset address\r
The element is returned in Reg *)\r
VAR\r
BitLength : integer;\r
Addr : Address;\r
Ptr : St_ElemPtr;\r
\r
BEGIN\r
GenCode(rREVSF);\r
END;\r
\r
PROCEDURE LoadPacked(e : ESTElementRef);\r
BEGIN\r
CodeConst(rRECHW,(E^.BitLength + E^.Value-1) + E^.Value SHL 8,\r
Anonymousspix);\r
E^.Backward^.BitLength := E^.BitLength;\r
ESTPop;\r
END;\r
\r
Procedure ExchangeTopElements;\r
VAR e : ESTElementRef;\r
BEGIN\r
e := ESTTop^.Backward;\r
e^.Backward^.xForward := ESTTop;\r
ESTTop^.xforward := e;\r
e^.xForward := nil;\r
ESTTop^.BackWard := e^.Backward;\r
e^.Backward := ESTTop;\r
ESTtop := e;\r
END;\r
\r
Procedure AddOffsetToAddr(e: ESTElementRef;Offset : integer);\r
BEGIN\r
\r
IF e^.Par = P_Share THEN LoadAbsAddr(e);\r
\r
CASE E^.Kind OF\r
O_Addr : E^.A_Offset := E^.A_Offset + offset;\r
O_IndAddr : E^.I_ObjectOffset :=\r
E^.I_ObjectOffset + offset;\r
O_AbsAddr : E^.A_Displacement := E^.A_Displacement +\r
offset;\r
\r
O_CAddr : E^.C_ObjectOffset :=\r
E^.C_ObjectOffset + offset;\r
O_Stack,O_StackOrTemp,O_Temp :\r
E^.T_ObjectOffset :=\r
E^.T_ObjectOffset + offset;\r
END;\r
END;\r
\r
Procedure AllocDynamic(InSymbol : St_address; AddLength : Integer;\r
off : integer);\r
VAR\r
PtrSt : st_ElemPtr;\r
BEGIN\r
GenCode(rREAXD);\r
CodeConst(rUADHW,1,Anonymousspix);\r
CodeConst(rSTVLA,off,Anonymousspix);\r
St_RetrieveType(InSymbol,PtrSt);\r
IF is_dynamic(PtrST,PtrSt^.St_Size) THEN\r
BEGIN\r
PushAddr(PtrSt);\r
IF AddLength <> 0 THEN\r
BEGIN\r
MegaLoad(ESTTop);\r
CodeConst(rUADHW,AddLength,AnonymousSpix);\r
END;\r
MegaLoad(ESTTop);\r
GenCode(rREVPW);\r
CodeConst(rRECHW,1,Anonymousspix);\r
GenCode(rAND);\r
GenCode(rUADD);\r
GenCode(rRENPB);\r
ESTPop;\r
END\r
ELSE CodeConst(rRENHB,(PtrST^.St_Size + AddLength) +\r
ord(odd(PtrST^.St_Size + AddLength)), anonymousspix);\r
END;\r
\r
PROCEDURE MakeCopyOfTop;\r
VAR e : ESTElementRef;\r
BEGIN\r
if ESTSort(ESTTop) = S_Stack THEN\r
BEGIN\r
GenCode(rREVPD);\r
END;\r
e := ESTTop;\r
ESTPushconst(IntegerType,0);\r
ESTTop^ := ESTTop^.BackWard^;\r
ESTTop^.xforward := nil;\r
ESTTop^.BackWard := e;\r
\r
END;\r
\r
\r
\r
Procedure MakeSetOprReady;\r
(* The procedure generates code to push the last setoperand to a set opr. *)\r
VAR\r
ptr : st_elemptr;\r
\r
BEGIN\r
IF NOT ((ESTTop^.Kind =O_Stack) AND (ESTTop^.IndVar = false))THEN\r
BEGIN\r
ESTTop^.IndVar := False;\r
MegaLoad(ESTTop);\r
\r
St_Retrieve(ESTTop^.OprType,Ptr);\r
ESTPushConst(IntegerType,Ptr^.St_Size);\r
MegaLoad(ESTTop);\r
ESTPop;\r
GenCode(rSETRE);\r
END;\r
ESTPop;\r
END;\r
\r
PROCEDURE PushSetOnStack(TypeAddr : St_Address);\r
VAR\r
ptr : st_elemptr;\r
length : integer;\r
BEGIN\r
St_RetrieveType(TypeAddr,Ptr);\r
Length := ptr^.St_Size;\r
Makesetoprready;\r
CodeConst(rRECHW,Length,Anonymousspix);\r
GenCode(rSETAD);\r
CodeConst(rSTNHB,2,Anonymousspix);\r
END;\r
\r
\r
\r
\r
PROCEDURE MakeProgramDesc(ProgOffset : Word; ProgState : State;\r
PoolParam : boolean; lab : St_Address);\r
(* The procedure generate code to make the program describtion at\r
address 'Addr'. This procedure has to be change if the pi3 type\r
programdescribtion is change *)\r
\r
VAR\r
Str : Ptr_String;\r
Ch : Char;\r
Str12 : String[12];\r
i : integer;\r
\r
BEGIN\r
\r
(* Generate code to push the parameter to init_internal or\r
init_external *)\r
\r
IF ProgState = Internal THEN\r
BEGIN\r
CodeConst(rREALD,MegaOffset(CurrentNiv,ProgOffset),Anonymousspix);\r
CodeLoadEffAddr(LastInternalLBDRLabel,0);\r
CallRoutine(AnonymousSpix,Init_Internal,St_extern);\r
END;\r
\r
\r
\r
END; (* MakeProgramDesc *)\r
\r
Procedure MegaAllocTemp(No: Integer);\r
var i : integer;\r
BEGIN\r
END;\r
\r
Procedure MegaAllocParam(No:Integer);\r
VAR i : Integer;\r
BEGIN\r
END;\r
(* ------------------------------------------------------------- *)\r
\r
\r
END.\r
\r
\r
(* -------------END PROCEDURE ESTOPR -------- ESTOPR -- *)\r
\r
«eof»