////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Float Point Unit (FPU) procedures.                                         //
// Note:                                                                      //
// In FPC most FPU code located in system,math units, so only wrapper needed. //
// This unit disable all FPU exceptions at startup as it requires for CRWLIB. //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20010705 - Creation (uses CRW16) & test                                    //
// 20030217 - PatchBug_cwChop modified                                        //
// 20160623 - PatchBug_cwChopCode                                             //
// 20231123 - Modified for FPC (A.K.) - most code replaced to math unit calls //
// 20241109 - FpuSetCurrentModes                                              //
////////////////////////////////////////////////////////////////////////////////

unit _crw_fpu; // Float Point Unit routines.

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, math,
 _crw_alloc;

 // General FPU routines

function  isNAN(const X:Double):Boolean;       // check value is NAN
function  isINF(const X:Double):Boolean;       // check value is +/- INF
function  isNANorINF(const X:Double):Boolean;  // check value is NAN or INF
function  _NaN:Double;                         // return NAN  value
function  _PlusInf:Double;                     // return +INF value
function  _MinusInf:Double;                    // return -INF value
function  CheckSign(const X:Double):Boolean;   // check sign of X

 // Low-level FPU routines

type
 TFPUModes = packed record                     // FPU modes:
  Ex : TFPUExceptionMask;                      // Exception mask
  Pm : TFPUPrecisionMode;                      // Precision mode
  Rm : TFPURoundingMode;                       // Rounding mode
 end;

function  FpuGetCurrentModes:TFPUModes;        // Get/Set FPU current modes
procedure FpuSetCurrentModes(const M:TFPUModes; Force:Boolean=false);

function  FpuInstalled:Boolean;                // Check if hardware FPU onboard
procedure FpuSetExceptions(TurnOn:Boolean);    // Turn all FPU exceptions on/off
procedure FpuClearExceptions;                  // Clear FPU exception indicators

function  GetFpuModesAsText(const modes:TFPUModes):String;

function  IsSameFpuModes(const M1,M2:TFPUModes):Boolean;

var // Save FPU modes at startup
 FpuStartupModes : TFPUModes = ( Ex:[]; Pm:pmSingle; Rm:rmNearest );
 FpuInitialModes : TFPUModes = ( Ex:[]; Pm:pmSingle; Rm:rmNearest );
 FpuDefaultModes : TFPUModes = ( Ex:[]; Pm:pmSingle; Rm:rmNearest );

const // All available FPU exceptions for SetExceptionMask
 AllAvailableFpuExceptions = [Low(TFPUException)..High(TFPUException)];
 //[exInvalidOp,exDenormalized,exZeroDivide,exOverflow,exUnderflow,exPrecision]

implementation

function isNAN(const X:Double):Boolean;
begin
 Result:=Math.IsNan(X);
end;

function isINF(const X:Double):Boolean;
begin
 Result:=Math.IsInfinite(X);
end;

function isNANorINF(const X:Double):Boolean;
begin
 Result:=Math.IsNan(X) or Math.IsInfinite(X);
end;

function _NaN:Double;
begin
 Result:=Math.NaN;
end;

function _PlusInf:Double;
begin
 Result:=Math.Infinity;
end;

function _MinusInf:Double;
begin
 Result:=Math.NegInfinity;
end;

function CheckSign(const X:Double):Boolean;
begin
 Result:=TDoubleRec(X).Sign;
end;

function FpuInstalled: Boolean;
begin
 Result:=true; // Just for compatibility
end;

procedure FpuSetExceptions(TurnOn:Boolean);
begin
 if TurnOn
 then SetExceptionMask(FpuInitialModes.Ex)
 else SetExceptionMask(AllAvailableFpuExceptions);
end;

procedure FpuClearExceptions;
begin
 Math.ClearExceptions;
end;

function FpuGetCurrentModes:TFPUModes;
begin
 Result.Ex:=GetExceptionMask;
 Result.Pm:=GetPrecisionMode;
 Result.Rm:=GetRoundMode;
end;

procedure FpuSetCurrentModes(const M:TFPUModes; Force:Boolean=false);
begin
 if Force or (GetExceptionMask<>M.Ex) then SetExceptionMask(M.Ex);
 if Force or (GetPrecisionMode<>M.Pm) then SetPrecisionMode(M.Pm);
 if Force or (GetRoundMode<>M.Rm)     then SetRoundMode(M.Rm);
end;

function GetFpuModesAsText(const modes:TFPUModes):String;
 procedure CheckEx(x:TFPUException; s:String);
 begin
  if (x in modes.ex) then Result:=Result+' '+s;
 end;
 procedure CheckPm(x:TFPUPrecisionMode; s:String);
 begin
  if (x=modes.pm) then Result:=Result+' '+s;
 end;
 procedure CheckRm(x:TFPURoundingMode; s:String);
 begin
  if (x=modes.rm) then Result:=Result+' '+s;
 end;
begin
 Result:='';
 CheckEx(exInvalidOp,    'exInvalidOp');
 CheckEx(exDenormalized, 'exDenormalized');
 CheckEx(exZeroDivide,   'exZeroDivide');
 CheckEx(exOverflow,     'exOverflow');
 CheckEx(exUnderflow,    'exUnderflow');
 CheckEx(exPrecision,    'exPrecision');
 CheckPm(pmSingle,       'pmSingle');
 CheckPm(pmReserved,     'pmReserved');
 CheckPm(pmDouble,       'pmDouble');
 CheckPm(pmExtended,     'pmExtended');
 CheckRm(rmNearest,      'rmNearest');
 CheckRm(rmDown,         'rmDown');
 CheckRm(rmUp,           'rmUp');
 CheckRm(rmTruncate,     'rmTruncate');
 Result:=Trim(Result);
end;

function IsSameFpuModes(const M1,M2:TFPUModes):Boolean;
begin
 Result:=(M1.Ex=M2.Ex) and (M1.Pm=M2.Pm) and (M1.Rm=M2.Rm);
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_fpu;
begin
 FpuStartupModes:=FpuGetCurrentModes;
 FpuInitialModes:=FpuStartupModes;
 FpuSetExceptions(false);
 FpuClearExceptions;
 FpuDefaultModes:=FpuGetCurrentModes;
end;

procedure Free_crw_fpu;
begin
end;

initialization

 Init_crw_fpu;

finalization

 Free_crw_fpu;

end.

//////////////
// END OF FILE
//////////////

