diff --git a/.gitattributes b/.gitattributes index 52f9b08e8c..0e35de2772 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/tests/test/cpu16/i8086/tfarcal2.pp b/tests/test/cpu16/i8086/tfarcal2.pp new file mode 100644 index 0000000000..c7f3d3cf7b --- /dev/null +++ b/tests/test/cpu16/i8086/tfarcal2.pp @@ -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.