mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-31 11:30:30 +02:00
+ handle also STATUS_FLOAT_MULTIPLE_FAULTS, resolves #32822
git-svn-id: trunk@38269 -
This commit is contained in:
parent
b421ed0db1
commit
4d63945b8d
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -15989,6 +15989,7 @@ tests/webtbs/tw3274.pp svneol=native#text/plain
|
||||
tests/webtbs/tw3280.pp svneol=native#text/plain
|
||||
tests/webtbs/tw3281.pp svneol=native#text/plain
|
||||
tests/webtbs/tw32821.pp svneol=native#text/pascal
|
||||
tests/webtbs/tw32822.pp svneol=native#text/pascal
|
||||
tests/webtbs/tw3286.pp svneol=native#text/plain
|
||||
tests/webtbs/tw3292.pp svneol=native#text/plain
|
||||
tests/webtbs/tw32938.pp svneol=native#text/pascal
|
||||
|
@ -495,6 +495,7 @@ function syswin32_i386_exception_handler(excep : PExceptionPointers) : Longint;s
|
||||
err := 218;
|
||||
must_reset_fpu := false;
|
||||
end;
|
||||
STATUS_FLOAT_MULTIPLE_FAULTS,
|
||||
STATUS_FLOAT_MULTIPLE_TRAPS:
|
||||
begin
|
||||
{ dumping ExtendedRegisters and comparing with the actually value of mxcsr revealed 24 }
|
||||
|
64
tests/webtbs/tw32822.pp
Normal file
64
tests/webtbs/tw32822.pp
Normal file
@ -0,0 +1,64 @@
|
||||
{ %CPU=i386 }
|
||||
{$mode delphi}
|
||||
program controlc;
|
||||
|
||||
{$ASMMODE intel}
|
||||
|
||||
uses
|
||||
Windows,
|
||||
SysUtils, Math;
|
||||
|
||||
type
|
||||
TSSE=record
|
||||
sse1,sse2,sse3,sse4:single;
|
||||
end;
|
||||
|
||||
{.$codealign recordmin=16}
|
||||
{.$align 16}{.$packrecords 16}
|
||||
TSSE2=record
|
||||
prefix:longint;
|
||||
sse: TSSE;
|
||||
end;
|
||||
|
||||
TTestProc = procedure; cdecl;
|
||||
|
||||
|
||||
var
|
||||
a: TSSE2 = ( prefix: 0; sse: (sse1: 3.4E38; sse2: 3.4E38; sse3: 3.0; sse4: 4.0));
|
||||
b: TSSE2 = (prefix: 0; sse: (sse1: 3.4E38; sse2: 3.4E38; sse3: 0.0; sse4: 0.0));
|
||||
c: TSSE2 = (prefix: 0; sse: (sse1: 0.0; sse2: 0.0; sse3: 0.0; sse4: 0.0));
|
||||
|
||||
procedure FailureCode; cdecl; assembler;
|
||||
asm
|
||||
movups xmm0, A.sse
|
||||
movups xmm1, B.sse
|
||||
// divps xmm0, xmm1
|
||||
mulps xmm0, xmm1 // must be overflow but STATUS_FLOAT_MULTIPLE_FAULTS
|
||||
movups c.sse, xmm0
|
||||
end;
|
||||
|
||||
procedure TestSafe(AProc: TTestProc);
|
||||
begin
|
||||
Writeln('-- begin safe ---');
|
||||
try
|
||||
AProc;
|
||||
except
|
||||
on E: EOverflow do
|
||||
begin
|
||||
WriteLn(E.ClassName + ': ' + E.Message);
|
||||
end;
|
||||
on E : Exception do
|
||||
halt(1);
|
||||
end;
|
||||
Writeln('-- end safe ---');
|
||||
end;
|
||||
|
||||
begin
|
||||
Writeln('== Default masking ===');
|
||||
TestSafe( FailureCode );
|
||||
|
||||
Writeln('== Unmasked ===');
|
||||
SetExceptionMask( [] );
|
||||
TestSafe( FailureCode );
|
||||
writeln('ok');
|
||||
end.
|
Loading…
Reference in New Issue
Block a user