|
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: 56146 (0xdb52)
Types: TextFile
Names: »P450CODE.PAS«
└─⟦037c0ce35⟧ Bits:30010524 DVBS1.SW2114.src.2.6-2 RTP compiler source SW2104+SW2114 Disk#2 30/1-92 HHA
└─⟦this⟧ »RTP\P450CODE.PAS«
└─⟦828f0d3dd⟧ Bits:30010527 DVBS1.SW2114.src.2.6-5 RTP Compiler Source SW2104+SW2114 Disk 2 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\P450CODE.PAS«
└─⟦891417be1⟧ Bits:30010519 DVBS1.SW2114.src.2-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
└─⟦this⟧ »RTP\P450CODE.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\P450CODE.PAS«
{$O+,F+}\r
unit p450code;\r
(* This module impl. procedure called when generating code *)\r
interface\r
uses pscplm,mpaunit,sthunit,sthcom,p4unit;\r
\r
\r
\r
\r
\r
(* --------- PUBLIC CODEGENERATOR -----------CODEGENERATOR --*)\r
\r
\r
\r
CONST\r
Proc_StackLimit = 8;\r
Proc_StackOccam = 9;\r
Proc_exception_offset = 2;\r
\r
Prog_Descr_Size = 100;\r
\r
\r
LengthOfSharedType = 12;\r
\r
LengthOfSemaphore = 12;\r
\r
SharedCounterOffset = 4;\r
\r
LockedOffset = 4;\r
\r
DataSizeOffset = 8;\r
\r
OffsetOffset = 12;\r
\r
DataPartOffset = 0;\r
\r
TopOffset = 16;\r
\r
StackBoundOffset = 28;\r
(* Offset to field StackBound in PI3 type Process_Descriptor *)\r
\r
NoParamOffset = 29;\r
(* offset to the field Noparam in the pi3 type program_describtion *)\r
\r
SubProgsHeadOffset = 74;\r
(* offset to the SubProgsHead field in pi3 type program_describtion *)\r
\r
ParamsizeForCreate = 20;\r
(* no of bytes for the parameter to create *)\r
\r
\r
(* The following constant gives the interupt parameter to an exception *)\r
\r
\r
IndexOutOfRangeInt = 50;\r
IndexOutOfRangeExc = 50; (* fault 50, Not used *)\r
\r
StackOverFlowInt = 12;\r
StackOverFlowExc = 12;\r
(* Parametre to interrupt when stack overflow *)\r
\r
OutOfRangeInt = 52;\r
OutOfRangeExc = 52; (* fault 52 , Not used *)\r
\r
OtherwiseInt = 7;\r
OtherwiseExc = 7;\r
\r
LockInt = 1;\r
LockExc = 1;\r
\r
(* AccessCheckInt = 15;\r
AccessCheckExc = 15;\r
(* Parametre to interupt when accesscheck error *)\r
\r
(* PointerNilInt = 10;\r
PointerNilExc = 10; *)\r
\r
CheckParamInt = 8;\r
CheckParamExc = 8;\r
\r
StrucInt = 14;\r
StrucExc = 14;\r
\r
WithInt = 6;\r
WithExc = 6;\r
\r
\r
(* PI3 constant *)\r
call_frame = 20;\r
(* The following gives the number for the predefined external routines *)\r
RtpLBDR = 1;\r
Push_Buf = 2;\r
Pop_Buf = 3;\r
GetBuf = 4;\r
GetBufDelay = 5;\r
Signal = 6;\r
Wait = 7;\r
WaitDelay = 8;\r
PutBuf = 9;\r
Resume = 10;\r
AllocPool = 11;\r
ChainDeQueue = 12;\r
ChainEnQueue = 13;\r
Init_Semaphore = 14;\r
WaitS = 15;\r
Set_Exception = 16;\r
Init_Reference = 17;\r
Init_Chain = 18;\r
Init_Shared = 19;\r
Init_Mailbox = 20;\r
Init_Process = 21;\r
Init_Internal = 22;\r
Init_External = 23;\r
Init_Port = 24;\r
SignalS = 25;\r
Init_Pool = 26;\r
EndProcess = 27;\r
Mark_LocalRef = 28;\r
UnChain_LocalRef = 29;\r
Init_LocalRef = 30;\r
\r
dynAlloc = 31;\r
Exchange = 32;\r
\r
\r
ExcRec = 33;\r
ExcPack = 34;\r
Eqrec = 35;\r
GtRec = 36;\r
StStr = 37;\r
ExStr = 38;\r
GtStr = 39;\r
EqStr = 40;\r
\r
NoRoutinesWithStatLink = 32;\r
NoOfPI3Routines = 40;\r
NoOfSetRoutines = 10;\r
NoOfPI3RoutinesAndSetRoutines = NoOfPI3Routines + NoOfSetRoutines;\r
\r
(* External set Routine *)\r
AssignSet = NoOfPi3Routines + 1;\r
AddSet = NoOfPi3Routines + 2;\r
SubSet = NoOfPi3Routines + 3;\r
MultSet= NoOfPi3Routines + 4;\r
GESet = NoOfPi3Routines + 5;\r
EQSet= NoOfPi3Routines + 6;\r
NESet= NoOfPi3Routines + 7;\r
LESet = NoOfPi3Routines + 8;\r
InSet = NoOfPi3Routines + 9;\r
MakeSet = NoOfPi3Routines + 10;\r
\r
\r
\r
Maxbin1Ix = 40;\r
\r
TYPE\r
\r
Pfix_type = RECORD\r
Prefixes : byte;\r
Code : ARRAY[1..8] OF Byte;\r
END;\r
\r
\r
VAR\r
\r
(* List contains the external routines *)\r
FirstExtDec : St_Address;\r
ExternalThunksDumped : Boolean;\r
\r
NoExtDecl, NoPreExtDecl : Word;\r
\r
LengthOfAllPreExtName, LengthOfAllExtName : Word;\r
\r
\r
CodeOn : boolean;\r
(* Symbolic code is generated if true *)\r
\r
LastNameEntry : St_Address;\r
\r
LengthOfNameTabel : word;\r
\r
LineTabel : boolean;\r
\r
Spacing : word;\r
\r
CurrentSegNo : Word;\r
(* Declarations which has to do with pass4_2 TURBO *)\r
\r
CONST\r
\r
LengthOfExternalLBDR = 29;\r
\r
LengthOfInternalLBDR = 8;\r
\r
\r
\r
\r
Max4Bit = 16;\r
\r
MaxByte = 256;\r
\r
\r
(* the following constant gives the type of records on codefile *)\r
Frstrc = $0B0; (* First record *)\r
\r
Lastrc = $0B2;\r
\r
TypDef = $8E;\r
\r
\r
\r
\r
TYPE\r
\r
CodeName = string[5];\r
\r
\r
\r
TypeExternalLBDR =\r
RECORD\r
CASE b : Boolean OF\r
\r
true : ( EntryPoint : Word;\r
LineTable : word;\r
GlobalSize : Word;\r
Appetite : Word;\r
SegSize : Word;\r
LinkCount : Byte;\r
Next1,Next2 : integer; (* a pointer *)\r
BlName : String[12];\r
BlKind : Byte );\r
\r
\r
false : ( Byt :ARRAY[1..LengthOfExternalLBDR] OF Byte);\r
END;\r
\r
\r
\r
VAR\r
MegaInstructionName : ARRAY[mJ..mCWORD] OF CodeName;\r
MegaInstructionValue: ARRAY[mJ..mCWORD] OF WORD;\r
iInstTomInst : ARRAY[iXLAT..iMOD] OF Instruction;\r
\r
PreExtName : ARRAY[1..NoOfPI3RoutinesAndSetRoutines] of SpixRange;\r
PreExtCalled : ARRAY[1..NoOfPI3RoutinesAndSetRoutines] of St_Address;\r
\r
FirstFixUpp, LastFixUpp : St_Address;\r
(* List of FixUpp *)\r
\r
NoFixUpp : Word;\r
(* Number of FixUpp *)\r
\r
\r
ContextEndOffset : Word;\r
\r
\r
VersionNumber : Array[1..4] OF Word;\r
\r
\r
FilePtrToSecSegDef : longint;\r
\r
InStrucValue : integer;\r
\r
Strucoffset : Integer;\r
StrucInExp : boolean;\r
\r
LastInternalLBDRLabel : St_Address;\r
(* The offset of the last internalLBDR written to TBinFile *)\r
\r
LastLabelOffset : Longint;\r
(* InternalOffset of the last generated label *)\r
LastJMPOffset : Longint; (* internaloffset after generating the last\r
JMP instruction *)\r
\r
Offsetstatistic, extthunkstatistic : array[1..8] OF Integer;\r
\r
(* -------------------------------------------- *)\r
\r
\r
PROCEDURE InitCodeGenerator;\r
(* The procedure initialize the codegenerator *)\r
\r
PROCEDURE DumpExternalThunks;\r
\r
PROCEDURE MakeExternalLBDR( SymbolPoint : St_Address;\r
EntryPoint : St_Address;\r
LineTable : integer;\r
GlobalSize : Word;\r
Appetite : Word;\r
BlName : SpixRange;\r
BlKind : integer );\r
(* The procedure makes a external LBDR *)\r
\r
PROCEDURE MakeInternalLBDR( EntryPoint : St_Address;\r
LineTable : integer;\r
GlobalSize : Word;\r
Appetite : Word ;\r
BlName : SpixRange);\r
(* The procedure makes a internal LBDR *)\r
\r
\r
\r
\r
\r
PROCEDURE StopBlock;\r
(* The procedure is called when where is no more code for\r
that block. The procedure makes the <object block> on file\r
codefile. That is the 2. pass of the block is made *)\r
\r
PROCEDURE StopCodeGene;\r
(* The procedure is called when where is no more code to be\r
generated. *)\r
\r
PROCEDURE GenCode(Inst : Instruction);\r
(* Generate a instruction without parameter *)\r
\r
PROCEDURE CodeConst(Inst : Instruction; Value : LongInt; spix : spixrange);\r
(* Generate a instruction with a constant parametre *)\r
\r
PROCEDURE CallExtern(Addr : ST_address);\r
\r
PROCEDURE CallRoutine(Spix : SpixRange; Number : word; RKind :\r
St_DeclareMode);\r
(* The procedure generates code for an external or open routine call *)\r
\r
FUNCTION StoreTemp(offset : Word) : Integer;\r
\r
Procedure StoreTempOK(Index : Integer);\r
\r
PROCEDURE CodeJump(Inst : Instruction; Lab : St_Address);\r
(* Generate a instruction with a label as parameter *)\r
\r
PROCEDURE ReleaseStrucDyn;\r
\r
\r
PROCEDURE CodeFaultAX( ErrorInt, ErrorExc: WORD);\r
PROCEDURE CodeFault(ErrorInt, ErrorExc: WORD);\r
\r
\r
\r
PROCEDURE CodeLoadEffAddr(Lab : St_Address; Offset : Word);\r
(* Generate code to load Areg with the effectiv address of Lab:+ Offset *)\r
\r
PROCEDURE GenerateLabel(Lab : St_Address);\r
(* Generate the label given by Lab *)\r
\r
PROCEDURE GenAsLabel(Lab1, Lab2 : St_Address);\r
(* The offset of Lab1 is given by the offset of Lab2\r
A command is made in the code if Lab2 has been generate *)\r
\r
PROCEDURE DumpConst(ConstAddr : St_Address );\r
(* the structured constant given by ConstAddr is dumped in the code *)\r
\r
\r
PROCEDURE DumpCaseTabel(CaseTab : St_Address; Size : word;\r
OtherwiseLab : St_Address; IndJumpLabel : St_Address);\r
(* The casetabel is generated *)\r
\r
Procedure MegaAllignCode;\r
\r
PROCEDURE NewLine(Line : Word);\r
(* The procedure write the linenumber to codelist if codeon *)\r
\r
PROCEDURE SetCodeTo(Bool : Boolean);\r
(* The procedure change the option codeon *)\r
\r
Procedure ContextStop;\r
(* The procedure is called when leaving linetabel. Only used when\r
making linetabel *)\r
\r
\r
Procedure RoutineDecl(Symbol : St_Address; start : boolean );\r
(* the routine is called when making a routine, program or a familie\r
declaration. Only used when making nameentry *)\r
\r
\r
\r
PROCEDURE MakeLongCall(Symbol : St_Address);\r
(* Makes a call to an other segment using segment fixup *)\r
\r
PROCEDURE DumpRoutineTabel;\r
(* Dumps the routine tabel . Only used when more than one segment *)\r
\r
Procedure MakeJumpToNextSegment;\r
(* Only used when more than one segment *)\r
\r
(* ----- END PUPLIC CODEGENERATOR --------CODEGENERATOR -- *)\r
\r
\r
IMPLEMENTATION\r
(* ---------- IMPORTS --------------------IMPORTS ---------*)\r
\r
uses dos,sthp34,files, rtp86mpa;\r
\r
\r
(* ------------IMPORTS END --------------IMPORTS END --------*)\r
\r
\r
\r
(* --------PRIVATE CODEGENERATOR ------ CODEGENERATOR -----*)\r
\r
\r
\r
\r
\r
\r
CONST\r
\r
MaxLengthOfOpenRoutines = 2000;\r
(* this constant must be changed if new opernroutins is made *)\r
\r
LengthOfVersion = 12;\r
MaxLabInOpen = 2;\r
\r
OpenCode = 1;\r
OpenFinish = 2;\r
OpenPushProc = 3;\r
OpenJump = 4;\r
OpenCJump = 5;\r
OpenLabel = 6;\r
\r
LabelPos = 6;\r
(* Gives the label pos on CodeList *)\r
\r
CodePos = 12;\r
(* Gives the code pos on CodeList *)\r
CommentPos = 20;\r
\r
VAR\r
\r
InternalOffset, Offset : Longint;\r
\r
\r
\r
LastLabel : St_Address; (* pointer to last generated label *)\r
\r
(* LastJMPOffset, LastLabelOffset and LastLabel is used to\r
eliminat superflous jumps *)\r
\r
\r
\r
(* The following variabels are tabels containing opcode for\r
instructions *)\r
\r
\r
CodeOfOpenRoutines : ARRAY[ 0 .. MaxLengthOfOpenRoutines ] OF Byte;\r
(* tabels contains the code for the open routines *)\r
\r
\r
ShiftFactor : ARRAY[0..7] OF Byte;\r
\r
\r
WordByte : RECORD\r
CASE Int : integer OF\r
1 : (i : Integer);\r
2 : (Byte1 : 0..255;\r
Byte2 : 0..255);\r
3 : (w : Word);\r
END;\r
(* Used to convert a integer/Word to two bytes or two bytes\r
to a integer/Word *)\r
\r
Filebufferindex : integer;\r
\r
CodeOnPass2 : Boolean;\r
(* Symbolic code is generated if true *)\r
\r
CheckSum : Word;\r
(* Used to calculated the checksum for a objectfile\r
record *)\r
\r
CurrentPos : integer;\r
(* Gives the possition for the last char written to\r
CodeList *)\r
\r
HexNumber : ARRAY[ 0 .. 15 ] OF Char;\r
\r
FirstBlock : boolean;\r
\r
TBinFileptr : byte;\r
\r
filebufferlast : Integer;\r
eoftbinfile : boolean;\r
\r
Nextbin1In, Nextbin1Out, Elonbin1, Bin2codeOut: word;\r
Tempbin1 : ARRAY[1..Maxbin1ix] OF Tempbin1_record;\r
\r
FirstTempPage , TempPage : St_Address;\r
TempIndex : Integer;\r
JumpRec : St_elemPtr;\r
(* -------------------------------------------- *)\r
procedure newtemppage;\r
VAR Ptr : St_elemPtr;\r
BEGIN\r
IF TempIndex >= JumpRec^.JumpNoElements THEN\r
BEGIN\r
ptr := JumpRec;\r
St_ReserveJump(JumpRec^.JumpListRef,JumpRec);\r
St_Unlock(Ptr);\r
St_Lock(JumpRec);\r
TempIndex := 0;\r
END;\r
TempIndex := TempIndex + 1;\r
END;\r
\r
procedure nexttemppage;\r
VAR Ptr : St_elemPtr;\r
BEGIN\r
IF TempIndex >= JumpRec^.JumpNoElements THEN\r
BEGIN\r
ptr := JumpRec;\r
St_Get(JumpRec^.JumpListRef,JumpRec);\r
St_Unlock(Ptr);\r
St_Lock(JumpRec);\r
TempIndex := 0;\r
END;\r
TempIndex := TempIndex + 1;\r
END;\r
\r
function eofTempPage : boolean;\r
BEGIN\r
eofTempPage := Equal_Addr(JumpRec^.JumpListRef,St_nillAddr)\r
AND (TempIndex = JumpRec^.JumpNoElements);\r
END;\r
\r
procedure emptyfilebuffer;\r
BEGIN\r
blockwrite(tbinfile,filebufferptr^,filebufferindex);\r
filebufferindex := 0;\r
end;\r
\r
Procedure puttbinfile( x: byte);\r
BEGIN\r
if Filebufferindex = Lengthoffilebuffer then\r
emptyfilebuffer;\r
filebufferindex := filebufferindex + 1;\r
filebufferptr^[filebufferindex] := x;\r
internaloffset := internaloffset + 1;\r
Bin2codeOut := Bin2codeOut + 1;\r
END;\r
\r
FUNCTION MegaPfixNo(Offset: Longint): Integer;\r
VAR neg : boolean;\r
result : integer;\r
BEGIN\r
neg := (offset < 0);\r
IF neg THEN offset := - offset;\r
result := 1;\r
while offset > 15 do\r
BEGIN\r
result := Result + 1;\r
offset := offset SHR 4;\r
END;\r
if neg and( result = 1) THEN Result := 2;\r
MegaPFixNo := result;\r
END;\r
\r
Procedure Putbin1Code;\r
VAR Bin1ix : Word;\r
BEGIN\r
Bin1ix := NextBin1Out + 1;\r
IF Bin1ix > Maxbin1ix THEN Bin1ix := 1;\r
WiTH Tempbin1[Nextbin1Out] DO\r
IF Bin1Param <> 0 THEN\r
BEGIN\r
NewTempPage;\r
IF Tempindex = Jumprec^.JumpNoElements THEN\r
IF Bin1Code = AddLabelToDis THEN\r
BEGIN\r
JumpRec^.JumpNoElements := JumpRec^.JumpNoElements - 1;\r
NewTempPage;\r
END;\r
JumpRec^.Jump_data[TempIndex] := Tempbin1[Nextbin1Out];\r
END ELSE\r
BEGIN\r
WITH Tempbin1[Bin1ix] DO\r
Bin2Code := Bin2Code + Tempbin1[Nextbin1Out].Bin2Code;\r
END;\r
Nextbin1Out := Bin1ix;\r
END;\r
\r
Procedure Putbin1Label(Code: CodeFormat; Labeladdr : St_address;\r
VAR Bin1ix : word);\r
VAR Ptr: St_Elemptr;\r
BEGIN\r
\r
Nextbin1In := Nextbin1In + 1;\r
IF Nextbin1In > Maxbin1ix THEN\r
BEGIN\r
Nextbin1In := 1;\r
Elonbin1 := Elonbin1 + Maxbin1ix;\r
IF Nextbin1Out <= 0 then Nextbin1Out := 1;\r
END;\r
IF Nextbin1Out = Nextbin1In then Putbin1Code;\r
\r
WITH Tempbin1[Nextbin1In] DO\r
BEGIN\r
Bin1Code := Code;\r
Bin1Label := Labeladdr;\r
Bin2Code := Bin2codeOut;\r
Bin2codeOut := 0;\r
CASE Code OF\r
TempSTL: Bin1Param := 0;\r
\r
UnCondJump, CondJump, InternalCall:\r
BEGIN\r
St_Retrieve(Labeladdr, Ptr);\r
WHILE NOT Equal_Addr(Ptr^.DefAsLabel,St_NillAddr) DO\r
St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
\r
if Ptr^.MegaLabel_offset = 0 then Bin1Param := 1 else\r
BEGIN\r
Bin1Param := MegaPfixNo(Ptr^.MegaLabel_offset-(InternalOffset+1));\r
END;\r
InternalOffset := InternalOffset + Bin1Param;\r
END;\r
\r
ExternalCall :\r
BEGIN\r
Bin1Param := 8;\r
InternalOffset := InternalOffset + Bin1Param;\r
END;\r
\r
AddLabelToDis :\r
BEGIN\r
Bin1Param := 3;\r
InternalOffset := InternalOffset + Bin1Param;\r
END;\r
\r
CaseLabList:\r
BEGIN\r
Bin1Param := LabelAddr.Va_High*4;\r
InternalOffset := InternalOffset + Bin1Param;\r
END;\r
\r
AllignCode:\r
BEGIN\r
Bin1Param := 3;\r
InternalOffset := InternalOffset + Bin1Param;\r
END;\r
\r
LongJump : (* External call Thunks *)\r
BEGIN\r
Bin1Param := 8;\r
InternalOffset := InternalOffset + Bin1Param;\r
END;\r
\r
ExternalLbdr :\r
BEGIN\r
Bin1Param := 40;\r
InternalOffset := InternalOffset + Bin1Param;\r
END;\r
\r
InternalLbdr : (* For Routines *)\r
BEGIN\r
Bin1Param := 28;\r
InternalOffset := InternalOffset + Bin1Param;\r
END;\r
\r
ELSE Bin1Param := 1;\r
END;\r
END;\r
\r
Bin1ix := Elonbin1 + Nextbin1In;\r
\r
END;\r
\r
Procedure Putbin1Value(Code : CodeFormat; CodeValue: WORD;\r
VAR Bin1ix : WORD);\r
VAR Labeladdr : St_address;\r
BEGIN\r
Labeladdr.Va_low := 0;\r
Labeladdr.Va_high := CodeValue;\r
Putbin1Label(Code, Labeladdr, Bin1ix);\r
END;\r
\r
FUNCTION InsertBin1ix(Bin1ix: WORD): BOOLEAN;\r
VAR Lastix : WORD;\r
ihelp : Integer;\r
BEGIN\r
Lastix := Elonbin1 + Nextbin1In;\r
IF ((Bin1ix <= (Lastix - Maxbin1ix)) AND\r
(Lastix >= Maxbin1ix)) OR\r
(Bin1ix = 0) THEN\r
BEGIN\r
writeln('1 Insertbin lastix:',lastix,' nextbin1in:',nextbin1in,\r
' bin1ix ',Bin1ix,' elonbin1 ',elonbin1);\r
InsertBin1ix := False;\r
END ELSE\r
IF Bin1ix > Lastix THEN\r
BEGIN\r
writeln('2 Insertbin lastix:',lastix,' nextbin1in:',nextbin1in,\r
' bin1ix ',Bin1ix,' elonbin1 ',elonbin1);\r
InsertBin1ix := False;\r
END ELSE\r
BEGIN\r
InsertBin1ix := True;\r
Ihelp := Nextbin1In - (Lastix - Bin1ix);\r
IF Ihelp < 1 THEN Ihelp := Ihelp + Maxbin1ix;\r
WITH Tempbin1[Ihelp] DO\r
IF Bin1Param = 0 THEN\r
BEGIN\r
Bin1Param := MegaPfixNo(Bin1Label.Va_high);\r
InternalOffset := InternalOffset + Bin1Param;\r
END ELSE\r
BEGIN\r
writeln('3 insertbin lastix:',lastix,' nextbin1in:',nextbin1in,\r
' bin1ix ',Bin1ix,' elonbin1 ',elonbin1);\r
InsertBin1ix := False;\r
END;\r
END;\r
END;\r
\r
\r
(* ------------------------------------------------------- *)\r
\r
PROCEDURE MakeFreeCodeBuffer( No : Integer);\r
(* The procedure makes at least No bytes free in the codebuffer\r
That is done by writting to the file TBinFile *)\r
begin\r
end;\r
\r
Procedure MegaAllignCode;\r
VAR\r
w : word;\r
BEGIN\r
PutBin1Value(AllignCode,0,w);\r
END;\r
\r
PROCEDURE DumpConst(ConstAddr : St_Address );\r
(* the structured constant given by ConstAddr is dumped in the code *)\r
VAR\r
Ptr : St_elemPtr;\r
More : boolean;\r
i , No : word;\r
Length , index : word;\r
ch : char;\r
\r
BEGIN\r
More := true;\r
While More Do\r
BEGIN\r
St_Retrieve(ConstAddr,Ptr);\r
Length := Ptr^.St_Size;\r
More := Not Ptr^.St_ListEnd;\r
ConstAddr := Ptr^.ListRef;\r
Index := 0;\r
WHILE Length > 0 DO\r
BEGIN\r
IF Length > 10 THEN No := 10\r
ELSE No := Length;\r
Length := Length - No;\r
For I:= 1 to no do\r
putTBinFile(Ptr^.Data_area[i + index]);\r
IF CodeOn THEN\r
BEGIN\r
Write(TSymFile,No,' ');\r
FOR i := (index + 1) TO (No + index) DO\r
BEGIN\r
ch := chr(Ptr^.Data_area[i]);\r
IF (( ord(' ') > ord(ch)) OR (ord(ch) > ord('}')))\r
THEN ch := '.';\r
\r
write(TSymFile,ch)\r
END;\r
Writeln(TSymFile);\r
END;\r
\r
index := index + No;\r
END;\r
END;\r
END; (* DumpConst *)\r
\r
(* ---------------------------------------------------------- *)\r
\r
\r
\r
PROCEDURE DumpCaseTabel(CaseTab : St_Address; Size : Word;\r
OtherwiseLab : St_Address; IndJumpLabel : St_Address);\r
(* The casetabel is generated *)\r
\r
VAR\r
w : word;\r
BEGIN\r
PutBin1Value(AllignCode,0,w);\r
PutBin1Value(CaseLabList,Size,w);\r
PutBin1Label(DummyElement,CaseTab,w);\r
PutBin1Label(DummyElement,OtherwiseLab,w);\r
PutBin1Label(DummyElement,IndJumpLabel,w);\r
\r
END; (* DumpCaseTabel *)\r
\r
\r
\r
\r
(*------------------------------------------------------------------*)\r
\r
\r
\r
(*------------------------------------------------------------------- *)\r
\r
\r
\r
(*------------------------------------------------------------------*)\r
\r
\r
PROCEDURE NewLine(Line : Word);\r
BEGIN\r
IF CodeOn or LineTabel THEN\r
BEGIN\r
Putbin1Value(LineNo, Line, Line);\r
END;\r
END;\r
\r
\r
(*------------------------------------------------------------------- *)\r
\r
\r
\r
\r
PROCEDURE SetCodeTo(Bool : Boolean);\r
VAR x,xx: WORD;\r
BEGIN\r
codeon := bool;\r
IF bool then xx:= SourceNumber\r
else xx := 255;\r
Putbin1Value(Setcode, xx, x);\r
END;\r
\r
\r
Procedure ContextStop;\r
(* The procedure is called when leaving context. Only used when\r
making linetabel *)\r
var ix : word;\r
BEGIN\r
PutBin1Value(ContextEnd,0,ix);\r
END;\r
\r
\r
Procedure RoutineDecl(Symbol : St_Address; start : boolean );\r
(* the routine is called when making a routine, program or a familie\r
declaration. Only used when making nameentry *)\r
VAR ix : word;\r
BEGIN\r
IF start THEN\r
PutBin1Label(RoutineStart,Symbol,ix)\r
ELSE\r
PutBin1Label(RoutineStop,Symbol,ix);\r
\r
\r
END;\r
\r
\r
PROCEDURE MakeLongCall(Symbol : St_Address);\r
BEGIN\r
writeln('makelongcall');\r
END;\r
\r
PROCEDURE DumpRoutineTabel;\r
VAR Ptr : St_ElemPtr;\r
Symb : Ptr_Symbol_Chain;\r
i : integer;\r
BEGIN\r
END;\r
\r
\r
PROCEDURE MakeJumpToNextSegment;\r
BEGIN\r
END;\r
\r
\r
\r
\r
PROCEDURE MakeInternalLBDR(EntryPoint : St_Address;\r
LineTable : integer;\r
GlobalSize : Word;\r
Appetite : Word;\r
BlName : SpixRange);\r
(* The procedure makes a Internal LBDR *)\r
\r
VAR Ptr : St_ElemPtr;\r
\r
BEGIN\r
megaalligncode;\r
St_Declaration(CLabel,AnonymousName,\r
LastInternalLBDRLabel,Ptr);\r
GenerateLabel(LastInternalLBDRLabel);\r
\r
MakeExternalLBDR(EntryPoint, EntryPoint,\r
LineTable,GlobalSize,Appetite,BlName,2);\r
END; (* MakeInternalLBDR *)\r
\r
\r
PROCEDURE MakeExternalLBDR(SymbolPoint : St_Address;\r
EntryPoint : St_Address;\r
LineTable : integer;\r
GlobalSize : Word;\r
Appetite : Word;\r
BlName : SpixRange;\r
BlKind : integer);\r
(* The procedure makes a external LBDR *)\r
\r
VAR\r
i : integer;\r
ix : Word;\r
Str : Ptr_String;\r
ch : char;\r
\r
BEGIN\r
\r
MegaAllignCode;\r
\r
IF BLkind = 1 THEN Putbin1Label(InternalLBDR,EntryPoint, ix)\r
ELSE\r
BEGIN\r
Putbin1Label(ExternalLBDR,EntryPoint, ix);\r
\r
END;\r
\r
(* Put BlKind *)\r
PutBin1value(DummyElement,BlKind,ix);\r
\r
(* Put BlName *)\r
PutBin1Value(DummyElement,BlName,ix);\r
\r
IF BLkind <> 1 THEN\r
(* Appetite is transfere to paragrahps *)\r
PutBin1Value(DummyElement,(Appetite + 3) Div 4 * 4,ix);\r
\r
\r
END; (* MakeExternalLBDR *)\r
\r
PROCEDURE DumpExternalThunks;\r
VAR Ptr : St_elemPtr;\r
ListOfExt : St_address;\r
Bin1ix : Word;\r
i, j : Integer;\r
Str : Ptr_string;\r
BEGIN\r
\r
For i := 2 to NoOfPi3RoutinesAndSetRoutines DO\r
IF Not Equal_Addr(PreExtCalled[i],St_Stopaddr) THEN\r
BEGIN\r
GenerateLabel(PreExtCalled[i]);\r
Putbin1Value(Longjump, i - 1, Bin1ix);\r
IF CodeOn THEN\r
BEGIN\r
write(tsymfile,MegaInstructionName[mJ],' ');\r
St_NameOfSpix(PreExtName[i],Str);\r
FOR j := 1 TO length(Str^) DO write(tsymfile,Str^[j]);\r
writeln(tsymfile,' ');\r
END;\r
END;\r
\r
ListOfExt := FirstExtDec;\r
WHILE Not Equal_Addr(ListOfExt,St_NillAddr) DO\r
BEGIN\r
St_Retrieve(ListOfExt,Ptr);\r
ListOfExt := Ptr^.Ext_Ref;\r
St_Retrieve(Ptr^.Ext_Owner,Ptr);\r
IF Not Equal_Addr(Ptr^.St_label,St_Stopaddr) THEN\r
BEGIN\r
GenerateLabel(Ptr^.St_label);\r
Putbin1Value(Longjump, Ptr^.St_Curno - 1, Bin1ix);\r
IF CodeOn THEN\r
BEGIN\r
write(tsymfile,MegaInstructionName[mJ],' ');\r
\r
St_NameOfSpix(Ptr^.St_Spix,Str);\r
FOR i := 1 TO length(Str^) DO write(tsymfile,Str^[i]);\r
writeln(tsymfile,' ');\r
END;\r
END;\r
END;\r
\r
ExternalThunksDumped := True;\r
END;\r
\r
(* -------------------------------------------------------------- *)\r
\r
\r
\r
\r
PROCEDURE Makepass4_2; FORWARD;\r
PROCEDURE StopBlock;\r
(* The procedure is called when there is no more code for\r
the block. The procedure makes the <Object Block> for the block\r
That is the secound pass is made *)\r
VAR x: Word;\r
BEGIN (* StopBlock *)\r
END; (* StopBlock *)\r
\r
\r
\r
(* ---------------------------------------------------------- *)\r
\r
\r
\r
\r
\r
PROCEDURE StopCodeGene;\r
(* The procedure is called when where is no more code to be\r
generated. *)\r
\r
VAR step : word;\r
checksum : word;\r
time_used : word;\r
BEGIN (* StopCodeGene *)\r
\r
IF Not ExternalThunksDumped THEN DumpExternalThunks;\r
MegaAllignCode;\r
IF Nextbin1Out = 0 THEN\r
IF Nextbin1in <> 0 THEN Nextbin1out := 1;\r
WHILE Nextbin1In <> Nextbin1Out DO Putbin1Code;\r
IF Nextbin1In <> 0 THEN Putbin1Code;\r
\r
Emptyfilebuffer;\r
\r
reset(TBinFile,1);\r
IF Make_Code THEN reset(TSymFile);\r
\r
JumpRec^.JumpNoElements := TempIndex;\r
\r
MakePass4_2;\r
\r
St_Unlock(Jumprec);\r
\r
(*\r
for step := 1 to 8 do writeln('OffsetSize( ', step ,' ) = ',\r
offsetstatistic[step]);\r
for step := 1 to 8 do\r
writeln('External thunk spare( ', step ,' ) = ',\r
extthunkstatistic[step]);\r
checksum := 0;\r
for step := 1 to nopreextdecl do\r
if preextcalled[step] then checksum := checksum + 1;\r
writeln('No Of Externals = ', noextdecl + checksum - 1);*)\r
END; (* StopCodeGene *)\r
\r
\r
\r
\r
(*-------------------------------------------------------- *)\r
\r
PROCEDURE MegaPfixCode(Inst: Instruction; Value: LongInt;\r
VAR Pfix: Pfix_type; Minlength: Integer);\r
VAR Startdiv : Longint;\r
i : integer;\r
FixStarted : Boolean;\r
\r
\r
Procedure PutCode(Code: Instruction; Param : byte);\r
VAR\r
I_code : RECORD\r
CASE BOOLEAN OF\r
TRUE: (W : WORD);\r
FALSE:(B1,B2: BYTE);\r
END;\r
BEGIN\r
I_Code.W := MegaInstructionValue[Code];\r
Pfix.prefixes := Pfix.Prefixes + 1;\r
Pfix.Code[Pfix.Prefixes] := I_Code.B1 + Param;\r
END;\r
\r
Procedure OutPfix;\r
VAR Val : Byte;\r
BEGIN\r
Val := Value DIV Startdiv;\r
if (Val <> 0) OR (Fixstarted) THEN\r
BEGIN\r
PutCode(mPFIX, Val);\r
Fixstarted := True;\r
END;\r
Value := Value MOD Startdiv;\r
Startdiv := Startdiv DIV 16;\r
END;\r
\r
BEGIN\r
Pfix.Prefixes := 0;\r
Startdiv := 16*16*16*16*16*16*16;\r
FixStarted := False;\r
\r
IF MinLength <> 0 THEN\r
BEGIN\r
MinLength := MinLength - MegaPfixNo(Value);\r
WHILE MinLength > 0 DO\r
BEGIN\r
MinLength := MinLength - 1;\r
PutCode(mPFIX, 0);\r
END;\r
END;\r
\r
IF Value < 0 THEN\r
BEGIN\r
Value := -Value - 1;\r
FOR i := 1 TO 6 DO OutPfix;\r
PutCode(mNFIX, Value DIV Startdiv);\r
PutCode(Inst, 15 - (Value MOD 16));\r
END ELSE\r
BEGIN\r
FOR i := 1 TO 7 DO OutPfix;\r
PutCode(Inst, Value MOD 16);\r
END;\r
\r
END;\r
\r
PROCEDURE GenCode(Inst : Instruction);\r
(* Generate a instruction without parameter *)\r
\r
VAR\r
op : Byte;\r
I_code : RECORD\r
CASE BOOLEAN OF\r
TRUE: (W : WORD);\r
FALSE:(B1,B2: BYTE);\r
END;\r
\r
BEGIN\r
\r
IF Inst < mJ THEN Inst := iInstTomInst[Inst];\r
\r
I_Code.W := MegaInstructionValue[Inst];\r
IF I_code.B2 <> 0 THEN\r
BEGIN\r
Puttbinfile(I_code.B2);\r
op := 2;\r
END ELSE\r
BEGIN\r
op := 1;\r
END;\r
Puttbinfile(I_code.B1);\r
\r
\r
(* Print to TSymFile *)\r
IF CodeOn THEN writeln(TsymFile,op,' ',MegaInstructionName[Inst]);\r
\r
END; (* GenCode *)\r
\r
\r
(* ---------------------------------------------------- *)\r
\r
\r
PROCEDURE CodeConst(Inst : Instruction; Value : longint; spix : spixrange );\r
(* Generate a instruction with a constant parametre *)\r
\r
VAR\r
str : Ptr_String;\r
i : integer;\r
Pfix : Pfix_type;\r
\r
BEGIN\r
\r
MegaPfixCode(Inst, Value, Pfix, 0);\r
FOR i := 1 TO Pfix.Prefixes DO Puttbinfile(Pfix.Code[i]);\r
Case inst of\r
mstl, mldl, mldnl, mstnl:\r
Offsetstatistic[pfix.prefixes] :=\r
Offsetstatistic[pfix.prefixes] + 1;\r
else;\r
end;\r
(* Print to TSymFile *)\r
IF CodeOn THEN\r
BEGIN\r
write(Tsymfile,Pfix.prefixes,' ',MegaInstructionName[Inst]);\r
if spix = anonymousspix then writeln(Tsymfile,' ',Value)\r
else\r
begin\r
St_NameOfSpix(Spix,Str);\r
writeln(Tsymfile,' ',str^,' (',Value,')');\r
end;\r
END;\r
\r
\r
END; (* CodeConst *)\r
\r
PROCEDURE CallExtern(Addr : ST_address);\r
Var Ptr : St_elemptr;\r
Spix : Spixrange;\r
BEGIN\r
St_Get(Addr, Ptr);\r
IF Equal_Addr(Ptr^.St_label, St_Stopaddr) THEN\r
BEGIN\r
spix := Ptr^.St_Spix;\r
St_Declaration(cLabel, AnonymousName, Ptr^.St_Label, Ptr);\r
Ptr^.St_Spix := Spix;\r
END;\r
END;\r
\r
PROCEDURE CallRoutine(Spix : SpixRange; Number : Word;\r
RKind : St_DeclareMode);\r
(* The procedure generates code for an external or an open routine call*)\r
\r
VAR\r
i :integer;\r
Index , Leng : word;\r
Str : Ptr_String;\r
Ptr : St_ElemPtr;\r
Lab : Array[0..MaxLabInOpen] OF\r
RECORD\r
Lab : St_Address;\r
Used : Boolean;\r
END;\r
BEGIN\r
\r
IF Spix = AnonymousSpix THEN Spix := PreExtName[Number];\r
\r
IF RKind = St_Extern THEN\r
BEGIN\r
if (Number <= NoRoutinesWithStatLink) THEN\r
CodeConst(mLDL,StaOff,AnonymousSpix);\r
IF Equal_Addr(PreExtCalled[Number], St_Stopaddr) THEN\r
BEGIN\r
St_Declaration(cLabel,AnonymousName,PreExtCalled[Number],Ptr);\r
Ptr^.St_Spix := Spix;\r
END;\r
Putbin1Label(InternalCall, PreExtCalled[Number], Index);\r
END;\r
\r
IF rkind = St_open THEN\r
(* An open routine call *)\r
BEGIN\r
for i := 0 To MaxLabInOpen DO Lab[i].Used := false;\r
WordByte.Byte1 := CodeOfOpenRoutines[(Number * 2) + 2];\r
WordByte.Byte2 := CodeOfOpenRoutines[(Number * 2) + 3];\r
Index := WordByte.w + 2;\r
\r
(* The index to the open routines length is in Index *)\r
while CodeOfOpenRoutines[Index] <> Openfinish DO\r
BEGIN\r
CASE CodeOfOpenRoutines[Index] OF\r
\r
OpenCode :\r
BEGIN\r
Index := Index + 1;\r
Leng := CodeOfOpenRoutines[Index];\r
IF Codeon THEN\r
BEGIN\r
write(tsymfile,Leng,' ','///// ');\r
St_NameOfSpix(Spix,Str);\r
FOR i := 1 TO length(Str^) DO\r
write(tsymfile,Str^[i]);\r
writeln(tsymfile,' ');\r
END;\r
For i := 1 to leng do\r
begin\r
Index := Index + 1;\r
PutTBinFile(CodeOfOpenRoutines[Index]);\r
end;\r
END;\r
OpenPushProc : CodeConst(mLDL,StaOff,AnonymousSpix);\r
\r
OpenJump :\r
BEGIN\r
Index := Index + 1;\r
IF Lab[CodeOfOpenRoutines[Index]].used = false then\r
St_Declaration(CLabel,AnonymousName,\r
Lab[CodeOfOpenRoutines[Index]].lab,Ptr);\r
CodeJump(mJ,Lab[CodeOfOpenRoutines[Index]].Lab);\r
Lab[CodeOfOpenRoutines[Index]].used := true;\r
END;\r
OpenCJump :\r
BEGIN\r
Index := Index + 1;\r
IF Lab[CodeOfOpenRoutines[Index]].used = false then\r
St_Declaration(CLabel,AnonymousName,\r
Lab[CodeOfOpenRoutines[Index]].lab,Ptr);\r
CodeJump(mCJ,Lab[CodeOfOpenRoutines[Index]].Lab);\r
Lab[CodeOfOpenRoutines[Index]].used := true;\r
END;\r
OpenLabel :\r
BEGIN\r
Index := Index + 1;\r
IF Lab[CodeOfOpenRoutines[Index]].used = false then\r
St_Declaration(CLabel,AnonymousName,\r
Lab[CodeOfOpenRoutines[Index]].lab,Ptr);\r
GenerateLabel(Lab[CodeOfOpenRoutines[Index]].Lab);\r
Lab[CodeOfOpenRoutines[Index]].used := true;\r
END;\r
END;\r
Index := Index + 1;\r
END;\r
\r
\r
END;\r
\r
\r
\r
END;\r
\r
(* ------------------------------------------------------ *)\r
\r
FUNCTION StoreTemp(offset : Word) : Integer;\r
VAR Index : word;\r
BEGIN\r
PutBin1Value(TempSTL,Offset,Index);\r
StoreTemp := Index;\r
END;\r
\r
Procedure StoreTempOK(Index : Integer);\r
BEGIN\r
if InsertBin1ix(Index) then else\r
BEGIN\r
Fatal_error(Pass4,11);\r
END;\r
END;\r
\r
\r
PROCEDURE CodeJump(Inst : Instruction; Lab : St_Address);\r
(* Generate a instruction with a label as operand *)\r
\r
VAR\r
Ptr : st_ElemPtr;\r
Lab1 : St_Address;\r
Bool : Boolean;\r
InstLength : word;\r
\r
BEGIN\r
IF Inst = iJMP THEN Inst := mJ;\r
\r
IF (Inst = mJ) OR (Inst = mCJ) THEN ReleaseStrucDyn;\r
\r
\r
IF (( Inst = mJ ) AND (LastLabelOffset = InternalOffset)) THEN\r
BEGIN\r
(* A superflous is elemined *)\r
(* Make sure lab is not defined as lastlabel *)\r
Bool := true;\r
Lab1 := Lab;\r
WHILE Bool AND Not Equal_Addr(Lab1,St_Nilladdr) DO\r
IF Equal_Addr(Lab1,LastLabel)\r
THEN Bool := false\r
ELSE\r
BEGIN\r
ST_Retrieve(Lab1,Ptr);\r
Lab1 := Ptr^.DefAsLabel;\r
END;\r
\r
IF Bool THEN\r
BEGIN\r
(* The superflous can be elemined *)\r
St_Get(LastLabel,Ptr);\r
Ptr^.MegaLabel_Offset := 0;\r
GenAsLabel(LastLabel,Lab);\r
LastLabelOffset := 0;\r
END\r
ELSE\r
(* the jmp may not be delete *)\r
LastJMPOffset := 0;\r
END;\r
\r
(* If this is a JMP instruction and the last instruction was a JMP\r
too this instruction is not generated *)\r
IF not ((Inst = mJ) AND ( LastJMPOffset = InternalOffset)) THEN\r
BEGIN (* generated the instruction *)\r
\r
CASE Inst OF\r
mJ : Putbin1Label(UnCondJump, Lab, InstLength);\r
mCJ : Putbin1Label(CondJump, Lab, InstLength);\r
mCALL : Putbin1Label(InternalCall, Lab, InstLength);\r
END;\r
if inst = mJ then LastJMPOffset := InternalOffset;\r
END;\r
END; (* CodeJump *)\r
\r
PROCEDURE ReleaseStrucDyn;\r
BEGIN\r
IF (InStrucValue = 0) AND StrucInExp THEN\r
BEGIN\r
CodeConst(mLDL,StrucOffset,Anonymousspix);\r
CodeConst(mLDL,StaOff,Anonymousspix);\r
CodeConst(mLDNL,Proc_StackOccam,Anonymousspix);\r
GenCode(mADD);\r
\r
CodeConst(mLDL,StaOff,Anonymousspix);\r
CodeConst(mSTNL,Proc_StackLimit,Anonymousspix);\r
StrucInExp := false;\r
END;\r
END;\r
(* --------------------------------------------------------- *)\r
\r
\r
\r
PROCEDURE CodeFault(ErrorInt, ErrorExc: WORD);\r
BEGIN\r
codeconst(mLDC,errorInt,AnonymousSpix);\r
CallRoutine(AnonymousSpix, 0, St_Open);\r
END;\r
\r
\r
\r
\r
PROCEDURE CodeFaultAX(ErrorInt, ErrorExc: WORD);\r
BEGIN\r
END;\r
\r
\r
(* --------------------------------------------------------- *)\r
\r
\r
\r
PROCEDURE CodeLoadEffAddr(Lab : St_Address; Offset : Word);\r
(* Generate code to load AReg with the effectiv address of Lab: + offset *)\r
\r
VAR\r
w : word;\r
BEGIN\r
PutBin1Label(AddLabelToDis,Lab,w);\r
PutBin1Value(DummyElement,Offset,w);\r
END; (* CodeLoadEffAddr *)\r
\r
\r
(* --------------------------------------------------------- *)\r
\r
\r
\r
PROCEDURE GenerateLabel(Lab : St_Address);\r
(* Generate the label given by Lab *)\r
\r
VAR Ptr : St_Elemptr;\r
ix : WORD;\r
BEGIN\r
\r
IF ((LastLabelOffset = InternalOffset) AND\r
( NOT Equal_Addr(Lab,LastLabel)))THEN\r
BEGIN\r
(* One label has been generated with this offset *)\r
GenAsLabel(Lab,LastLabel);\r
END\r
ELSE\r
BEGIN\r
(* generate the label *)\r
St_Get(Lab,Ptr);\r
\r
Ptr^.MegaLabel_Offset := InternalOffset;\r
Ptr^.Label_Scope := $FFFF;\r
Putbin1Label(DeclareLabel, Lab, ix);\r
\r
LastLabelOffset := InternalOffset;\r
LastLabel := Lab;\r
END;\r
\r
END; (* GenerateLabel *)\r
\r
\r
(* --------------------------------------------------------- *)\r
\r
\r
PROCEDURE GenAsLabel(Lab1, Lab2 : St_Address);\r
(* The offset of Lab1 is defined by the offset of Lab2\r
Lab1 is never generated *)\r
VAR\r
Ptr : St_ElemPtr;\r
Spix : Spixrange;\r
BEGIN\r
\r
St_Get(Lab1,Ptr);\r
Ptr^.DefAsLabel := Lab2;\r
Spix := Ptr^.St_Spix;\r
IF Spix <> AnonymousSpix THEN\r
Begin\r
St_Get(Lab2, Ptr);\r
Ptr^.St_Spix := Spix;\r
END;\r
\r
END; (* GenAsLabel *)\r
\r
\r
\r
PROCEDURE Init_Pass4_2;\r
(* The procedure initialize Pass4_2 *)\r
\r
VAR\r
i : integer;\r
BEGIN\r
\r
\r
FirstExtDec := St_NillAddr;\r
NoExtDecl := 0;\r
\r
LengthOfAllPreExtName := 0;\r
LengthOfAllExtName := 0;\r
\r
FirstFixUpp := St_NillAddr;\r
LastFixUpp := St_NillAddr;\r
NoFixUpp := 0;\r
\r
\r
CodeOnPass2 := false;\r
\r
filebufferindex := 0;\r
filebufferlast := 0;\r
eoftbinfile := false;\r
\r
FirstBlock := true;\r
(* Used when making linetabel *)\r
\r
FOR i := 0 TO 9 DO\r
HexNumber[ i ] := chr(ord('0') + i);\r
FOR i := 0 TO 5 DO\r
HexNumber[ 10 + i ] := chr(ord('A') + i);\r
\r
END; (* InitPass4_2 *)\r
\r
PROCEDURE InitCodeGenerator;\r
(* The procedure initialize the codegenerator *)\r
\r
VAR\r
i : integer;\r
PreName : string[16];\r
Inst : Instruction;\r
BEGIN\r
\r
StrucInExp := false;\r
\r
Filebufferindex := 0;\r
CodeOn := false;\r
InternalOffset := 0;\r
\r
Nextbin1In := 0;\r
Nextbin1Out:= 0;\r
Elonbin1 := 0;\r
Bin2codeOut:= 0;\r
\r
St_reserveJump(FirstTempPage, JumpRec);\r
ST_Lock(JumpRec);\r
TempIndex := 0;\r
\r
LastLabelOffset := -1;\r
LastJMPOffset := -1;\r
LastLabel := St_NillAddr;\r
\r
Spacing := Call_Options.Spacing;\r
LineTabel := (Spacing <> 0);\r
LastNameEntry := St_NillAddr;\r
LengthOfNameTabel := 0;\r
\r
CurrentSegNo := 1;\r
\r
(* reads the code for the open routines *)\r
i := 0;\r
WHILE NOT EOF(OpenRoutine) DO\r
BEGIN\r
IF i > MaxLengthOfOpenRoutines THEN\r
Fatal_Error(Pass4,9);\r
\r
read(OpenRoutine,CodeOfOpenRoutines[i]);\r
(*\r
CodeOfOpenRoutines[i] := OpenRoutine^;\r
get(OpenRoutine);*)\r
i := i + 1;\r
END;\r
\r
Init_Pass4_2;\r
\r
MegaInstructionName[mJ] := 'J';\r
MegaInstructionName[mLDLP] := 'LDLP';\r
MegaInstructionName[mPFIX] := 'PFIX';\r
MegaInstructionName[mLDNL] := 'LDNL';\r
MegaInstructionName[mLDC] := 'LDC';\r
MegaInstructionName[mLDNLP] := 'LDNLP';\r
MegaInstructionName[mNFIX] := 'NFIX';\r
MegaInstructionName[mLDL] := 'LDL';\r
MegaInstructionName[mADC] := 'ADC';\r
MegaInstructionName[mCALL] := 'CALL';\r
MegaInstructionName[mCJ] := 'CJ';\r
MegaInstructionName[mAJW] := 'AJW';\r
MegaInstructionName[mEQC] := 'EQC';\r
MegaInstructionName[mSTL] := 'STL';\r
MegaInstructionName[mSTNL] := 'STNL';\r
MegaInstructionName[mOPR] := 'OPR';\r
MegaInstructionName[mREV] := 'REV';\r
MegaInstructionName[mLB] := 'LB';\r
MegaInstructionName[mBSUB] := 'BSUB';\r
MegaInstructionName[mDIFF] := 'DIFF';\r
MegaInstructionName[mADD] := 'ADD';\r
MegaInstructionName[mGCALL] := 'GCALL';\r
MegaInstructionName[mPROD] := 'PROD';\r
MegaInstructionName[mGT] := 'GT';\r
MegaInstructionName[mWSUB] := 'WSUB';\r
MegaInstructionName[mSUB] := 'SUB';\r
MegaInstructionName[mSETERR]:= 'SETERR';\r
MegaInstructionName[mCSUB0] := 'CSUB0';\r
MegaInstructionName[mLDPI] := 'LDPI';\r
MegaInstructionName[mXDBLE] := 'XDBLE';\r
MegaInstructionName[mREM] := 'REM';\r
MegaInstructionName[mRET] := 'RET';\r
MegaInstructionName[mDIV] := 'DIV';\r
MegaInstructionName[mNOT] := 'NOT';\r
MegaInstructionName[mXOR] := 'XOR';\r
MegaInstructionName[mXWORD] := 'XWORD';\r
MegaInstructionName[mSB] := 'SB';\r
MegaInstructionName[mSHR] := 'SHR';\r
MegaInstructionName[mSHL] := 'SHL';\r
MegaInstructionName[mAND] := 'AND';\r
MegaInstructionName[mMOVE] := 'MOVE';\r
MegaInstructionName[mOR] := 'OR';\r
MegaInstructionName[mCCNT1] := 'CCNT1';\r
MegaInstructionName[mMUL] := 'MUL';\r
MegaInstructionName[mCWORD] := 'CWORD';\r
\r
MegaInstructionValue[mJ] := $0000;\r
MegaInstructionValue[mLDLP] := $0010;\r
MegaInstructionValue[mPFIX] := $0020;\r
MegaInstructionValue[mLDNL] := $0030;\r
MegaInstructionValue[mLDC] := $0040;\r
MegaInstructionValue[mLDNLP] := $0050;\r
MegaInstructionValue[mNFIX] := $0060;\r
MegaInstructionValue[mLDL] := $0070;\r
MegaInstructionValue[mADC] := $0080;\r
MegaInstructionValue[mCALL] := $0090;\r
MegaInstructionValue[mCJ] := $00a0;\r
MegaInstructionValue[mAJW] := $00b0;\r
MegaInstructionValue[mEQC] := $00c0;\r
MegaInstructionValue[mSTL] := $00d0;\r
MegaInstructionValue[mSTNL] := $00e0;\r
MegaInstructionValue[mOPR] := $00f0;\r
MegaInstructionValue[mREV] := $00f0;\r
MegaInstructionValue[mLB] := $00f1;\r
MegaInstructionValue[mBSUB] := $00f2;\r
MegaInstructionValue[mDIFF] := $00f4;\r
MegaInstructionValue[mADD] := $00f5;\r
MegaInstructionValue[mGCALL] := $00f6;\r
MegaInstructionValue[mPROD] := $00f8;\r
MegaInstructionValue[mGT] := $00f9;\r
MegaInstructionValue[mWSUB] := $00fa;\r
MegaInstructionValue[mSUB] := $00fc;\r
MegaInstructionValue[mSETERR]:= $21f0;\r
MegaInstructionValue[mCSUB0] := $21f3;\r
MegaInstructionValue[mLDPI] := $21fb;\r
MegaInstructionValue[mXDBLE] := $21fd;\r
MegaInstructionValue[mREM] := $21ff;\r
MegaInstructionValue[mRET] := $22f0;\r
MegaInstructionValue[mDIV] := $22fc;\r
MegaInstructionValue[mNOT] := $23f2;\r
MegaInstructionValue[mXOR] := $23f3;\r
MegaInstructionValue[mXWORD] := $23fa;\r
MegaInstructionValue[mSB] := $23fb;\r
MegaInstructionValue[mSHR] := $24f0;\r
MegaInstructionValue[mSHL] := $24f1;\r
MegaInstructionValue[mAND] := $24f6;\r
MegaInstructionValue[mMOVE] := $24fa;\r
MegaInstructionValue[mOR] := $24fb;\r
MegaInstructionValue[mCCNT1] := $24fd;\r
MegaInstructionValue[mMUL] := $25f3;\r
MegaInstructionValue[mCWORD] := $25f6;\r
\r
FOR Inst := iXLAT TO iMOD DO iInstTomInst[Inst] := mPFIX;\r
iInstTomInst[iAND] := mAND;\r
iInstTomInst[iMUL] := mMUL;\r
iInstTomInst[iOR] := mOR;\r
iInstTomInst[iSUB] := mSUB;\r
iInstTomInst[iXOR] := mXOR;\r
iInstTomInst[iADD] := mADD;\r
iInstTomInst[iDIV] := mDIV;\r
iInstTomInst[iMOD] := mREM;\r
\r
NoPreExtDecl := NoOfPi3RoutinesAndSetRoutines;\r
(* Initialize the the list of External Name *)\r
for i := 1 to NoOfPi3RoutinesAndSetRoutines do\r
PreExtCalled[i] := St_Stopaddr;\r
PreExtCalled[1] := St_Nilladdr;\r
\r
PreName := 'RTPLBDR';\r
PreExtName[Rtplbdr] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 7;\r
\r
PreName := 'PUSH_BUF';\r
PreExtName[push_buf] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 8;\r
\r
PreName := 'POP_BUF';\r
PreExtName[pop_buf] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 7;\r
\r
PreName := 'GETBUF';\r
PreExtName[getbuf] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 6;\r
\r
PreName := 'GETBUFDELAY';\r
PreExtName[getbufdelay] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 11;\r
\r
PreName := 'SIGNAL';\r
PreExtName[signal] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 6;\r
\r
PreName := 'WAIT';\r
PreExtName[wait] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 4;\r
\r
PreName := 'WAITDELAY';\r
PreExtName[waitdelay] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
PreName := 'PUTBUF';\r
PreExtName[putbuf] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 6;\r
\r
if computer = Partner then\r
begin\r
Prename := 'FAULT';\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 5;\r
end\r
else\r
begin\r
PreName := 'RESUME';\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 6;\r
end;\r
PreExtName[resume] := St_SpixOfName(PreName);\r
\r
\r
\r
if computer = Partner then\r
begin\r
Prename := 'FAULT';\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 5;\r
end\r
else\r
begin\r
PreName := 'CHAINDEQUEUE';\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 12;\r
end;\r
\r
PreExtName[ChainDeQueue] := St_SpixOfName(PreName);\r
\r
if computer = Partner then\r
begin\r
Prename := 'FAULT';\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 5;\r
end\r
else\r
begin\r
PreName := 'CHAINENQUEUE';\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 12;\r
end;\r
\r
PreExtName[ChainEnQueue] := St_SpixOfName(PreName);\r
\r
\r
\r
\r
\r
PreName := 'ALLOCPOOL';\r
PreExtName[AllocPool] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
PreName := 'INIT_SEMAPHORE';\r
PreExtName[Init_Semaphore] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 14;\r
\r
\r
PreName := 'WAITS';\r
PreExtName[WAITS] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 5;\r
\r
\r
PreName := 'SET_EXCEPTION';\r
PreExtName[Set_Exception ] := St_SpixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 13;\r
\r
\r
PreName := 'INIT_REFERENCE';\r
PreExtName[Init_Reference] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 14;\r
\r
\r
\r
PreName := 'INIT_CHAIN';\r
PreExtName[Init_Chain] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 10;\r
\r
\r
\r
PreName := 'INIT_SHARED';\r
PreExtName[Init_Shared] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 11;\r
\r
\r
\r
PreName := 'INIT_MAILBOX';\r
PreExtName[Init_MailBox] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 12;\r
\r
\r
\r
PreName := 'INIT_PROCESS';\r
PreExtName[Init_Process] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 12;\r
\r
\r
\r
PreName := 'INIT_INTERNAL';\r
PreExtName[Init_Internal] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 13;\r
\r
\r
\r
PreName := 'INIT_EXTERNAL';\r
PreExtName[Init_External] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 13;\r
\r
\r
\r
PreName := 'INIT_PORT';\r
PreExtName[Init_Port] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
PreName := 'SIGNALS';\r
PreExtName[SignalS] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 7;\r
\r
\r
PreName := 'INIT_POOL';\r
PreExtName[Init_Pool] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
PreName := 'ENDPROCESS';\r
PreExtName[EndProcess] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 10;\r
\r
\r
PreName := 'MARK_LOCALREF';\r
PreExtName[Mark_LocalRef] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 13;\r
\r
\r
PreName := 'UNCHAIN_LOCALREF'; (* EF insert *)\r
PreExtName[UnChain_LocalRef] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 16;\r
\r
\r
PreName := 'INIT_LOCALREF';\r
PreExtName[Init_LocalRef] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 13;\r
\r
\r
PreName := 'EXCHANGE';\r
PreExtName[Exchange] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 8;\r
\r
\r
PreName := 'RTP.EXREC';\r
PreExtName[ExcRec] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
\r
PreName := 'RTP.EXPACK';\r
PreExtName[ExcPack] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 10;\r
\r
\r
\r
PreName := 'RTP.EQREC';\r
PreExtName[Eqrec] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
\r
PreName := 'RTP.GTREC';\r
PreExtName[Gtrec] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
PreName := 'RTP.DYNALLOC';\r
PreExtName[DynAlloc] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 12;\r
\r
\r
PreName := 'RTP.STSTR';\r
PreExtName[StStr] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
PreName := 'RTP.EXSTR';\r
PreExtName[ExStr] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
PreName := 'RTP.GTSTR';\r
PreExtName[GtStr] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
PreName := 'RTP.EQSTR';\r
PreExtName[EqStr] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
IF Make_Set THEN\r
BEGIN\r
\r
PreName := 'ASSIGNSET';\r
PreExtName[AssignSet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 9;\r
\r
\r
PreName := 'ADDSET';\r
PreExtName[AddSet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 6;\r
\r
\r
PreName := 'SUBSET';\r
PreExtName[SubSet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 6;\r
\r
\r
PreName := 'MULTSET';\r
PreExtName[MultSet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 7;\r
\r
\r
PreName := 'GESET';\r
PreExtName[GESet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 5;\r
\r
\r
PreName := 'EQSET';\r
PreExtName[EQSet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 5;\r
\r
\r
PreName := 'NESET';\r
PreExtName[NESet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 5;\r
\r
\r
PreName := 'LESET';\r
PreExtName[LESet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 5;\r
\r
\r
PreName := 'INSET';\r
PreExtName[INSet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 5;\r
\r
\r
PreName := 'MAKESET';\r
PreExtName[MakeSet] := St_spixOfName(PreName);\r
LengthOfAllPreExtName := LengthOfAllPreExtName + 7;\r
\r
\r
END;\r
\r
For i := 1 to 8 do\r
begin\r
Offsetstatistic[i] := 0;\r
extthunkstatistic[i] := 0;\r
end;\r
\r
ExternalThunksDumped := False;\r
\r
END; (* InitCodeGenerator *)\r
\r
\r
(* --------------------------------------------------- *)\r
\r
{$I P450}\r
\r
\r
END\r
.\r
\r
\r
\r
\r
(* -------- PRIVATE CODEGENERATOR ----------- CODEGENERATOR --*)\r
\r
\r
\r
\r
\r
«eof»