|
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: 47673 (0xba39)
Types: TextFile
Names: »P450EOPR.PAS«
└─⟦a2bcc95d7⟧ Bits:30010511 DVBS1.SW2114.src.2.14-2 SW2114 REAL #2/4 TIME PASCAL SOURCE REL 2.14 92.09.01
└─⟦this⟧ »RTP\P450EOPR.PAS«
{$O+,F+}\r
unit p450eopr;\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(VAR 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 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
Procedure MakeCopyOfTop;\r
PROCEDURE PushSetParam;\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
Procedure LoadInt16;\r
implementation\r
uses sthcom,sthp34,p4evalst,p450code,p450bool,p450stat;\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
WITH E^ DO\r
IF Kind = O_Stack THEN\r
BEGIN\r
MegaAllocTemp(1);\r
T_Offset := TempOffset;\r
T_IndexToSTL := StoreTemp(T_Offset);\r
Kind := O_StackOrTemp;\r
END;\r
\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
StoreTempOK(e^.T_IndexToSTL);\r
e^.Kind := O_Temp;\r
END;\r
END;\r
e := e^.backward;\r
END;\r
END;\r
\r
\r
Procedure MegaPointer;\r
VAR offset,niv : word;\r
BEGIN\r
IF esttop^.Kind = O_Addr THEN\r
BEGIN\r
offset := Esttop^.A_offset;\r
niv := Esttop^.A_Niv;\r
Esttop^.Kind := O_IndAddr;\r
EstTop^.I_Offset := offset;\r
ESTTop^.I_Niv := Niv;\r
ESTTop^.I_ObjectOffset := 0;\r
ESTTop^.AccessCheck := true;\r
ESTTop^.I_Allign := true;\r
END\r
ELSE\r
BEGIN\r
Megaload(ESTTop);\r
\r
\r
(* Access check *)\r
MakeFreeReg(1);\r
CodeConst(mLDC,-1,AnonymousSpix);\r
Gencode(mCCNT1);\r
\r
StoreStacktotemp(ESTTop);\r
esttop^.T_Address := true;\r
esttop^.T_ObjectOffset := 0;\r
esttop^.T_Allign := true;\r
END;\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
VAR Offset : word;\r
OffsetI: Integer;\r
ObjectOffset : longint;\r
Allign : boolean;\r
Typeaddr : St_Address;\r
BEGIN\r
\r
IF ESTSort(e) <> S_Stack THEN MakeFreeReg(1);\r
IF e^.Par = P_Share THEN\r
BEGIN\r
e^.Par := P_Normal;\r
TypeAddr := e^.OprType;\r
e^.OprType := IntegerType;\r
MegaLoad(e);\r
e^.Kind := O_stack;\r
e^.OprType := TypeAddr;\r
e^.T_Address := True;\r
e^.T_Allign := True;\r
e^.T_ObjectOffset := 0;\r
END;\r
\r
\r
\r
\r
ObjectOffset := 0;\r
\r
Case e^.Kind OF\r
\r
O_Addr :\r
BEGIN\r
if CurrentNIV = e^.A_Niv then\r
BEGIN\r
Offset := e^.A_Offset;\r
CodeConst(mLDLP,offset div 4 ,e^.spix);\r
ObjectOffset := Offset MOD 4;\r
allign := true;\r
END\r
else\r
BEGIN\r
CodeConst(mLDL,StaOff+1+e^.A_Niv,anonymousSpix);\r
ObjectOffset := e^.A_Offset;\r
Allign := true;\r
END;\r
END;\r
\r
O_IndAddr:\r
BEGIN\r
\r
IF e^.AccessCheck then\r
BEGIN\r
(* Access check *)\r
MakeFreeReg(2);\r
END;\r
\r
if CurrentNIV = e^.I_Niv then\r
BEGIN\r
Offset := e^.I_Offset;\r
CodeConst(mLDL,(offset) div 4 ,e^.spix);\r
ObjectOffset := e^.I_ObjectOffset;\r
allign := e^.I_Allign;\r
END\r
else\r
BEGIN\r
CodeConst(mLDL,StaOff+1+e^.I_Niv,anonymousSpix);\r
OffsetI := e^.I_Offset;\r
CodeConst(mLDNL,OffsetI DIV 4,e^.Spix);\r
ObjectOffset := e^.I_ObjectOffset;\r
Allign := e^.I_Allign;\r
END;\r
\r
IF e^.AccessCheck then\r
begin\r
(* Access check *)\r
CodeConst(mLDC,-1,AnonymousSpix);\r
Gencode(mCCNT1);\r
end;\r
END;\r
\r
O_Temp :\r
BEGIN (* Address *)\r
IF e^.T_Address THEN\r
BEGIN\r
codeconst(mLDL,e^.T_Offset,AnonymousSpix);\r
TempOffset := TempOffset + 1;\r
ObjectOffset := e^.T_ObjectOffset;\r
Allign := e^.T_Allign;\r
END\r
ELSE\r
BEGIN\r
codeconst(mLDLP,e^.T_Offset,AnonymousSpix);\r
TempOffset := TempOffset + 1;\r
ObjectOffset := 0;\r
Allign := true;\r
END\r
\r
END;\r
\r
O_Stack :\r
BEGIN\r
ObjectOffset := e^.T_ObjectOffset;\r
Allign := e^.T_Allign;\r
END;\r
\r
O_StackOrTemp :\r
BEGIN\r
ObjectOffset := e^.T_ObjectOffset;\r
Allign := e^.T_Allign;\r
TempOffset := TempOffset + 1;\r
END;\r
\r
O_CAddr : BEGIN\r
CodeLoadEffAddr(e^.C_Label,e^.C_ObjectOffset);\r
Allign := true;\r
ObjectOffset := 0;\r
END;\r
END; (* end case *)\r
\r
e^.Kind := O_Stack;\r
e^.T_Address := true;\r
e^.T_ObjectOffset := ObjectOffset;\r
e^.T_Allign := Allign;\r
\r
END; (* MegaMakeAddr *)\r
\r
PROCEDURE TempSpaceError(Str : String; Wanted : Integer);\r
BEGIN\r
writeln(' ', Str,'(Line,No,P,T) ',\r
LineNumber,' ',Wanted,' ',paramindex,' ',TempOffset);\r
Fatal_Error(Pass4,10);\r
END;\r
\r
Procedure NewParam(PInOut : Boolean;\r
PKind : ParamType;\r
PTempOffset : Integer);\r
VAR Ptr : ParamRecordType;\r
BEGIN\r
Ptr := ParamList;\r
new(ParamList);\r
ParamList^.Next := Ptr;\r
ParamList^.InOut := PInOut;\r
ParamList^.NextParamNo := 1;\r
ParamList^.Kind := PKind;\r
ParamList^.TempOffset := PTempOffset;\r
END;\r
Procedure InitParamList;\r
BEGIN\r
ParamList := Nil;\r
newparam(false,stop,0); (* Call Thunk *)\r
END;\r
Procedure StartCall;\r
BEGIN\r
MakeFreeReg(3);\r
NewParam(False,Stop,0);\r
END;\r
\r
Procedure EndCall(ParamSize : Integer);\r
VAR Ptr : ParamRecordType;\r
BEGIN\r
\r
IF (ParamSize > 8) AND ((ParamIndex - (ParamSize - 8) DIV 4) > 0)\r
THEN BEGIN\r
CodeConst(mAJW,-(ParamIndex - (ParamSize - 8) DIV 4),AnonymousSpix);\r
StoreStackToTemp(ESTTop); (* Function Result *)\r
MakeFreeReg(3);\r
CodeConst(mLDLP,ParamIndex,anonymousSpix);\r
CodeConst(mLDLP,0,AnonymousSpix);\r
CodeConst(mLDC,(ParamIndex * 4 - (ParamSize - 8)),AnonymousSpix);\r
GenCode(mMOVE);\r
END\r
ELSE\r
IF (ESTTop <> bottom_ESTTop) AND\r
(ESTTop^.Kind = O_Stack) THEN StoreStackToTemp(ESTTop);\r
IF ParamSize > 8 THEN\r
ParamIndex := (ParamIndex - (ParamSize - 8) DIV 4);\r
While Paramlist^.Kind <> Stop DO\r
BEGIN\r
IF ParamList^.InOut THEN\r
BEGIN\r
MakeFreeReg(3);\r
CodeConst(mLDLP,ParamList^.TempOffset,AnonymousSpix);\r
CodeConst(mLDL,ParamList^.TempOffset + 1,anonymousSpix);\r
CodeConst(mLDC,4,AnonymousSpix);\r
GenCode(mMOVE);\r
TempOffset := TempOffset + 2;\r
END;\r
Ptr := ParamList;\r
ParamList := ParamList^.Next;\r
Dispose(Ptr);\r
END;\r
\r
Ptr := ParamList;\r
IF Ptr^.Next <> nil THEN\r
BEGIN\r
ParamList := ParamList^.Next;\r
Dispose(Ptr);\r
END;\r
\r
END;\r
\r
Procedure LoadFirstParams(ParamSize : Integer;routinekind : st_declaremode);\r
VAR Ptr : ParamRecordType;\r
oldkind : ParamType;\r
CopySize : Integer;\r
BEGIN\r
IF (ParamSize > 8) AND ((ParamIndex - (ParamSize - 8) DIV 4) > 0)\r
THEN BEGIN\r
MakeFreeReg(3);\r
CodeConst(mLDLP,0,anonymousSpix);\r
CodeConst(mLDLP,ParamIndex,AnonymousSpix);\r
CopySize := (ParamIndex * 4 - (ParamSize - 8));\r
CodeConst(mLDC, CopySize, AnonymousSpix);\r
GenCode(mMOVE);\r
CopySize := (CopySize+3) DIV 4;\r
IF TempOffset < ParamIndex + CopySize\r
THEN TempSpaceError(' ParamCopy', CopySize);\r
END;\r
OldKind := Stop;\r
Ptr := ParamList;\r
While Paramlist^.Kind <> Stop DO\r
BEGIN\r
IF ParamList^.Kind <> Loaded THEN\r
BEGIN\r
IF ParamList^.Inout THEN\r
BEGIN\r
CodeConst(mLDLP,ParamList^.TempOffset,AnonymousSpix);\r
END ELSE\r
BEGIN\r
IF ParamList^.Kind = Areg THEN\r
BEGIN\r
IF (ESTSort(ESTTop) = S_Stack) AND\r
(OldKind = Breg) THEN GenCode(mREV);\r
END;\r
IF ESTTop^.IndVar = True THEN\r
MegaLoad(ESTTop)\r
ELSE\r
BEGIN\r
MegaMakeAddr(ESTTop);\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
END;\r
ESTPop;\r
END;\r
OldKind := ParamList^.Kind;\r
END;\r
ParamList := ParamList^.Next;\r
END;\r
ParamList := Ptr;\r
IF (Routinekind = St_Extern) OR (Routinekind = St_Global) THEN\r
CodeConst(mLDL,StaOff,AnonymousSpix)\r
ELSE\r
if Routinekind <> St_Open THEN\r
CodeConst(mLDLP,StaOff,AnonymousSpix);\r
IF (ParamSize > 8) AND ((ParamIndex - (ParamSize - 8) DIV 4) > 0)\r
THEN BEGIN\r
CodeConst(mAJW,(ParamIndex - (ParamSize - 8) DIV 4),AnonymousSpix);\r
END;\r
END;\r
\r
PROCEDURE PushParam(ParamKind : codes);\r
VAR\r
Ptr : St_ElemPtr;\r
No,Nextno : integer;\r
Kind : ParamType;\r
size : integer;\r
PROCEDURE StoreParam;\r
BEGIN\r
CodeConst(mSTL,ParamIndex,AnonymousSpix);\r
MegaAllocParam(1);\r
END;\r
BEGIN\r
ST_RetrieveType(ESTTop^.OprType,Ptr);\r
Size := Ptr^.St_Size;\r
No := ParamList^.NextParamNo;\r
IF ParamKind = CvalueParam THEN\r
BEGIN\r
if (no < 3) And (size > 4) then no := 3;\r
END;\r
NextNo := no + 1;\r
IF paramkind = cVarParam THEN\r
BEGIN\r
IF (Size = 4) AND\r
not megaallign(ESTTop) THEN\r
BEGIN\r
MegaAllocTemp(2);\r
MakeFreeReg(3);\r
MegaMakeAddr(ESTTop);\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
CodeConst(mSTL,TempOffset + 1,anonymousSpix);\r
CodeConst(mLDL,TempOffset + 1,anonymousSpix);\r
CodeConst(mLDLP,TempOffset,AnonymousSpix);\r
CodeConst(mLDC,4,AnonymousSpix);\r
GenCode(mMOVE);\r
\r
IF no = 1 THEN Kind := AReg\r
ELSE\r
IF no = 2 THEN Kind := BReg\r
ELSE Kind := Loaded;\r
\r
if kind = loaded THEN\r
BEGIN\r
CodeConst(mLDLP,TempOffset,AnonymousSpix);\r
Storeparam;\r
END;\r
\r
NewParam(true,Kind,TempOffset);\r
ESTPop;\r
no := 0;\r
END;\r
END;\r
\r
IF no > 2 THEN\r
BEGIN\r
IF ESTTop^.IndVar = False THEN\r
BEGIN\r
MegaMakeAddr(ESTTop);\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
storeParam;\r
\r
IF ParamKind = cShared THEN\r
MegaAllocParam((LengthOfSharedType DIV 4) - 1);\r
END\r
ELSE\r
BEGIN\r
IF (Size <= 4) THEN\r
BEGIN\r
MegaLoad(ESTTop);\r
StoreParam;\r
END\r
ELSE\r
BEGIN\r
MegaMakeAddr(ESTTop);\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
MakeFreeReg(2);\r
Codeconst(mLDLP,ParamIndex,AnonymousSpix);\r
CodeConst(mLDC,Ptr^.St_Size,AnonymousSpix);\r
GenCode(mMOVE);\r
ParamIndex := ParamIndex + (Size DIV 4);\r
IF (Size MOD 4) <> 0 THEN\r
MegaAllocParam(1);\r
END;\r
END;\r
ESTPop;\r
END\r
ELSE\r
IF no = 1 THEN newparam(false,areg,0)\r
ELSE\r
IF no = 2 THEN newparam(false,breg,0);\r
ParamList^.NextParamNo := NextNo;\r
END;\r
\r
PROCEDURE MegaStore(Size : Integer);\r
VAR\r
HelpOff : Integer;\r
ptrst : st_elemPtr;\r
domove : boolean;\r
size1 : integer;\r
BEGIN\r
domove := false;\r
St_RetrieveType(ESTTop^.OprType,PtrSt);\r
Size1 := PtrSt^.St_Size;\r
(* if (PtrSt^.St_Size <> Size) And\r
( (size = 4) OR (size = 1)) then\r
BEGIN\r
IF (PtrSt^.St_Size = 2) AND (PtrSt^.St_Kind = CSubrange) THEN\r
LoadInt16\r
ELSE\r
MegaLoad(ESTTop);\r
END;\r
*)\r
if (Size1 <> Size) And\r
( (size = 4) OR (size = 1) OR (Size = 2)) then\r
BEGIN\r
IF Size1 = 1 THEN MegaLoad(ESTTop)\r
ELSE\r
IF Size1 = 2 THEN\r
BEGIN\r
IF Size = 1 THEN DOMove := true\r
ELSE LoadInt16;\r
END\r
ELSE\r
BEGIN\r
IF Size = 2 THEN DoMove := true\r
ELSE\r
BEGIN\r
IF MegaAllign(ESTTop) THEN MegaLoad(ESTTop)\r
ELSE domove := true;\r
END;\r
END;\r
\r
END;\r
\r
if ((Size <> 4) AND (size <> 1)) OR domove OR\r
( not MegaAllign(ESTTop^.Backward) AND (Size = 4)) OR\r
( not MegaAllign(ESTTop) AND (Size = 4)) THEN\r
BEGIN (* mMOVE *)\r
IF (ESTSort(ESTTop) = S_Memery) OR\r
((ESTSort(ESTTop) = S_Stack) AND ESTTop^.T_Address) THEN\r
BEGIN\r
MegaMakeAddr(ESTTop);\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
\r
END\r
ELSE\r
BEGIN\r
if ESTTop^.Kind <> O_Temp THEN\r
BEGIN\r
MegaLoad(ESTTop);\r
helpoff := paramindex;\r
CodeConst(mSTL,helpoff,anonymousspix);\r
END\r
else\r
BEGIN\r
makefreereg(1);\r
helpoff := ESTTop^.T_Offset;\r
TempOffset := TempOffset + 1;\r
END;\r
CodeConst(mLDLP,helpOff,Anonymousspix);\r
\r
END;\r
ESTPop;\r
if ESTSort(ESTTop) = S_Stack THEN\r
Gencode(mREV);\r
MegaMakeAddr(ESTTop);\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
St_RetrieveType(ESTTop^.OprType,PtrSt);\r
MakefreeReg(2);\r
IF is_dynamic(PtrSt,size) then\r
BEGIN\r
PushAddr(PtrSt);\r
MegaLoad(ESTTop);\r
ESTPop;\r
END\r
ELSE\r
IF Size = 0 THEN\r
BEGIN\r
CodeConst(mLDC,PtrSt^.St_Size,AnonymousSpix);\r
END ELSE\r
CodeConst(mLDC,Size,AnonymousSpix);\r
GenCode(mMOVE);\r
END\r
else\r
BEGIN\r
MegaLoad(ESTTop);\r
ESTPop;\r
if (ESTTop^.kind = O_Addr) AND ( CurrentNIV = ESTTop^.A_Niv)\r
AND (Size = 4) AND (ESTTop^.Par = P_Normal) THEN\r
CodeConst(mSTL,(ESTTop^.A_offset) div 4 ,ESTTop^.spix)\r
else\r
BEGIN\r
if ESTSort(ESTTop) = S_Stack THEN\r
Gencode(mREV);\r
MegaMakeAddr(ESTTop);\r
IF size = 4 THEN\r
codeconst(mSTNL,(ESTTop^.T_Objectoffset div 4),ESTTop^.spix)\r
ELSE\r
BEGIN\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
GenCode(mSB);\r
END;\r
END;\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
allign : boolean;\r
Size : Integer;\r
\r
Procedure Load(Offset : Integer);\r
BEGIN\r
IF size = 1 THEN\r
BEGIN\r
if Offset <> 0 then\r
codeconst(mADC,Offset,Anonymousspix);\r
Gencode(mLB);\r
END\r
ELSE\r
codeconst(mLDNL,(Offset DIV 4),e^.Spix);\r
END;\r
BEGIN\r
IF ESTSort(e) <> S_Stack THEN MakeFreeReg(1);\r
\r
St_Retrieve(e^.OprType,St_AddrRef);\r
Size := ST_AddrRef^.St_Size;\r
\r
CASE e^.Kind OF\r
\r
O_Addr, O_IndAddr, O_AbsAddr, O_CAddr :\r
BEGIN (* Address *)\r
if (e^.A_Niv = CurrentNiv) AND (e^.Kind = O_Addr) and\r
(Size = 4) AND (e^.Par = P_Normal) THEN\r
codeconst(mLDL,(e^.A_Offset DIV 4),e^.Spix)\r
else\r
BEGIN\r
MegaMakeaddr(e);\r
load(e^.T_ObjectOffset);\r
END;\r
END;\r
\r
O_Temp :\r
BEGIN (* Address *)\r
codeconst(mLDL,e^.T_Offset,AnonymousSpix);\r
IF e^.T_Address THEN\r
load(e^.T_ObjectOffset);\r
TempOffset := TempOffset + 1;\r
END;\r
\r
O_Stack :\r
BEGIN\r
IF e^.T_Address THEN\r
Load(e^.T_ObjectOffset);\r
END;\r
\r
O_StackOrTemp :\r
BEGIN\r
IF e^.T_Address THEN\r
Load(e^.T_ObjectOffset);\r
\r
TempOffset := TempOffset + 1;\r
END;\r
\r
O_Const :\r
BEGIN\r
CodeConst(mLDC,e^.Value,e^.spix);\r
END;\r
\r
\r
END; (* END CASE *)\r
\r
e^.Kind := O_Stack;\r
e^.T_Address := false;\r
\r
\r
END; (* LoadRegister *)\r
\r
\r
PROCEDURE MegaMoveToTemp(e : ESTelementRef);\r
\r
VAR\r
Addr : Address;\r
St_AddrRef : St_elemptr;\r
int16_var : Boolean;\r
Size : Integer;\r
\r
BEGIN\r
IF ESTSort(e) <> S_Stack THEN MakeFreeReg(3)\r
ELSE MakeFreeReg(2);\r
\r
St_RetrieveType(ESTTop^.OprType,St_AddrRef);\r
Size := ST_AddrRef^.St_Size;\r
(*Int16_var := (Size = 2) AND (ST_AddrRef^.St_Kind = cSubRange);*)\r
\r
MegaMakeAddr(e);\r
IF e^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,e^.T_ObjectOffset,AnonymousSpix);\r
\r
MegaAllocTemp(1);\r
IF (Size < 4) THEN\r
BEGIN\r
CodeConst(mLDC,0,AnonymousSpix);\r
CodeConst(mSTL,TempOffset,AnonymousSpix);\r
END;\r
CodeConst(mLDLP,TempOffset,AnonymousSpix);\r
CodeConst(mLDC,Size,AnonymousSpix);\r
GenCode(mMOVE);\r
\r
\r
e^.Kind := O_Temp;\r
e^.T_Offset := TempOffset;\r
e^.T_Address := false;\r
\r
\r
END;\r
\r
Procedure LoadAbsAddr(e : ESTElementRef);\r
BEGIN\r
MegaMakeAddr(E);\r
IF E^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,E^.T_ObjectOffset,AnonymousSpix);\r
E^.T_ObjectOffset := 0;\r
\r
END;\r
\r
Procedure PushOperand;\r
BEGIN\r
MegaMakeAddr(ESTTop);\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
ESTTop^.T_ObjectOffset := 0;\r
\r
END;\r
\r
\r
Procedure PushOperands;\r
BEGIN\r
\r
END;\r
\r
\r
Procedure MegaOperationOnStack(inst : Instruction; commutativ : boolean);\r
\r
VAR\r
ptr : St_elemptr;\r
BEGIN\r
IF (Not commutativ) AND\r
(ESTSort(ESTTop) = S_Stack) AND\r
(ESTSort(ESTTop^.BackWard) <> S_Stack)\r
THEN\r
BEGIN\r
MegaLoad(ESTTop^.Backward);\r
MegaLoad(ESTTop);\r
GenCode(mREV);\r
END\r
ELSE\r
BEGIN\r
MegaLoad(ESTTop^.Backward);\r
MegaLoad(ESTTop);\r
END;\r
\r
gencode(inst);\r
ESTPop;\r
St_Retrievetype(ESTTop^.OprType,ptr);\r
IF Ptr^.St_kind = csubrange THEN ESTTop^.OprType := ptr^.TypeRef;\r
\r
StoreStackToTemp(ESTTop);\r
END;\r
(* ---------------------------------------------- *)\r
\r
\r
PROCEDURE CMPTopelements(VAR inst : instruction; neg : boolean);\r
(* The procedure generates code to compare the two topelements\r
if neg is true : AREG Top-1 BREG Top\r
if neg is false : AREG Top BREG Top - 1.*)\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
\r
IF ((Length = 1) or (Length = 4)) THEN\r
BEGIN\r
IF (Inst = mDIFF) AND (ESTSort(ESTTop^.Backward) = S_Const)\r
THEN\r
BEGIN\r
Inst := mEQC;\r
MegaLoad(ESTTop);\r
CodeConst(mEQC,ESTTop^.Backward^.Value,AnonymousSpix);\r
END\r
ELSE\r
IF (Inst = mDIFF) AND (ESTSort(ESTTop) = S_Const)\r
THEN\r
BEGIN\r
Inst := mEQC;\r
MegaLoad(ESTTop^.Backward);\r
CodeConst(mEQC,ESTTop^.Value,AnonymousSpix);\r
END\r
ELSE\r
BEGIN\r
IF (ESTSort(ESTTop^.BackWard) = S_Stack) THEN\r
BEGIN\r
megaload(ESTTop^.Backward);\r
megaload(ESTTop);\r
if neg then GenCode(mREV);\r
END\r
else\r
IF (ESTSort(ESTTop) = S_Stack) THEN\r
BEGIN\r
megaload(ESTTop);\r
megaload(ESTTop^.BackWard);\r
if (not neg) AND (Inst <> mDIFF) then GenCode(mREV);\r
END\r
else\r
begin\r
if neg then\r
begin\r
megaload(ESTTop);\r
megaload(ESTTop^.Backward);\r
end\r
else\r
begin\r
megaload(ESTTop^.Backward);\r
megaload(ESTTop);\r
end;\r
\r
End;\r
\r
gencode(Inst);\r
END;\r
ESTPop;\r
ESTPop;\r
\r
END\r
\r
ELSE\r
BEGIN\r
IF ESTSort(ESTTop) = S_Stack THEN\r
BEGIN\r
MegaMakeAddr(ESTTop);\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
ESTPop;\r
helpbool := False;\r
IF (ESTSort(ESTTop) = S_Stack) AND\r
(ESTTop^.T_ObjectOffset <> 0) THEN GenCode(mREV);\r
END ELSE\r
BEGIN\r
helpbool := True;\r
MegaMakeAddr(ESTTop^.BackWard);\r
IF ESTTop^.BackWard^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.BackWard^.T_ObjectOffset,AnonymousSpix);\r
END;\r
MegaMakeAddr(ESTTop);\r
IF ESTTop^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,ESTTop^.T_ObjectOffset,AnonymousSpix);\r
if helpbool THEN ESTpop;\r
IF inst = mGT THEN\r
BEGIN\r
IF helpbool = neg then GenCode(mREV);\r
END;\r
St_RetrieveType(ESTTop^.OprType,PtrSt);\r
ESTpop;\r
IF is_dynamic(PtrSt,length) then\r
BEGIN\r
PushAddr(PtrSt);\r
MegaLoad(ESTTop);\r
ESTPop;\r
END\r
ELSE\r
CodeConst(mLDC,Length,AnonymousSpix);\r
IF Inst = mGT THEN\r
BEGIN\r
CallRoutine(AnonymousSpix,GTRec,ST_Extern);\r
END\r
ELSE\r
BEGIN\r
CallRoutine(AnonymousSpix,EQRec,ST_Extern);\r
Inst := mEQC;\r
END;\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
if offset >= (8 + GlobalParSize) THEN\r
BEGIN\r
Offset := (offset-(GlobalParSize+Prog_Descr_Size)) - GlobalVarSize;\r
off := offset;\r
if off > 0 then Fatal_Error(Pass4,14);\r
END;\r
END;\r
IF Niv = CurrentNiv THEN\r
BEGIN\r
off := Offset;\r
MegaOffset := (VarOff * 4) + Off;\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
funclev : integer;\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
IF TypeAddr THEN\r
BEGIN\r
WITH AddrType DO\r
BEGIN\r
IF AddrType_Mode = direct THEN\r
ESTPushAddr(Spix,IntegerType,False,Par,\r
level,MegaOffset(level,Offset))\r
ELSE\r
IF AddrType_Mode = indirect THEN\r
BEGIN\r
ESTPushIndAddr(Spix,IntegerType,false,Par,\r
Level,MegaOffset(Level,Offset),dopeoffset);\r
ESTTop^.I_Allign := True;\r
END\r
ELSE\r
ESTPushCAddr(Spix,IntegerType,false,par,addr_label,\r
dopeoffset);\r
END;\r
END\r
ELSE\r
\r
IF ST_Kind = CFunction THEN\r
BEGIN\r
(* a Function *)\r
funclev := st_level;\r
if not SimpelFuncRes(PtrSt)\r
then\r
BEGIN\r
estpushindaddr(spix,typeref,false,par,\r
funclev,MegaOffset(funclev,func_result_offset),0);\r
ESTTop^.I_Allign := true;\r
END\r
else ESTPushAddr(Spix,TypeRef,false,Par,\r
FuncLev,MegaOffset(FuncLev,Func_Result_Offset));\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 = 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 IF (St_Kind = cLockVar) 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
ESTPop;\r
END;\r
PROCEDURE PutPackedElement;\r
VAR e : ESTElementRef;\r
allign : boolean;\r
mask : longint;\r
\r
PROCEDURE swop;\r
BEGIN\r
if ESTTop^.Kind = O_Const THEN\r
BEGIN\r
Exchangetopelements;\r
ESTPop;\r
ESTTop^.Value := ((ESTTop^.Value SHR 8) AND 255) +\r
((ESTTop^.Value AND 255) SHL 8);\r
MegaStore(2);\r
END\r
ELSE\r
BEGIN\r
megaload(ESTTop);\r
CodeConst(mSTL,ParamIndex,Anonymousspix);\r
ESTPop;\r
ESTPop;\r
LoadAbsAddr(ESTTop);\r
CodeConst(mSTL,ParamIndex + 1,Anonymousspix);\r
CodeConst(mLDL,ParamIndex,Anonymousspix);\r
CodeConst(mLDL,ParamIndex + 1,Anonymousspix);\r
CodeConst(mADC,1 ,Anonymousspix);\r
GenCode(mSB);\r
CodeConst(mLDLP,ParamIndex,Anonymousspix);\r
CodeConst(mADC,1 ,Anonymousspix);\r
GenCode(mLB);\r
CodeConst(mLDL,ParamIndex + 1,Anonymousspix);\r
GenCode(mSB);\r
ESTPop;\r
END;\r
END;\r
PROCEDURE MakeMask;\r
VAR e : ESTElementRef;\r
mask : Longint;\r
BEGIN\r
e := ESTTop^.Backward;\r
mask := 1;\r
mask := (mask SHL e^.Bitlength) - 1;\r
IF e^.Kind = O_Const THEN\r
BEGIN\r
mask := mask SHL e^.Value;\r
CodeConst(mLDC,mask,AnonymousSpix);\r
END\r
ELSE\r
BEGIN\r
CodeConst(mLDC,mask,AnonymousSpix);\r
MegaLoad(e);\r
GenCode(mSHL);\r
END;\r
GenCode(mNOT);\r
END;\r
\r
BEGIN\r
e := ESTTop^.Backward;\r
IF (e^.BitLength = 16) AND (e^.Set_Temp) THEN swop\r
ELSE\r
BEGIN\r
\r
IF (ESTTop^.Kind <> O_Const) OR\r
(e^.Kind <> O_Const) THEN Megaload(ESTTop);\r
\r
IF ESTSort(E) = S_Stack THEN\r
BEGIN\r
StoreTempOK(e^.T_IndexTOSTL);\r
e^.kind := O_Temp;\r
END;\r
mask := 1;\r
mask := (mask SHL e^.Bitlength) - 1;\r
\r
IF E^.Kind = O_Const THEN\r
BEGIN\r
IF ESTTop^.Kind = O_Const THEN\r
BEGIN\r
ESTTop^.Value := (ESTTop^.Value AND mask) SHL e^.Value;\r
MegaLoad(ESTTop);\r
END\r
ELSE\r
BEGIN\r
CodeConst(mLDC,mask,AnonymousSpix);\r
GenCode(mAND);\r
IF E^.Value <> 0 THEN\r
BEGIN\r
CodeConst(mLDC,E^.Value,AnonymousSpix);\r
GenCode(mSHL);\r
END;\r
END;\r
END\r
ELSE\r
BEGIN\r
CodeConst(mLDC,mask,AnonymousSpix);\r
GenCode(mAND);\r
CodeConst(mLDL,e^.T_Offset,AnonymousSpix);\r
GenCode(mSHL);\r
END;\r
\r
e := e^.BackWard;\r
allign := MegaAllign(e);\r
IF not Allign Then\r
BEGIN\r
StoreStackToTemp(ESTTop);\r
StoreTempOK(ESTTop^.T_IndexTOSTL);\r
ESTTop^.Kind := O_Temp;\r
END;\r
\r
MegaMakeAddr(e);\r
IF e^.T_ObjectOffset <> 0 THEN\r
CodeConst(mADC,e^.T_ObjectOffset,AnonymousSpix);\r
\r
\r
CodeConst(mSTL,ParamIndex,AnonymousSpix);\r
IF allign THEN MakeMask;\r
\r
CodeConst(mLDL,ParamIndex,AnonymousSpix);\r
\r
IF Allign THEN CodeConst(mLDNL,0,Anonymousspix)\r
ELSE\r
BEGIN\r
CodeConst(mLDLP,ParamIndex + 1,AnonymousSpix);\r
CodeConst(mLDC,4,AnonymousSpix);\r
GenCode(mMOVE);\r
MakeMask;\r
CodeConst(mLDL,ParamIndex + 1,Anonymousspix);\r
END;\r
\r
GenCode(mAND);\r
MegaLoad(ESTTop);\r
GenCode(mOR);\r
IF Allign THEN\r
BEGIN\r
CodeConst(mLDL,ParamIndex,AnonymousSpix);\r
CodeConst(mSTNL,0,AnonymousSpix);\r
END\r
ELSE\r
BEGIN\r
CodeConst(mSTL,ParamIndex + 1,AnonymousSpix);\r
CodeConst(mLDLP,ParamIndex + 1,AnonymousSpix);\r
CodeConst(mLDL,ParamIndex,AnonymousSpix);\r
CodeConst(mLDC,4,AnonymousSpix);\r
GenCode(mMOVE);\r
END;\r
\r
ESTPop;\r
ESTPop;\r
ESTPop;\r
END;\r
\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
helpmask : LongInt;\r
PROCEDURE swop;\r
BEGIN\r
LoadAbsAddr(e^.Backward);\r
MakeFreeReg(2);\r
CodeConst(mSTL,ParamIndex ,Anonymousspix);\r
CodeConst(mLDL,ParamIndex,Anonymousspix);\r
CodeConst(mADC,1 ,Anonymousspix);\r
GenCode(mLB);\r
CodeConst(mLDL,ParamIndex,Anonymousspix);\r
GenCode(mLB);\r
CodeConst(mLDC,128 ,Anonymousspix);\r
GenCode(mXWORD);\r
CodeConst(mLDC,8 ,Anonymousspix);\r
GenCode(mSHL);\r
GenCode(mOR);\r
END;\r
BEGIN\r
\r
BitLength := e^.BitLength;\r
if (bitlength = 16) AND e^.Set_Temp THEN swop\r
else\r
BEGIN\r
MegaLoad(e^.Backward);\r
IF (e^.Kind = O_Const) AND (e^.Value = 0) THEN ELSE\r
BEGIN\r
MegaLoad(e);\r
GenCode(mSHR);\r
END;\r
\r
helpmask := 1;\r
CodeConst(mLDC,(helpmask SHL BitLength) - 1,Anonymousspix);\r
GenCode(mAND);\r
\r
St_RetrieveType(TypeAddr,Ptr);\r
IF (Ptr^.St_Kind = csubrange) and (Ptr^.subr_Low >= $8000 ) THEN\r
(* Sign Extent *)\r
BEGIN\r
CodeConst(mLDC,1 SHL (BitLength - 1),AnonymousSpix);\r
GenCode(mXWORD);\r
END;\r
END;\r
END;\r
\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
Procedure AddOffsetToAddr(e: ESTElementRef;Offset : integer);\r
BEGIN\r
\r
IF e^.Par = P_Share THEN MegaMakeAddr(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
VAR\r
PtrSt : st_ElemPtr;\r
BEGIN\r
MakeFreeReg(3);\r
IF (SSTTop^.DynamicAlloc = false) AND (SSTTop^.Kind <> S_Prog) THEN\r
BEGIN\r
codeconst(mLDL,StaOff,Anonymousspix);\r
codeconst(mLDNL,Proc_StackLimit,Anonymousspix);\r
codeconst(mSTL,VarOff + 1,Anonymousspix);\r
SSTTop^.DynamicAlloc := true;\r
END;\r
\r
St_RetrieveType(Insymbol,PtrSt);\r
IF is_Dynamic(PtrSt,PtrSt^.St_Size) THEN pushaddr(PtrSt)\r
ELSE EstPushConst(IntegerType,PtrSt^.St_Size);\r
MegaLoad(ESTTop);\r
ESTPop;\r
IF AddLength <> 0 THEN CodeConst(mADC,AddLength,Anonymousspix);\r
Callroutine(Anonymousspix,DynAlloc,St_Extern);\r
EstPushStack(IntegerType,true);\r
END;\r
\r
PROCEDURE MakeCopyOfTop;\r
VAR e : ESTElementRef;\r
BEGIN\r
if ESTSort(ESTTop) = S_Stack THEN\r
BEGIN\r
StoreStackToTemp(ESTTop);\r
StoreTempOK(ESTTop^.T_IndexTOSTL);\r
ESTTop^.Kind := O_Temp;\r
END;\r
IF ESTTop^.Kind = O_Temp THEN\r
BEGIN\r
MakeFreeReg(1);\r
END;\r
e := ESTTop;\r
ESTPushconst(IntegerType,0);\r
ESTTop^ := ESTTop^.BackWard^;\r
ESTTop^.xforward := nil;\r
ESTTop^.BackWard := e;\r
IF ESTTop^.Kind = O_Temp THEN\r
BEGIN\r
CodeConst(mLDL,ESTTop^.T_Offset,Anonymousspix);\r
ESTTop^.Kind := O_Stack;\r
StoreStackToTemp(ESTTop);\r
END;\r
\r
END;\r
\r
\r
PROCEDURE PushSetParam;\r
VAR\r
PtrSt : st_ElemPtr;\r
size : integer;\r
BEGIN\r
ESTTop^.IndVar := False;\r
IF ESTTop^.Set_Temp THEN Size := 0\r
ELSE\r
BEGIN\r
St_RetrieveType(ESTTop^.OprType,PtrSt);\r
Size := PtrSt^.St_Size;\r
END;\r
PushParam(cVarParam);\r
ESTPushConst(IntegerType,Size);\r
PushParam(cValueParam);\r
END;\r
\r
Procedure MakeSetOprReady;\r
(* The procedure generates code to push the last setoperand to a set opr. *)\r
VAR size : integer;\r
\r
BEGIN\r
PushSetParam;\r
LoadFirstParams(16,St_Extern);\r
END;\r
\r
PROCEDURE PushSetOnStack(TypeAddr : St_Address);\r
VAR\r
ptr : st_elemptr;\r
low,high : integer;\r
length : integer;\r
BEGIN\r
St_RetrieveType(TypeAddr,Ptr);\r
length := ((Ptr^.St_Size + 3) DIV 4) * 4;\r
Low := Ptr^.Subr_Low;\r
High := Ptr^.Subr_High;\r
\r
IF (ESTTop^.Kind = O_Temp) OR (ESTTop^.Kind = O_StackOrTemp) THEN\r
MegaMakeAddr(ESTTop);\r
MegaAllocTemp(Length Div 4);\r
ESTPushAddr(AnonymousSpix,Typeaddr,false,P_Normal,\r
CurrentNiv,TempOffset * 4);\r
StoreStackToTemp(ESTTop^.Backward);\r
\r
StartCall;\r
\r
PushParam(cVarParam);\r
ExchangeTopElements;\r
ESTPushConst(IntegerType,Low);\r
PushParam(cValueParam);\r
ExchangeTopElements;\r
PushSetParam;\r
ESTPushConst(IntegerType,High);\r
PushParam(cValueParam);\r
\r
LoadFirstParams(20,St_Extern);\r
\r
\r
CallRoutine(AnonymousSpix,AssignSet,St_Extern);\r
EndCall(20);\r
\r
\r
ESTPushStack(TypeAddr,true);\r
IF Length > 4 THEN\r
BEGIN\r
CodeConst(mLDLP,TempOffset,Anonymousspix);\r
ESTTop^.T_Address := true;\r
ESTTop^.T_ObjectOffset := 0;\r
PushParam(cValueParam);\r
tempOffset := TempOffset + (length DIV 4);\r
END\r
ELSE\r
BEGIN\r
ESTTop^.T_Offset := TempOffset;\r
ESTTop^.Kind := O_Temp;\r
PushParam(cValueParam);\r
END;\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
CodeLoadEffAddr(LastInternalLBDRLabel,0);\r
CodeConst(mSTL,0,Anonymousspix);\r
(* push a pointer to the name *)\r
(*CodeLoadEffAddr(Lab,0);\r
CodeConst(mSTL,1,Anonymousspix);*)\r
END;\r
\r
\r
CodeConst(mLDC,ord(PoolParam),Anonymousspix);\r
\r
\r
\r
CodeConst(mLDLP,MegaOffset(CurrentNiv,ProgOffset) DIV 4,\r
Anonymousspix);\r
IF ProgState = Internal THEN\r
BEGIN\r
CallRoutine(AnonymousSpix,Init_Internal,St_extern);\r
END\r
ELSE\r
CallRoutine(AnonymousSpix,Init_External,St_Extern);\r
\r
\r
END; (* MakeProgramDesc *)\r
\r
Procedure MegaAllocTemp(No: Integer);\r
var i : integer;\r
BEGIN\r
TempOffset := TempOffset - No;\r
i := TempOffset;\r
IF i < ParamIndex THEN TempSpaceError(' TempSpace',No);\r
END;\r
\r
Procedure MegaAllocParam(No:Integer);\r
VAR i : Integer;\r
BEGIN\r
ParamIndex := ParamIndex + No;\r
i := TempOffset;\r
IF i < ParamIndex THEN TempSpaceError('ParamSpace', No);\r
END;\r
(* ------------------------------------------------------------- *)\r
PROCEDURE LoadInt16;\r
VAR Moved : boolean;\r
BEGIN\r
Moved := false;\r
IF not MegaAllign(ESTTop) THEN\r
BEGIN\r
MegaMoveToTemp(ESTTop);\r
Moved := true;\r
END;\r
ESTTop^.OprType := IntegerType;\r
MegaLoad(ESTTop);\r
MakeFreeReg(1);\r
IF Not Moved THEN\r
BEGIN\r
CodeConst(mLDC, (1 SHL 16) - 1, AnonymousSpix);\r
GenCode(mAND);\r
END;\r
CodeConst(mLDC, 1 SHL 15, AnonymousSpix);\r
GenCode(mXWORD);\r
StoreStackToTemp(ESTTop);\r
\r
END;\r
\r
END.\r
\r
\r
(* -------------END PROCEDURE ESTOPR -------- ESTOPR -- *)\r
\r
«eof»