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;
begin
  Result := aValue * 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;
var rValue: double;
begin
  rValue := x.getrawValue;
  Result := Round(rValue * IntPower(10,x.getScale-aNewScale));
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:	381
Committed:	Sat Jan 15 00:06:22 2022 UTC (2 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	15452 byte(s)
Log Message:	Release Candidate 1
#	Content
1	(*
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	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	function NumericFromRawValues(aValue: Int64; aScale: integer): IFBNumeric;
61	function NumericToDouble(aValue: Int64; aScale: integer): double;
62
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	{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
76	{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	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	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	public
116	{IFBNumeric}
117	function getRawValue: Int64;
118	function getScale: integer;
119	function AdjustScaleTo(aNewScale: integer): IFBNumeric;
120	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	function StrToNumeric(aValue: AnsiString): IFBNumeric;
130	begin
131	Result := TFBNumeric.CreateFromStr(aValue);
132	end;
133
134	function DoubleToNumeric(aValue: double): IFBNumeric;
135	begin
136	Result := TFBNumeric.CreateFromDouble(aValue);
137	end;
138
139	function BCDToNumeric(aValue: TBCD): IFBNumeric;
140	begin
141	Result := TFBNumeric.CreateFromBCD(aValue);
142	end;
143
144	function CurrToNumeric(aValue: currency): IFBNumeric;
145	begin
146	Result := TFBNumeric.CreateFromCurr(aValue);
147	end;
148
149	function IntToNumeric(aValue: Int64): IFBNumeric;
150	begin
151	Result := TFBNumeric.CreateFromINT(aValue);
152	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	begin
235	Result := aValue * IntPower(10,aScale);
236	end;
237
238	function SafeSmallInt(aValue: Int64): Smallint;
239	begin
240	if aValue > High(smallint) then
241	IBError(ibxeIntegerOverflow,[]);
242	if aValue < Low(smallint) then
243	IBError(ibxIntegerUnderflow,[]);
244	Result := aValue;
245	end;
246
247	function SafeInteger(aValue: Int64): integer;
248	begin
249	if aValue > High(integer) then
250	IBError(ibxeIntegerOverflow,[]);
251	if aValue < Low(integer) then
252	IBError(ibxIntegerUnderflow,[]);
253	Result := aValue;
254	end;
255
256	{AdjustScale returns a raw int64 value derived from x but with aNewScale}
257
258	function AdjustScale(x: IFBNumeric; aNewScale: integer): int64;
259	var rValue: double;
260	begin
261	rValue := x.getrawValue;
262	Result := Round(rValue * IntPower(10,x.getScale-aNewScale));
263	end;
264
265	function CompareInt(a,b: integer): integer;
266	begin
267	if a < b then
268	Result := -1
269	else
270	if a = b then
271	Result := 0
272	else
273	Result := 1;
274	end;
275
276	function NumericAdd(x, y: IFBNumeric): IFBNumeric;
277	begin
278	case CompareInt(x.getScale,y.getScale) of
279	0:
280	Result := NumericFromRawValues(x.getRawValue + y.getRawValue,x.getScale);
281	1:
282	Result := NumericFromRawValues(AdjustScale(x,y.getscale) + y.getRawValue,y.getScale);
283	else
284	Result := NumericFromRawValues(AdjustScale(y,x.getscale) + x.getRawValue,x.getScale);
285	end;
286	end;
287
288	function NumericSubtract(x, y: IFBNumeric): IFBNumeric;
289	begin
290	case CompareInt(x.getScale,y.getScale) of
291	0:
292	Result := NumericFromRawValues(x.getRawValue - y.getRawValue,x.getScale);
293	1:
294	Result := NumericFromRawValues(AdjustScale(x,y.getscale) - y.getRawValue,y.getScale);
295	else
296	Result := NumericFromRawValues(AdjustScale(y,x.getscale) - x.getRawValue,x.getScale);
297	end;
298	end;
299
300	function NumericMultiply(x, y: IFBNumeric): IFBNumeric;
301	begin
302	Result := NumericFromRawValues(x.getRawValue * y.getRawValue,x.getScale+y.getScale);
303	end;
304
305	function NumericDivide(x, y: IFBNumeric): IFBNumeric;
306	var z: double;
307	begin
308	{Compute actual value as a double}
309	z := (x.getRawValue / y.getRawValue) * IntPower(10, x.getScale - y.getScale);
310	{Return numeric at original no. of decimal places of numerator}
311	Result := DoubleTONumeric(z).AdjustScaleTo(x.getScale);
312	end;
313
314	function NumericCompare(x, y: IFBNumeric): integer;
315	begin
316	case CompareInt(x.getScale,y.getScale) of
317	0:
318	Result := CompareInt(x.getRawValue,y.getRawValue);
319	1:
320	Result := CompareInt(AdjustScale(x,y.getscale),y.getRawValue);
321	else
322	Result := CompareInt(x.getRawValue,AdjustScale(y,x.getscale));
323	end;
324	end;
325
326	function NegateNumeric(x: IFBNumeric): IFBNumeric;
327	begin
328	Result := NumericFromRawValues(-x.getRawValue,x.getScale);
329	end;
330
331	function NumericAdd(x: IFBNumeric; y: int64): IFBNumeric;
332	begin
333	Result := NumericAdd(x,IntToNumeric(y));
334	end;
335
336	function NumericSubtract(x: IFBNumeric; y: int64): IFBNumeric;
337	begin
338	Result := NumericSubtract(x,IntToNumeric(y));
339	end;
340
341	function NumericSubtract(x: int64; y: IFBNumeric): IFBNumeric;
342	begin
343	Result := NumericSubtract(IntToNumeric(x),y);
344	end;
345
346	function NumericMultiply(x: IFBNumeric; y: int64): IFBNumeric;
347	begin
348	Result := NumericMultiply(x,IntToNumeric(y));
349	end;
350
351	function NumericDivide(x: IFBNumeric; y: int64): IFBNumeric;
352	begin
353	Result := NumericDivide(x,IntToNumeric(y));
354	end;
355
356	function NumericDivide(x: int64; y: IFBNumeric): IFBNumeric;
357	begin
358	Result := NumericDivide(IntToNumeric(x),y);
359	end;
360
361	function NumericCompare(x: IFBNumeric; y: int64): integer;
362	begin
363	Result := NumericCompare(x,IntToNumeric(y));
364	end;
365
366	function NumericAdd(x: IFBNumeric; y: double): IFBNumeric;
367	begin
368	Result := NumericAdd(x,DoubleToNumeric(y));
369	end;
370
371	function NumericSubtract(x: IFBNumeric; y: double): IFBNumeric;
372	begin
373	Result := NumericSubtract(x,DoubleToNumeric(y));
374	end;
375
376	function NumericSubtract(x: double; y: IFBNumeric): IFBNumeric;
377	begin
378	Result := NumericSubtract(DoubleToNumeric(x),y);
379	end;
380
381	function NumericMultiply(x: IFBNumeric; y: double): IFBNumeric;
382	begin
383	Result := NumericMultiply(x,DoubleToNumeric(y));
384	end;
385
386	function NumericDivide(x: IFBNumeric; y: double): IFBNumeric;
387	begin
388	Result := NumericDivide(x,DoubleToNumeric(y));
389	end;
390
391	function NumericDivide(x: double; y: IFBNumeric): IFBNumeric;
392	begin
393	Result := NumericDivide(DoubleToNumeric(x),y);
394	end;
395
396	function NumericCompare(x: IFBNumeric; y: double): integer;
397	begin
398	Result := NumericCompare(x,DoubleToNumeric(y));
399	end;
400
401	constructor TFBNumeric.Create(aValue: Int64; aScale: integer);
402	begin
403	inherited Create;
404	FValue := aValue;
405	FScale := aScale;
406	end;
407
408	constructor TFBNumeric.CreateFromInt(aValue: Int64);
409	begin
410	inherited Create;
411	FValue := aValue;
412	FScale := 0;
413	end;
414
415	constructor TFBNumeric.CreateFromStr(aValue: AnsiString);
416	begin
417	inherited Create;
418	if not TryStrToNumeric(aValue,FValue,FScale) then
419	IBError(ibxeInvalidDataConversion,[aValue]);
420	end;
421
422	constructor TFBNumeric.CreateFromDouble(aValue: double);
423
424	function WithinLimits(a: double): boolean;
425	begin
426	a := abs(frac(a));
427	Result := (a > 0.001) and (a < 0.999); {avoid small rounding errors converting to decimal}
428	end;
429
430	var aScale: integer;
431	i: int64;
432	begin
433	aScale := 0;
434	while WithinLimits(AValue) do
435	begin
436	aValue := aValue * 10;
437	Inc(aScale);
438	end;
439	i := Round(aValue);
440	Create(i,-aScale);
441	end;
442
443	constructor TFBNumeric.CreateFromCurr(aValue: Currency);
444	begin
445	inherited Create;
446	Move(aValue,FValue,sizeof(Int64));
447	FScale := -4;
448	end;
449
450	constructor TFBNumeric.CreateFromBCD(aValue: TBCD);
451	var ScaledBCD: TBCD;
452	begin
453	inherited Create;
454	FScale := -BCDScale(aValue);
455	BCDMultiply(aValue,Power(10,-FScale),ScaledBCD);
456	FValue := BCDToInteger(ScaledBCD,true);
457	end;
458
459	function TFBNumeric.getRawValue: Int64;
460	begin
461	Result := FValue;
462	end;
463
464	function TFBNumeric.getScale: integer;
465	begin
466	Result := FScale;
467	end;
468
469	function TFBNumeric.AdjustScaleTo(aNewScale: integer): IFBNumeric;
470	begin
471	if FScale = aNewScale then
472	Result := TFBNumeric.Create(FValue,FScale)
473	else
474	Result := TFBNumeric.Create(AdjustScale(self,aNewScale),aNewScale);
475	end;
476
477	function TFBNumeric.getAsString: AnsiString;
478	var Scaling : AnsiString;
479	i: Integer;
480	begin
481	Result := IntToStr(FValue);
482	Scaling := '';
483	if FScale > 0 then
484	begin
485	for i := 1 to FScale do
486	Result := Result + '0';
487	end
488	else
489	if FScale < 0 then
490	{$IF declared(DefaultFormatSettings)}
491	with DefaultFormatSettings do
492	{$ELSE}
493	{$IF declared(FormatSettings)}
494	with FormatSettings do
495	{$IFEND}
496	{$IFEND}
497	begin
498	if Length(Result) > -FScale then
499	system.Insert(DecimalSeparator,Result,Length(Result) + FScale+1)
500	else
501	begin
502	Scaling := '0' + DecimalSeparator;
503	for i := -1 downto FScale + Length(Result) do
504	Scaling := Scaling + '0';
505	if FValue < 0 then
506	system.insert(Scaling,Result,2)
507	else
508	Result := Scaling + Result;
509	end;
510	end;
511	end;
512
513	function TFBNumeric.getAsDouble: double;
514	begin
515	Result := NumericToDouble(FValue,FScale);
516	end;
517
518	function TFBNumeric.getAsCurrency: Currency;
519	var value: int64;
520	begin
521	if FScale <> -4 then
522	begin
523	value := AdjustScaleTo(-4).GetRawValue;
524	Move(value,Result,sizeof(Currency));
525	end
526	else
527	Move(FValue,Result,sizeof(Currency));
528	end;
529
530	function TFBNumeric.getAsBCD: TBCD;
531	begin
532	Result := DoubleToBCD(getAsDouble);
533	end;
534
535	function TFBNumeric.getAsInt64: Int64;
536	var
537	Scaling : Int64;
538	i: Integer;
539	Val: Int64;
540	begin
541	Scaling := 1;
542	Val := FValue;
543	if FScale > 0 then begin
544	for i := 1 to FScale do Scaling := Scaling * 10;
545	result := Val * Scaling;
546	end else if FScale < 0 then begin
547	for i := -1 downto FScale do Scaling := Scaling * 10;
548	result := Val div Scaling;
549	end else
550	result := Val;
551	end;
552
553	function TFBNumeric.getAsInteger: integer;
554	begin
555	Result := SafeInteger(getAsInt64);
556	end;
557
558	function TFBNumeric.getAsSmallInt: SmallInt;
559	begin
560	Result := SafeSmallInt(getAsInt64);
561	end;
562
563	end.
564