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
#	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			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	tony	381	{AdjustScale returns a raw int64 value derived from x but with aNewScale}
257	tony	371
258	tony	381	function AdjustScale(x: IFBNumeric; aNewScale: integer): int64;
259			var rValue: double;
260	tony	371	begin
261	tony	381	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	tony	371	else
270	tony	381	if a = b then
271			Result := 0
272	tony	371	else
273	tony	381	Result := 1;
274			end;
275	tony	371
276	tony	381	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	tony	371	constructor TFBNumeric.Create(aValue: Int64; aScale: integer);
402			begin
403			inherited Create;
404			FValue := aValue;
405			FScale := aScale;
406			end;
407
408	tony	381	constructor TFBNumeric.CreateFromInt(aValue: Int64);
409	tony	371	begin
410			inherited Create;
411			FValue := aValue;
412			FScale := 0;
413			end;
414
415	tony	381	constructor TFBNumeric.CreateFromStr(aValue: AnsiString);
416	tony	371	begin
417			inherited Create;
418			if not TryStrToNumeric(aValue,FValue,FScale) then
419			IBError(ibxeInvalidDataConversion,[aValue]);
420			end;
421
422	tony	381	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	tony	371	begin
433	tony	381	aScale := 0;
434			while WithinLimits(AValue) do
435	tony	371	begin
436	tony	381	aValue := aValue * 10;
437			Inc(aScale);
438			end;
439			i := Round(aValue);
440			Create(i,-aScale);
441	tony	371	end;
442
443	tony	381	constructor TFBNumeric.CreateFromCurr(aValue: Currency);
444	tony	371	begin
445			inherited Create;
446			Move(aValue,FValue,sizeof(Int64));
447			FScale := -4;
448			end;
449
450	tony	381	constructor TFBNumeric.CreateFromBCD(aValue: TBCD);
451	tony	371	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	tony	381	function TFBNumeric.AdjustScaleTo(aNewScale: integer): IFBNumeric;
470	tony	371	begin
471	tony	375	if FScale = aNewScale then
472			Result := TFBNumeric.Create(FValue,FScale)
473			else
474	tony	381	Result := TFBNumeric.Create(AdjustScale(self,aNewScale),aNewScale);
475	tony	371	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	tony	381	value := AdjustScaleTo(-4).GetRawValue;
524	tony	371	Move(value,Result,sizeof(Currency));
525	tony	375	end
526	tony	371	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