|
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: 58112 (0xe300)
Types: TextFile
Names: »P4CODE.PAS«
└─⟦02956c927⟧ Bits:30010510 DVBS1.SW2114.src.2.14-1 SW2114 REAL #1/4 TIME PASCAL SOURCE REL 2.14
└─⟦this⟧ »RTP\P4CODE.PAS«
└─⟦4f587ad96⟧ Bits:30010518 DVBS1.SW2114.src.2.7-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
└─⟦this⟧ »RTP\P4CODE.PAS«
└─⟦a2a9e188c⟧ Bits:30010526 DVBS1.SW2114.src.2.6-4 RTP Compiler Source SW2104+SW2114 Disk 1 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\P4CODE.PAS«
└─⟦b607d6035⟧ Bits:30010532 RTP compiler Source 1 2.14 26/9(?)-92 DVBS1.SW2114.src.2.14-8
└─⟦this⟧ »P4CODE.PAS«
└─⟦fd2665794⟧ Bits:30010523 DVBS1.SW2114.src.2.6-1 RTP compiler source SW2104+SW2114 Disk#1 30/1-92 HHA
└─⟦this⟧ »RTP\P4CODE.PAS«
{$O+,F+}\r
unit p4code;\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
\r
LengthOfSharedType = 10;\r
\r
LengthOfSemaphore = 8;\r
\r
SharedCounterOffset = 4;\r
\r
LockedOffset = 2;\r
\r
DataSizeOffset = 4;\r
\r
OffsetOffset = 6;\r
\r
DataPartOffset = 8;\r
\r
TopOffset = 10;\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 = 1; (*3;*)\r
\r
IndexOutOfRangeInt = 5;\r
IndexOutOfRangeExc = 2; (* fault 50 *)\r
\r
StackOverFlowInt = 30;\r
StackOverFlowExc = 3; (* fault 51 *)\r
(* Parametre to interrupt when stack overflow *)\r
\r
OutOfRangeInt = 29;\r
OutOfRangeExc = 4; (* fault 52 *)\r
\r
OtherwiseInt = 28;\r
OtherwiseExc = 5; (* 53 *)\r
\r
LockInt = 27;\r
LockExc = 6; (* 54 *)\r
\r
AccessCheckInt = 26;\r
AccessCheckExc = 7; (* 55 *)\r
(* Parametre to interupt when accesscheck error *)\r
\r
PointerNilInt = 25;\r
PointerNilExc = 8; (* 56 *)\r
\r
CheckParamInt = 24;\r
CheckParamExc = 9; (* 57 *)\r
\r
StrucInt = 23;\r
StrucExc = 10; (* 58 *)\r
\r
SubRangeInt = 22;\r
SubRangeExc = 11; (* 59 *)\r
\r
WithInt = 21;\r
WithExc = 12; (* 60 *)\r
\r
IntOnFault = 31;\r
\r
DynArrayExc = 13; (*64*)\r
\r
DynRecordExc = 13; (* 64 *)\r
\r
\r
\r
\r
(* PI3 constant *)\r
call_frame = 20;\r
(* The following gives the number for the predefined external routines *)\r
Fault = 1;\r
Resume = 2;\r
AllocPool = 3;\r
Init_Semaphore = 4;\r
WaitS = 5;\r
Set_Exception = 6;\r
Init_Reference = 7;\r
Init_Chain = 8;\r
Init_Shared = 9;\r
Init_Mailbox = 10;\r
Init_Process = 11;\r
Init_Internal = 12;\r
Init_External = 13;\r
Init_Port = 14;\r
SignalS = 15;\r
Init_Pool = 16;\r
EndProcess = 17;\r
Mark_LocalRef = 18;\r
UnChain_LocalRef = 19;\r
Init_LocalRef = 20;\r
\r
(* External set Routine *)\r
AssignSet = 21;\r
PushSet = 22;\r
AddSet = 23;\r
SubSet = 24;\r
MultSet= 25;\r
GESet = 26;\r
EQSet= 27;\r
NESet= 28;\r
LESet = 29;\r
InSet = 30;\r
MakeSet = 31;\r
\r
\r
NoOfPI3Routines = 20;\r
NoOfSetRoutines = 11;\r
NoOfPI3RoutinesAndSetRoutines = 31;\r
TYPE\r
\r
\r
\r
\r
\r
\r
\r
JumpRang = iJE..iJCXZ;\r
\r
NegInstTable = ARRAY[JumpRang] OF Instruction;\r
\r
\r
\r
VAR\r
\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
\r
NegInstruction : NegInstTable;\r
(* Tabel contains the negation of the cond jumps *)\r
\r
LastNameEntry : St_Address;\r
\r
LengthOfNameTabel : word;\r
\r
LineTabel : boolean;\r
\r
Spacing : word;\r
\r
CurrentSegNo : Word;\r
\r
\r
(* Declarations which has to do with pass4_2 TURBO *)\r
\r
CONST\r
\r
\r
OpCodeLongJmp = $EA; (* 11101010B;*)\r
\r
OpcodeCallExt = $9A; (*10011010B;*)\r
\r
\r
\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
CodeFormat = (DeclareLabel, ExternalCall, ShortJump, NearUnCondJump,\r
NearCondJump, CaseLabList, AddLabelToDis,\r
InternalLBDR, ExternalLBDR, LineNo, SetCode,\r
RoutineStartStop, ContextEnd,\r
LongCall, LongJump,ExternalJump);\r
\r
CodeName = PACKED ARRAY[1..6] OF char;\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
\r
\r
InstructionName : ARRAY[ iXLAT..iXCHG ] OF CodeName;\r
(* Tabel of names of instructiones *)\r
\r
PreExtName : ARRAY[1..NoOfPI3RoutinesAndSetRoutines] of SpixRange;\r
PreExtCalled : ARRAY[1..NoOfPI3Routines] of boolean;\r
\r
FirstFixUpp, LastFixUpp : St_Address;\r
(* List of FixUpp *)\r
\r
NoFixUpp : Word;\r
(* Number of FixUpp *)\r
\r
\r
\r
\r
(* The following variabels are tabels containing opcode for\r
instructions *)\r
\r
OpcodeShort : ARRAY[ iJE .. iJMP ] OF Byte;\r
(* Tabel of opcodes for short jumps *)\r
\r
OpcodeNear : ARRAY [ iJMP .. iCALL ] OF Byte;\r
(* Tabel of opcodes for near jumps *)\r
\r
ContextEndOffset : Word;\r
\r
\r
VersionNumber : Array[1..4] OF Word;\r
\r
\r
FilePtrToSecSegDef : longint;\r
\r
(* -------------------------------------------- *)\r
\r
\r
PROCEDURE InitCodeGenerator;\r
(* The procedure initialize the codegenerator *)\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
(* The procedure makes a internal LBDR *)\r
\r
\r
\r
PROCEDURE MakeProgramDesc(ProgOffset : Word; ProgState : State;\r
PoolParam : boolean; Lab : St_Address );\r
(* The procedure generate code to make the program describtion at \r
address 'Addr'. This procedure has to be change if the pi3 type\r
programdescribtion is change *)\r
\r
\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 : word );\r
(* Generate a instruction with a constant parametre *)\r
\r
PROCEDURE CodeAddr(Inst : Instruction; InstType : InstrucType;\r
VAR a : Address);\r
(* Generate a instruction with a address as parametre *)\r
\r
PROCEDURE CodeReg(Inst : Instruction; InstType : InstrucType;\r
r : Register );\r
(* Generate a instruction with a register as parametre *)\r
\r
PROCEDURE CodeAddrConst(Inst : Instruction; InstType : InstrucType;\r
VAR a : Address; Value : word );\r
(* Generate a instruction with a address as the first parametre\r
and a constant as the secend parametre *)\r
\r
\r
PROCEDURE CodeAddrReg(Inst : Instruction; InstType : InstrucType;\r
VAR a : Address; r : Register );\r
(* Generate a instruction with an address as first parametre\r
and an register as secend parameter *)\r
\r
PROCEDURE CodeRegAddr(Inst : Instruction; InstType : InstrucType;\r
r : Register; VAR a : Address );\r
(* Generate a instruction with a register as first parametre\r
and an adddress as secend parametre *)\r
\r
PROCEDURE CodeRegConst(Inst : Instruction; InstType : InstrucType;\r
r : Register; Value : word );\r
(* Generate a instruction with a register as the first\r
parametre and a constant as the secend parametre *)\r
\r
PROCEDURE CodeRegReg(Inst : Instruction; InstType : InstrucType;\r
r1, r2 : Register );\r
(* Generate a instruction where both parametres are registers *)\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
\r
PROCEDURE CodeJump(Inst : Instruction; Lab : St_Address);\r
(* Generate a instruction with a label as parameter *)\r
\r
\r
PROCEDURE CodeIndJump(Lab : St_Address; IndexReg : Register);\r
(* Generate a indirect jump at address CS: Lab.Offset [IndexReg] *)\r
\r
PROCEDURE CodeFaultAX( ErrorInt, ErrorExc: WORD);\r
\r
PROCEDURE CodeFault( ErrorInt, ErrorExc: WORD);\r
\r
\r
PROCEDURE CodeLoadEffAddr(Reg : Register; Lab : St_Address; Offset : Word);\r
(* Generate code to load reg 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);\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 sthp34,files,rtp86p4,p4;\r
\r
\r
(* ------------IMPORTS END --------------IMPORTS END --------*)\r
\r
\r
\r
(* --------PRIVATE CODEGENERATOR ------ CODEGENERATOR -----*)\r
\r
Const\r
FirstExc = RefLockExc;\r
LastExc = DynRecordExc;\r
\r
VAR\r
FaultInfo :\r
Array[FirstExc..LastExc] OF\r
Record\r
used : boolean;\r
number : byte;\r
faultThunk : St_address;\r
end;\r
\r
\r
\r
CONST\r
\r
MaxLengthOfOpenRoutines = 2000;\r
(* this constant must be changed if new opernroutins is made *)\r
\r
LengthOfCodeBuffer = 500; (* length of internal buffer *)\r
\r
\r
OpcodeMovImmToReg = $B0; (*10110000B;*)\r
\r
OpcodeMovR_MToSeg = $8E; (*10001110B;*)\r
\r
OpCodeMovSegToR_M = $8C; (*10001100B;*)\r
\r
\r
OpcodePreFix = $26; (* 00100110B;*)\r
\r
OpcodeCSPreFix = $2E; (*00101110B;*)\r
\r
CRegFieldJumpIndirect = $4; (*100B;*)\r
\r
OpcodeJumpIndirect = $FF; (*11111111B;*)\r
\r
\r
\r
\r
\r
VAR\r
\r
CodeBuffer : ARRAY[0..LengthOfCodeBuffer] OF byte;\r
(* the internal buffer *)\r
BufferIndex : Word;\r
(* Index to the codebuffer where to put the\r
next byte *)\r
FirstIndex : Word;\r
(* Index to codebuffer to the first insert byte *)\r
\r
NoBytesInBuffer : word;\r
(* Number of bytes i codebuffer *)\r
InternalOffset : Word;\r
(* Offset to next byte to be insert in codebuffer *)\r
FileOffset : Word;\r
(* Offset to next byte to be written to TBinFile *)\r
\r
LastInternalLBDROffset : Word;\r
(* The offset of the last internalLBDR written to TBinFile *)\r
\r
\r
\r
LastJMPOffset : Word; (* internaloffset after generating the last\r
JMP instruction *)\r
\r
LastLabelOffset : Word;\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
OpcodeNoOpr : ARRAY[ iXLAT..iRETIS ] OF Byte;\r
(* Tabel of opcodes for instruction with no operands *)\r
\r
OpcodeCOpr : ARRAY[ iInt..iRETIS ] OF Byte;\r
(* Tabel of opcodes for instructions with a constant\r
operand *)\r
\r
OpcodeSROpr : ARRAY[ iPUSH .. iPOP ] OF Byte;\r
(* Tabel of opcodes for instructions with a Seg Register *)\r
\r
OpcodeRegOpr : ARRAY[ iPUSH .. iDEC ] OF Byte;\r
(* Tabel of opcodes for instructions with a register \r
packed into the opcode *)\r
\r
OpcodeR_M : ARRAY[ iPUSH .. iXCHG ] OF Byte;\r
(* Tabel of opcodes for instructions with a register or a\r
address as operand. Operand of type R_M *)\r
\r
OpcodeCRegField : ARRAY[ iPUSH .. iMOV ] OF 0..7;\r
(* Tabel of the value of the reg field for instruction\r
of type R_M not useing the RegField ( only one operand\r
or a constant operand *) \r
\r
OpcodeConstandAcc : ARRAY[ iADD..iXOR ] OF Byte;\r
(* Tabel of opcode for instruction with a accumulate\r
and a const as operands *)\r
\r
OpcodeR_MandConst : ARRAY[ iADD .. iMOV ] OF Byte;\r
(* Tabel of opcode for instruction with a R_M operand\r
and a const *)\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
\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
END;\r
\r
\r
Procedure InitFaultInfo;\r
VAR i : integer;\r
BEGIN\r
FOR i := firstExc TO LastExc DO FaultInfo[i].used := false;\r
FaultInfo[RefLockExc].Number := 3;\r
FaultInfo[IndexOutOfRangeExc].Number := 50;\r
FaultInfo[StackOverFlowExc].Number := 51;\r
FaultInfo[OutOfRangeExc].Number := 52;\r
FaultInfo[OtherwiseExc].Number := 53;\r
FaultInfo[LockExc].Number := 54;\r
FaultInfo[AccessCheckExc].Number := 55;\r
FaultInfo[PointerNilExc].Number :=56;\r
FaultInfo[CheckParamExc].Number := 57;\r
FaultInfo[StrucExc].Number :=58;\r
FaultInfo[SubRangeExc].Number := 59;\r
FaultInfo[WithExc].Number := 60;\r
FaultInfo[DynArrayExc].Number :=64;\r
FaultInfo[DynRecordExc].Number := 64;\r
END;\r
\r
Procedure DumpFaultThunk;\r
VAR i : integer;\r
first : boolean;\r
BEGIN\r
first := true;\r
FOR i := FirstExc TO LastExc DO\r
WITH FaultInfo[i] DO\r
IF used THEN\r
BEGIN\r
IF not first THEN GenCode(iNOOP2);\r
First := false;\r
GenerateLabel(FaultThunk);\r
CodeRegConst(iMOV,b,AL,Number);\r
END;\r
IF Not First THEN\r
BEGIN\r
CodeRegReg(iXOR,b,AH,AH);\r
CodeReg(iPOP,w,DX);\r
CodeReg(iPUSH,w,AX);\r
CodeReg(iPUSH,w,CS);\r
CodeReg(IPUSH,w,DX);\r
CallRoutine(Anonymousspix,Fault,St_Jump);\r
END;\r
END;\r
\r
PROCEDURE PackField(VAR x : Byte; RightPos: integer;\r
FieldValue : integer );\r
(* The procedure packed the FieldValue into x. The lowest bit\r
is packed into x at bit possition "RightPos". It is assumed\r
that the bits in x where fieldvalue is insert is 0 *)\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' PackField ',x,' ',RightPos,' ',\r
FieldValue);\r
(*ENDTEST#*)\r
\r
FieldValue := FieldValue * ShiftFactor[RightPos];\r
x := ( x + FieldValue) MOD MaxByte;\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' PackField ',x);\r
(*ENDTEST#*)\r
END; (* PackField *)\r
\r
\r
(* -------------------------------------------------------*)\r
\r
\r
FUNCTION RegField( r : Register) : integer;\r
(* The function returns the value of the regfield *)\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' RegField ',ord(r));\r
(*ENDTEST#*)\r
RegField := ord(r) MOD ord(AL);\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' RegField ');\r
(*ENDTEST#*)\r
END; (* RegField *)\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
\r
VAR\r
i,j,codelength, Diff,iii : integer;\r
helpbyte : byte;\r
Lab : St_Address;\r
Ptr : St_ElemPtr;\r
WordIndex,help : Word;\r
DeleteJump : boolean;\r
Str : ptr_String;\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
PROCEDURE WriteBytesToTBinFile(No : integer);\r
VAR\r
i : integer;\r
BEGIN\r
FOR i := 1 TO No DO\r
BEGIN\r
(* TURBO\r
TBinFile^ := CodeBuffer[FirstIndex];\r
put(TBinFile); *)\r
PutTBinFile(CodeBuffer[FirstIndex]);\r
FirstIndex := (FirstIndex + 1) MOD LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer - 1;\r
END;\r
\r
END;\r
\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 > 2 THEN\r
writeln(TestOutput,' START',' MakeFreeCodeBuffer',No,' ',\r
NoBytesInBuffer);\r
IF TestPass4 >= 0 THEN write('.');\r
(*ENDTEST#*)\r
\r
WHILE (((InternalOffset - FileOffset) > 130) OR\r
((LengthOfCodeBuffer - NoBytesInBuffer) < No)) DO\r
BEGIN (* write a codeformat to TBinFile *)\r
codelength := CodeBuffer[FirstIndex];\r
\r
IF CodeLength <> 0 THEN\r
BEGIN\r
WriteBytesToTBinFile(CodeLength + 1);\r
\r
FileOffset := FileOffset + codelength;\r
END\r
\r
ELSE (* codelength = 0 *)\r
BEGIN (* a jump or a label or a LBDR or a external call*)\r
\r
FirstIndex := (FirstIndex + 1) Mod LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer - 1;\r
\r
IF ((CodeBuffer[FirstIndex] <> ord(ExternalCall) ) AND\r
(CodeBuffer[FirstIndex] <> ord(ExternalJump) ) AND\r
(CodeBuffer[FirstIndex] <> ord(ShortJump) ) AND\r
(CodeBuffer[FirstIndex] <> ord(NearunCondJump) ) AND\r
(CodeBuffer[FirstIndex] <> ord(NearCondJump) ) AND\r
(CodeBuffer[FirstIndex] <> ord(RoutineStartStop) )) THEN\r
BEGIN (* not external Call and not a jump *)\r
(*TBinFile^ := 0;\r
put(TBinFile);*)\r
helpbyte := 0;\r
putTBinFile(helpbyte);\r
END;\r
\r
\r
CASE CodeFormat(CodeBuffer[FirstIndex]) OF\r
\r
DeclareLabel:\r
BEGIN (* a label *)\r
WriteBytesToTBinFile(1);\r
\r
(* Get Label *)\r
WordByte.Byte1 := CodeBuffer[FirstIndex] ; \r
WordByte.Byte2 := CodeBuffer[(FirstIndex+1) MOD\r
LengthOfCodeBuffer];\r
Lab.Va_Low := WordByte.w;\r
WordByte.Byte1 := CodeBuffer[(FirstIndex+2) MOD\r
LengthOfCodeBuffer] ; \r
WordByte.Byte2 := CodeBuffer[(FirstIndex+3) MOD\r
LengthOfCodeBuffer];\r
Lab.Va_High := WordByte.w;\r
\r
\r
St_Get(Lab,Ptr);\r
\r
Ptr^.Label_Offset := FileOffset;\r
\r
(* write the label to TBinFile *)\r
WriteBytesToTBinFile(4);\r
END;\r
\r
\r
RoutineStartStop :\r
BEGIN \r
FirstIndex := (FirstIndex + 1) MOD LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer - 1;\r
\r
(* Get Routine node *)\r
WordByte.Byte1 := CodeBuffer[FirstIndex] ; \r
WordByte.Byte2 := CodeBuffer[(FirstIndex+1) MOD\r
LengthOfCodeBuffer];\r
Lab.Va_Low := WordByte.w;\r
WordByte.Byte1 := CodeBuffer[(FirstIndex+2) MOD\r
LengthOfCodeBuffer] ; \r
WordByte.Byte2 := CodeBuffer[(FirstIndex+3) MOD\r
LengthOfCodeBuffer];\r
Lab.Va_High := WordByte.w;\r
\r
j := CodeBuffer[(FirstIndex+4) MOD\r
LengthOfCodeBuffer];\r
\r
\r
St_Get(Lab,Ptr);\r
IF Ptr^.St_Kind = cType THEN\r
BEGIN\r
IF j = 1 THEN (* Start *)\r
BEGIN\r
Ptr^.T_First_Offset := FileOffset;\r
Ptr^.t_Name_Entry_List := LastNameEntry;\r
END\r
ELSE (* Stop *)\r
Ptr^.T_Last_Offset := FileOffset;\r
END\r
ELSE\r
BEGIN\r
IF j = 1 THEN (* Start *)\r
BEGIN\r
Ptr^.First_Offset := FileOffset;\r
Ptr^.Name_Entry_List := LastNameEntry;\r
END\r
\r
ELSE (* Stop *)\r
BEGIN\r
Ptr^.Last_Offset := FileOffset;\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^.label_offset;\r
St_Get(Lab,Ptr);\r
Ptr^.First_Offset :=help;\r
END;\r
END;\r
\r
IF j = 1 THEN\r
BEGIN\r
LastNameEntry := Lab;\r
(* update lengthofnametabel *)\r
st_NameofSpix(Ptr^.St_Spix,Str);\r
LengthOfNameTabel := LengthOfNameTabel + length(Str^)\r
+ 8;\r
END;\r
\r
FirstIndex := (FirstIndex + 5) MOD LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer - 5;\r
\r
END;\r
\r
LongJump :\r
BEGIN\r
WriteBytesToTBinFile(4);\r
FileOffset := FileOffset + 5;\r
END;\r
\r
LongCall :\r
BEGIN\r
WriteBytesToTBinFile(5);\r
FileOffset := FileOffset + 5;\r
END;\r
\r
\r
LineNo:\r
BEGIN\r
WriteBytesToTBinFile(3);\r
END;\r
\r
\r
SetCode:\r
BEGIN\r
WriteBytesToTBinFile(2);\r
END;\r
\r
ContextEnd :\r
BEGIN\r
WriteBytesToTBinFile(1);\r
ContextEndOffset := FileOffset;\r
END;\r
\r
\r
AddLabelToDis :\r
BEGIN\r
CodeLength := CodeBuffer[(FirstIndex + 1)\r
MOD LengthOfCodeBuffer];\r
\r
WriteBytesToTBinFile(CodeLength + 6);\r
FileOffset := FileOffset + CodeLength;\r
\r
END;\r
\r
\r
\r
\r
CaseLabList : (* a case tabel *) \r
BEGIN\r
(* get the length *)\r
WordByte.Byte1 := CodeBuffer[(FirstIndex + 1) MOD\r
LengthOfCodeBuffer];\r
WordByte.Byte2 := CodeBuffer[(FirstIndex + 2) MOD\r
LengthOfCodeBuffer];\r
\r
(* No of labels in WordByte.w *)\r
FileOffset := FileOffset + ( WordByte.w * 2);\r
\r
(* write the labels to TBinFile *)\r
WriteBytesToTBinFile(11);\r
\r
\r
END;\r
\r
\r
\r
\r
InternalLBDR:\r
BEGIN (* A Internal LBDR *)\r
\r
LastInternalLBDROffset := FileOffset;\r
\r
WriteBytesToTBinFile(LengthOfInternalLBDR + 5);\r
\r
FileOffset := FileOffset + LengthOfInternalLBDR;\r
\r
END;\r
\r
\r
\r
ExternalLBDR:\r
BEGIN (* A External LBDR *)\r
WriteBytesToTBinFile(LengthOfExternalLBDR + 5);\r
\r
\r
FileOffset := LengthOfExternalLBDR;\r
\r
END;\r
\r
\r
\r
\r
ExternalCall,\r
ExternalJump :\r
\r
BEGIN (* an External call *)\r
(*TBinFile^ := 5;\r
Put(TBinFile);\r
TBinFile^ := OpcodeCallExt;\r
Put(TBinFile);*)\r
helpbyte := 5;\r
PutTBinFile(helpbyte);\r
IF CodeFormat(CodeBuffer[FirstIndex]) = ExternalCall\r
THEN helpbyte := OpcodeCallExt\r
ELSE Helpbyte := OpcodeLongJmp;\r
PutTBinFile(helpbyte);\r
\r
FOR i := 1 TO 4 DO\r
BEGIN\r
(*TBinFile^ := 0;\r
Put(TBinfile);*)\r
helpbyte := 0;\r
putTBinFile(helpbyte);\r
END;\r
\r
FirstIndex := (FirstIndex + 1) Mod LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer - 1;\r
\r
WordByte.Byte1 := CodeBuffer[FirstIndex];\r
FirstIndex := (FirstIndex + 1) Mod LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer - 1;\r
\r
\r
WordByte.Byte2 := CodeBuffer[FirstIndex];\r
FirstIndex := (FirstIndex + 1) Mod LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer - 1;\r
\r
\r
St_New_FixUpp(WordByte.w,FileOffset + 1,\r
FirstFixUpp,LastFixUpp);\r
\r
NoFixUpp := NoFixUpp + 1;\r
\r
\r
FileOffset := FileOffset + 5;\r
\r
END;\r
\r
\r
\r
NearUnCondJump, NearCondJump:\r
BEGIN (* a jump *)\r
DeleteJump := false; \r
\r
IF CodeBuffer[FirstIndex] = ord(NearUnCondJump)\r
THEN CodeLength := 3\r
ELSE CodeLength := 5;\r
\r
\r
IF( CodeBuffer[(FirstIndex + 1) MOD LengthOfCodeBuffer]\r
<> ord(iCALL)) \r
THEN\r
BEGIN (* a near jump\r
check if it can be change to a short jump *)\r
\r
\r
(* Get Label *)\r
WordByte.Byte1 := CodeBuffer[(FirstIndex + 2)\r
MOD LengthOfCodeBuffer];\r
WordByte.Byte2 := CodeBuffer[(FirstIndex+3) MOD\r
LengthOfCodeBuffer];\r
Lab.Va_Low := WordByte.w;\r
\r
WordByte.Byte1 := CodeBuffer[(FirstIndex + 4)\r
MOD LengthOfCodeBuffer];\r
WordByte.Byte2 := CodeBuffer[(FirstIndex + 5) MOD\r
LengthOfCodeBuffer];\r
Lab.Va_High := WordByte.w;\r
\r
\r
St_Retrieve(Lab,Ptr);\r
WHILE NOT Equal_Addr(Ptr^.DefAsLabel,St_NillAddr) DO\r
St_Retrieve(Ptr^.DefAsLabel,Ptr);\r
\r
IF Ptr^.Label_Offset <> 0\r
THEN\r
BEGIN (* The label has been generated *)\r
(* $NoCheck *)\r
IF (Ptr^.Label_Offset > FileOffset)\r
THEN\r
Diff := Ptr^.Label_Offset - CodeLength\r
+ 2 - (FileOffset + 2)\r
ELSE\r
Diff := Ptr^.Label_Offset - (FileOffset + 2);\r
\r
IF Diff = 0 THEN\r
BEGIN\r
(* The jump can be deleted *)\r
DeleteJump := true;\r
InternalOffset := InternalOffset -\r
CodeLength;\r
IF LastJMPOffset <> 0 THEN\r
LastJMPOffset := LastJMPOffset - CodeLength;\r
IF LastLabelOffset <> 0 THEN\r
LastLabelOffset := LastLabelOffset -\r
CodeLength;\r
END\r
ELSE\r
IF ((-128 <= Diff) AND (Diff <= 127))\r
THEN\r
BEGIN (* Near jump can bee short *)\r
InternalOffset := InternalOffset -\r
CodeLength + 2;\r
IF LastJMPOffset <> 0 THEN\r
LastJMPOffset := LastJMPOffset -\r
CodeLength + 2;\r
IF LastLabelOffset <> 0 THEN\r
LastLabelOffset := LastLabelOffset -\r
CodeLength + 2;\r
CodeLength := 2;\r
CodeBuffer[FirstIndex] := Ord(ShortJump);\r
END;\r
END;\r
\r
END;\r
\r
\r
IF NOT DeleteJump THEN\r
BEGIN\r
(* write the jump instruction to TBinFile *)\r
\r
FileOffset := FileOffset + CodeLength;\r
(* TURBO\r
TBinFile^:=0;\r
Put(TBinFile); *)\r
helpbyte := 0;\r
PutTBinFile(helpbyte);\r
\r
WriteBytesToTBinFile(6);\r
END\r
ELSE\r
BEGIN\r
(* delete the jump instruction *)\r
FirstIndex := (FirstIndex + 6 ) MOD LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer - 6;\r
END;\r
END;\r
\r
\r
\r
END; (* END Case *)\r
\r
END;\r
\r
END; (* end While *)\r
\r
\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' MakeFreeCodeBuffer ',Fileoffset);\r
(*#ENDTEST#*)\r
END; (* MakeFreeCodeBuffer *)\r
\r
\r
(* --------------------------------------------- *)\r
\r
\r
\r
\r
\r
\r
\r
(* The following routines is used to insert in the codebuffer *)\r
\r
\r
PROCEDURE PutCodeBuffer( x : Byte);\r
(* Puts a byte into the internal buffer. If the buffer is full\r
write the buffer out on TBinFile *)\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' PutCodeBuffer ',x,' ',\r
NoBytesInBuffer);\r
(*ENDTEST#*)\r
\r
IF NoBytesInBuffer = LengthOfCodeBuffer THEN\r
MakeFreeCodeBuffer(1);\r
\r
CodeBuffer[ BufferIndex ] := x;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer + 1;\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' PutCodeBuffer ');\r
(*ENDTEST#*)\r
END; (* PutCodeBuffer *)\r
\r
\r
(* ------------------------------------------------------- *)\r
\r
\r
\r
PROCEDURE Put1CodeFormat( x : Byte);\r
(* Puts a codeformat of length 1 into the internal buffer *)\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' Put1CodeFormat ',x,' ',\r
NoBytesInBuffer);\r
(*ENDTEST#*)\r
\r
IF NoBytesInBuffer + 2 > LengthOfCodeBuffer THEN\r
MakeFreeCodeBuffer(2);\r
\r
CodeBuffer[ BufferIndex ] := 1;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer + 2;\r
\r
IF ( InternalOffset > (Max_Word - 1)) THEN Fatal_Error(Pass4,4);\r
InternalOffset := InternalOffset + 1;\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' Put1CodeFormat ');\r
(*ENDTEST#*)\r
END; (* Put1CodeFormat *)\r
\r
\r
\r
\r
(* ------------------------------------------------------- *)\r
\r
\r
\r
PROCEDURE Put2CodeFormat( x1, x2 : Byte);\r
(* Puts a codeformat of length 2 into the internal buffer *)\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' Put2CodeFormat ',x1,' ',x2,' ',\r
NoBytesInBuffer);\r
(*ENDTEST#*)\r
\r
IF NoBytesInBuffer + 3 > LengthOfCodeBuffer THEN\r
MakeFreeCodeBuffer(3);\r
\r
CodeBuffer[ BufferIndex ] := 2;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x1;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x2;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer + 3;\r
\r
\r
IF ( InternalOffset > (Max_Word - 2)) THEN Fatal_Error(Pass4,4);\r
InternalOffset := InternalOffset + 2;\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' Put2CodeFormat ');\r
(*ENDTEST#*)\r
END; (* Put2CodeFormat *)\r
\r
\r
\r
\r
\r
(* ------------------------------------------------------- *)\r
\r
\r
\r
PROCEDURE Put3CodeFormat( x1, x2, x3 : Byte);\r
(* Puts a codeformat of length 3 into the internal buffer *)\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' Put3CodeFormat ',x1,' ',x2,\r
' ',x3,' ',NoBytesInBuffer);\r
(*ENDTEST#*)\r
\r
IF NoBytesInBuffer + 4 > LengthOfCodeBuffer THEN\r
MakeFreeCodeBuffer(4);\r
\r
CodeBuffer[ BufferIndex ] := 3;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x1;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x2;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x3;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer + 4;\r
\r
IF ( InternalOffset > (Max_Word - 3)) THEN Fatal_Error(Pass4,4);\r
InternalOffset := InternalOffset + 3;\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' Put3CodeFormat ');\r
(*ENDTEST#*)\r
END; (* Put3CodeFormat *)\r
\r
\r
\r
\r
(* ------------------------------------------------------- *)\r
\r
\r
\r
PROCEDURE Put4CodeFormat( x1, x2, x3, x4 : Byte);\r
(* Puts a codeformat of length 4 into the internal buffer *)\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' Put4CodeFormat ',x1,' ',x2,\r
' ',x3,' ',x4,' ', NoBytesInBuffer);\r
(*ENDTEST#*)\r
\r
IF NoBytesInBuffer + 5 > LengthOfCodeBuffer THEN\r
MakeFreeCodeBuffer(5);\r
\r
CodeBuffer[ BufferIndex ] := 4;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x1;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x2;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x3;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
CodeBuffer[ BufferIndex ] := x4;\r
BufferIndex := (BufferIndex + 1 ) MOD LengthOfCodeBuffer;\r
NoBytesInBuffer := NoBytesInBuffer + 5;\r
\r
IF ( InternalOffset > (Max_Word - 4)) THEN Fatal_Error(Pass4,4);\r
InternalOffset := InternalOffset + 4;\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' Put4CodeFormat ');\r
(*ENDTEST#*)\r
END; (* Put4CodeFormat *)\r
\r
\r
\r
(* ------------------------------------------------------------- *)\r
\r
\r
PROCEDURE PutR_MOperand(op : byte;VAR Addr : Address; \r
Reg : integer);\r
(* Puts a instruction with operand op and operand of type R_M\r
into the codebuffer. The operand is given by Addr and the \r
Regfield by Reg. If the instruction have to be prefixed\r
this is done *)\r
\r
VAR \r
LengthIndex : integer;\r
CodeLength : integer;\r
PreOp : Byte;\r
LengthOfDisplacement : integer;\r
R_M, ModField : Byte;\r
\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' PutR_MOperand ',op,' ',Reg);\r
(*ENDTEST#*)\r
\r
WITH Addr DO\r
BEGIN\r
IF NoBytesInBuffer + 8 > LengthOfCodeBuffer THEN\r
MakeFreeCodeBuffer(8);\r
(* make 8 free. No test in PutR_MOpr_AndConst *)\r
\r
LengthIndex := BufferIndex;\r
CodeLength := 0;\r
BufferIndex := (BufferIndex + 1) MOD LengthOfCodeBuffer;\r
\r
IF (( Seg <> DS) AND (Seg <> SS)) OR \r
(DSIsChange AND (Addr.Base = RNIL)) THEN\r
BEGIN (* The instruction has to be prefixed by Seg *)\r
IF Seg = DS THEN Seg := SS;\r
PreOp := OpcodePreFix;\r
PackField(PreOp, 3, ord(Seg) - ord(ES));\r
CodeBuffer[BufferIndex] := PreOp;\r
BufferIndex := (BufferIndex + 1) MOD LengthOfCodeBuffer;\r
CodeLength := 1;\r
END;\r
\r
\r
(* Calculation of the R_MField *)\r
IF (Index = Rnil) THEN\r
IF (Base = BX) THEN R_M := $07 (*111B*)\r
ELSE R_M := $06 (*110B*)\r
\r
ELSE\r
IF (Base = BX) THEN R_M := $00 (*000B*) - ord(SI) + ord(Index)\r
ELSE\r
IF (Base = BP) THEN R_M := $02 (*010B*) - ord(SI) + ord(Index)\r
ELSE R_M := $04 (*100B*) - ord(SI) + ord(Index);\r
\r
\r
\r
wordByte.w := Displacement;\r
(* Calculation of the mod field *)\r
IF (( Base = RNil) AND (R_M = $06 (*110B*) ))\r
THEN\r
BEGIN\r
ModField := $00; (* 000B;*)\r
LengthOfDisplacement := 2;\r
END\r
ELSE\r
BEGIN\r
IF((-128 <= wordbyte.i) AND (wordbyte.i <= 127))\r
THEN IF Displacement = 0 THEN LengthOfDisplacement := 0\r
ELSE LengthOFDisplacement := 1\r
ELSE LengthOfDisplacement := 2;\r
\r
ModField := LengthOfDisplacement;\r
END;\r
\r
\r
PackField(R_M, 3, Reg);\r
PackField(R_M, 6, ModField);\r
\r
CodeBuffer[BufferIndex] := Op;\r
BufferIndex := (BufferIndex + 1) Mod LengthOfCodeBuffer;\r
\r
CodeBuffer[BufferIndex] := R_M;\r
BufferIndex := (BufferIndex + 1) MOD LengthOfCodeBuffer;\r
CodeLength := CodeLength + 2;\r
\r
\r
IF LengthOfDisplacement = 1 THEN\r
BEGIN\r
CodeBuffer[BufferIndex] := WordByte.Byte1;\r
BufferIndex := (BufferIndex + 1) MOD LengthOfCodeBuffer;\r
END\r
ELSE\r
IF LengthOfDisplacement = 2\r
THEN\r
BEGIN\r
CodeBuffer[BufferIndex] := WordByte.Byte1;\r
BufferIndex := (BufferIndex + 1) MOD LengthOfCodeBuffer;\r
CodeBuffer[BufferIndex] := WordByte.Byte2;\r
BufferIndex := (BufferIndex + 1) MOD LengthOfCodeBuffer;\r
END;\r
CodeLength := CodeLength + LengthOfDisplacement;\r
\r
\r
CodeBuffer[LengthIndex] := CodeLength;\r
NoBytesInBuffer := NoBytesInBuffer + CodeLength + 1;\r
\r
IF ( InternalOffset > (Max_Word - CodeLength)) THEN Fatal_Error(Pass4,4);\r
InternalOffset := InternalOffset + CodeLength;\r
\r
END; (* With Addr *)\r
\r
\r
\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' PutR_MOperand');\r
(*ENDTEST#*)\r
END; (* PutR_MOperand *)\r
\r
\r
(* --------------------------------------------------------- *)\r
\r
\r
PROCEDURE PutR_MOprAndConst(op : Byte; VAR Addr : Address; Reg : integer;\r
InstType : InstrucType; Value : Word );\r
(* The procedure puts a instruction with opcode op and one \r
operand of type R_M and one of type const into the codebuffer.\r
The first operand is given by addr (RegField by Reg ) and\r
the secend operand by value (InstType tells if byte or word)*)\r
\r
VAR\r
LengthIndex, CodeLength : integer;\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' PutR_MOprAndConst ',op,' ',Reg,\r
' ',ord(InstType),' ',Value);\r
(*ENDTEST#*)\r
LengthIndex := BufferIndex;\r
\r
PutR_MOperand(op,Addr,Reg);\r
\r
WordByte.w := Value;\r
\r
IF InstType = b\r
THEN\r
BEGIN\r
CodeBuffer[BufferIndex] := WordByte.Byte1;\r
BufferIndex := (BufferIndex + 1) MOD LengthOfCodeBuffer;\r
CodeLength := 1;\r
END\r
ELSE\r
BEGIN\r
CodeBuffer[BufferIndex] := WordByte.Byte1;\r
BufferIndex := (BufferIndex + 1) MOD LengthOfCodeBuffer;\r
CodeBuffer[BufferIndex] := WordByte.Byte2;\r
BufferIndex := (BufferIndex + 1) MOD LengthOfCodeBuffer;\r
CodeLength := 2;\r
END;\r
\r
CodeBuffer[LengthIndex] := CodeBuffer[LengthIndex] +\r
CodeLength;\r
\r
IF ( InternalOffset > (Max_Word - CodeLength)) THEN Fatal_Error(Pass4,4);\r
InternalOffset := InternalOffset + CodeLength;\r
NoBytesInBuffer := NoBytesInBuffer + CodeLength;\r
\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' PutR_MOprAndConst');\r
(*ENDTEST#*)\r
END; (* PutR_MOprAndConst *)\r
\r
\r
(* ------------------------------------------------------------ *)\r
\r
\r
\r
\r
(* The following routines is used to print operands to symbolic\r
code *)\r
\r
\r
PROCEDURE PrintReg(r : Register; InstType : InstrucType);\r
(* The procedure prints the register r *)\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' PrintReg ',ord(r),' ',\r
ord(InstType));\r
(*ENDTEST#*)\r
\r
CASE r OF\r
\r
AX : IF ((InstType = w) OR (InstType = vw))\r
THEN write(TSymFile,'AX')\r
ELSE write(TSymFile,'AL');\r
\r
BX : IF ((InstType = w) OR (InstType = vw))\r
THEN write(TSymFile,'BX')\r
ELSE write(TSymFile,'BL');\r
\r
CX : IF ((InstType = w) OR (InstType = vw))\r
THEN write(TSymFile,'CX')\r
ELSE write(TSymFile,'CL');\r
\r
DX : IF ((InstType = w) OR (InstType = vw))\r
THEN write(TSymFile,'DX')\r
ELSE write(TSymFile,'DL');\r
\r
AL : write(TSymFile,'AL');\r
\r
BL : write(TSymFile,'BL');\r
\r
CL : write(TSymFile,'CL');\r
\r
DL : write(TSymFile,'DL');\r
\r
AH : write(TSymFile,'AH');\r
\r
BH : write(TSymFile,'BH');\r
\r
CH : write(TSymFile,'CH');\r
\r
DH : write(TSymFile,'DH');\r
\r
SI : write(TSymFile,'SI');\r
\r
DI : write(TSymFile,'DI');\r
\r
SP : write(TSymFile,'SP');\r
\r
BP : write(TSymFile,'BP');\r
\r
ES : write(TSymFile,'ES');\r
\r
CS : write(TSymFile,'CS');\r
\r
SS : write(TSymFile,'SS');\r
\r
DS : write(TSymFile,'DS');\r
\r
Rnil : write(TSymFile,'Rnil');\r
\r
END; (* End case *)\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' PrintReg');\r
(*ENDTEST#*)\r
END; (* PrintReg *)\r
\r
\r
(* ---------------------------------------------------- *)\r
\r
\r
PROCEDURE PrintAddr(VAR Addr : Address);\r
(* Print Addr *)\r
\r
VAR\r
i : integer;\r
Str : ptr_String;\r
PreFix : Boolean;\r
(* indicates if the address has to be prefixed by a segment register *)\r
\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' PrintAddr');\r
(*ENDTEST#*)\r
\r
WITH Addr DO\r
BEGIN\r
IF ((Addr.Seg <> DS) AND (Addr.Seg <> SS)) \r
OR ( DSISChange AND ( Addr.Base = RNil) ) THEN PreFix := True\r
ELSE \r
IF ((Addr.Base = RNil) AND (Addr.Index = RNil)) THEN\r
PreFix := true\r
ELSE\r
PreFix := false;\r
\r
IF PreFix THEN\r
BEGIN\r
PrintReg(Seg,w);\r
write(TSymFile,': ');\r
END;\r
\r
IF Base <> Rnil THEN\r
BEGIN\r
write(TSymFile,'[');\r
PrintReg(Base,w);\r
write(TSymFile,'] ');\r
END;\r
\r
IF Spix <> Anonymousspix THEN\r
BEGIN\r
St_NameOfSpix(Spix,Str);\r
For i := 1 To length(Str^) DO\r
write(TSymFile,Str^[i]);\r
write(TSymfile,'(=',Displacement,')');\r
END\r
ELSE\r
IF Displacement <> 0 THEN\r
write(TSymFile,Displacement,' ');\r
\r
IF Index <> Rnil THEN\r
BEGIN\r
write(TSymFile,'[');\r
PrintReg(Index,w);\r
write(TSymFile,']');\r
END;\r
END; (* End With *)\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' PrintAddr');\r
(*ENDTEST#*)\r
END; (* PrintAddr *)\r
\r
\r
\r
\r
(* ------------------------------------------------------ *)\r
\r
\r
\r
(* ---------------------------------------------------------- *)\r
\r
\r
\r
\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
\r
IF ( InternalOffset > (Max_Word - Length)) THEN\r
Fatal_Error(Pass4,4);\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
PutCodeBuffer(No);\r
FOR i := (index + 1) TO (No + index) DO\r
PutCodeBuffer(Ptr^.Data_area[i]);\r
InternalOffset := InternalOffset + No;\r
\r
IF CodeOn THEN\r
BEGIN\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);\r
(* The casetabel is generated *)\r
\r
VAR\r
Lab : St_Address;\r
Index : integer;\r
BEGIN\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' START',' DumpCaseTabel');\r
(*ENDTEST#*)\r
\r
PutCodeBuffer(0);\r
PutCodeBuffer(ord(CaseLabList));\r
\r
WordByte.w := Size;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
\r
\r
WordByte.w := CaseTab.Va_Low;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
WordByte.w := CaseTab.Va_High;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
\r
WordByte.w := OtherwiseLab.Va_Low;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
WordByte.w := OtherwiseLab.Va_High;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
\r
IF ( InternalOffset > (Max_Word - (Size * 2))) THEN\r
Fatal_Error(Pass4,4);\r
\r
InternalOffset := InternalOffset + (Size * 2);\r
\r
(*#BEGINTEST\r
IF TestPass4 >= 10 THEN\r
writeln(TestOutput,' SLUT',' DumpCaseTabel');\r
(*ENDTEST#*)\r
END; (* DumpCaseTabel *)\r
\r
\r
\r
\r
(*------------------------------------------------------------------*)\r
\r
\r
PROCEDURE NewLine(Line : Word);\r
BEGIN\r
IF CodeOn or LineTabel THEN\r
BEGIN\r
PutCodeBuffer(0);\r
PutCodeBuffer(ord(LineNo));\r
WordByte.w := Line;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
END;\r
END;\r
\r
\r
(*------------------------------------------------------------------- *)\r
\r
\r
\r
\r
PROCEDURE SetCodeTo(Bool : Boolean);\r
BEGIN\r
PutCodeBuffer(0);\r
PutCodeBuffer(ord(SetCode));\r
IF Bool THEN PutCodeBuffer(SourceNumber)\r
ELSE PutCodeBuffer(255);\r
CodeOn := Bool;\r
END;\r
\r
\r
\r
\r
Procedure ContextStop;\r
(* The procedure is called when leaving context. Only used when\r
making linetabel *)\r
BEGIN\r
PutCodeBuffer(0);\r
PutCodeBuffer(ord(ContextEnd));\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
PutCodeBuffer(0);\r
PutCodeBuffer(ord(RoutineStartStop));\r
\r
WordByte.w := Symbol.Va_Low;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
WordByte.w := Symbol.Va_High;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
IF Start THEN PutCodeBuffer(1) ELSE PutCodeBuffer(0);\r
\r
END;\r
\r
\r
PROCEDURE MakeLongCall(Symbol : St_Address);\r
BEGIN\r
PutCodeBuffer(0);\r
PutCodeBuffer(Ord(LongCall));\r
(* Put Label *)\r
\r
WordByte.w := Symbol.Va_Low;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
WordByte.w := Symbol.Va_High;\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
\r
IF InternalOffset > (Max_Word - 5) THEN Fatal_Error(Pass4,4);\r
InternalOffset := InternalOffset + 5;\r
END;\r
\r
PROCEDURE DumpRoutineTabel;\r
VAR Ptr : St_ElemPtr;\r
Symb : Ptr_Symbol_Chain;\r
i : integer;\r
BEGIN\r
Symb := Segment_Info[CurrentSegNo].List;\r
FOR i := 1 TO Segment_Info[CurrentSegNo].No_Of_Symbol DO\r
BEGIN\r
St_Retrieve(Symb^.Symbol,Ptr);\r
(* No Optimize *)\r
LastLabelOffset := 0;\r
LastJmpOffset := 0;\r
\r
CodeJump(iJMP,Ptr^.St_Label);\r
Symb := Symb^.Next;\r
END;\r
(* Make sure that all jumps are 3 bytes jumps *)\r
LastJmpOffset := 0;\r
MakeFreeCodeBuffer(LengthOfCodeBuffer);\r
END;\r
\r
\r
PROCEDURE MakeJumpToNextSegment;\r
BEGIN\r
PutCodeBuffer(0);\r
PutCodeBuffer(Ord(LongJump));\r
PutCodeBuffer(CurrentSegNo + 1);\r
WordByte.w := LengthOfExternalLBDR + (Segment_Info[CurrentSegNo + 1].\r
No_Of_Symbol * 3);\r
PutCodeBuffer(WordByte.Byte1);\r
PutCodeBuffer(WordByte.Byte2);\r
\r
\r
IF InternalOffset > (Max_Word - 5) THEN Fatal_Error(Pass4,4);\r
InternalOffset := InternalOffset + 5;\r
END;\r
\r
\r
\r
(* --------------------------------------------------- *)\r
{$I p4code1}\r
\r
END\r
.\r
\r
\r
\r
\r
(* -------- PRIVATE CODEGENERATOR ----------- CODEGENERATOR --*)\r
\r
\r
\r
\r
\r
«eof»