paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-06 10:58:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ added an i8086 inline asm test for the indirect near and far call instructions

Browse Source 
git-svn-id: trunk@32107 -
This commit is contained in:
nickysn 2015-10-21 01:07:00 +00:00
parent 09218c88aa
commit c5aa64bc2c
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

@ -11456,6 +11456,7 @@ tests/test/cg/variants/tvarol91.pp svneol=native#text/plain
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/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/tfarcal2.pp Normal file
View File

@ -0,0 +1,158 @@
{ %target=msdos }
{ test for i8086 inline assembler indirect near and far calls }
{ since testing and detecting near calls miscompiled as far (and vice versa)
is hard, we don't actually execute the calls, but instead, before each call,
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 tfarcal2;
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) <> 2 then
Error;
{ 'call reg'? -> not an indirect call }
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) <> 3 then
Error;
{ 'call reg'? -> not an indirect call }
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
call word [a] { near }
int FarInt
call [a] { far }
int FarInt
call a { far }
int FarInt
call dword [b] { far }
int NearInt
call [b] { near }
int NearInt
call 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
call g16 { near }
int NearInt
call [g16] { near }
int FarInt
call g32 { far }
int FarInt
call [g32] { far }
int FarInt
call 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
call far [bx]
{ using the 'near' keyword }
int NearInt
call near [bx]
{ ambigous (that's why it's not supported by TP7), but FPC supports it by
extension from the 32-bit mode }
int NearInt
call [bx]
{$endif FPC}
end;
testloc(5, 10);
Writeln('Ok');
SetIntVec(NearInt, OldNearIntVec);
SetIntVec(FarInt, OldFarIntVec);
end.