|
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: 45378 (0xb142)
Types: TextFile
Names: »P435CODE.PAS«
└─⟦037c0ce35⟧ Bits:30010524 DVBS1.SW2114.src.2.6-2 RTP compiler source SW2104+SW2114 Disk#2 30/1-92 HHA
└─⟦this⟧ »RTP\P435CODE.PAS«
└─⟦828f0d3dd⟧ Bits:30010527 DVBS1.SW2114.src.2.6-5 RTP Compiler Source SW2104+SW2114 Disk 2 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\P435CODE.PAS«
└─⟦891417be1⟧ Bits:30010519 DVBS1.SW2114.src.2-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
└─⟦this⟧ »RTP\P435CODE.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\P435CODE.PAS«
{$O+,F+}\r
unit p435code;\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
\r
MaxStack = 16;\r
BonAppetite = 42;\r
ExopCode = 8;\r
ExPoint = 13;\r
ExitAppetite = 0;\r
ExCode = 6;\r
exic = 9;\r
\r
mfirst = 0;\r
mlast = 2;\r
msize = 10;\r
mstart = 12;\r
\r
Proc_StackLimit = 8;\r
Proc_StackOccam = 9;\r
Proc_exception_offset = 2;\r
\r
Prog_Descr_Size = 100;\r
Proc3502_Descr_Size = 80;\r
\r
LengthOfSharedType = 10;\r
LengthOfSemaphore = 8;\r
SharedCounterOffset = 4;\r
LockedOffset = 4;\r
DataSizeOffset = 8;\r
OffsetOffset = 12;\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
RefLockExc = 3;\r
\r
IndexOutOfRangeInt = 5;\r
IndexOutOfRangeExc = 50; (* fault 50 *)\r
(*\r
StackOverFlowInt = 30;\r
StackOverFlowExc = 51; (* fault 51 *)\r
(* Parametre to interrupt when stack overflow *)\r
\r
OutOfRangeInt = 0;\r
OutOfRangeExc = 52; (* fault 52 *)\r
\r
OtherwiseInt = 36;\r
OtherwiseExc = 53; (* 53 *)\r
(*\r
LockInt = 27;\r
LockExc = 54; (* 54 *)\r
(*\r
AccessCheckInt = 26;\r
AccessCheckExc = 55; (* 55 *)\r
(* Parametre to interupt when accesscheck error *)\r
(*\r
PointerNilInt = 25;\r
PointerNilExc = 56; (* 56 *)\r
\r
CheckParamInt = 43;\r
CheckParamExc = 57; (* 57 *)\r
\r
StrucInt = 23;\r
StrucExc = 58; (* 58 *)\r
(*\r
SubRangeInt = 22;\r
SubRangeExc = 59; (* 59 *)\r
\r
WithInt = 39;\r
WithExc = 60; (* 60 *)\r
(*\r
IntOnFault = 31;\r
\r
DynArrayExc = 64;\r
\r
DynRecordExc = 64;\r
*)\r
\r
\r
\r
(* PI3 constant *)\r
call_frame = 20;\r
(* The following gives the number for the predefined external routines *)\r
Exception = 1;\r
shift = 2;\r
Init_Reference = 3;\r
Init_Chain = 4;\r
Init_Shared = 5;\r
Init_Mailbox = 6;\r
Init_Process = 7;\r
Init_Internal = 8;\r
Init_External = 9;\r
Init_Port = 10;\r
Init_Pool = Init_Mailbox;\r
UnChain_LocalRef = 11;\r
Init_LocalRef = Init_Reference;\r
\r
AllocPool = 12;\r
ChainDeQueue = 13;\r
ChainEnQueue = 14;\r
Init_Semaphore = 15;\r
waits = 16;\r
Signals = 17;\r
\r
\r
ExcRec = 18;\r
ExcProcess = 19;\r
ExcPack = 20;\r
Eqrec = 21;\r
StStr = 22;\r
ExStr = 23;\r
GtStr = 24;\r
LtStr = 25;\r
EqStr = 26;\r
ExcRecPack = 27;\r
ExcPackRec = 28;\r
heapref = 29;\r
\r
NoOfPI3Routines = 29;\r
NoOfSetRoutines = 11;\r
NoOfPI3RoutinesAndSetRoutines = NoOfPI3Routines + NoOfSetRoutines;\r
\r
(* External set Routine *)\r
AssignSet = NoOfPi3Routines + 1;\r
PushSet = NoOfPi3Routines + 2;\r
AddSet = NoOfPi3Routines + 3;\r
SubSet = NoOfPi3Routines + 4;\r
MultSet= NoOfPi3Routines + 5;\r
GESet = NoOfPi3Routines + 6;\r
EQSet= NoOfPi3Routines + 7;\r
NESet= NoOfPi3Routines + 8;\r
LESet = NoOfPi3Routines + 9;\r
InSet = NoOfPi3Routines + 10;\r
MakeSet = NoOfPi3Routines + 11;\r
\r
\r
VAR\r
CodeSize : Word ; (* to be removed at sometime *)\r
(* List contains the external routines *)\r
FirstExtDec : St_Address;\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
ExceptionLab : 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
\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[6];\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
InstructionName : ARRAY[rRENPB..rMTRS] OF CodeName;\r
InstructionValue: ARRAY[rRENPB..rMTRS] OF WORD;\r
InstructionStack: ARRAY[rRENPB..rMTRS] OF Byte;\r
iInstTorInst : ARRAY[iXLAT..iMOD] OF Instruction;\r
\r
InStack : Integer;\r
RelativeCondJumpInst : Integer;\r
\r
PreExtName : ARRAY[1..NoOfPI3RoutinesAndSetRoutines] of SpixRange;\r
PreExtCalled : ARRAY[1..NoOfPI3RoutinesAndSetRoutines] of Integer;\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
Offsetstatistic, extthunkstatistic : array[1..8] OF Integer;\r
\r
(* -------------------------------------------- *)\r
\r
\r
PROCEDURE InitCodeGenerator;\r
(* The procedure initialize the codegenerator *)\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
PROCEDURE MakeInternalLBDR( SymbolPoint : St_Address;\r
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
\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
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 GenerateEntryPoint(Lab : St_Address);\r
(* Generate the Entry Point 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; low,high : integer;\r
OtherwiseLab : St_Address);\r
(* The casetabel is generated *)\r
\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
StackAbs = 128;\r
StackNeg = 64;\r
StackPar = 8;\r
\r
MaxLengthOfOpenRoutines = 2000;\r
(* this constant must be changed if new opernroutins is made *)\r
\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
NoOfOutPageJumps : Integer;\r
NewPageCounter : Integer;\r
LineTabSize : Integer;\r
LastLineTabSize : Integer;\r
LastLinenumber : Integer;\r
\r
InternalStartList, InternalEndList,\r
ExternalStartList, ExternalEndList : St_Address;\r
St_LineTable, St_RoutineName : St_Address;\r
\r
InternalOffset, Offset : Longint;\r
\r
LastJMPOffset : Longint; (* internaloffset after generating the last\r
JMP instruction *)\r
\r
LastLabelOffset : Longint;\r
(* InternalOffset of the last generated label *)\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
FirstLine : Integer;\r
\r
TBinFileptr : byte;\r
\r
filebufferlast : Integer;\r
eoftbinfile : boolean;\r
\r
Bin2codeOut: word;\r
\r
FirstTempPage , TempPage : St_Address;\r
TempIndex : Integer;\r
JumpRec : St_elemPtr;\r
LastJumprec : Tempbin1_Record;\r
JumpToNextPage : Integer;\r
InternalLinkEntries : Word;\r
maxcodeblock : word;\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 Putbin1Value(Code : CodeFormat; CodeValue: WORD); FORWARD;\r
\r
Procedure CheckRoomOnPage(Size : Integer);\r
BEGIN\r
IF (InternalOffset DIV CodeSize) <> ((InternalOffset + Size + LineTabSize\r
+ (NoOfOutPageJumps+JumpToNextPage)*4) DIV CodeSize) THEN\r
BEGIN\r
InternalOffset := ((InternalOffset DIV CodeSize)+1)*CodeSize;\r
NoOfOutPageJumps := 0;\r
END;\r
END;\r
\r
Procedure AddInternal(Addition : Integer);\r
BEGIN\r
CheckRoomOnPage(Addition);\r
internaloffset := internaloffset + Addition;\r
END;\r
\r
PROCEDURE ChangeCodeSize(Val : Word);\r
BEGIN\r
CodeSize := Val + ord(odd(val)) + 18; (* room for entrypoint *)\r
CodeSize := CodeSize + ((5+1+1) + CodeSize DIV Spacing)*2;\r
LineTabSize := (5+1+1) + CodeSize DIV Spacing;\r
maxcodeblock := CodeSize -linetabsize - 4 - 18;\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
AddInternal(1);\r
Bin2codeOut := Bin2codeOut + 1;\r
END;\r
\r
PROCEDURE RegisterStackAdjust(Inst : Instruction);\r
VAR InstStack, Wanted, StackAdd : Integer;\r
BEGIN\r
InstStack := InstructionStack[Inst];\r
Wanted := (InstStack SHR 3) AND 7;\r
IF InStack < Wanted THEN\r
BEGIN\r
CodeConst(rRESTA, 2*Wanted, AnonymousSpix);\r
END;\r
StackAdd := InstStack AND 7;\r
IF (InstStack AND StackAbs) <> 0 THEN\r
BEGIN\r
InStack := StackAdd;\r
StackAdd := 0;\r
END;\r
\r
IF (InstStack AND StackNeg) <> 0 THEN StackAdd := -StackAdd;\r
InStack := Instack + StackAdd;\r
IF Instack > 8 THEN\r
BEGIN\r
IF 2*Wanted < 8 THEN CodeConst(rRESTA, 8, Anonymousspix)\r
ELSE CodeConst(rRESTA, 2*Wanted, AnonymousSpix);\r
InStack := Instack + StackAdd;\r
END ELSE\r
IF Instack < 0 THEN\r
BEGIN\r
Instack := 0;\r
END;\r
END;\r
\r
Procedure Putbin1Code(Var Trec : Tempbin1_record);\r
BEGIN\r
NewTempPage;\r
IF Tempindex = Jumprec^.JumpNoElements THEN\r
IF Trec.Bin1Code = AddLabelToDis THEN\r
BEGIN\r
JumpRec^.JumpNoElements := JumpRec^.JumpNoElements - 1;\r
NewTempPage;\r
END;\r
JumpRec^.Jump_data[TempIndex] := Trec;\r
END;\r
\r
Procedure Putbin1Label(Code: CodeFormat; Labeladdr : St_address);\r
VAR Ptr: St_Elemptr;\r
Trec : TempBin1_record;\r
Help : Integer;\r
BEGIN\r
WITH Trec DO\r
BEGIN\r
Bin1Code := Code;\r
Bin1Label := Labeladdr;\r
CASE Code OF\r
\r
UnCondJump:\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\r
BEGIN\r
AddInternal(4);\r
Bin1Param := 4 * 3;\r
END ELSE\r
IF (Ptr^.MegaLabel_Offset DIV CodeSize)\r
<> (InternalOffset DIV CodeSize) THEN\r
BEGIN\r
AddInternal(4);\r
Bin1Param := 4 * 3;\r
END ELSE\r
BEGIN\r
AddInternal(3);\r
Bin1Param := 3 * 3;\r
END;\r
RegisterStackAdjust(rJMPRW);\r
END;\r
\r
CondJump:\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
Bin1Param := RelativeCondJumpInst * 3;\r
AddInternal(3);\r
IF Ptr^.MegaLabel_offset = 0 then\r
BEGIN\r
NoOfOutPageJumps := NoOfOutPageJumps + 1;\r
END ELSE\r
IF (Ptr^.MegaLabel_Offset DIV CodeSize)\r
<> (InternalOffset DIV CodeSize) THEN\r
BEGIN\r
NoOfOutPageJumps := NoOfOutPageJumps + 1;\r
END;\r
RegisterStackAdjust(rJMZEQ);\r
END;\r
\r
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
Bin1Param := RelativeCondJumpInst * 3;\r
AddInternal(4);\r
IF RelativeCondJumpInst = ord(rJMCHT) THEN\r
RegisterStackAdjust(rJMCHT)\r
ELSE\r
RegisterStackAdjust(rPCALS0);\r
END;\r
\r
AddLabelToDis :\r
BEGIN\r
Bin1Param := 4 * 3;\r
AddInternal(4);\r
RegisterStackAdjust(rREARD);\r
END;\r
\r
CaseLabList:\r
BEGIN\r
Help := LabelAddr.Va_High * 3 + 7;\r
IF Help > maxcodeblock THEN ChangeCodeSize(Help);\r
AddInternal(Help);\r
END;\r
\r
ExternalLbdr:\r
AddInternal(16);\r
\r
InternalLbdr:\r
AddInternal(10);\r
\r
RoutineEntryPoint : (* For Program and Routine Entry Points *)\r
BEGIN\r
Bin1Param := 18 * 3;\r
AddInternal(18);\r
END;\r
\r
\r
ELSE Bin1Param := 0;\r
END;\r
END;\r
\r
LastJumpRec.Bin2Code := Bin2codeOut;\r
IF Bin2codeOut > maxcodeblock THEN ChangeCodeSize(Bin2codeOut);\r
Bin2codeOut := 0;\r
Putbin1Code(LastJumpRec);\r
LastJumpRec := Trec;\r
\r
END;\r
\r
Procedure Putbin1Value(Code : CodeFormat; CodeValue: WORD);\r
VAR Labeladdr : St_address;\r
BEGIN\r
Labeladdr.Va_low := 0;\r
Labeladdr.Va_high := CodeValue;\r
Putbin1Label(Code, Labeladdr);\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 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
JumpToNextPage := 0;\r
LastJumpRec.Bin1Code := DeclareLabelConst;\r
While More Do\r
BEGIN\r
St_Retrieve(ConstAddr,Ptr);\r
Length := Ptr^.St_Size;\r
IF Length > maxcodeblock THEN ChangeCodeSize(Length);\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; Low,High : Integer;\r
OtherwiseLab : St_Address);\r
(* The casetabel is generated *)\r
VAR nolabels : integer;\r
BEGIN\r
IF high < low then nolabels := 0 else nolabels := high - low + 1;\r
LastJumpRec.Bin1Param := (nolabels + 1) * 3;\r
PutBin1Value(CaseLabList,nolabels);\r
PutBin1Value(DummyElement,low);\r
PutBin1Value(DummyElement,high);\r
PutBin1Label(DummyElement,CaseTab);\r
PutBin1Label(DummyElement,OtherwiseLab);\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) and not incontext THEN\r
BEGIN\r
Putbin1Value(LineNo, Line);\r
END;\r
END;\r
\r
\r
(*------------------------------------------------------------------- *)\r
\r
\r
\r
\r
PROCEDURE SetCodeTo(Bool : Boolean);\r
VAR xx: WORD;\r
BEGIN\r
codeon := bool;\r
IF bool then xx:= SourceNumber\r
else xx := 255;\r
Putbin1Value(Setcode, xx);\r
END;\r
\r
\r
Procedure ContextStop;\r
(* The procedure is called when leaving context. Only used when\r
making linetabel *)\r
BEGIN\r
PutBin1Value(ContextEnd,0);\r
if internaloffset >= codesize then changecodesize(internaloffset);\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
BEGIN\r
IF start THEN\r
PutBin1Label(RoutineStart,Symbol)\r
ELSE\r
PutBin1Label(RoutineStop,Symbol);\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(SymbolPoint : St_Address;\r
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
St_Declaration(CLabel,AnonymousName,\r
LastInternalLBDRLabel,Ptr);\r
GenerateLabel(LastInternalLBDRLabel);\r
\r
Putbin1Label(InternalLBDR,SymbolPoint);\r
\r
\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
Str : Ptr_String;\r
ch : char;\r
\r
BEGIN\r
\r
Putbin1Label(ExternalLBDR,SymbolPoint);\r
\r
END; (* MakeExternalLBDR *)\r
\r
\r
PROCEDURE Makepass4_2; FORWARD;\r
PROCEDURE Init_pass4_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
i: integer;\r
BEGIN (* StopBlock *)\r
\r
Putbin1Value(AllignCode, NoOfOutPageJumps);\r
\r
Emptyfilebuffer;\r
\r
reset(TBinFile,1);\r
IF Make_Code THEN reset(TSymFile);\r
\r
JumpRec^.JumpNoElements := TempIndex;\r
\r
InternalStartList := St_nilladdr;\r
InternalEndList := St_nilladdr;\r
ExternalStartList := St_nilladdr;\r
ExternalEndList := St_nilladdr;\r
St_LineTable:= IntegerType;\r
St_RoutineName := BooleanType;\r
\r
i := lastlinenumber;\r
LastLineNumber := LineNumber;\r
linenumber := i;\r
\r
MakePass4_2;\r
St_Unlock(Jumprec);\r
\r
NoOfOutPageJumps := 0;\r
\r
StrucInExp := false;\r
\r
FirstExtDec := St_NillAddr;\r
NoExtDecl := 0;\r
Filebufferindex := 0;\r
CodeOn := false;\r
InternalOffset := 0;\r
\r
Bin2codeOut:= 0;\r
LastJumpRec.Bin1Code := DummyElement;\r
JumpToNextPage := 1;\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
ChangeCodeSize(pagesize3502); (* To be removed at sometime *)\r
IF CodeSize < Spacing THEN ChangeCodeSize(Spacing);\r
\r
NoPreExtDecl := NoOfPi3RoutinesAndSetRoutines;\r
(* Initialize the the list of External Name *)\r
for i := 1 to NoOfPi3RoutinesAndSetRoutines do\r
PreExtCalled[i] := 0;\r
\r
CurrentSegNo := 1;\r
\r
Init_Pass4_2;\r
\r
rewrite(TBinFile,1);\r
IF Make_Code THEN rewrite(TSymFile);\r
END; (* StopBlock *)\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
Put_byte(0); Put_byte(0); (* End Of File *)\r
\r
END; (* StopCodeGene *)\r
\r
PROCEDURE GenCode(Inst : Instruction);\r
(* Generate a instruction without parameter *)\r
\r
BEGIN\r
IF Inst < rRENPB THEN Inst := iInstTorInst[Inst];\r
\r
RegisterStackAdjust(Inst);\r
Puttbinfile(InstructionValue[Inst]);\r
\r
(* Print to TSymFile *)\r
IF CodeOn THEN writeln(TsymFile,1,' ',InstructionName[Inst]);\r
END; (* GenCode *)\r
\r
PROCEDURE CodeConst(Inst:Instruction; Value:LongInt; spix:spixrange );\r
(* Generate a instruction with a constant parametre *)\r
VAR\r
str : Ptr_String;\r
InstSpecial : Byte;\r
Opcodes : Byte;\r
InstCode, i, IValue : Integer;\r
InstSave : ARRAY[1..5] OF Byte;\r
\r
PROCEDURE PutByte(B : Byte);\r
BEGIN\r
Opcodes := Opcodes + 1;\r
InstSave[Opcodes] := B;\r
END;\r
\r
PROCEDURE PutInteger(Valeur : Integer);\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 := Valeur;\r
PutByte(I_code.B2);\r
PutByte(I_code.B1);\r
END;\r
\r
BEGIN\r
InstCode := InstructionValue[Inst];\r
InstSpecial := InstCode SHR 8;\r
InstCode := InstCode AND 255;\r
Opcodes := 0;\r
Ivalue := Value;\r
\r
IF Inst = rRESTA THEN InStack := Value DIV 2 ELSE\r
RegisterStackAdjust(Inst);\r
\r
IF InstSpecial = 0 THEN\r
BEGIN\r
PutByte(Instcode);\r
PutInteger(IValue);\r
END ELSE\r
BEGIN\r
CASE InstSpecial OF\r
1: (* RECHW *)\r
IF (IValue < 0) OR (IValue > 255) THEN\r
BEGIN\r
PutByte(Instcode);\r
PutInteger(IValue);\r
END ELSE\r
IF IValue = 0 THEN PutByte($88) ELSE\r
BEGIN\r
IF IValue > 15 THEN PutByte($c8);\r
PutByte(IValue);\r
END;\r
2: (* RECHD *)\r
BEGIN\r
PutByte(InstCode);\r
PutInteger(Value SHR 16);\r
PutInteger(Value AND $ffff);\r
END;\r
3, 4, 11, 12, 13, 14, 19, 20, 21, 22:\r
(* REALD, REAGD, REVGB, REVGW, REVGA, REVGD,\r
STVLB, STVLW, STVLA, STVLD *)\r
IF (IValue < 0) OR (IValue > 255) THEN\r
BEGIN\r
PutByte(Instcode);\r
PutInteger(IValue);\r
END ELSE\r
BEGIN\r
CASE InstSpecial OF\r
3: PutByte($cf);\r
4: PutByte($ce);\r
11:PutByte($89);\r
12:Putbyte($a9);\r
13:PutByte($c9);\r
14:PutByte($e9);\r
19:PutByte($8a);\r
20:PutByte($aa);\r
21:PutByte($ca);\r
22:PutByte($ea);\r
END;\r
PutByte(IValue);\r
END;\r
5: (* BYTE PARAMETER: REAID, RESTA *)\r
BEGIN\r
PutByte(Instcode);\r
PutByte(IValue);\r
END;\r
6: (* REASD *)\r
IF IValue = 1 THEN PutByte($30) ELSE\r
BEGIN\r
PutByte(Instcode);\r
PutInteger(IValue);\r
END;\r
7,8,9,10: (* REVLB, REVLW, REVLA, REVLD *)\r
IF (IValue < -255) OR (IValue > 255) THEN\r
BEGIN\r
PutByte(Instcode);\r
PutInteger(IValue);\r
END ELSE\r
BEGIN\r
IF IValue < 0 THEN\r
BEGIN\r
CASE InstSpecial OF\r
7: PutByte($da);\r
8: PutByte($db);\r
9: PutByte($dc);\r
10:PutByte($dd);\r
END;\r
IValue := -IValue;\r
END ELSE\r
BEGIN\r
CASE InstSpecial OF\r
7: PutByte($8b);\r
8: PutByte($ab);\r
9: PutByte($cb);\r
10:PutByte($eb);\r
END;\r
END;\r
PutByte(IValue);\r
END;\r
15, 23:(* REVSB, STVSB *)\r
IF (IValue > 7) OR (IValue < 0) THEN\r
BEGIN\r
PutByte(Instcode);\r
PutInteger(IValue);\r
END ELSE\r
IF InstSpecial = 15 THEN\r
BEGIN\r
CASE IValue OF\r
0: PutByte($f0);\r
1: PutByte($B9);\r
2: PutByte($83);\r
3: PutByte($bb);\r
4: PutByte($85);\r
5: PutByte($bd);\r
6: PutByte($87);\r
7: PutByte($bf);\r
END;\r
END ELSE\r
BEGIN\r
CASE IValue OF\r
0: PutByte($f1);\r
1: PutByte($99);\r
2: PutByte($82);\r
3: PutByte($9b);\r
4: PutByte($84);\r
5: PutByte($9d);\r
6: PutByte($86);\r
7: PutByte($9f);\r
END;\r
END;\r
16, 17, 18, 24, 25 :\r
(* REVSW, REVSA, REVSD, STVSW, STVSA *)\r
CASE IValue OF\r
0: Case InstSpecial OF\r
16: PutByte($f2);\r
17: PutByte($f4);\r
18: PutByte($f6);\r
24: PutByte($f3);\r
25: PutByte($f5);\r
End;\r
2: Case InstSpecial OF\r
16: PutByte($a3);\r
17: PutByte($c3);\r
18: PutByte($e3);\r
24: PutByte($a2);\r
25: PutByte($c2);\r
End;\r
4: Case InstSpecial OF\r
16: PutByte($a5);\r
17: PutByte($c5);\r
18: PutByte($e5);\r
24: PutByte($a4);\r
25: PutByte($c4);\r
End;\r
6: Case InstSpecial OF\r
16: PutByte($a7);\r
17: PutByte($c7);\r
18: PutByte($e7);\r
24: PutByte($a6);\r
25: PutByte($c6);\r
End;\r
ELSE\r
BEGIN\r
PutByte(Instcode);\r
PutInteger(IValue);\r
END;\r
END;\r
26, 27: (* INDH0, INDH1 *)\r
CASE Value AND $ffff OF\r
1: BEGIN\r
IF InstSpecial = 26 THEN PutByte($8d) ELSE PutByte($cd);\r
PutInteger(Value SHR 16);\r
END;\r
2: BEGIN\r
IF InstSpecial = 26 THEN PutByte($ad) ELSE PutByte($ed);\r
PutInteger(Value SHR 16);\r
END;\r
ELSE\r
BEGIN\r
PutByte(InstCode);\r
PutInteger(Value SHR 16);\r
PutInteger(Value AND $ffff);\r
END;\r
END;\r
28: (* PCALS *)\r
BEGIN\r
PutByte(InstCode);\r
PutByte(0);\r
PutInteger(IValue);\r
END;\r
END;\r
END;\r
\r
CheckRoomOnPage(Opcodes);\r
FOR i:=1 TO Opcodes DO Puttbinfile(InstSave[i]);\r
\r
(* Print to TSymFile *)\r
IF CodeOn THEN\r
BEGIN\r
write(Tsymfile, Opcodes, ' ', InstructionName[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
END; (* CodeConst *)\r
\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
Lable : St_Address;\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
Lable.Va_high := Spix;\r
Lable.Va_low := Number;\r
Putbin1Label(ExternalCall, Lable);\r
CodeConst(rPCALS0, 0, Spix);\r
IF Number <= NoPreextDecl THEN\r
BEGIN\r
PreextCalled[Number] := PreextCalled[Number]+1;\r
END ELSE\r
BEGIN\r
Lable := FirstExtDec;\r
WHILE Not Equal_Addr(Lable,St_NillAddr) DO\r
BEGIN\r
St_Retrieve(Lable,Ptr);\r
St_Retrieve(Ptr^.Ext_Owner,Ptr);\r
IF Ptr^.St_CurNo = Number THEN\r
BEGIN\r
St_Get(Lable, Ptr);\r
Ptr^.Fixup_no := Ptr^.Fixup_no + 1;\r
Lable := St_Nilladdr;\r
END ELSE\r
BEGIN\r
St_Retrieve(Lable, Ptr);\r
Lable := Ptr^.Ext_Ref;\r
END;\r
END;\r
END;\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(rJMPRW,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
\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
InstType : Instruction;\r
BEGIN\r
InstType := Inst;\r
IF Inst = iJMP THEN Insttype := rJMPRW ELSE\r
IF (Inst >= rJMZEQ) AND (Inst <= rJMZGE) THEN Insttype := rJMZEQ;\r
\r
IF (Insttype = rJMPRW) OR (Insttype = rJMZEQ) THEN ReleaseStrucdyn;\r
\r
IF ((Insttype=rJMPRW) 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 ((Insttype=rJMPRW) AND ( LastJMPOffset = InternalOffset)) THEN\r
BEGIN (* generate the instruction *)\r
\r
RelativeCondJumpInst := Ord(Inst);\r
CASE Insttype OF\r
rJMPRW : Putbin1Label(UnCondJump, Lab);\r
rJMZEQ : Putbin1Label(CondJump, Lab);\r
ELSE Putbin1Label(InternalCall, Lab);\r
END;\r
if insttype = rJMPRW then LastJMPOffset := InternalOffset;\r
END;\r
END; (* CodeJump *)\r
\r
PROCEDURE ReleaseStrucDyn;\r
BEGIN\r
IF (InStrucValue = 0) AND StrucInExp THEN\r
BEGIN\r
StrucInExp := false;\r
END;\r
END;\r
(* --------------------------------------------------------- *)\r
\r
\r
\r
PROCEDURE CodeFault(ErrorInt, ErrorExc: WORD);\r
BEGIN\r
codeconst(rRECHW,errorInt,AnonymousSpix);\r
GenCode(rMTRS);\r
END;\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
BEGIN\r
PutBin1Label(AddLabelToDis,Lab);\r
PutBin1Value(DummyElement,Offset);\r
END; (* CodeLoadEffAddr *)\r
\r
PROCEDURE GenerateEntryPoint(Lab : St_Address);\r
(* Generate the Entry Point given by Lab *)\r
BEGIN\r
Putbin1Label(RoutineEntryPoint, Lab);\r
GenerateLabel(Lab);\r
END;\r
\r
PROCEDURE GenerateLabel(Lab : St_Address);\r
(* Generate the label given by Lab *)\r
\r
VAR Ptr : St_Elemptr;\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);\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
LengthOfAllPreExtName := 0;\r
LengthOfAllExtName := 0;\r
\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
{$I P435INIT}\r
{$I P435}\r
\r
END.\r
\r
\r
\r
\r
\r
«eof»