 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2001, <kouriakine@mail.ru>
 Float Point Unit (FPU) procedures, FPU exceptions handling.
 Modifications:
 20010705 - Creation (uses CRW16) & test
 20030217 - PatchBug_cwChop modified
 20160623 - PatchBug_cwChopCode
 ****************************************************************************
 }

unit _fpu; { float point unit }

{$I _sysdef}

interface

uses
 sysutils, _alloc;

 { General FPU routines }

function  isNAN(const X: Double): Boolean; overload;      { check value if it is NAN }
function  isINF(const X: Double): Boolean; overload;      { check value if it is INF }
function  isNANorINF(const X: Double): Boolean; overload; { check value if it is NAN or INF }
function  _NaN: Double;                          { assign NAN to value }
function  _PlusInf: Double;                      { assign plus INF to value }
function  _MinusInf: Double;                     { assign minus INF to value }
function  CheckDouble(const X: Double): Boolean; { if NAN,INF -> set CheckFpuMsg }
function  CheckSign(const X: Double): Boolean;   { check sign of value }

const
 CheckFpuMsg : ShortString = '';                 { Uses by CheckDouble }

 { Low-level FPU routines }

function  FpuInstalled : Boolean;                { Check if hardware FPU onboard }
procedure FpuSetExceptions(TurnOn : Boolean);    { Turn FPU exceptions on / off }
function  FpuGetStatus : Word;                   { Return FPU error status }
function  FpuGetStatusClear : Word;              { Return & clear FPU error status }
function  FpuGetStatusMsg(SW:word):ShortString;  { Return flags of FPU status }
procedure FpuInit;                               { Initialize FPU }
function  FpuGetCtrlWord: Word;                  { Get control word of FPU chip }
procedure FpuSetCtrlWord(CtrlWord: Word);        { Set control word of FPU chip }
procedure FpuClearExceptions;                    { Clear FPU exception indicators }

 {
 *******************************************************************************
 Patch Delphi 5.0 System unit.
 *******************************************************************************
 Reason:
  Int, Frac and Trunc functions reload FPU control word using internal cwChop
 constant in System unit:
   const cwChop : Word = $1F32;
   procedure       _INT;
   asm
        SUB     ESP,4
        FSTCW   [ESP]
        FWAIT
        FLDCW   cwChop
        FRNDINT
        FWAIT
        FLDCW   [ESP]
        ADD     ESP,4
   end;
   procedure       _FRAC;
   asm
        FLD     ST(0)
        SUB     ESP,4
        FSTCW   [ESP]
        FWAIT
        FLDCW   cwChop
        FRNDINT
        FWAIT
        FLDCW   [ESP]
        ADD     ESP,4
        FSUB
   end;
   procedure       _TRUNC;
   asm
        SUB     ESP,12
        FSTCW   [ESP]
        FWAIT
        FLDCW   cwChop
        FISTP   qword ptr [ESP+4]
        FWAIT
        FLDCW   [ESP]
        POP     ECX
        POP     EAX
        POP     EDX
   end;
 Due to this fact, Delphi ALWAYS generate exception after operations with NAN
 or INF result, like 1/0 or 0/0, when call int(), frac() or trunc(). Exceptions
 will be raised even after Set8087CW($133F) call. Some programs uses NAN or INF
 in calculations, for example, MatLab uses NAN & INF as other numerical values.
 If we change cwChop to $1F3F (mask all FPU exceptions), as BP 7.0 RTL does,
 exceptions will not allow. But cwChop is not public variable, we has no access
 to this.
 To address internal System unit variable, we may use address of Default8087CW
 (that is offset 0 from System data segment) and offset $28.
 Default8087CW          - Data segment, offset 0.
                          This public variable uses as base address.
 cwChop : Word          - Data segment, offset $30.
                          This internal variable to be patch.
 two2neg32 : Double     - This internal constant uses to test for safety reason.
 *******************************************************************************
 }
function PatchBug_cwChop(OnOff:Boolean):Boolean;
function PatchBug_cwChopCode:Integer;

implementation

type
 Dump               = packed array[0..3] of Word; { Memory dump of double type }

const
 { 8087 status word masks }
 mIE                = $0001;
 mDE                = $0002;
 mZE                = $0004;
 mOE                = $0008;
 mUE                = $0010;
 mPE                = $0020;
 mC0                = $0100;
 mC1                = $0200;
 mC2                = $0400;
 mC3                = $4000;
 { Dump[3] flags }
 InfFlag            = $7FF0;                      { overflow flag }
 SgnFlag            = $8000;                      { sign flag }
 NaNCheck           = $000F;                      { NaN or INF flag }
 MaskAllIntr        = $133F; { ? $0372;}          { to mask all fpu interrupts }
 Saved8087CW : word = $133F;                      { to save FPU defaults }

function isNAN(const X: Double): Boolean; overload;
begin
 Result:=(Dump(X)[3] and InfFlag=InfFlag) and (Dump(X)[3] and NaNCheck<>0) ;
end;

function isINF(const X: Double): Boolean; overload;
begin
 Result:=(Dump(X)[3] and InfFlag=InfFlag) and (Dump(X)[3] and NaNCheck=0) ;
end;

function isNANorINF(const X: Double): Boolean; overload;
begin
 Result:=(Dump(X)[3] and InfFlag=InfFlag);
end;

function _NaN: Double;
begin
 int64(Dump(Result)):=0;
 Dump(Result)[3]:=SgnFlag+InfFlag+NaNCheck;
end;

function _PlusInf: Double;
begin
 int64(Dump(Result)):=0;
 Dump(Result)[3]:=InfFlag;
end;

function _MinusInf: Double;
begin
 int64(Dump(Result)):=0;
 Dump(Result)[3]:=SgnFlag+InfFlag;
end;

function CheckDouble(const X: Double): Boolean;
begin
 Result:=false;
 if isNaN(X)  then begin
  CheckFpuMsg:= 'NAN';
  exit;
 end;
 if isINF(X)  then begin
  if Dump(X)[3] and SgnFlag = SgnFlag
  then CheckFpuMsg:='-INF'
  else CheckFpuMsg:='+INF';
  exit;
 end;
 Result:=true;
end;

function CheckSign(const X: Double): Boolean;
begin
 Result := Dump(X)[3] and SgnFlag = SgnFlag;
end;

function FpuInstalled: Boolean;
begin
 FpuInit;                                        { if FPU installed, after initialization }
 Result:=((FpuGetCtrlWord shr 8)=$03)            { upper byte of control word = 3 }
end;

procedure FpuSetExceptions(TurnOn : Boolean);
begin
 if TurnOn then Set8087CW(Saved8087CW) else Set8087CW(MaskAllIntr);
end;

function FpuGetStatus : Word;
asm
 FSTSW Result
end;

function FpuGetStatusClear : Word;
begin
 Result:=FpuGetStatus;
 FpuClearExceptions;
end;

function FpuGetStatusMsg(SW:word):ShortString;
 procedure Check(f:word; s:ShortString);
 begin
  if SW and f <> 0 then Result:=Result+s;
  SW:=SW and not f;
 end;
begin
 Result:='';
 Check(mIE,' IE');
 Check(mDE,' DE');
 Check(mZE,' ZE');
 Check(mOE,' OE');
 Check(mUE,' UE');
 Check(mPE,' PE');
 Check(mC0,' C0');
 Check(mC1,' C1');
 Check(mC2,' C2');
 Check(mC3,' C3');
 if SW<>0 then Result:=Result+' '+Format('%x4',[SW]);
end;

procedure FpuInit;
asm
 FINIT
end;

function FpuGetCtrlWord: Word;
asm
 FSTCW Result
end;

procedure FpuSetCtrlWord(CtrlWord: Word);
var CW : Word;
asm
 MOV    CW, CtrlWord  { Store CtrlWord in CW }
 FNCLEX               { don't raise pending exceptions enabled by the new flags }
 FLDCW  CW            { apply CW }
end;

procedure FpuClearExceptions;
asm
 FCLEX
end;

const
 cwChopCode : Integer = 0;

function PatchBug_cwChopCode:Integer;
begin
 Result:=cwChopCode;
end;

function PatchBug_cwChop(OnOff:Boolean):Boolean;
type
 TPatch = packed record
  cwChop    : Word;
  Dummy     : Word;
  two2neg32 : Double;
 end;
const
 cwChops : packed array[Boolean] of Word = ($1F3F, $1F32);
var
 Patch:^TPatch;
begin
 Result:=false;
 Patch:=IncPtr(@Default8087CW,$30);
 try
  if Patch.cwChop=cwChops[OnOff] then
  if Patch.two2neg32=((1.0/$10000)/$10000) then begin
   Patch.cwChop:=cwChops[not OnOff];
   cwChopCode:=Patch.cwChop;
   Result:=true;
  end else begin
   if Default8087CW=0 then              // 00 This stuff uses
   if HeapAllocFlags=0 then             // 04 only to link
   if DebugHook=0 then                  // 08 variables & functions
   if JITEnable=0 then                  // 0C to give known cwChop
   if NoErrMsg then                     // 10 offset
   if VarDispProc=nil then              // 14
   if DispCallByIDProc=nil then         // 18
   if LibModuleList=nil then            // 1C
   if ModuleUnloadList=nil then         // 20, MemoryManager 24
   if Trunc(Random)=0 then;             // 30 cwChop, 34 two2neg32
  end;
 except
  Result:=false;
 end;
end;

initialization

 Saved8087CW := Default8087CW; { get current FPU exceptions, system unit }
 FpuSetExceptions(false);      { turn off FPU exceptions                 }
 PatchBug_cwChop(true);        { patch bug for Delphi 5.0                }

finalization

end.
