fbintf/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:	402
Committed:	Mon Aug 1 10:07:24 2022 UTC (20 months, 4 weeks ago) by tony
Content type:	text/x-pascal
File size:	15631 byte(s)
Log Message:	IBX Release 2.5.0
#	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	var rValue: extended;
235	begin
236	rValue := aValue;
237	Result := rValue * IntPower(10,aScale);
238	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	{AdjustScale returns a raw int64 value derived from x but with aNewScale}
259
260	function AdjustScale(x: IFBNumeric; aNewScale: integer): int64;
261	begin
262	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	end;
275
276	function CompareInt(a,b: integer): integer;
277	begin
278	if a < b then
279	Result := -1
280	else
281	if a = b then
282	Result := 0
283	else
284	Result := 1;
285	end;
286
287	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	constructor TFBNumeric.Create(aValue: Int64; aScale: integer);
413	begin
414	inherited Create;
415	FValue := aValue;
416	FScale := aScale;
417	end;
418
419	constructor TFBNumeric.CreateFromInt(aValue: Int64);
420	begin
421	inherited Create;
422	FValue := aValue;
423	FScale := 0;
424	end;
425
426	constructor TFBNumeric.CreateFromStr(aValue: AnsiString);
427	begin
428	inherited Create;
429	if not TryStrToNumeric(aValue,FValue,FScale) then
430	IBError(ibxeInvalidDataConversion,[aValue]);
431	end;
432
433	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	begin
444	aScale := 0;
445	while WithinLimits(AValue) do
446	begin
447	aValue := aValue * 10;
448	Inc(aScale);
449	end;
450	i := Round(aValue);
451	Create(i,-aScale);
452	end;
453
454	constructor TFBNumeric.CreateFromCurr(aValue: Currency);
455	begin
456	inherited Create;
457	Move(aValue,FValue,sizeof(Int64));
458	FScale := -4;
459	end;
460
461	constructor TFBNumeric.CreateFromBCD(aValue: TBCD);
462	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	function TFBNumeric.AdjustScaleTo(aNewScale: integer): IFBNumeric;
481	begin
482	if FScale = aNewScale then
483	Result := TFBNumeric.Create(FValue,FScale)
484	else
485	Result := TFBNumeric.Create(AdjustScale(self,aNewScale),aNewScale);
486	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	value := AdjustScaleTo(-4).GetRawValue;
535	Move(value,Result,sizeof(Currency));
536	end
537	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