udr/client/FBNumeric.pas

(*
 *  Firebird Interface (fbintf). The fbintf components provide a set of
 *  Pascal language bindings for the Firebird API. Although predominantly
 *  a new development they include source code taken from IBX and may be
 *  considered a derived product. This software thus also includes the copyright
 *  notice and license conditions from IBX.
 *
 *  Except for those parts dervied from IBX, contents of this file are subject
 *  to the Initial Developer's Public License Version 1.0 (the "License"); you
 *  may not use this file except in compliance with the License. You may obtain a
 *  copy of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2021 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit FBNumeric;

{$IFDEF MSWINDOWS}
{$DEFINE WINDOWS}
{$ENDIF}

{$IFDEF FPC}
{$mode delphi}
{$codepage UTF8}
{$interfaces COM}
{$ENDIF}

interface

uses
  Classes, SysUtils, IB, FBActivityMonitor, FmtBCD;

{ The IFBNumeric interface is a managed type to hold a fixed point integer
  as a 64-bit signed integer plus a scale factor. i.e. the scale factor is
  the base 10 exponent in

    Fixed Point Value = <64-bit signed integer> * 10^<scale factor>

}

function StrToNumeric(aValue: AnsiString): IFBNumeric;
function DoubleToNumeric(aValue: double): IFBNumeric;
function BCDToNumeric(aValue: TBCD): IFBNumeric;
function CurrToNumeric(aValue: currency): IFBNumeric;
function IntToNumeric(aValue: Int64): IFBNumeric;
function NumericFromRawValues(aValue: Int64; aScale: integer): IFBNumeric;
function NumericToDouble(aValue: Int64; aScale: integer): double;

function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;

function SafeSmallInt(aValue: Int64): Smallint;
function SafeInteger(aValue: Int64): integer;

{Numeric Arithmetic}
function NumericAdd(x,y: IFBNumeric): IFBNumeric; overload; {returns x + y}
function NumericSubtract(x,y: IFBNumeric): IFBNumeric; overload; {returns x - y}
function NumericMultiply(x,y: IFBNumeric): IFBNumeric; overload; {returns x * y}
function NumericDivide(x,y: IFBNumeric): IFBNumeric; overload; {returns x / y}
function NumericCompare(x,y: IFBNumeric): integer; overload; {returns -1: x < y; 0: x = y; 1: x > y}
function NegateNumeric(x: IFBNumeric): IFBNumeric; overload; {returns -x}

{integer operations}
function NumericAdd(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x + y}
function NumericSubtract(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x - y}
function NumericSubtract(x: int64; y: IFBNumeric): IFBNumeric; overload; {returns x - y}
function NumericMultiply(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x * y}
function NumericDivide(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x / y}
function NumericDivide(x: int64; y: IFBNumeric): IFBNumeric; overload; {returns x / y}
function NumericCompare(x: IFBNumeric; y: int64): integer; overload; {returns -1: x < y; 0: x = y; 1: x > y}

{floating point operations}
function NumericAdd(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x + y}
function NumericSubtract(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x - y}
function NumericSubtract(x: double; y: IFBNumeric): IFBNumeric; overload; {returns x - y}
function NumericMultiply(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x * y}
function NumericDivide(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x div y}
function NumericDivide(x: double; y: IFBNumeric): IFBNumeric; overload; {returns x div y}
function NumericCompare(x: IFBNumeric; y: double): integer; overload; {returns -1: x < y; 0: x = y; 1: x > y}

implementation

uses IBUtils, FBMessages, Math;

type

  { TIBNumeric }

  { TFBNumeric }

  TFBNumeric = class(TFBInterfacedObject,IFBNumeric)
  private
    FValue: Int64;
    FScale: integer;
  public
    constructor Create(aValue: Int64; aScale: integer);
    constructor CreateFromInt(aValue: Int64);
    constructor CreateFromStr(aValue: AnsiString);
    constructor CreateFromDouble(aValue: double);
    constructor CreateFromCurr(aValue: Currency);
    constructor CreateFromBCD(aValue: TBCD);
  public
    {IFBNumeric}
    function getRawValue: Int64;
    function getScale: integer;
    function AdjustScaleTo(aNewScale: integer): IFBNumeric;
    function getAsString: AnsiString;
    function getAsDouble: double;
    function getAsCurrency: Currency;
    function getAsBCD: TBCD;
    function getAsInt64: Int64; {scaled}
    function getAsInteger: integer; {scaled - may be truncated}
    function getAsSmallInt: SmallInt; {scaled - may be truncated}
  end;

function StrToNumeric(aValue: AnsiString): IFBNumeric;
begin
  Result :=  TFBNumeric.CreateFromStr(aValue);
end;

function DoubleToNumeric(aValue: double): IFBNumeric;
begin
  Result :=  TFBNumeric.CreateFromDouble(aValue);
end;

function BCDToNumeric(aValue: TBCD): IFBNumeric;
begin
  Result :=  TFBNumeric.CreateFromBCD(aValue);
end;

function CurrToNumeric(aValue: currency): IFBNumeric;
begin
  Result :=  TFBNumeric.CreateFromCurr(aValue);
end;

function IntToNumeric(aValue: Int64): IFBNumeric;
begin
  Result :=  TFBNumeric.CreateFromINT(aValue);
end;

function NumericFromRawValues(aValue: Int64; aScale: integer): IFBNumeric;
begin
  Result := TFBNumeric.Create(aValue,aScale);
end;

function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
var i: integer;
    ds: integer;
    exponent: integer;
begin
  Result := false;
  ds := 0;
  exponent := 0;
  S := Trim(S);
  Value := 0;
  scale := 0;
  if Length(S) = 0 then
    Exit;
  {$IF declared(DefaultFormatSettings)}
  with DefaultFormatSettings do
  {$ELSE}
  {$IF declared(FormatSettings)}
  with FormatSettings do
  {$IFEND}
  {$IFEND}
  begin
    for i := length(S) downto 1 do
    begin
      if S[i] = AnsiChar(DecimalSeparator) then
      begin
          if ds <> 0 then Exit; {only one allowed}
          ds := i;
          dec(exponent);
          system.Delete(S,i,1);
      end
      else
      if S[i] in ['+','-'] then
      begin
       if (i > 1) and not (S[i-1] in ['e','E']) then
          Exit; {malformed}
      end
      else
      if S[i] in ['e','E'] then {scientific notation}
      begin
        if ds <> 0 then Exit; {not permitted in exponent}
        if exponent <> 0 then Exit; {only one allowed}
        exponent := i;
      end
      else
      if not (S[i] in ['0'..'9']) then
      {Note: ThousandSeparator not allowed by Delphi specs}
          Exit; {bad character}
    end;

    if exponent > 0 then
    begin
      Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
      if Result then
      begin
        {adjust scale for decimal point}
        if ds <> 0 then
          Scale := Scale - (exponent - ds);
        Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
      end;
    end
    else
    begin
      if ds > 0 then
      begin
        {remove trailing zeroes}
        while (ds < length(S)) and (S[length(S)] = '0') do {no need to check length as ds > 0}
          system.delete(S,Length(S),1);
        scale := ds - Length(S) - 1;
      end;
      Result := TryStrToInt64(S,Value);
    end;
  end;
end;

function NumericToDouble(aValue: Int64; aScale: integer): double;
var rValue: extended;
begin
  rValue := aValue;
  Result := rValue * IntPower(10,aScale);
end;

function SafeSmallInt(aValue: Int64): Smallint;
begin
  if aValue > High(smallint) then
    IBError(ibxeIntegerOverflow,[]);
  if aValue < Low(smallint) then
    IBError(ibxIntegerUnderflow,[]);
  Result := aValue;
end;

function SafeInteger(aValue: Int64): integer;
begin
  if aValue > High(integer) then
    IBError(ibxeIntegerOverflow,[]);
  if aValue < Low(integer) then
    IBError(ibxIntegerUnderflow,[]);
  Result := aValue;
end;

{AdjustScale returns a raw int64 value derived from x but with aNewScale}

function AdjustScale(x: IFBNumeric; aNewScale: integer): int64;
begin
  Result := x.getRawValue;
  aNewScale := x.getScale - aNewScale;
  while aNewScale < 0 do
  begin
    Result := Round(Result / 10);
    Inc(aNewScale);
  end;
  while aNewScale > 0 do
  begin
    Result := Result * 10;
    Dec(aNewScale);
  end;
end;

function CompareInt(a,b: integer): integer;
begin
  if a < b then
    Result := -1
  else
  if a = b then
    Result := 0
  else
    Result := 1;
end;

function NumericAdd(x, y: IFBNumeric): IFBNumeric;
begin
  case CompareInt(x.getScale,y.getScale) of
  0:
    Result := NumericFromRawValues(x.getRawValue + y.getRawValue,x.getScale);
  1:
    Result := NumericFromRawValues(AdjustScale(x,y.getscale) + y.getRawValue,y.getScale);
  else
    Result := NumericFromRawValues(AdjustScale(y,x.getscale)  + x.getRawValue,x.getScale);
  end;
end;

function NumericSubtract(x, y: IFBNumeric): IFBNumeric;
begin
  case CompareInt(x.getScale,y.getScale) of
  0:
    Result := NumericFromRawValues(x.getRawValue - y.getRawValue,x.getScale);
  1:
    Result := NumericFromRawValues(AdjustScale(x,y.getscale) - y.getRawValue,y.getScale);
  else
    Result := NumericFromRawValues(AdjustScale(y,x.getscale) - x.getRawValue,x.getScale);
  end;
end;

function NumericMultiply(x, y: IFBNumeric): IFBNumeric;
begin
  Result := NumericFromRawValues(x.getRawValue * y.getRawValue,x.getScale+y.getScale);
end;

function NumericDivide(x, y: IFBNumeric): IFBNumeric;
var z: double;
begin
  {Compute actual value as a double}
  z := (x.getRawValue / y.getRawValue) * IntPower(10, x.getScale - y.getScale);
  {Return numeric at original no. of decimal places of numerator}
  Result := DoubleTONumeric(z).AdjustScaleTo(x.getScale);
end;

function NumericCompare(x, y: IFBNumeric): integer;
begin
  case CompareInt(x.getScale,y.getScale) of
  0:
    Result := CompareInt(x.getRawValue,y.getRawValue);
  1:
    Result := CompareInt(AdjustScale(x,y.getscale),y.getRawValue);
  else
    Result := CompareInt(x.getRawValue,AdjustScale(y,x.getscale));
  end;
end;

function NegateNumeric(x: IFBNumeric): IFBNumeric;
begin
  Result := NumericFromRawValues(-x.getRawValue,x.getScale);
end;

function NumericAdd(x: IFBNumeric; y: int64): IFBNumeric;
begin
  Result := NumericAdd(x,IntToNumeric(y));
end;

function NumericSubtract(x: IFBNumeric; y: int64): IFBNumeric;
begin
  Result := NumericSubtract(x,IntToNumeric(y));
end;

function NumericSubtract(x: int64; y: IFBNumeric): IFBNumeric;
begin
  Result := NumericSubtract(IntToNumeric(x),y);
end;

function NumericMultiply(x: IFBNumeric; y: int64): IFBNumeric;
begin
  Result := NumericMultiply(x,IntToNumeric(y));
end;

function NumericDivide(x: IFBNumeric; y: int64): IFBNumeric;
begin
  Result := NumericDivide(x,IntToNumeric(y));
end;

function NumericDivide(x: int64; y: IFBNumeric): IFBNumeric;
begin
  Result := NumericDivide(IntToNumeric(x),y);
end;

function NumericCompare(x: IFBNumeric; y: int64): integer;
begin
  Result := NumericCompare(x,IntToNumeric(y));
end;

function NumericAdd(x: IFBNumeric; y: double): IFBNumeric;
begin
  Result := NumericAdd(x,DoubleToNumeric(y));
end;

function NumericSubtract(x: IFBNumeric; y: double): IFBNumeric;
begin
  Result := NumericSubtract(x,DoubleToNumeric(y));
end;

function NumericSubtract(x: double; y: IFBNumeric): IFBNumeric;
begin
  Result := NumericSubtract(DoubleToNumeric(x),y);
end;

function NumericMultiply(x: IFBNumeric; y: double): IFBNumeric;
begin
  Result := NumericMultiply(x,DoubleToNumeric(y));
end;

function NumericDivide(x: IFBNumeric; y: double): IFBNumeric;
begin
  Result := NumericDivide(x,DoubleToNumeric(y));
end;

function NumericDivide(x: double; y: IFBNumeric): IFBNumeric;
begin
  Result := NumericDivide(DoubleToNumeric(x),y);
end;

function NumericCompare(x: IFBNumeric; y: double): integer;
begin
  Result := NumericCompare(x,DoubleToNumeric(y));
end;

constructor TFBNumeric.Create(aValue: Int64; aScale: integer);
begin
  inherited Create;
  FValue := aValue;
  FScale := aScale;
end;

constructor TFBNumeric.CreateFromInt(aValue: Int64);
begin
  inherited Create;
  FValue := aValue;
  FScale := 0;
end;

constructor TFBNumeric.CreateFromStr(aValue: AnsiString);
begin
  inherited Create;
  if not TryStrToNumeric(aValue,FValue,FScale) then
    IBError(ibxeInvalidDataConversion,[aValue]);
end;

constructor TFBNumeric.CreateFromDouble(aValue: double);

  function WithinLimits(a: double): boolean;
  begin
    a := abs(frac(a));
    Result := (a > 0.001) and (a < 0.999); {avoid small rounding errors converting to decimal}
  end;

var aScale: integer;
    i: int64;
begin
  aScale := 0;
  while WithinLimits(AValue) do
  begin
    aValue := aValue * 10;
    Inc(aScale);
  end;
  i := Round(aValue);
  Create(i,-aScale);
end;

constructor TFBNumeric.CreateFromCurr(aValue: Currency);
begin
  inherited Create;
  Move(aValue,FValue,sizeof(Int64));
  FScale := -4;
end;

constructor TFBNumeric.CreateFromBCD(aValue: TBCD);
var ScaledBCD: TBCD;
begin
  inherited Create;
  FScale := -BCDScale(aValue);
  BCDMultiply(aValue,Power(10,-FScale),ScaledBCD);
  FValue := BCDToInteger(ScaledBCD,true);
end;

function TFBNumeric.getRawValue: Int64;
begin
  Result := FValue;
end;

function TFBNumeric.getScale: integer;
begin
 Result := FScale;
end;

function TFBNumeric.AdjustScaleTo(aNewScale: integer): IFBNumeric;
begin
 if FScale = aNewScale then
   Result := TFBNumeric.Create(FValue,FScale)
 else
  Result := TFBNumeric.Create(AdjustScale(self,aNewScale),aNewScale);
end;

function TFBNumeric.getAsString: AnsiString;
var Scaling : AnsiString;
    i: Integer;
begin
  Result := IntToStr(FValue);
  Scaling := '';
  if FScale > 0 then
  begin
    for i := 1 to FScale do
      Result := Result + '0';
  end
  else
  if FScale < 0 then
  {$IF declared(DefaultFormatSettings)}
  with DefaultFormatSettings do
  {$ELSE}
  {$IF declared(FormatSettings)}
  with FormatSettings do
  {$IFEND}
  {$IFEND}
  begin
    if Length(Result) > -FScale then
      system.Insert(DecimalSeparator,Result,Length(Result) + FScale+1)
    else
    begin
      Scaling := '0' + DecimalSeparator;
      for i := -1 downto FScale + Length(Result) do
        Scaling := Scaling + '0';
      if FValue < 0 then
        system.insert(Scaling,Result,2)
      else
        Result := Scaling + Result;
    end;
  end;
end;

function TFBNumeric.getAsDouble: double;
begin
  Result := NumericToDouble(FValue,FScale);
end;

function TFBNumeric.getAsCurrency: Currency;
var value: int64;
begin
  if FScale <> -4 then
  begin
    value := AdjustScaleTo(-4).GetRawValue;
    Move(value,Result,sizeof(Currency));
  end
  else
    Move(FValue,Result,sizeof(Currency));
end;

function TFBNumeric.getAsBCD: TBCD;
begin
  Result := DoubleToBCD(getAsDouble);
end;

function TFBNumeric.getAsInt64: Int64;
var
  Scaling : Int64;
  i: Integer;
  Val: Int64;
begin
  Scaling := 1;
  Val := FValue;
  if FScale > 0 then begin
    for i := 1 to FScale do Scaling := Scaling * 10;
    result := Val * Scaling;
  end else if FScale < 0 then begin
    for i := -1 downto FScale do Scaling := Scaling * 10;
    result := Val div Scaling;
  end else
    result := Val;
end;

function TFBNumeric.getAsInteger: integer;
begin
  Result := SafeInteger(getAsInt64);
end;

function TFBNumeric.getAsSmallInt: SmallInt;
begin
  Result := SafeSmallInt(getAsInt64);
end;

end.

Revision:	383
Committed:	Sat Jan 15 16:02:25 2022 UTC (2 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	15631 byte(s)
Log Message:	use integer arithmetic for adjust scale in FBNumeric
#	User	Rev	Content
1	tony	371	(*
2			* Firebird Interface (fbintf). The fbintf components provide a set of
3			* Pascal language bindings for the Firebird API. Although predominantly
4			* a new development they include source code taken from IBX and may be
5			* considered a derived product. This software thus also includes the copyright
6			* notice and license conditions from IBX.
7			*
8			* Except for those parts dervied from IBX, contents of this file are subject
9			* to the Initial Developer's Public License Version 1.0 (the "License"); you
10			* may not use this file except in compliance with the License. You may obtain a
11			* copy of the License here:
12			*
13			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
14			*
15			* Software distributed under the License is distributed on an "AS
16			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17			* implied. See the License for the specific language governing rights
18			* and limitations under the License.
19			*
20			* The Initial Developer of the Original Code is Tony Whyman.
21			*
22			* The Original Code is (C) 2021 Tony Whyman, MWA Software
23			* (http://www.mwasoftware.co.uk).
24			*
25			* All Rights Reserved.
26			*
27			* Contributor(s): ______________________________________.
28			*
29			*)
30			unit FBNumeric;
31
32			{$IFDEF MSWINDOWS}
33			{$DEFINE WINDOWS}
34			{$ENDIF}
35
36			{$IFDEF FPC}
37			{$mode delphi}
38			{$codepage UTF8}
39			{$interfaces COM}
40			{$ENDIF}
41
42			interface
43
44			uses
45			Classes, SysUtils, IB, FBActivityMonitor, FmtBCD;
46
47			{ The IFBNumeric interface is a managed type to hold a fixed point integer
48			as a 64-bit signed integer plus a scale factor. i.e. the scale factor is
49			the base 10 exponent in
50
51			Fixed Point Value = <64-bit signed integer> * 10^<scale factor>
52
53			}
54
55	tony	381	function StrToNumeric(aValue: AnsiString): IFBNumeric;
56			function DoubleToNumeric(aValue: double): IFBNumeric;
57			function BCDToNumeric(aValue: TBCD): IFBNumeric;
58			function CurrToNumeric(aValue: currency): IFBNumeric;
59			function IntToNumeric(aValue: Int64): IFBNumeric;
60	tony	371	function NumericFromRawValues(aValue: Int64; aScale: integer): IFBNumeric;
61	tony	381	function NumericToDouble(aValue: Int64; aScale: integer): double;
62	tony	371
63			function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
64
65			function SafeSmallInt(aValue: Int64): Smallint;
66			function SafeInteger(aValue: Int64): integer;
67
68	tony	381	{Numeric Arithmetic}
69			function NumericAdd(x,y: IFBNumeric): IFBNumeric; overload; {returns x + y}
70			function NumericSubtract(x,y: IFBNumeric): IFBNumeric; overload; {returns x - y}
71			function NumericMultiply(x,y: IFBNumeric): IFBNumeric; overload; {returns x * y}
72			function NumericDivide(x,y: IFBNumeric): IFBNumeric; overload; {returns x / y}
73			function NumericCompare(x,y: IFBNumeric): integer; overload; {returns -1: x < y; 0: x = y; 1: x > y}
74			function NegateNumeric(x: IFBNumeric): IFBNumeric; overload; {returns -x}
75	tony	371
76	tony	381	{integer operations}
77			function NumericAdd(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x + y}
78			function NumericSubtract(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x - y}
79			function NumericSubtract(x: int64; y: IFBNumeric): IFBNumeric; overload; {returns x - y}
80			function NumericMultiply(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x * y}
81			function NumericDivide(x: IFBNumeric; y: int64): IFBNumeric; overload; {returns x / y}
82			function NumericDivide(x: int64; y: IFBNumeric): IFBNumeric; overload; {returns x / y}
83			function NumericCompare(x: IFBNumeric; y: int64): integer; overload; {returns -1: x < y; 0: x = y; 1: x > y}
84
85			{floating point operations}
86			function NumericAdd(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x + y}
87			function NumericSubtract(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x - y}
88			function NumericSubtract(x: double; y: IFBNumeric): IFBNumeric; overload; {returns x - y}
89			function NumericMultiply(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x * y}
90			function NumericDivide(x: IFBNumeric; y: double): IFBNumeric; overload; {returns x div y}
91			function NumericDivide(x: double; y: IFBNumeric): IFBNumeric; overload; {returns x div y}
92			function NumericCompare(x: IFBNumeric; y: double): integer; overload; {returns -1: x < y; 0: x = y; 1: x > y}
93
94	tony	371	implementation
95
96			uses IBUtils, FBMessages, Math;
97
98			type
99
100			{ TIBNumeric }
101
102			{ TFBNumeric }
103
104			TFBNumeric = class(TFBInterfacedObject,IFBNumeric)
105			private
106			FValue: Int64;
107			FScale: integer;
108			public
109	tony	381	constructor Create(aValue: Int64; aScale: integer);
110			constructor CreateFromInt(aValue: Int64);
111			constructor CreateFromStr(aValue: AnsiString);
112			constructor CreateFromDouble(aValue: double);
113			constructor CreateFromCurr(aValue: Currency);
114			constructor CreateFromBCD(aValue: TBCD);
115	tony	371	public
116			{IFBNumeric}
117			function getRawValue: Int64;
118			function getScale: integer;
119	tony	381	function AdjustScaleTo(aNewScale: integer): IFBNumeric;
120	tony	371	function getAsString: AnsiString;
121			function getAsDouble: double;
122			function getAsCurrency: Currency;
123			function getAsBCD: TBCD;
124			function getAsInt64: Int64; {scaled}
125			function getAsInteger: integer; {scaled - may be truncated}
126			function getAsSmallInt: SmallInt; {scaled - may be truncated}
127			end;
128
129	tony	381	function StrToNumeric(aValue: AnsiString): IFBNumeric;
130	tony	371	begin
131	tony	381	Result := TFBNumeric.CreateFromStr(aValue);
132	tony	371	end;
133
134	tony	381	function DoubleToNumeric(aValue: double): IFBNumeric;
135	tony	371	begin
136	tony	381	Result := TFBNumeric.CreateFromDouble(aValue);
137	tony	371	end;
138
139	tony	381	function BCDToNumeric(aValue: TBCD): IFBNumeric;
140	tony	371	begin
141	tony	381	Result := TFBNumeric.CreateFromBCD(aValue);
142	tony	371	end;
143
144	tony	381	function CurrToNumeric(aValue: currency): IFBNumeric;
145	tony	371	begin
146	tony	381	Result := TFBNumeric.CreateFromCurr(aValue);
147	tony	371	end;
148
149	tony	381	function IntToNumeric(aValue: Int64): IFBNumeric;
150	tony	371	begin
151	tony	381	Result := TFBNumeric.CreateFromINT(aValue);
152	tony	371	end;
153
154			function NumericFromRawValues(aValue: Int64; aScale: integer): IFBNumeric;
155			begin
156			Result := TFBNumeric.Create(aValue,aScale);
157			end;
158
159			function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
160			var i: integer;
161			ds: integer;
162			exponent: integer;
163			begin
164			Result := false;
165			ds := 0;
166			exponent := 0;
167			S := Trim(S);
168			Value := 0;
169			scale := 0;
170			if Length(S) = 0 then
171			Exit;
172			{$IF declared(DefaultFormatSettings)}
173			with DefaultFormatSettings do
174			{$ELSE}
175			{$IF declared(FormatSettings)}
176			with FormatSettings do
177			{$IFEND}
178			{$IFEND}
179			begin
180			for i := length(S) downto 1 do
181			begin
182			if S[i] = AnsiChar(DecimalSeparator) then
183			begin
184			if ds <> 0 then Exit; {only one allowed}
185			ds := i;
186			dec(exponent);
187			system.Delete(S,i,1);
188			end
189			else
190			if S[i] in ['+','-'] then
191			begin
192			if (i > 1) and not (S[i-1] in ['e','E']) then
193			Exit; {malformed}
194			end
195			else
196			if S[i] in ['e','E'] then {scientific notation}
197			begin
198			if ds <> 0 then Exit; {not permitted in exponent}
199			if exponent <> 0 then Exit; {only one allowed}
200			exponent := i;
201			end
202			else
203			if not (S[i] in ['0'..'9']) then
204			{Note: ThousandSeparator not allowed by Delphi specs}
205			Exit; {bad character}
206			end;
207
208			if exponent > 0 then
209			begin
210			Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
211			if Result then
212			begin
213			{adjust scale for decimal point}
214			if ds <> 0 then
215			Scale := Scale - (exponent - ds);
216			Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
217			end;
218			end
219			else
220			begin
221			if ds > 0 then
222			begin
223			{remove trailing zeroes}
224			while (ds < length(S)) and (S[length(S)] = '0') do {no need to check length as ds > 0}
225			system.delete(S,Length(S),1);
226			scale := ds - Length(S) - 1;
227			end;
228			Result := TryStrToInt64(S,Value);
229			end;
230			end;
231			end;
232
233			function NumericToDouble(aValue: Int64; aScale: integer): double;
234	tony	383	var rValue: extended;
235	tony	371	begin
236	tony	383	rValue := aValue;
237			Result := rValue * IntPower(10,aScale);
238	tony	371	end;
239
240			function SafeSmallInt(aValue: Int64): Smallint;
241			begin
242			if aValue > High(smallint) then
243			IBError(ibxeIntegerOverflow,[]);
244			if aValue < Low(smallint) then
245			IBError(ibxIntegerUnderflow,[]);
246			Result := aValue;
247			end;
248
249			function SafeInteger(aValue: Int64): integer;
250			begin
251			if aValue > High(integer) then
252			IBError(ibxeIntegerOverflow,[]);
253			if aValue < Low(integer) then
254			IBError(ibxIntegerUnderflow,[]);
255			Result := aValue;
256			end;
257
258	tony	381	{AdjustScale returns a raw int64 value derived from x but with aNewScale}
259	tony	371
260	tony	381	function AdjustScale(x: IFBNumeric; aNewScale: integer): int64;
261	tony	371	begin
262	tony	383	Result := x.getRawValue;
263			aNewScale := x.getScale - aNewScale;
264			while aNewScale < 0 do
265			begin
266			Result := Round(Result / 10);
267			Inc(aNewScale);
268			end;
269			while aNewScale > 0 do
270			begin
271			Result := Result * 10;
272			Dec(aNewScale);
273			end;
274	tony	381	end;
275
276			function CompareInt(a,b: integer): integer;
277			begin
278			if a < b then
279			Result := -1
280	tony	371	else
281	tony	381	if a = b then
282			Result := 0
283	tony	371	else
284	tony	381	Result := 1;
285			end;
286	tony	371
287	tony	381	function NumericAdd(x, y: IFBNumeric): IFBNumeric;
288			begin
289			case CompareInt(x.getScale,y.getScale) of
290			0:
291			Result := NumericFromRawValues(x.getRawValue + y.getRawValue,x.getScale);
292			1:
293			Result := NumericFromRawValues(AdjustScale(x,y.getscale) + y.getRawValue,y.getScale);
294			else
295			Result := NumericFromRawValues(AdjustScale(y,x.getscale) + x.getRawValue,x.getScale);
296			end;
297			end;
298
299			function NumericSubtract(x, y: IFBNumeric): IFBNumeric;
300			begin
301			case CompareInt(x.getScale,y.getScale) of
302			0:
303			Result := NumericFromRawValues(x.getRawValue - y.getRawValue,x.getScale);
304			1:
305			Result := NumericFromRawValues(AdjustScale(x,y.getscale) - y.getRawValue,y.getScale);
306			else
307			Result := NumericFromRawValues(AdjustScale(y,x.getscale) - x.getRawValue,x.getScale);
308			end;
309			end;
310
311			function NumericMultiply(x, y: IFBNumeric): IFBNumeric;
312			begin
313			Result := NumericFromRawValues(x.getRawValue * y.getRawValue,x.getScale+y.getScale);
314			end;
315
316			function NumericDivide(x, y: IFBNumeric): IFBNumeric;
317			var z: double;
318			begin
319			{Compute actual value as a double}
320			z := (x.getRawValue / y.getRawValue) * IntPower(10, x.getScale - y.getScale);
321			{Return numeric at original no. of decimal places of numerator}
322			Result := DoubleTONumeric(z).AdjustScaleTo(x.getScale);
323			end;
324
325			function NumericCompare(x, y: IFBNumeric): integer;
326			begin
327			case CompareInt(x.getScale,y.getScale) of
328			0:
329			Result := CompareInt(x.getRawValue,y.getRawValue);
330			1:
331			Result := CompareInt(AdjustScale(x,y.getscale),y.getRawValue);
332			else
333			Result := CompareInt(x.getRawValue,AdjustScale(y,x.getscale));
334			end;
335			end;
336
337			function NegateNumeric(x: IFBNumeric): IFBNumeric;
338			begin
339			Result := NumericFromRawValues(-x.getRawValue,x.getScale);
340			end;
341
342			function NumericAdd(x: IFBNumeric; y: int64): IFBNumeric;
343			begin
344			Result := NumericAdd(x,IntToNumeric(y));
345			end;
346
347			function NumericSubtract(x: IFBNumeric; y: int64): IFBNumeric;
348			begin
349			Result := NumericSubtract(x,IntToNumeric(y));
350			end;
351
352			function NumericSubtract(x: int64; y: IFBNumeric): IFBNumeric;
353			begin
354			Result := NumericSubtract(IntToNumeric(x),y);
355			end;
356
357			function NumericMultiply(x: IFBNumeric; y: int64): IFBNumeric;
358			begin
359			Result := NumericMultiply(x,IntToNumeric(y));
360			end;
361
362			function NumericDivide(x: IFBNumeric; y: int64): IFBNumeric;
363			begin
364			Result := NumericDivide(x,IntToNumeric(y));
365			end;
366
367			function NumericDivide(x: int64; y: IFBNumeric): IFBNumeric;
368			begin
369			Result := NumericDivide(IntToNumeric(x),y);
370			end;
371
372			function NumericCompare(x: IFBNumeric; y: int64): integer;
373			begin
374			Result := NumericCompare(x,IntToNumeric(y));
375			end;
376
377			function NumericAdd(x: IFBNumeric; y: double): IFBNumeric;
378			begin
379			Result := NumericAdd(x,DoubleToNumeric(y));
380			end;
381
382			function NumericSubtract(x: IFBNumeric; y: double): IFBNumeric;
383			begin
384			Result := NumericSubtract(x,DoubleToNumeric(y));
385			end;
386
387			function NumericSubtract(x: double; y: IFBNumeric): IFBNumeric;
388			begin
389			Result := NumericSubtract(DoubleToNumeric(x),y);
390			end;
391
392			function NumericMultiply(x: IFBNumeric; y: double): IFBNumeric;
393			begin
394			Result := NumericMultiply(x,DoubleToNumeric(y));
395			end;
396
397			function NumericDivide(x: IFBNumeric; y: double): IFBNumeric;
398			begin
399			Result := NumericDivide(x,DoubleToNumeric(y));
400			end;
401
402			function NumericDivide(x: double; y: IFBNumeric): IFBNumeric;
403			begin
404			Result := NumericDivide(DoubleToNumeric(x),y);
405			end;
406
407			function NumericCompare(x: IFBNumeric; y: double): integer;
408			begin
409			Result := NumericCompare(x,DoubleToNumeric(y));
410			end;
411
412	tony	371	constructor TFBNumeric.Create(aValue: Int64; aScale: integer);
413			begin
414			inherited Create;
415			FValue := aValue;
416			FScale := aScale;
417			end;
418
419	tony	381	constructor TFBNumeric.CreateFromInt(aValue: Int64);
420	tony	371	begin
421			inherited Create;
422			FValue := aValue;
423			FScale := 0;
424			end;
425
426	tony	381	constructor TFBNumeric.CreateFromStr(aValue: AnsiString);
427	tony	371	begin
428			inherited Create;
429			if not TryStrToNumeric(aValue,FValue,FScale) then
430			IBError(ibxeInvalidDataConversion,[aValue]);
431			end;
432
433	tony	381	constructor TFBNumeric.CreateFromDouble(aValue: double);
434
435			function WithinLimits(a: double): boolean;
436			begin
437			a := abs(frac(a));
438			Result := (a > 0.001) and (a < 0.999); {avoid small rounding errors converting to decimal}
439			end;
440
441			var aScale: integer;
442			i: int64;
443	tony	371	begin
444	tony	381	aScale := 0;
445			while WithinLimits(AValue) do
446	tony	371	begin
447	tony	381	aValue := aValue * 10;
448			Inc(aScale);
449			end;
450			i := Round(aValue);
451			Create(i,-aScale);
452	tony	371	end;
453
454	tony	381	constructor TFBNumeric.CreateFromCurr(aValue: Currency);
455	tony	371	begin
456			inherited Create;
457			Move(aValue,FValue,sizeof(Int64));
458			FScale := -4;
459			end;
460
461	tony	381	constructor TFBNumeric.CreateFromBCD(aValue: TBCD);
462	tony	371	var ScaledBCD: TBCD;
463			begin
464			inherited Create;
465			FScale := -BCDScale(aValue);
466			BCDMultiply(aValue,Power(10,-FScale),ScaledBCD);
467			FValue := BCDToInteger(ScaledBCD,true);
468			end;
469
470			function TFBNumeric.getRawValue: Int64;
471			begin
472			Result := FValue;
473			end;
474
475			function TFBNumeric.getScale: integer;
476			begin
477			Result := FScale;
478			end;
479
480	tony	381	function TFBNumeric.AdjustScaleTo(aNewScale: integer): IFBNumeric;
481	tony	371	begin
482	tony	375	if FScale = aNewScale then
483			Result := TFBNumeric.Create(FValue,FScale)
484			else
485	tony	381	Result := TFBNumeric.Create(AdjustScale(self,aNewScale),aNewScale);
486	tony	371	end;
487
488			function TFBNumeric.getAsString: AnsiString;
489			var Scaling : AnsiString;
490			i: Integer;
491			begin
492			Result := IntToStr(FValue);
493			Scaling := '';
494			if FScale > 0 then
495			begin
496			for i := 1 to FScale do
497			Result := Result + '0';
498			end
499			else
500			if FScale < 0 then
501			{$IF declared(DefaultFormatSettings)}
502			with DefaultFormatSettings do
503			{$ELSE}
504			{$IF declared(FormatSettings)}
505			with FormatSettings do
506			{$IFEND}
507			{$IFEND}
508			begin
509			if Length(Result) > -FScale then
510			system.Insert(DecimalSeparator,Result,Length(Result) + FScale+1)
511			else
512			begin
513			Scaling := '0' + DecimalSeparator;
514			for i := -1 downto FScale + Length(Result) do
515			Scaling := Scaling + '0';
516			if FValue < 0 then
517			system.insert(Scaling,Result,2)
518			else
519			Result := Scaling + Result;
520			end;
521			end;
522			end;
523
524			function TFBNumeric.getAsDouble: double;
525			begin
526			Result := NumericToDouble(FValue,FScale);
527			end;
528
529			function TFBNumeric.getAsCurrency: Currency;
530			var value: int64;
531			begin
532			if FScale <> -4 then
533			begin
534	tony	381	value := AdjustScaleTo(-4).GetRawValue;
535	tony	371	Move(value,Result,sizeof(Currency));
536	tony	375	end
537	tony	371	else
538			Move(FValue,Result,sizeof(Currency));
539			end;
540
541			function TFBNumeric.getAsBCD: TBCD;
542			begin
543			Result := DoubleToBCD(getAsDouble);
544			end;
545
546			function TFBNumeric.getAsInt64: Int64;
547			var
548			Scaling : Int64;
549			i: Integer;
550			Val: Int64;
551			begin
552			Scaling := 1;
553			Val := FValue;
554			if FScale > 0 then begin
555			for i := 1 to FScale do Scaling := Scaling * 10;
556			result := Val * Scaling;
557			end else if FScale < 0 then begin
558			for i := -1 downto FScale do Scaling := Scaling * 10;
559			result := Val div Scaling;
560			end else
561			result := Val;
562			end;
563
564			function TFBNumeric.getAsInteger: integer;
565			begin
566			Result := SafeInteger(getAsInt64);
567			end;
568
569			function TFBNumeric.getAsSmallInt: SmallInt;
570			begin
571			Result := SafeSmallInt(getAsInt64);
572			end;
573
574			end.
575