paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 14:19:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ added test for i8086 inline asm far and near indirect jmps as well

Browse Source 
git-svn-id: trunk@32110 -
This commit is contained in:
nickysn 2015-10-21 01:26:15 +00:00
parent 2fbcdaf7d5
commit 520f7226aa
2 changed files with 159 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -11457,6 +11457,7 @@ tests/test/cg/variants/tvarol94.pp svneol=native#text/plain
tests/test/cg/variants/tvarol96.pp svneol=native#text/plain
tests/test/cpu16/i8086/tfarcal1.pp svneol=native#text/pascal
tests/test/cpu16/i8086/tfarcal2.pp svneol=native#text/pascal
tests/test/cpu16/i8086/tfarjmp2.pp svneol=native#text/pascal
tests/test/cpu16/i8086/tfarptr1.pp svneol=native#text/pascal
tests/test/cpu16/i8086/tfarptr2.pp svneol=native#text/pascal
tests/test/cpu16/i8086/tfarptr3.pp svneol=native#text/pascal

158
tests/test/cpu16/i8086/tfarjmp2.pp Normal file
View File

@ -0,0 +1,158 @@
{ %target=msdos }
{ test for i8086 inline assembler indirect near and far jumps }
{ since testing and detecting near jumps miscompiled as far (and vice versa)
is hard, we don't actually execute the jumps, but instead, before each jump,
we issue an int instruction that calls our own interrupt handler that
manually disassembles the instruction, checks that it is of the correct type
and then skips the instruction. }
{ this test is Turbo Pascal 7 compatible }
program tfarjmp2;
uses
dos;
{$ifndef FPC}
type
FarPointer = Pointer;
{$endif ndef FPC}
const
NearInt = $E7;
FarInt = $E8;
var
OldNearIntVec: FarPointer;
OldFarIntVec: FarPointer;
procedure Error;
begin
Writeln('Error');
SetIntVec(NearInt, OldNearIntVec);
SetIntVec(FarInt, OldFarIntVec);
halt(1);
end;
procedure IntNearHandler(Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP: Word); interrupt;
var
modrm: Byte;
begin
if Mem[CS:IP]<>$FF then
Error;
Inc(IP);
modrm := Mem[CS:IP];
Inc(IP);
if ((modrm shr 3) and 7) <> 4 then
Error;
{ 'jmp reg'? -> not an indirect jmp }
if (modrm shr 6)=3 then
Error;
case modrm shr 6 of
0: if (modrm and 7) = 6 then
Inc(IP, 2); { disp16 }
1: Inc(IP); { disp8 }
2: Inc(IP,2); { disp16 }
end;
end;
procedure IntFarHandler(Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP: Word); interrupt;
var
modrm: Byte;
begin
if Mem[CS:IP]<>$FF then
Error;
Inc(IP);
modrm := Mem[CS:IP];
Inc(IP);
if ((modrm shr 3) and 7) <> 5 then
Error;
{ 'jmp far reg'??? -> invalid instruction }
if (modrm shr 6)=3 then
Error;
case modrm shr 6 of
0: if (modrm and 7) = 6 then
Inc(IP, 2); { disp16 }
1: Inc(IP); { disp8 }
2: Inc(IP,2); { disp16 }
end;
end;
procedure testloc(a: longint; b: integer);
begin
asm
int NearInt
jmp word [a] { near }
int FarInt
jmp [a] { far }
int FarInt
jmp a { far }
int FarInt
jmp dword [b] { far }
int NearInt
jmp [b] { near }
int NearInt
jmp b { near }
end;
end;
var
g16: integer;
g32: longint;
begin
GetIntVec(NearInt, OldNearIntVec);
SetIntVec(NearInt, @IntNearHandler);
GetIntVec(FarInt, OldFarIntVec);
SetIntVec(FarInt, @IntFarHandler);
asm
int NearInt
jmp g16 { near }
int NearInt
jmp [g16] { near }
int FarInt
jmp g32 { far }
int FarInt
jmp [g32] { far }
int FarInt
jmp dword [bx] { far }
{$ifdef FPC}
{ these three are supported by Free Pascal only. They don't work with
Turbo Pascal 7's inline assembler. }
{ using the 'far' keyword }
int FarInt
jmp far [bx]
{ using the 'near' keyword }
int NearInt
jmp near [bx]
{ ambiguous (that's why it's not supported by TP7), but FPC supports it by
extension from the 32-bit mode }
int NearInt
jmp [bx]
{$endif FPC}
end;
testloc(5, 10);
Writeln('Ok');
SetIntVec(NearInt, OldNearIntVec);
SetIntVec(FarInt, OldFarIntVec);
end.