|
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: 51808 (0xca60)
Types: TextFile
Names: »P435.PAS«
└─⟦02956c927⟧ Bits:30010510 DVBS1.SW2114.src.2.14-1 SW2114 REAL #1/4 TIME PASCAL SOURCE REL 2.14
└─⟦this⟧ »RTP\P435.PAS«
└─⟦4f587ad96⟧ Bits:30010518 DVBS1.SW2114.src.2.7-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
└─⟦this⟧ »RTP\P435.PAS«
└─⟦a2a9e188c⟧ Bits:30010526 DVBS1.SW2114.src.2.6-4 RTP Compiler Source SW2104+SW2114 Disk 1 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\P435.PAS«
└─⟦b607d6035⟧ Bits:30010532 RTP compiler Source 1 2.14 26/9(?)-92 DVBS1.SW2114.src.2.14-8
└─⟦this⟧ »P435.PAS«
└─⟦fd2665794⟧ Bits:30010523 DVBS1.SW2114.src.2.6-1 RTP compiler source SW2104+SW2114 Disk#1 30/1-92 HHA
└─⟦this⟧ »RTP\P435.PAS«
PROCEDURE GetTBinFile;\r
BEGIN\r
if filebufferindex = filebufferlast then\r
BEGIN\r
filebufferindex := 0;\r
if eof(Tbinfile) then\r
begin\r
filebufferlast := 0;\r
eoftbinfile := true;\r
end\r
else\r
begin\r
blockread(TBinFile,Filebufferptr^,lengthoffilebuffer,filebufferlast);\r
if filebufferlast = 0 THEN\r
eoftbinfile := true\r
else\r
eoftbinfile := false;\r
end\r
END;\r
\r
if not eoftbinfile then\r
begin\r
filebufferindex := filebufferindex + 1;\r
tbinfileptr := filebufferptr^[filebufferindex];\r
end;\r
END;\r
\r
Procedure PutInteger( Value : 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 := Value;\r
Put_Byte(I_code.b2);\r
Put_Byte(I_code.B1);\r
END;\r
\r
Procedure PutAddr(Ptr : ST_ElemPtr);\r
BEGIN\r
PutInteger((Ptr^.MegaLabel_Offset DIV CodeSize) + 1);\r
PutInteger(Ptr^.MegaLabel_Offset MOD CodeSize );\r
END;\r
\r
\r
Procedure PutParamKind(code : Codes;TypeRef : St_Address);\r
VAR Size : Integer;\r
Typ : Integer;\r
BEGIN\r
ExtParamKind(Code,TypeRef,Typ,Size);\r
PutInteger(typ);\r
PutInteger(Size);\r
END;\r
\r
Procedure ExtPutParameters(Lab : St_Address);\r
VAR Ptr : St_ElemPtr;\r
help : Integer;\r
typeAddr,Addr : St_Address;\r
BEGIN\r
help := ExtNoOfParams(Lab);\r
PutInteger(Help);\r
St_Retrieve(Lab,Ptr);\r
Addr := Ptr^.ListRef;\r
IF Ptr^.St_Kind = CFunction THEN\r
BEGIN\r
PutParamKind(CFunction,Ptr^.TypeRef);\r
END;\r
WHILE Not Equal_Addr(Addr,St_StopAddr) DO\r
BEGIN\r
st_Retrieve(Addr,ptr);\r
Addr := Ptr^.ListRef;\r
TypeAddr := Ptr^.TypeRef;\r
PutParamKind(Ptr^.St_Kind,TypeAddr);\r
st_retrieve(TypeAddr,ptr);\r
IF Ptr^.Type_Mode = Open_fam THEN\r
PutParamKind(cInspectParam,Ptr^.st_Family_ref);\r
END;\r
END;\r
\r
(* The following procedure writes on file CodeList *)\r
\r
PROCEDURE WriteHexByte( x : integer );\r
(* The procedure writes a hex byte to codefile *)\r
\r
BEGIN\r
write(CodeList,HexNumber[x DIV Max4Bit MOD Max4Bit]);\r
write(CodeList,HexNumber[x MOD Max4Bit]);\r
\r
CurrentPos := CurrentPos + 2;\r
END; (* WriteHexByte *)\r
\r
\r
(*---------------------------------------------------------*)\r
\r
PROCEDURE WriteHexWord(x : Word);\r
(* The procedure writes a Hex word to CodeList *)\r
\r
VAR\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
\r
\r
BEGIN\r
WordByte.w := x;\r
WriteHexByte(WordByte.Byte2);\r
WriteHexByte(WordByte.Byte1);\r
\r
END; (* WriteHexWord *)\r
\r
\r
(* ----------------------------------------------------------- *)\r
\r
\r
\r
\r
PROCEDURE WriteSpace( x : integer);\r
(* The procedure writes x spaces to CodeList *)\r
\r
VAR\r
i : integer;\r
\r
BEGIN\r
FOR i := 1 TO x DO\r
write(CodeList,' ');\r
CurrentPos := CurrentPos + x;\r
END; (* WriteSpace *)\r
\r
PROCEDURE InternalLinkTable(Place : St_Address; AddOff : Integer);\r
VAR Page, Offz : Word;\r
Ptr : St_ElemPtr;\r
BEGIN\r
InternalLinkEntries := InternalLinkEntries + 1;\r
Page := Offset DIV CodeSize;\r
Offz := Offset - Page*CodeSize;\r
St_New_Fixupp(Page+1, Offz, InternalStartList, InternalEndList);\r
St_Get(InternalEndList, Ptr);\r
Ptr^.Ext_Owner := Place;\r
Ptr^.Ext_spix := AddOff;\r
END;\r
\r
PROCEDURE ExternalLinkTable(routno : integer);\r
VAR Page, Offz : Word;\r
Ptr : St_ElemPtr;\r
BEGIN\r
Page := Offset DIV CodeSize;\r
Offz := Offset - Page*CodeSize;\r
St_New_Fixupp(Page+1, Offz, ExternalStartList, ExternalEndList);\r
St_Get(ExternalEndList, Ptr);\r
Ptr^.Ext_Spix := routno;\r
END;\r
\r
Procedure PutName(Spix : Spixrange; CodeOn : Boolean);\r
VAR Str : Ptr_string;\r
i : Integer;\r
Ch : Byte;\r
BEGIN\r
St_NameOfSpix(Spix,Str);\r
IF CodeOn THEN\r
BEGIN\r
WriteHexWord(Offset);\r
WriteSpace(CodePos - CurrentPos);\r
END;\r
For i := 1 To 12 DO\r
BEGIN\r
IF i > Length(Str^) THEN Ch := 32 ELSE Ch := ord(Str^[i]);\r
IF (Ch >= ord('A')) AND (Ch <= ord('Z'))\r
THEN Ch := Ch - ord('A') + ord('a');\r
Put_byte(Ch);\r
IF CodeOn THEN WriteHexByte(Ch);\r
END;\r
IF CodeOn THEN\r
BEGIN\r
WriteSpace(CommentPos - CurrentPos);\r
Writeln(CodeList, ' ', Str^);\r
CurrentPos := 0;\r
END;\r
END;\r
\r
\r
PROCEDURE WriteLabel( Lab : St_elemptr);\r
(* The procedure writes the label pointed to by lab to CodeList *)\r
\r
VAR\r
i : integer;\r
Str : Ptr_string;\r
BEGIN\r
IF Lab^.St_Spix <> AnonymousSpix THEN\r
BEGIN\r
St_NameOfSpix(Lab^.St_Spix,Str);\r
(*FOR i := 1 TO Str^.Length DO\r
write(CodeList,Str^.Name[i]); *)\r
(* TURBO *)\r
write(CodeList,str^);\r
write(CodeList,':');\r
END\r
ELSE\r
BEGIN\r
write(CodeList,'?',Lab^.MegaLabel_Offset,':');\r
END;\r
\r
END; (* WriteLabel *)\r
\r
PROCEDURE PutAbsAddr(Labbe : St_Address; Str : String);\r
VAR Ptr : St_ElemPtr;\r
BEGIN\r
Offset := Offset - 1;\r
InternalLinkTable(Labbe,0);\r
Offset := Offset + 1;\r
PutInteger(0);\r
Put_byte(0);\r
IF CodeOnPass2 THEN\r
BEGIN\r
WriteHexWord(Offset);\r
WriteSpace(CodePos - CurrentPos);\r
WriteHexByte(0);\r
WriteHexWord(0);\r
WriteSpace(CommentPos - CurrentPos);\r
(* write Label *)\r
St_Retrieve(Labbe, Ptr);\r
WHILE NOT Equal_Addr(Ptr^.DefAsLabel,St_NillAddr)\r
DO St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
Write(CodeList,' ');\r
WriteLabel(Ptr);\r
writeln(CodeList, Str);\r
CurrentPos := 0;\r
END;\r
\r
Offset := Offset + 3;\r
END;\r
\r
PROCEDURE WriteInteger( I: Integer; Comm : String);\r
BEGIN\r
PutInteger(i);\r
IF CodeOnPass2 THEN\r
BEGIN\r
WriteHexWord(Offset);\r
WriteSpace(CodePos - CurrentPos);\r
WriteHexWord(I);\r
WriteSpace(CommentPos - CurrentPos);\r
Writeln(CodeList, Comm);\r
CurrentPos := 0;\r
END;\r
Offset := Offset + 2;\r
END;\r
\r
PROCEDURE WritePointer(Size : Integer;Comm : String);\r
VAR i : Integer;\r
BEGIN\r
FOR i := 1 TO Size DO Put_byte(0);\r
IF CodeOnPass2 THEN\r
BEGIN\r
WriteHexWord(Offset);\r
WriteSpace(CodePos - CurrentPos);\r
FOR i := 1 TO Size DO WriteHexByte(0);\r
WriteSpace(CommentPos - CurrentPos);\r
Writeln(CodeList, Comm);\r
CurrentPos := 0;\r
END;\r
Offset := Offset + Size;\r
END;\r
\r
PROCEDURE ReadRestSymLine;\r
VAR Ch : char;\r
BEGIN\r
WHILE NOT eoln(TSymFile) DO\r
BEGIN\r
read(TSymFile,ch);\r
write(CodeList,ch);\r
END;\r
readln(TSymFile);\r
writeln(CodeList);\r
CurrentPos := 0;\r
END;\r
\r
Procedure RCPutJumpInst(Inst: Instruction; JumpPlace: Longint;\r
InstLength: Integer);\r
VAR i : Integer;\r
BEGIN\r
IF CodeOnPass2 THEN\r
BEGIN\r
WriteHexWord(Offset);\r
WriteSpace(2);\r
WriteSpace(CodePos - CurrentPos);\r
END;\r
\r
i := InstructionValue[Inst] AND 255;\r
Put_byte(i);\r
IF CodeOnPass2 THEN WriteHexByte(i);\r
\r
If InstLength <> 4 THEN\r
BEGIN\r
i := (JumpPlace - (Offset+InstLength)) AND $ffff;\r
Putinteger(i);\r
IF CodeOnPass2 THEN WriteHexWord(i);\r
END ELSE\r
BEGIN\r
i := JumpPlace DIV CodeSize;\r
Put_byte(0(*i*));\r
IF CodeOnPass2 THEN WriteHexByte(i);\r
i := JumpPlace - (JumpPlace DIV CodeSize)*CodeSize;\r
PutInteger(0(*i*));\r
IF CodeOnPass2 THEN WriteHexWord(i);\r
END;\r
IF CodeOnPass2 THEN\r
BEGIN\r
WriteSpace(commentPos - CurrentPos);\r
write(Codelist, ' ', InstructionName[Inst],' ');\r
END;\r
END;\r
\r
PROCEDURE RCPutJump(VAR Jump: Tempbin1_record;Offz:Integer);\r
VAR Inst : Instruction;\r
InstLength, i : Integer;\r
Ptr : St_Elemptr;\r
BEGIN\r
\r
St_Retrieve(Jump.Bin1Label,Ptr);\r
WHILE NOT Equal_Addr(Ptr^.DefAsLabel,St_NillAddr)\r
DO St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
\r
i := Jump.Bin1Param DIV 3;\r
InstLength := 3;\r
CASE Jump.Bin1Code OF\r
UnCondJump :\r
IF (Ptr^.MegaLabel_Offset DIV CodeSize)\r
<>(Offset DIV CodeSize) THEN\r
BEGIN\r
Inst := rJMPHC;\r
InstLength := 4;\r
InternalLinkTable(Jump.Bin1Label,offz);\r
END ELSE Inst := rJMPRW;\r
CondJump: Inst := Instruction(i);\r
InternalCall:\r
BEGIN\r
Inst := Instruction(i);\r
InstLength := 4;\r
InternalLinkTable(Jump.Bin1Label,offz);\r
END;\r
ELSE\r
IF (Ptr^.MegaLabel_Offset DIV CodeSize)\r
<>(Offset DIV CodeSize) THEN\r
BEGIN\r
Inst := rREAAD;\r
InstLength := 4;\r
InternalLinkTable(Jump.Bin1Label,offz);\r
END ELSE\r
BEGIN\r
Inst := rREARD;\r
InstLength := 0;\r
END;\r
END;\r
\r
RCPutJumpInst(Inst, Ptr^.MegaLabel_Offset + offz, InstLength);\r
IF InstLength = 0 THEN InstLength := 3;\r
\r
IF CodeOnPass2 THEN\r
BEGIN\r
WriteLabel(Ptr);\r
IF Offz <> 0 THEN write(Codelist,' + ',Offz);\r
Writeln(Codelist);\r
Offset := Offset +InstLength;\r
CurrentPos := 0;\r
END ELSE\r
BEGIN\r
Offset := Offset + InstLength;\r
END;\r
END;\r
\r
PROCEDURE RCPageJump(Offz, Instoffz:Integer);\r
VAR Inst : Instruction;\r
InstLength, i : Integer;\r
BEGIN\r
IF Instoffz = 0 THEN\r
BEGIN (* Uncondjump *)\r
Inst := rJMPHC;\r
InstLength := 4;\r
InternalLinkTable(St_Nilladdr,0);\r
END ELSE\r
BEGIN\r
Inst := Instruction(Instoffz);\r
InstLength := 3;\r
END;\r
\r
RCPutJumpInst(Inst, Offz, InstLength);\r
\r
IF CodeOnPass2 THEN\r
BEGIN\r
write(CodeList,'?',Offz,':');\r
Writeln(Codelist);\r
Offset := Offset +InstLength;\r
CurrentPos := 0;\r
END ELSE\r
BEGIN\r
Offset := Offset + InstLength;\r
END;\r
END;\r
\r
PROCEDURE RCPutCode(CodeLength: Integer);\r
VAR i, j, InstLength : Integer;\r
ch : Char;\r
BEGIN\r
i := 0;\r
WHILE i < CodeLength DO\r
BEGIN\r
IF CodeOnPass2 THEN\r
BEGIN\r
WriteHexWord(Offset);\r
WriteSpace(2);\r
WriteSpace(CodePos - CurrentPos);\r
Read(Tsymfile, InstLength);\r
FOR j := 1 TO InstLength DO\r
BEGIN\r
GetTBinfile;\r
WriteHexByte(Tbinfileptr);\r
Put_byte(Tbinfileptr);\r
END;\r
WriteSpace(CommentPos - CurrentPos);\r
ReadRestSymLine;\r
i := i + InstLength;\r
Offset := Offset + InstLength;\r
END ELSE\r
BEGIN\r
GetTBinfile;\r
Put_byte(Tbinfileptr);\r
i := i + 1;\r
Offset := Offset + 1;\r
END;\r
END;\r
END;\r
\r
PROCEDURE MakePass4_2;\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 . FileOffset gives the length\r
of the code in the block *)\r
TYPE\r
PtrJumpElement = ^CondjumpElement;\r
CondJumpElement = RECORD\r
NextJumpElement : PtrJumpElement;\r
JumpLabel : St_Address;\r
END;\r
VAR\r
CondJumpHead : PtrJumpElement;\r
Ptr, Ptr1 : St_ElemPtr;\r
i, j , CharValue : integer;\r
Leng, StepW : Word;\r
NoLabels : integer;\r
ch : char;\r
Lab, Lab1, Lab2 : St_Address;\r
Inst : Instruction;\r
Low, High : integer;\r
Off, OtherwiseOffset : Longint;\r
(* Gives the offset of the next byte written to\r
CodeFile *)\r
Str : Ptr_string;\r
LastLBDR : longint;\r
firstlbdr : boolean;\r
CurrentFile1 : Boolean;\r
\r
JumpRec1,Helprec : Tempbin1_record;\r
StartOffset : LongInt;\r
ParamSize : integer;\r
CreateSize : word;\r
dateandtime : DateTime;\r
CONST\r
NameEntryLength = 10;\r
LineTabLength = 16;\r
VAR\r
NameEntry :\r
record\r
case b : boolean of\r
true : ( firstOffset : Longint;\r
CodeLength : Longint;\r
blocktype : byte;\r
length : byte);\r
false : ( a : array[1..NameEntryLength] of byte);\r
end;\r
\r
LineTab :\r
Record\r
case b : boolean of\r
true : ( FirstLine : Longint;\r
FirstOffset : Longint;\r
OffsetSpacing : Longint;\r
LastOffset : Longint );\r
False : ( a : array[1..LineTabLength] of byte)\r
End;\r
\r
\r
LengthOfLineTabel : word ;\r
LineTabelAddr, TempLineTabelAddr : St_Address;\r
LineTabelIndex : Word;\r
LineTabelOffset : Longint;\r
MakingLineTab : Boolean;\r
LastLine, LineRest, LineDiff : Word;\r
\r
NoSegFixUp : Word;\r
FirstSegFixUp, LastSegFixup : St_Address;\r
SegNumber : Byte;\r
CurSpix : SpixRange;\r
UseLabel : Boolean;\r
RoutineOffset : Word;\r
\r
CodeDumpLength : integer;\r
skip : boolean;\r
Entrypoint : Boolean;\r
ActivePI3Routines : Integer;\r
ConvertExtNumber:Array[1..NoOfPi3RoutinesAndSetRoutines] OF Integer;\r
help : longint;\r
allignedLengthOfNameTable : word;\r
\r
PROCEDURE NewCondJump(Lab : St_Address);\r
VAR NewEl : PtrJumpElement;\r
BEGIN\r
New(NewEl);\r
NewEl^.NextJumpElement := CondJumpHead;\r
NewEl^.JumpLabel := Lab;\r
CondJumpHead := NewEl;\r
NoOfOutPageJumps := NoOfOutPageJumps + 1;\r
END;\r
\r
PROCEDURE DisposeCondJump(VAR Lab : St_Address);\r
VAR NewEl : PtrJumpElement;\r
BEGIN\r
NewEl := CondJumpHead;\r
Lab := CondJumpHead^.JumpLabel;\r
CondJumpHead := NewEl^.NextJumpElement;\r
NoOfOutPageJumps := NoOfOutPageJumps - 1;\r
Dispose(NewEl);\r
END;\r
\r
PROCEDURE InsertLineDiff(Force : Boolean);\r
(* This procedure is only used when making linetabel. The procedure\r
inserts the next linediff. in the linetabel *)\r
\r
BEGIN\r
WHILE ((Offset - LineTabelOffset) >= Spacing) OR (Force) DO\r
BEGIN\r
LineDiff := ( LineNumber - LastLine) + LineRest;\r
\r
IF LineDiff > 255 THEN\r
BEGIN\r
LineRest := LineDiff - 255;\r
LineDiff := 255;\r
END\r
ELSE\r
LineRest := 0;\r
LastLine := LineNumber;\r
\r
LineTabelOffset := LineTabelOffset + Spacing;\r
\r
St_Get(TempLineTabelAddr,Ptr);\r
\r
Ptr^.Data_area[LineTabelIndex] := LineDiff;\r
LineTabelIndex := LineTabelIndex + 1;\r
IF LineTabelIndex > Ptr^.St_Size THEN\r
BEGIN\r
TempLineTabelAddr := Ptr^.ListRef;\r
LineTabelIndex := 1;\r
END;\r
Force := False;\r
END;\r
END;\r
\r
PROCEDURE ResetBin1Files;\r
BEGIN\r
St_unlock(JumpRec);\r
ST_get(FirstTempPage, JumpRec);\r
tempIndex := 0;\r
ST_lock(JumpRec);\r
END;\r
\r
PROCEDURE ReadJumpRec(VAR r: Tempbin1_record);\r
BEGIN\r
NextTempPage;\r
r := JumpRec^.Jump_data[TempIndex];\r
END;\r
\r
PROCEDURE WriteJumpRec(VAR r: Tempbin1_record);\r
BEGIN\r
r.Bin1Param := r.Bin1Param + NewPageCounter;\r
NewPageCounter := 0;\r
JumpRec^.Jump_data[TempIndex] := R;\r
END;\r
\r
PROCEDURE AddOffset( Size : Integer);\r
VAR Allign : TempBin1_Record;\r
BEGIN\r
IF (Offset DIV CodeSize) <> (Offset - 1 + Size + LineTabSize\r
+ (NoOfOutPageJumps+JumpToNextPage)*4) DIV CodeSize THEN\r
BEGIN\r
NewPageCounter := NewPageCounter + 2;\r
Offset := ((Offset DIV CodeSize)+1)*CodeSize;\r
NoOfOutPageJumps := 0;\r
END;\r
Offset := Offset + Size;\r
END;\r
\r
PROCEDURE InsertJumpSizes;\r
VAR Stable : Boolean;\r
JumpBack : Boolean;\r
CaseLabel : Boolean;\r
InstLength : Integer;\r
noturns : integer;\r
diff,Diff1 : integer;\r
JumpRelValue : Longint;\r
BEGIN\r
\r
noturns := 2;\r
NewPageCounter := 0;\r
Diff := 0;\r
offset := internaloffset;\r
REPEAT\r
(* writeln('stabel fors off: ',offset,' noturns ',noturns,\r
' lastpagelinetab ',Lastlinetabsize + (noofoutpagejumps * 4));*)\r
Stable := True;\r
Offset := 0;\r
diff := 0;\r
JumpToNextPage := 1;\r
NoOfOutPageJumps := 0;\r
ResetBin1Files;\r
WHILE NOT eofTempPage DO\r
BEGIN\r
ReadJumpRec(JumpRec1);\r
JumpRec1.Bin1Param := (JumpRec1.Bin1Param DIV 3) * 3;\r
\r
CASE JumpRec1.Bin1Code OF\r
\r
Lineno: ;\r
\r
ExternalCall :\r
BEGIN\r
AddOffset(JumpRec1.Bin2Code);\r
END;\r
\r
DeclareLabel,DeclareLabelConst : (* Label *)\r
BEGIN\r
Diff := 0;\r
CaseLabel := JumpRec1.Bin1Param <> 0;\r
IF (Jumprec1.Bin1code = DeclareLabelConst)\r
OR CaseLabel THEN\r
BEGIN\r
IF Not CaseLabel THEN JumpToNextPage := 0;\r
IF Odd(Offset) THEN\r
BEGIN\r
addoffset(1);\r
IF (offset - 1) MOD CodeSize = 0 THEN\r
offset := Offset - 1;\r
Diff := 1;\r
END;\r
END;\r
IF EntryPoint THEN\r
BEGIN\r
EntryPoint := False;\r
AddOffset(18 + JumpRec1.Bin2Code);\r
END ELSE\r
AddOffset(JumpRec1.Bin2Code);\r
St_Get(JumpRec1.Bin1Label, Ptr);\r
IF ((Ptr^.Label_Scope AND 1) = 0) AND (Diff = 1)\r
THEN Stable := False;\r
Diff1 := 0;\r
IF CaseLabel THEN\r
BEGIN\r
Diff1 := JumpRec1.Bin1Param + 4;\r
AddOffset(Diff1);\r
END;\r
Ptr^.MegaLabel_offset := Offset - JumpRec1.Bin2Code - Diff1;\r
IF (Ptr^.Label_scope shr 1) <>\r
(Ptr^.MegaLabel_offset Div CodeSize)\r
THEN Stable := False;\r
Ptr^.Label_Scope := Diff +\r
((Ptr^.MegaLabel_Offset DIV CodeSize) shl 1);\r
END;\r
\r
AddLabelToDis :\r
BEGIN\r
St_Retrieve(JumpRec1.Bin1Label,Ptr);\r
WHILE NOT Equal_Addr(Ptr^.DefAsLabel,St_NillAddr) DO\r
St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
\r
AddOffset(4);\r
Offset := Offset - 4;\r
IF (Ptr^.MegaLabel_Offset DIV CodeSize)\r
<> (Offset DIV CodeSize) THEN\r
BEGIN\r
InstLength := 4;\r
END ELSE\r
BEGIN\r
InstLength := 3;\r
END;\r
\r
(* IF (InstLength > JumpRec1.Bin1Param) OR\r
(( noturns > 0) AND (InstLength <> JumpRec1.Bin1Param))*)\r
IF InstLength <> (jumpRec1.Bin1Param DIV 3) THEN\r
BEGIN\r
(* writeln('addlabtodis instlength ' , instlength,\r
' old ',JumpRec1.bin1param,' off ',offset,\r
' label ', Ptr^.MegaLabel_Offset);*)\r
\r
Stable := False;\r
JumpRec1.Bin1Param := InstLength * 3;\r
END;\r
Offset := Offset + InstLength;\r
END;\r
\r
\r
CondJump :\r
BEGIN\r
St_Retrieve(JumpRec1.Bin1Label,Ptr);\r
WHILE NOT Equal_Addr(Ptr^.DefAsLabel,St_NillAddr) DO\r
St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
IF (Ptr^.MegaLabel_Offset DIV CodeSize)\r
<>(Offset DIV CodeSize) THEN\r
BEGIN\r
AddOffset(7);\r
Offset := Offset - 7;\r
END\r
ELSE\r
BEGIN\r
AddOffset(3);\r
Offset := Offset - 3;\r
END;\r
IF (Ptr^.MegaLabel_Offset DIV CodeSize)\r
<>(Offset DIV CodeSize) THEN\r
BEGIN\r
NoOfOutPageJumps := NoOfOutPageJumps + 1;\r
END;\r
Offset := Offset + 3;\r
END;\r
\r
UnCondJump:\r
BEGIN\r
St_Retrieve(JumpRec1.Bin1Label,Ptr);\r
WHILE NOT Equal_Addr(Ptr^.DefAsLabel,St_NillAddr) DO\r
St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
AddOffset(4);\r
Offset := Offset - 4;\r
IF (Ptr^.MegaLabel_Offset DIV CodeSize)\r
<> (Offset DIV CodeSize) THEN\r
BEGIN\r
InstLength := 4;\r
END ELSE\r
BEGIN\r
InstLength := 3;\r
END;\r
\r
i := JumpRec1.Bin1Param div 3;\r
(* writeln('jump instlength ' , instlength,\r
' old ',i,' off ' ,offset,\r
' label ', Ptr^.MegaLabel_Offset ,\r
' back ', ord(jumpback),\r
' diff ',diff);\r
*)\r
(*IF (InstLength > i) OR\r
(( noturns > 0) AND (InstLength <> JumpRec1.Bin1Param))*)\r
IF InstLength <> i THEN\r
BEGIN\r
Stable := False;\r
JumpRec1.Bin1Param := InstLength * 3;\r
END;\r
Offset := Offset + InstLength;\r
END;\r
\r
InternalCall:\r
BEGIN\r
AddOffset(4);\r
END;\r
\r
ExternalLBDR: (* external LBDR *)\r
BEGIN\r
AddOffset(16);\r
END;\r
\r
InternalLBDR:\r
BEGIN\r
AddOffset(10);;\r
END;\r
\r
RoutineEntryPoint:\r
BEGIN\r
EntryPoint := True;\r
END;\r
\r
\r
ELSE;\r
\r
END; (* end case *)\r
\r
If NewPageCounter <> 0 THEN NewPageCounter := 1;\r
IF (JumpRec1.Bin1Code <> DeclareLabel) AND\r
(JumpRec1.Bin1Code <> DeclareLabelConst) AND\r
(JumpRec1.Bin1code <> ExternalCall) THEN\r
AddOffset(JumpRec1.Bin2Code);\r
\r
WriteJumpRec(JumpRec1);\r
\r
END; (* while *)\r
\r
CurrentFile1 := NOT CurrentFile1;\r
noturns := noturns - 1;\r
Offset := Offset + NoOfOutPageJumps*4;\r
LastLineTabSize := (5+1+1) + (Offset Mod CodeSize) DIV Spacing;\r
Offset := Offset + LastLineTabSize;\r
IF Odd(Offset) THEN\r
BEGIN\r
LastLineTabSize := LastLineTabSize + 1;\r
Offset := Offset + 1;\r
END;\r
NoofOutPageJumps := 0;\r
UNTIL Stable;\r
END;\r
\r
PROCEDURE RCPutAllign(off : integer);\r
Var i : Integer;\r
BEGIN\r
IF CodeOnPass2 THEN\r
IF off > 0 THEN\r
BEGIN\r
WriteHexWord(Offset);\r
WriteSpace(CodePos - CurrentPos);\r
END;\r
For i := 1 TO Off DO\r
BEGIN\r
IF CodeOnPass2 THEN WriteHexByte(0);\r
Put_byte(0);\r
Offset := Offset + 1;\r
END;\r
IF CodeOnPass2 THEN\r
IF Off > 0 THEN\r
BEGIN\r
Writespace(CommentPos - CurrentPos);\r
CurrentPos := 0;\r
Writeln(Codelist,' ALLIGNMENT');\r
END;\r
END;\r
\r
Procedure ChangePage;\r
VAR i : Longint;\r
j : Integer;\r
LastPage, Firstpos : Boolean;\r
Uncond : Tempbin1_record;\r
step : integer;\r
StepLinRec : Integer;\r
LastLinrec : Integer;\r
BEGIN\r
\r
i := ((Offset DIV CodeSize)+1)*CodeSize;\r
IF JumpToNextPage = 0 THEN\r
BEGIN\r
RCPageJump(i, 0);\r
END;\r
IF i > InternalOffset THEN\r
BEGIN\r
LastPage := True;\r
LastLinRec := LastLineTabSize - 5;\r
i := Offset + NoOfOutPageJumps*4 + LastLineTabSize;\r
END ELSE\r
BEGIN\r
LastPage := False;\r
LastLinRec := LineTabSize - 5;\r
RCPutAllign(i - Offset - NoOfOutPageJumps*4 - LineTabSize);\r
END;\r
UnCond.Bin1Code := UnCondJump;\r
WHILE CondJumpHead <> Nil DO\r
BEGIN\r
DisposeCondJump(Uncond.Bin1Label);\r
RcPutJump(Uncond, 0);\r
END;\r
\r
IF MakingLineTab THEN InsertLineDiff(True);\r
\r
(* Generate Linetable *)\r
InternalLinkTable(St_StopAddr,0);\r
PutInteger(0);\r
Put_byte(0);\r
PutInteger(FirstLine);\r
IF CodeOnPass2 THEN\r
BEGIN\r
WriteHexWord(Offset);\r
WriteSpace(LabelPos - CurrentPos);\r
Writeln(Codelist, 'LINETABLE:');\r
CurrentPos := 0;\r
WriteSpace(CodePos - CurrentPos);\r
For j := 1 to 3 DO WriteHexByte(0);\r
WriteHexWord(FirstLine);\r
Writeln(CodeList, ' Next(A), FirstLine(W)');\r
CurrentPos := 0;\r
END;\r
Offset := Offset + 5;\r
FirstPos := True;\r
\r
TempLineTabelAddr := LineTabelAddr;\r
StepLinRec := 0;\r
WHILE Not Equal_Addr(TempLineTabelAddr,St_StopAddr) DO\r
BEGIN\r
St_Retrieve(TempLineTabelAddr,Ptr);\r
IF CodeOnPass2 THEN\r
IF StepLinRec <> LastLinRec THEN\r
BEGIN\r
FirstPos := False;\r
WriteHexWord(Offset);\r
WriteSpace(CodePos - CurrentPos);\r
END;\r
For Step := 1 TO Ptr^.St_Size DO\r
IF LastLinRec <> StepLinRec THEN\r
BEGIN\r
StepLinRec := StepLinRec + 1;\r
Put_Byte(Ptr^.Data_area[Step]);\r
Offset := Offset + 1;\r
IF CodeOnPass2 THEN\r
BEGIN\r
WriteHexByte(Ptr^.Data_area[Step]);\r
IF (step MOD 10 = 0) OR (Step = Ptr^.St_Size)\r
OR (StepLinRec = LastLinRec) THEN\r
BEGIN\r
Writeln(CodeList);\r
CurrentPos := 0;\r
FirstPos := True;\r
IF (Step <> Ptr^.St_Size) AND (SteplinRec <> LastLinRec) THEN\r
BEGIN\r
FirstPos := False;\r
WriteHexWord(Offset);\r
WriteSpace(CodePos - CurrentPos);\r
END;\r
END;\r
END;\r
END;\r
TempLineTabelAddr := Ptr^.ListRef;\r
END;\r
\r
FirstLine := LineNumber;\r
TempLineTabelAddr := LineTabelAddr;\r
LineTabelIndex := 2;\r
\r
LineDiff := LineNumber - LastLine + LineRest;\r
IF LineDiff > 255 THEN LineDiff := 255;\r
Step := 0;\r
WHILE Offset < i DO\r
BEGIN\r
Put_Byte(LineDiff);\r
IF CodeOnPass2 THEN\r
BEGIN\r
Step := (Step + 1) MOD 10;\r
IF Step = 1 THEN\r
BEGIN\r
IF Firstpos THEN ELSE\r
BEGIN\r
Writeln(CodeList);\r
CurrentPos := 0;\r
END;\r
WriteHexWord(Offset);\r
WriteSpace(CodePos - CurrentPos);\r
WriteHexByte(LineDiff);\r
FirstPos := False;\r
END\r
END;\r
Offset := Offset + 1;\r
END;\r
IF CodeOnPass2 THEN\r
BEGIN\r
IF FirstPos THEN ELSE\r
BEGIN\r
Writeln(CodeList);\r
CurrentPos := 0;\r
END;\r
IF LastPage THEN ELSE\r
BEGIN\r
WriteHexWord(Offset);\r
WriteSpace(LabelPos - CurrentPos);\r
Writeln(Codelist, 'PAGE ', (Offset DIV CodeSize)+1);\r
CurrentPos := 0;\r
END;\r
END;\r
\r
LineTabelOffset := Offset;\r
END;\r
\r
PROCEDURE ReadJumpRec2(VAR Jumprec1: Tempbin1_record);\r
BEGIN\r
ReadJumpRec(JumpRec1);\r
CodeDumpLength := CodeDumpLength + JumpRec1.Bin2Code;\r
JumpToNextPage := ord(JumpRec1.Bin1Code = DeclareLabelConst);\r
IF (JumpRec1.Bin1Param Mod 3) = 1 THEN ChangePage;\r
Leng := JumpRec1.Bin1Param Mod 3;\r
\r
JumpRec1.Bin1Param := (JumpRec1.Bin1Param DIV 3) * 3;\r
END;\r
\r
BEGIN (* MakePass4_2 *)\r
\r
LastLBDR := 0;\r
LengthOfLineTabel := 0;\r
InternalLinkEntries := 0;\r
FirstLBDR := true;\r
CurrentFile1 := True;\r
\r
EntryPoint := False;\r
InsertJumpSizes;\r
\r
InternalOffset := Offset;\r
CondJumpHead := Nil;\r
\r
CurrentPos := 0;\r
CodeDumpLength:= 0;\r
MakingLineTab := false;\r
Offset := 0;\r
\r
ResetBin1Files;\r
JumpToNextPage := 0;\r
\r
WHILE NOT eofTempPage DO\r
BEGIN\r
ReadJumpRec2(Jumprec1);\r
\r
CASE JumpRec1.Bin1Code OF\r
\r
LineNo :\r
BEGIN\r
IF MakingLineTab THEN InsertLineDiff(false);\r
LineNumber := JumpRec1.Bin1Label.va_high;\r
IF CodeOnPass2 THEN\r
BEGIN\r
writeln(CodeList,'$L',LineNumber);\r
END;\r
END;\r
\r
\r
DeclareLabel,DeclareLabelConst : (* Label *)\r
BEGIN\r
IF (Odd(Offset)) AND ((JumpRec1.Bin1param <> 0) OR\r
(JumpRec1.Bin1Code = DeclareLabelConst)) THEN\r
BEGIN\r
RcPutAllign(1);\r
END;\r
\r
IF EntryPoint THEN\r
BEGIN\r
EntryPoint := False;\r
St_Retrieve(JumpRec1.Bin1Label, Ptr);\r
PutName(Ptr^.St_Spix, CodeOnPass2);\r
Offset := Offset + 12;\r
InternalLinkTable(St_LineTable,0);\r
WritePointer(3, ' Pointer to LineTable');\r
InternalLinktable(St_RoutineName,0);\r
WritePointer(3, ' Pointer to Routine Name');\r
END;\r
\r
IF CodeOnPass2 THEN\r
BEGIN\r
St_Retrieve(JumpRec1.Bin1Label, Ptr);\r
IF Equal_Addr(Ptr^.DefAsLabel,St_NillAddr) THEN\r
BEGIN (* write the label *)\r
WriteHexWord(Offset);\r
WriteSpace(LabelPos - CurrentPos);\r
WriteLabel(Ptr);\r
Writeln(Codelist);\r
CurrentPos := 0;\r
END;\r
END;\r
\r
END;\r
\r
\r
SetCode:\r
BEGIN\r
CodeOnPass2 := JumpRec1.Bin1Label.Va_high <> 255;\r
IF CodeOnPass2 THEN\r
WriteLn(CodeList,'$S',JumpRec1.Bin1Label.Va_high);\r
END;\r
\r
ContextEnd :\r
IF LineTabel THEN\r
BEGIN\r
(* Start Making linetabel *)\r
St_Reserve(LineTabSize-5,LineTabelAddr,Ptr);\r
\r
LineTabelIndex := 1;\r
(* linenumber gives the line of endinclude *)\r
FirstLine := LineNumber;\r
\r
\r
Ptr^.Data_area[LineTabelIndex] := 0;\r
LineTabelIndex := LineTabelIndex + 1;\r
\r
LineTabelOffset := 0;\r
MakingLineTab := true;\r
LastLine := FirstLine;\r
LineRest := 0;\r
TempLineTabelAddr := LineTabelAddr;\r
END;\r
\r
\r
RoutineStart :\r
BEGIN\r
(* Get Routine node *)\r
St_Get(JumpRec1.Bin1Label,Ptr);\r
IF Ptr^.St_Kind = cType THEN\r
BEGIN\r
Ptr^.MegaT_First_Offset := Offset;\r
Ptr^.t_Name_Entry_List := LastNameEntry;\r
END\r
ELSE\r
BEGIN\r
IF (Ptr^.St_Kind = cProgram) AND\r
(Ptr^.St_Specs = St_Global) THEN\r
StartOffset := Offset;\r
Ptr^.MegaFirst_Offset := Offset;\r
Ptr^.Name_Entry_List := LastNameEntry;\r
END;\r
\r
LastNameEntry := JumpRec1.Bin1Label;\r
(* update lengthofnametabel *)\r
st_NameofSpix(Ptr^.St_Spix,Str);\r
LengthOfNameTabel := LengthOfNameTabel + length(Str^)\r
+ NameEntryLength;\r
END;\r
\r
\r
\r
RoutineStop :\r
BEGIN\r
St_Get(JumpRec1.Bin1Label,Ptr);\r
IF Ptr^.St_Kind = cType THEN\r
BEGIN\r
Ptr^.MegaT_Last_Offset := Offset-1;\r
END\r
ELSE\r
BEGIN\r
IF (Ptr^.St_Kind = cProgram) AND\r
(Ptr^.St_Specs = St_Global) THEN\r
BEGIN\r
Ptr^.St_Size := Offset - StartOffset;\r
Ptr^.Last_offset := (Offset - StartOffset) SHR 16;\r
END;\r
Ptr^.MegaLast_Offset := Offset-1;\r
St_Retrieve(Ptr^.St_Label,Ptr);\r
WHILE Not Equal_Addr(Ptr^.DefAsLabel,St_NillAddr) DO\r
St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
help := ptr^.MegaLabel_Offset;\r
St_Get(JumpRec1.Bin1Label,Ptr);\r
Ptr^.MegaFirst_Offset :=help;\r
END;\r
SizeOfConst := offset;\r
END;\r
\r
AddLabelToDis :\r
BEGIN\r
ReadJumpRec2(Helprec);\r
RCPutJump(JumpRec1, HelpRec.Bin1Label.Va_high);\r
END;\r
\r
UnCondJump, InternalCall:\r
BEGIN\r
RCPutJump(JumpRec1,0);\r
END;\r
\r
CondJump:\r
BEGIN\r
St_Retrieve(JumpRec1.Bin1Label,Ptr);\r
WHILE NOT Equal_Addr(Ptr^.DefAsLabel,St_NillAddr)\r
DO St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
IF (Ptr^.MegaLabel_Offset DIV CodeSize)\r
<>(Offset DIV CodeSize) THEN\r
BEGIN\r
NewCondJump(JumpRec1.Bin1Label);\r
IF (Offset DIV CodeSize)\r
=(InternalOffset Div CodeSize) THEN\r
BEGIN\r
RCPageJump(InternalOffset\r
- NoOfOutPageJumps*4 - LastLineTabSize,\r
JumpRec1.Bin1Param DIV 3);\r
END ELSE\r
BEGIN\r
RCPageJump(((Offset DIV CodeSize)+1)*CodeSize\r
- NoOfOutPageJumps*4 - LineTabSize,\r
JumpRec1.Bin1Param DIV 3);\r
END;\r
END ELSE\r
BEGIN\r
RCPutJump(JumpRec1,0);\r
END;\r
END;\r
\r
ExternalCall:\r
BEGIN\r
ExternalLinkTable(JumpRec1.Bin1Label.Va_low);\r
END;\r
\r
CaseLabList : (* a list of case labels *)\r
BEGIN\r
NoLabels := JumpRec1.Bin1Label.Va_High;\r
ReadJumpRec2(JumpRec1); (* low *)\r
WriteInteger(JumpRec1.Bin1Label.va_High,' Case Low');\r
ReadJumpRec2(JumpRec1); (* high *)\r
WriteInteger(JumpRec1.Bin1Label.va_High, ' Case High');\r
ReadJumpRec2(JumpRec1);\r
Lab := JumpRec1.Bin1Label; (* Casetable *)\r
\r
ReadJumpRec2(JumpRec1);\r
Lab1 := JumpRec1.Bin1Label; (* Otherwise *)\r
\r
PutAbsAddr(Lab1,' Case Otherwise');\r
IF Not Equal_Addr(Lab,St_NillAddr) THEN\r
WHILE NoLabels > 0 DO\r
BEGIN\r
St_Retrieve(Lab,Ptr);\r
Low := Ptr^.Label_Low;\r
High := Ptr^.Label_High;\r
\r
Lab2 := Ptr^.ListRef;\r
\r
FOR i := Low TO High DO\r
BEGIN\r
NoLabels := NoLabels - 1;\r
PutAbsAddr(Lab,'');\r
END;\r
\r
IF NoLabels > 0 THEN\r
BEGIN\r
St_Retrieve(Lab2,Ptr);\r
FOR i := (High + 1) TO (Ptr^.Label_Low - 1) DO\r
BEGIN\r
NoLabels := NoLabels - 1;\r
PutAbsAddr(Lab1,'');\r
END;\r
END;\r
Lab := Lab2;\r
END; (* While *)\r
END;\r
\r
\r
RoutineEntryPoint:\r
BEGIN\r
EntryPoint := True;\r
END;\r
\r
ExternalLBDR: (* external LBDR *)\r
BEGIN\r
NoLabels := ExtNoofParams(JumpRec1.Bin1Label);\r
\r
St_Retrieve(JumpRec1.Bin1Label, Ptr);\r
\r
PutInteger(44 + NoLabels*4);\r
PutInteger(((InternalOffset-1) DIV CodeSize)+1);\r
\r
PutInteger(CodeSize);\r
PutInteger(InternalOffset MOD CodeSize);\r
Case Ptr^.St_Kind OF\r
cprogram: Off := 1;\r
cfunction:Off := 3;\r
Else Off := 2;\r
END;\r
PutInteger(Off);\r
\r
Lab := Ptr^.St_Label;\r
IF off = 1 THEN CreateSize := Ptr^.Prog_CreateSize\r
ELSE CreateSize := 0;\r
ParamSize := Ptr^.St_ParamSize + Proc3502_Descr_Size;\r
St_Retrieve(Lab, Ptr);\r
PutName(Ptr^.St_Spix, False);\r
\r
PutAddr(Ptr); (* EntryPoint *)\r
IF off = 1 THEN\r
BEGIN\r
St_Retrieve(ExceptionLab, Ptr);\r
PutAddr(Ptr); (* Exception Point *)\r
END\r
ELSE\r
BEGIN\r
PutInteger(0);\r
PutInteger(0);\r
END;\r
PutInteger(CreateSize DIV 2); (* Default appetite *)\r
PutInteger(ParamSize); (* Last param offset *)\r
UnPackTime(SourceDate,DateAndTime);\r
with DateAndtime Do\r
BEGIN\r
Stepw := (Year - 1900) shl 9 + ( Month shl 5) +\r
+ day;\r
PutInteger(Stepw);(* Source Date *)\r
stepw := (10 SHL 11) +\r
(hour SHL 6) +\r
min;\r
PutInteger(stepw); (* Source Time *)\r
END;\r
PutInteger((Call_options.version SHL 8) +\r
Call_options.subversion ); (* Version *)\r
PutInteger(5 SHL 13 + releaseno * 256 + versionno);\r
\r
ExtPutParameters(Jumprec1.Bin1Label);\r
with DateAndtime Do\r
BEGIN\r
GetDate(Year,Month,day,stepw);\r
GetTime(Hour,Min,Sec,stepw);\r
Stepw := (Year - 1900) shl 9 +\r
month SHL 5 + day;\r
WriteInteger(Stepw, ' Object Date');\r
stepw := (10 SHL 11) + (hour SHL 6 ) +\r
min;\r
WriteInteger(stepw,' Object Time');\r
END;\r
WriteInteger(CodeSize - LineTabSize, ' Length of Code');\r
WriteInteger(InternalOffset MOD CodeSize - LastLineTabSize,\r
' Length of Last');\r
WriteInteger(LastLineNumber, ' Last Line Number');\r
WriteInteger(Spacing, ' Line Spacing');\r
InternalLinkTable(St_StopAddr,0);\r
WritePointer(4, ' First Linetable');\r
END;\r
\r
InternalLBDR: (* Internal LBDR *)\r
BEGIN\r
St_Retrieve(JumpRec1.Bin1Label, Ptr);\r
\r
Lab := Ptr^.St_External_List;\r
CreateSize := Ptr^.Prog_CreateSize div 2;\r
ParamSize := Ptr^.St_ParamSize + Proc3502_Descr_Size;\r
\r
PutAbsAddr(Ptr^.St_Label,' EntryPoint');\r
PutAbsAddr(Lab,' Exception');\r
\r
\r
WriteInteger(CreateSize div 2,' Default Appetite'); (* Default appetite *)\r
WriteInteger(ParamSize,' Last parameter offset');\r
END;\r
\r
END; (* end case *)\r
\r
IF (Leng) = 2 THEN ChangePage;\r
IF CodeDumpLength <> 0 THEN\r
BEGIN\r
RCPutCode(CodeDumpLength);\r
CodeDumpLength := 0;\r
END;\r
\r
\r
END; (* while *)\r
IF CodeDumpLength <> 0 THEN RCPutCode(CodeDumpLength);\r
JumpToNextPage := 1;\r
ChangePage;\r
\r
St_Get(GlobalBlockSymbol,Ptr);\r
Ptr^.MegaLast_offset := Offset;\r
Ptr^.St_size := Codesize;\r
\r
(* Output the Descriptor segment PART 2 *)\r
NoLabels := 0;\r
Lab := FirstExtDec;\r
WHILE Not Equal_Addr(Lab,St_NillAddr) DO\r
BEGIN\r
St_Retrieve(Lab,Ptr);\r
IF Ptr^.Fixup_no <> 0 THEN NoLabels := NoLabels + 1;\r
Lab := Ptr^.Ext_Ref;\r
END;\r
FOR j := 1 TO NoPreextDecl DO\r
IF PreextCalled[j] <> 0 THEN NoLabels := NoLabels + 1;\r
\r
(* External Link Table *)\r
Putinteger(NoLabels);\r
j := 0;\r
Lab := FirstExtDec;\r
FOR High := 1 TO NoLabels DO\r
BEGIN\r
Low := 0; (* No Of Calls Of External Routine *)\r
(* with number j *)\r
REPEAT\r
j := j + 1;\r
IF j <= NoPreextDecl THEN Low := PreextCalled[j] ELSE\r
BEGIN\r
St_Retrieve(Lab,Ptr);\r
Low := Ptr^.Fixup_no;\r
Lab1 := Lab;\r
Lab := Ptr^.Ext_Ref;\r
END;\r
UNTIL Low > 0;\r
\r
IF j <= NoPreextDecl THEN\r
BEGIN\r
CurSpix := PreExtName[j];\r
PutName(CurSpix, False);\r
\r
CASE j OF\r
Exception :\r
BEGIN\r
PutInteger(1);\r
PutInteger(34);\r
PutInteger(2);\r
END;\r
Shift :\r
BEGIN\r
PutInteger(2);\r
FOR i := 1 TO 2 DO\r
BEGIN\r
PutInteger(34);\r
PutInteger(2);\r
END;\r
END;\r
\r
Init_Reference,\r
Init_Chain,\r
Init_Shared ,\r
Init_Mailbox,\r
Init_Process,\r
Init_Port,\r
Init_Pool,\r
Init_LocalRef,\r
HeapRef :\r
BEGIN\r
PutInteger(1);\r
PutInteger(6);\r
PutInteger(3);\r
END;\r
\r
Init_Semaphore :\r
BEGIN\r
PutInteger(3);\r
PutInteger(9);\r
PutInteger(7);\r
for i := 1 to 2 DO\r
BEGIN\r
PutInteger(34);\r
PutInteger(2);\r
END;\r
END;\r
\r
waits,\r
signals :\r
BEGIN\r
PutInteger(1);\r
PutInteger(25);\r
PutInteger(10);\r
END;\r
Init_Internal,\r
Init_External:\r
BEGIN\r
PutInteger(2);\r
PutInteger(6);\r
PutInteger(3);\r
PutInteger(6);\r
PutInteger(3);\r
END;\r
\r
ExcRec:\r
BEGIN\r
PutInteger(3);\r
FOR I := 1 To 2 DO\r
BEGIN\r
putInteger(6);\r
PutInteger(3);\r
END;\r
putInteger(34);\r
PutInteger(2);\r
END;\r
\r
ExcProcess:\r
BEGIN\r
PutInteger(2);\r
FOR I := 1 To 2 DO\r
BEGIN\r
putInteger(17);\r
PutInteger(6);\r
END;\r
END;\r
\r
Eqrec:\r
BEGIN\r
PutInteger(4);\r
PutInteger(35);\r
PutInteger(1);\r
FOR I := 1 To 2 DO\r
BEGIN\r
putInteger(6);\r
PutInteger(3);\r
END;\r
putInteger(34);\r
PutInteger(2);\r
END;\r
\r
ExcPack :\r
BEGIN\r
PutInteger(4);\r
FOR I := 1 To 2 DO\r
BEGIN\r
putInteger(6);\r
PutInteger(3);\r
putInteger(34);\r
PutInteger(2);\r
END;\r
END;\r
ExcRecPack :\r
BEGIN\r
PutInteger(3);\r
putInteger(6);\r
PutInteger(3);\r
putInteger(6);\r
PutInteger(3);\r
putInteger(34);\r
PutInteger(2);\r
END;\r
\r
ExcPackRec :\r
BEGIN\r
PutInteger(3);\r
putInteger(6);\r
PutInteger(3);\r
putInteger(34);\r
PutInteger(2);\r
putInteger(6);\r
PutInteger(3);\r
END;\r
StStr,\r
ExStr:\r
BEGIN\r
PutInteger(4);\r
FOR I := 1 To 2 DO\r
BEGIN\r
putInteger(6);\r
PutInteger(3);\r
END;\r
FOR I := 1 To 2 DO\r
BEGIN\r
putInteger(34);\r
PutInteger(2);\r
END;\r
END;\r
GtStr,\r
LtStr,\r
EqStr:\r
BEGIN\r
PutInteger(5);\r
PutInteger(35);\r
PutInteger(1);\r
FOR I := 1 To 2 DO\r
BEGIN\r
putInteger(6);\r
PutInteger(3);\r
END;\r
FOR I := 1 To 2 DO\r
BEGIN\r
putInteger(34);\r
PutInteger(2);\r
END;\r
END;\r
ELSE PutInteger(0);\r
END;\r
END ELSE\r
BEGIN\r
St_Retrieve(Lab1, Ptr);\r
Lab2 := Ptr^.Ext_Owner;\r
St_Retrieve(Lab2, Ptr);\r
CurSpix := Ptr^.St_Spix;\r
PutName(CurSpix, False);\r
ExtPutParameters(Lab2);\r
END; (* Description of parameters *)\r
PutInteger(Low); (* No Of Uses *)\r
Lab2 := ExternalStartList;\r
i := 0;\r
REPEAT\r
St_Retrieve(Lab2, Ptr);\r
IF Ptr^.Ext_Spix = j THEN\r
BEGIN\r
PutInteger(Ptr^.Fixup_no);\r
PutInteger(Ptr^.Fixup_Offset + 3);\r
i := i + 1;\r
END;\r
Lab2 := Ptr^.Ext_Ref;\r
UNTIL i >= Low;\r
END;\r
\r
(* Internal Link Table *)\r
low := 0;\r
PutInteger(InternalLinkEntries);\r
Lab := InternalStartList;\r
For Stepw := 1 TO InternalLinkEntries DO\r
BEGIN\r
St_Retrieve(Lab, Ptr);\r
Lab := Ptr^.Ext_ref;\r
PutInteger(Ptr^.Fixup_no);\r
IF Equal_Addr(Ptr^.Ext_Owner, St_NillAddr) THEN\r
BEGIN (* UnConditional Jump to Next Page *)\r
PutInteger(Ptr^.Fixup_Offset + 3);\r
PutInteger(Ptr^.Fixup_no + 1);\r
PutInteger(0);\r
END ELSE\r
IF Equal_Addr(Ptr^.Ext_Owner, St_StopAddr) THEN\r
BEGIN (* Link Of LineTable on the Next Page *)\r
PutInteger(Ptr^.Fixup_Offset + 2);\r
IF (Low = 0) OR ( Low = ((Offset DIV CodeSize) + 1)) THEN\r
PutInteger(Ptr^.Fixup_no)\r
ELSE\r
PutInteger(Ptr^.Fixup_no + 1);\r
IF ( Low >= (Offset DIV CodeSize) ) THEN\r
PutInteger((Offset - LastLineTabSize) MOD CodeSize)\r
ELSE\r
PutInteger(CodeSize - LineTabSize);\r
Low := Low + 1;\r
END ELSE\r
IF Equal_Addr(Ptr^.Ext_Owner, St_RoutineName) THEN\r
BEGIN (* Pointer to RoutineName in LineTable *)\r
PutInteger(Ptr^.Fixup_Offset + 2);\r
PutInteger(Ptr^.Fixup_no);\r
PutInteger(Ptr^.Fixup_Offset - 15);\r
END ELSE\r
IF Equal_Addr(Ptr^.Ext_Owner, St_LineTable) THEN\r
BEGIN (* Pointer to Start of LineTable *)\r
PutInteger(Ptr^.Fixup_Offset + 2);\r
PutInteger(1);\r
PutInteger(0);\r
END ELSE\r
BEGIN\r
PutInteger(Ptr^.Fixup_Offset + 3);\r
j := Ptr^.ext_Spix;\r
St_Retrieve(Ptr^.Ext_Owner, Ptr);\r
WHILE NOT Equal_Addr(Ptr^.DefAsLabel,St_NillAddr)\r
DO St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
i := Ptr^.MegaLabel_Offset DIV CodeSize;\r
PutInteger(i + 1);\r
PutInteger((Ptr^.MegaLabel_Offset - i*CodeSize) + j);\r
END;\r
END;\r
\r
END; (* MakePass4_2 *)\r
«eof»