{ *********************************************************************** }
{                                                                         }
{ Delphi Visual Component Library                                         }
{                                                                         }
{ Copyright (c) 1995-2004 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit Borland.Vcl.FMTBcd;

interface

uses
  SysUtils, Variants, Classes;

const
  MaxStringDigits = 100;
  _NoDecimal = -255;
  _DefaultDecimals = 10;

  { From DB.pas }
  { Max supported by Midas }
  MaxFMTBcdFractionSize = 64;
  { Max supported by Midas }
  MaxFMTBcdDigits =   32;
  DefaultFMTBcdScale = 6;
  MaxBcdPrecision =   18;
  MaxBcdScale     =   4;

  SizeOfFraction  = 32;
  SizeOfTBCD      = 2 + SizeOfFraction;

type
  TBcdFraction = packed array [0..SizeOfFraction - 1] of Byte;
  TFormatSection = (sectionPositive, sectionNegative, sectionZero);

  TBcd = packed record(IComparable, IConvertible)
  private
    var
      FPrecision: Byte;          { 1..64 }
      FSignSpecialPlaces: Byte;  { Sign:1, Special:1, Places:6 }
      FFraction: TBcdFraction;   { BCD Nibbles, 00..99 per Byte, high Nibble 1st }
  strict private
    class function AddChars(V, M: Char; var R: Byte): string; static;
    class procedure AddCurrency(var Output: string;
      const CurrencyPos: Integer; const MoneySymbol: string); static;
    class procedure AddLiterals(LiteralList: TList; var Output: string;
      const Format: string); static;
    class procedure AddNormalizedFractions(const BcdIn1, BcdIn2: TBcd;
      var BcdOut: TBcd); static;
    class function AddStrings(const V, M: string): string; static;
    class procedure AddSubtractNormalizedFractions(const BcdIn1, BcdIn2: TBcd;
      var BcdOut: TBcd; Subtract: Boolean); static;
    class function AdjustDecimalPosition(const Value: string;
      DecPos: SmallInt): string; static;
    class function BcdFixedOrNumberFormat(const Start: string;
      Format: TFloatFormat; const Precision, Digits: Integer): string; static;
    class function BcdCurrencyFormat(const Bcd: TBcd; const Start: string;
      const Precision, Digits: Integer): string; static;
    class procedure BcdDivZeroError; static;
    class procedure BcdError(const AMessage: string); static;
    class procedure BcdErrorFmt(const AMessage, BcdAsString: string); static;
    class function BcdGeneralFormat(const Bcd: TBcd;
      const Precision, Digits: Integer): string; static;
    class function BcdScientificFormat(const Bcd: TBcd;
      const Precision, Digits: Integer): string; static;
    class function BlankArgument(const S: string): Boolean; static;
    class procedure CalcPrecisionAndDigits( const HoldFormat: string;
      var Precision, Digits, ReqIntDigits: Integer); static;
    class function CompareDigits(S1, S2: string): Integer; static;
    class function CanUseShort(A, B: string; MaxDigits: ShortInt): Boolean; static;
    class function CompactBcd(const ABcd: TBcd; const MinSize: Integer): TBcd; static;
    class function CompareNormalizedFractions(const BcdIn1, BcdIn2: TBcd;
      Digits1, Digits2: SmallInt): Integer; static;
    class procedure ExtractLiterals(LiteralList: TList; var HoldFormat: string); static;
    class function ExtractMoneySymbol( var CurrencyPos: Integer;
      var HoldFormat: String): string; static;
    class function FormatOneBcd(const Format: string; Bcd: TBcd): string; static;
    class function GetBcdDigit(const Bcd: TBcd; Digit: Integer): Byte; static;
    class function GetCurrencyDigit(var V: Currency; Digit: Integer): Byte; static;
    class function GetFormat(const Format: string; Section: TFormatSection): string; static;
    class procedure GetValueAndMultiplyOrder(A, B: string; var V, M: string;
      LA, LB: Integer; var Wid, Len, DecPos: Integer); static;
    class function InternalDivide(const A, B: string): string; static;
    class function InternalLongDivide(A, B: string): string; static;
    class function InternalLongMultiply(const A, B: string): string; static;
    class function InternalMultiply(const A, B: string): string; static;
    class function InternalShortMultiply(const A, B: string): string; static;
    class function InvalidBcdString(Value: string): Boolean; static;
    class function IsDecimalSeparator(const S, Dot: string; Index: SmallInt): Boolean; static;
    function IsZero: Boolean;
    class function LeftTrim(const Value: string): string; static;
    class procedure MoveNibblesRight(var BcdOut: TBcd;
      const BcdIn: TBcd; const Size: Byte); static;
    class function NextDigit(const V, D: string; var R: string): string; static;
    class procedure NormalizeBcdPair(const BcdIn1, BcdIn2: TBcd;
      var bcdOut1, bcdOut2: TBcd; ExtraDigits: Word = 0 ); static;
    class function NumberOfDigits(const ABcd: TBcd): Integer; static;
    class procedure OverflowError(const AMessage: string); static;
    class function PadInputString(var InputString: string;
      var Precision: Integer; const ReqIntDigits: Integer): Boolean; static;
    class function PutCurrencyDigit(Value: Byte; Digit: Integer): Currency; static;
    class procedure PutTwoBcdDigits(const Nibble1, Nibble2: Byte;
      var Bcd: TBcd; Digit: Integer); static;
    class function ReverseNegative(ASignSpecialPlaces: Byte): Byte; static;
    class function SignificantIntDigits(const BcdIn: TBcd; Digits: Word): Word; static;
    class function StringMultiplyByByte(const Value: string; B: Byte): string; static;
    class function SubtractChars(V, M: Char; var R: Byte): string; static;
    class function SubtractStrings(const Value, Minus: string): string; static;
    class procedure SubtractNormalizedFractions(const BcdIn1, BcdIn2: TBcd;
      var BcdOut: TBcd); static;
    class function ValueOverOne(D: string): string; static;
    class procedure ZeroBcd(var Bcd: TBcd; FractionOnly: Boolean = False); static;
  public
    constructor Create(const AValue: Double; APrecision, AScale: Word); overload;
    constructor Create(const AValue: string; APrecision, AScale: Word); overload;
    constructor Create(const AValue: Currency; APrecision: Integer = 32;
      ADecimals: Integer = 4); overload;

    class function FromBytes(const AValue: TBytes): TBcd; static;
    class function ToBytes(const Value: TBcd): TBytes; static;
    class function FromObject(AObject: System.Object): TBcd; static;

    function Format(const Format: string): string;

    function IsEmpty: Boolean;
    class function Empty: TBcd; static;

    function IsNegative: Boolean;
    function Normalize(APrecision, AScale: Word): TBcd;
    class function RoundAt(const Value: string; Position: SmallInt): string; static;
    function Scale: Word;
    function SignificantDigits: Word;
    class function StringDivide(const Left, Right: string): TBcd; static;
    class function StringMultiply(const Left, Right: string): TBcd; static;
    class function ToInt64(const AValue: TBcd; Truncate: Boolean = False): Int64; overload; static;

    function get_Fraction(Index: Integer): Byte;

    property Fraction[Index: Integer]: Byte read get_Fraction;
    property Precision: Byte read FPrecision;
    property SignSpecialPlaces: Byte read FSignSpecialPlaces;

    class function Parse(const AText: string): TBcd; overload; static;
    class function Parse(const AText: string; const AProvider: IFormatProvider): TBcd; overload; static;
    class function TryParse(const AValue: string; var Bcd: TBcd): Boolean; static;
    function ToString: System.String; overload; override;
    function ToString(Format: TFloatFormat; const APrecision, ADigits: Integer): string; reintroduce; overload;

    class function Compare(const Left, Right: TBcd): Integer; static;
    class function Equals(const Left, Right: TBcd): Boolean; overload; static;
    function Equals(AValue: TObject): Boolean; overload; override;

    class operator Add(const Left, Right: TBcd): TBcd;
    class operator Subtract(const Left, Right: TBcd): TBcd;
    class operator Multiply(const Left, Right: TBcd): TBcd; overload;
    class operator Multiply(const Left: TBcd; Right: Double): TBcd; overload;
    class operator Multiply(const Left: TBcd; Right: string): TBcd; overload;
    class operator Divide(const Left, Right: TBcd): TBcd; overload;
    class operator Divide(const Left: TBcd; Right: Double): TBcd; overload;
    class operator Divide(const Left: TBcd; Right: string): TBcd; overload;
    class operator IntDivide(const Left, Right: TBcd): Integer;
    class operator Negative(const Value: TBcd): TBcd;

    class operator Equal(const Left, Right: TBcd): Boolean;
    class operator NotEqual(const Left, Right: TBcd): Boolean;
    class operator LessThan(const Left, Right: TBcd): Boolean;
    class operator LessThanOrEqual(const Left, Right: TBcd): Boolean;
    class operator GreaterThan(const Left, Right: TBcd): Boolean;
    class operator GreaterThanOrEqual(const Left, Right: TBcd): Boolean;

    class operator Implicit(const AValue: Currency): TBcd;
    class operator Implicit(const AValue: Double): TBcd;
    class operator Implicit(const AValue: Integer): TBcd;
    class operator Implicit(const AValue: Int64): TBcd;
    class operator Implicit(const AValue: Word): TBcd;
    class operator Implicit(const AValue: LongWord): TBcd;
    class operator Implicit(const AValue: UInt64): TBcd;
    class operator Implicit(const AValue: Variant): TBcd;
    class operator Implicit(const AValue: TBcd): Double;
    class operator Implicit(const AValue: TBcd): Currency;

    // IComparable
    function CompareTo(Right: TObject): System.Int32;

    // IConvertible
    function GetTypeCode: TypeCode;
    function ToBoolean(AProvider: IFormatProvider): System.Boolean;
    function ToByte(AProvider: IFormatProvider): System.Byte;
    function ToChar(AProvider: IFormatProvider): System.Char;
    function ToDateTime(AProvider: IFormatProvider): System.DateTime;
    function ToDecimal(AProvider: IFormatProvider): System.Decimal;
    function ToDouble(AProvider: IFormatProvider): System.Double;
    function ToInt16(AProvider: IFormatProvider): System.Int16;
    function ToInt32(AProvider: IFormatProvider): System.Int32;
    function ToInt64(AProvider: IFormatProvider): System.Int64; overload;
    function ToSByte(AProvider: IFormatProvider): System.SByte;
    function ToSingle(AProvider: IFormatProvider): System.Single;
    function ToString(AProvider: IFormatProvider): System.String; overload;
    function ToType(AType: System.Type; AProvider: IFormatProvider): System.Object;
    function ToUInt16(AProvider: IFormatProvider): System.UInt16;
    function ToUInt32(AProvider: IFormatProvider): System.UInt32;
    function ToUInt64(AProvider: IFormatProvider): System.UInt64;
  end;

{ Exception classes }

  EBcdException = class(Exception);
  EBcdOverflowException = class(EBcdException);
  EBcdDivByZero = class(EDivByZero);

{ Utility functions for TBcd access }

function BcdPrecision(const Bcd: TBcd): Word; deprecated;
function BcdScale(const Bcd: TBcd): Word; deprecated;
function IsBcdNegative(const Bcd: TBcd): Boolean; deprecated;

{ Bcd Arithmetic}

procedure BcdAdd(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd); deprecated;
procedure BcdSubtract(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd); deprecated;
{ Returns True if successful, False if Int Digits needed to be truncated }
function NormalizeBcd(const InBcd: TBcd; var OutBcd: TBcd;
  const Prec, Scale: Word): Boolean; deprecated; 

procedure BcdMultiply(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd); overload; deprecated;
procedure BcdMultiply(const bcdIn: TBcd; const DoubleIn: Double; var bcdOut: TBcd); overload; deprecated;
procedure BcdMultiply(const bcdIn: TBcd; const StringIn: string; var bcdOut: TBcd); overload; deprecated;
procedure BcdMultiply(StringIn1, StringIn2: string; var bcdOut: TBcd); overload; deprecated; 
procedure BcdDivide(Dividend, Divisor: string; var bcdOut: TBcd); overload; deprecated;
procedure BcdDivide(const Dividend, Divisor: TBcd; var bcdOut: TBcd); overload; deprecated;
procedure BcdDivide(const Dividend: TBcd; const Divisor: Double; var bcdOut: TBcd); overload; deprecated;
procedure BcdDivide(const Dividend: TBcd; const Divisor: string; var bcdOut: TBcd); overload; deprecated; 

{ TBcd variant creation utils }
procedure VarFMTBcdCreate(var ADest: Variant; const ABcd: TBcd); overload;
function VarFMTBcdCreate: Variant; overload;
function VarFMTBcdCreate(const AValue: string; Precision, Scale: Word): Variant; overload;
function VarFMTBcdCreate(const AValue: Double; Precision: Word = 18; Scale: Word = 4): Variant; overload;
function VarFMTBcdCreate(const ABcd: TBcd): Variant; overload;
function VarIsFMTBcd(const AValue: Variant): Boolean; overload;
function VarFMTBcd: TVarType;

{ Convert String/Double/Integer to BCD struct }
function StrToBcd(const AValue: string): TBcd; deprecated;
function TryStrToBcd(const AValue: string; var Bcd: TBcd): Boolean; deprecated;
function DoubleToBcd(const AValue: Double): TBcd; overload; deprecated;
procedure DoubleToBcd(const AValue: Double; var Bcd: TBcd); overload; deprecated;
function IntegerToBcd(const AValue: Integer): TBcd; deprecated;
function VarToBcd(const AValue: Variant): TBcd; deprecated;

{ From DB.pas }
function CurrToBCD(const Curr: Currency; var BCD: TBcd; Precision: Integer = 32;
  Decimals: Integer = 4): Boolean; deprecated;

{ Convert Bcd struct to string/Double/Integer }
function BcdToStr(const Bcd: TBcd): string; deprecated;
function BcdToDouble(const Bcd: TBcd): Double; deprecated;
function BcdToInteger(const Bcd: TBcd; Truncate: Boolean = False): Integer; deprecated; 

{ From DB.pas }
function BCDToCurr(const BCD: TBcd; var Curr: Currency): Boolean; deprecated;
{ Formatting Bcd as string }
function BcdToStrF(const Bcd: TBcd; Format: TFloatFormat; const Precision, Digits: Integer): string; deprecated; 
function FormatBcd(const Format: string; Bcd: TBcd): string; deprecated;
function BcdCompare(const bcd1, bcd2: TBcd): Integer; deprecated; 

function RoundAt(const Value: string; Position: SmallInt): string; deprecated; 
function NullBcd: TBcd; deprecated;

implementation

{$RANGECHECKS ON}
{$OVERFLOWCHECKS ON}
{$FINITEFLOAT ON}

uses
  TypInfo, Math, DBConsts;

{ TBcd }

{ in Delphi for .NET DecimalSeparator is a string, possibly more than 1 char }
class function TBcd.IsDecimalSeparator(const S, Dot: string; Index: SmallInt): Boolean;
var
  L: Integer;
begin
  if Length(Dot) = 1 then
    Result := S[Index] = Dot[1]
  else
  begin
    L := Length(Dot);
    Dec(Index, L-1);
    Result := Copy(S, Index, L) = Dot;
  end;
end;

{ Digit is the index into Nibbles: Fraction[Index] = Index div 2 }
class procedure TBcd.PutTwoBcdDigits(const Nibble1, Nibble2: Byte;
  var Bcd: TBcd; Digit: Integer);
var
  b: Byte;
begin
  b := Nibble1 SHL 4;
  b := b OR (Nibble2 AND 15);
  Bcd.FFraction[Digit div 2] := b;
end;

{ Digit is the index into Nibbles: Fraction[Index] = Index div 2;
  Byte returned is either left or right Nibble of Fraction Byte }
class function TBcd.GetBcdDigit(const Bcd: TBcd; Digit: Integer): Byte;
begin
  if Digit mod 2 = 0 then
    Result := Byte((Bcd.FFraction[Digit div 2]) SHR 4)
  else
    Result := Byte(Byte((Bcd.FFraction[Digit div 2]) AND 15));
end;


const
  DValue: array[-10..20] of Currency = (0, 0, 0, 0, 0, 0, 0,
                                        0.0001, 0.001, 0.01, 0.1, 1,
                                        10,
                                        100,
                                        1000,
                                        10000,
                                        100000,
                                        1000000,
                                        10000000,
                                        100000000,
                                        1000000000,
                                        10000000000,
                                        100000000000,
                                        1000000000000,
                                        10000000000000,
                                        100000000000000,
                                        0, 0, 0, 0, 0);

{ return the digit value for any slot in currency: e.g.
  GetCurrencyDigit(91234.5678, 1) returns 4
  GetCurrencyDigit(91234.5678, 2) returns 3
  GetCurrencyDigit(91234.5678, 3) returns 2,
  GetCurrencyDigit(91234.5678, 4) returns 1,
  GetCurrencyDigit(91234.5678, 5) returns 9 }
class function TBcd.GetCurrencyDigit(var V: Currency; Digit: Integer): Byte;
var
  DropValue: Currency;
  IResult: Byte;
begin
  Result := 0;
  if (Digit < Low(DValue)) or (Digit > High(DValue)) then
    Exit;
  DropValue := DValue[Digit];
  if DropValue = 0 then Exit;
  IResult := 0;
  while V >= DropValue do
  begin
    V := V - DropValue;
    Inc(IResult);
  end;
  Result := IResult;
end;

{ Currency Value of a Byte for a specific digit column }
class function TBcd.PutCurrencyDigit(Value: Byte; Digit: Integer): Currency;
begin
  Result := DValue[Digit] * Value;
end;

function TBcd.IsZero: Boolean;
var
  I: Integer;
begin
  Result := True;
  I := 0;
  while Result and (I < Precision div 2) do
  begin
    if Byte(FFraction[I]) <> 0 then
      Result := False;
    Inc(I);
  end;
{ if odd nibble, check it }
  if Result and (Precision mod 2 > 0) then
    if (Byte(FFraction[I]) shr 4) > 0 then
      Result := False;
end;

class procedure TBcd.BcdErrorFmt(const AMessage, BcdAsString: string);
begin
  raise EBcdException.Create(Borland.Vcl.SysUtils.Format(AMessage, [BcdAsString]));
end;

class procedure TBcd.BcdDivZeroError;
begin
  raise EBcdDivByZero.Create(SDivByZero);
end;

class procedure TBcd.BcdError(const AMessage: string);
begin
  raise EBcdException.Create(AMessage);
end;

class procedure TBcd.OverflowError(const AMessage: string);
begin
  raise EBcdOverflowException.Create(AMessage);
end;

class function TBcd.ReverseNegative(ASignSpecialPlaces: Byte): Byte;
begin
  if (ASignSpecialPlaces and (1 shl 7)) <> 0 then
    Result := (ASignSpecialPlaces and 63)
  else
    Result := (ASignSpecialPlaces and 63) or (1 shl 7);
end;

{ Shift Fractions one Nibble to Right }
class procedure TBcd.MoveNibblesRight(var BcdOut: TBcd;
  const BcdIn: TBcd; const Size: Byte);
var
  I, InPos, OutPos: Integer;
  N1, N2: BYTE;
begin
  I := 0;
  InPos := 0;
  OutPos := 0;
  N1 := BYTE(0);
  while I < Size do
  begin
    N2 := Byte(BcdIn.FFraction[InPos]);
    BcdOut.FFraction[OutPos] := Byte((Byte(N1 AND 15) SHL 4) OR Byte(N2 SHR 4));
    N1 := N2;
    Inc(OutPos);
    Inc(InPos);
    Inc(I,2);
  end;
end;

constructor TBcd.Create(const AValue: Double; APrecision, AScale: Word);
begin
  Create(AValue.ToString, APrecision, AScale);
end;

constructor TBcd.Create(const AValue: string; APrecision, AScale: Word);
var
  LBcd: TBcd;
begin
  inherited Create;
  LBcd := TBcd.Parse(AValue).Normalize(APrecision, AScale);
  FPrecision := LBcd.FPrecision;
  FSignSpecialPlaces := LBcd.FSignSpecialPlaces;
  FFraction := LBcd.FFraction;
end;

constructor TBcd.Create(const AValue: Currency; APrecision: Integer = 32;
  ADecimals: Integer = 4);
var
  Temp: Currency;
  I: Integer;
  B1, B2: Byte;
begin
  inherited Create;
  FPrecision := APrecision;
  FSignSpecialPlaces := ADecimals;
  for I := 0 to 31 do
    FFraction[I] := 0;
  if AValue = 0 then
    Exit;
  if AValue < 0 then
    Temp := -AValue
  else
    Temp := AValue;
  I := 0;
  while I < Precision do
  begin
    B1 := GetCurrencyDigit(Temp, APrecision - (ADecimals + I));
    B2 := GetCurrencyDigit(Temp, APrecision - (ADecimals + I + 1));
    PutTwoBcdDigits(B1, B2, Self, I);
    Inc(I, 2);
  end;
  if AValue < 0 then
    FSignSpecialPlaces := (FSignSpecialPlaces and 63) or (1 shl 7);
end;

function TBcd.Format(const Format: string): string;
begin
  if IsNegative then
    Result := FormatOneBcd(GetFormat(Format, sectionNegative), Self)
  else if IsZero then
    Result := FormatOneBcd(GetFormat(Format, sectionZero), Self)
  else
    Result := FormatOneBcd(GetFormat(Format, sectionPositive), Self);
end;

function TBcd.IsEmpty: Boolean;
begin
  Result := Self = TBcd.Empty;
end;

function TBcd.IsNegative: Boolean;
begin
  Result := (FSignSpecialPlaces and (1 shl 7)) <> 0;
end;

function TBcd.Normalize(APrecision, AScale: Word): TBcd;
var
  DecDigits, AddDec: SmallInt;
  Negative: Boolean;
begin
  if (FPrecision = APrecision) and ((FSignSpecialPlaces and 63) = AScale) then
    Result := Self
  else
  begin
    Negative := FSignSpecialPlaces and (1 shl 7) <> 0;
    DecDigits := FSignSpecialPlaces and 63;
    AddDec := AScale - DecDigits;
    Result.FPrecision := FPrecision;
    Result.FFraction := FFraction;
    Result.FSignSpecialPlaces := AScale;
    while Result.FPrecision < (APrecision - AddDec) do
    begin
      MoveNibblesRight(Result, Result, MaxFMTBcdFractionSize{of Result});
      Inc(Result.FPrecision);
    end;
    if (Result.FPrecision < APrecision) or (AddDec < 0) then
      Result.FPrecision := Result.FPrecision + AddDec;
      //Inc(Result.FPrecision, AddDec); /// causes range checking error when AddDec is < 0
    if Negative then
      Result.FSignSpecialPlaces := (Result.FSignSpecialPlaces and 63) or (1 shl 7);
  end;
end;

class function TBcd.Empty: TBcd;
begin
  // Do nothing - value types are always zero initialized
end;

function TBcd.Scale: Word;
begin
  Result := (FSignSpecialPlaces and 63);
end;

function TBcd.SignificantDigits: Word;
begin
  Result := FPrecision - Scale;
end;

class function TBcd.RoundAt(const Value: string; Position: SmallInt): string;

  Procedure RoundChar(const PrevChar: SmallInt; var Carry: Boolean);
  begin
    if ((Result[PrevChar] in ['0' .. '9'])) then
    begin
      if Result[PrevChar] = '9' then
      begin
        Result[PrevChar] := '0';
        Carry := True;
      end else
      begin
        Result[PrevChar] := Char(Byte(Result[PrevChar]) + 1);
        Carry := False;
      end;
    end;
  end;

var
  C: Char;
  DecSepLen, PrevChar, I, DecPos, DecDigits: SmallInt;
  Carry: Boolean;
  Dot, Neg: string;
begin
  Dot := DecimalSeparator;
  DecSepLen := Length(Dot);
  if Value[1] = '-' then
  begin
    Result := Copy(Value, 2, MaxInt);
    Neg := '-';
  end else
  begin
    Result := Value;
    Neg := '';
  end;                                                            
  DecPos := Pos(Dot, Result);
  if DecPos > 0 then
    DecDigits := Length(Result) - (DecPos + DecSepLen - 1) 
  else
    DecDigits := 0;
  if (DecPos = 0) or (DecDigits <= Position) then
    { nothing to round }
  begin
    Result := Value;
    Exit;
  end;
  if Result[DecPos + Position + 1] < '5' then
  begin
    { no possible rounding required }
    if Position = 0 then
      Result := Neg + Copy(Result, DecSepLen, DecPos + Position -1)
    else
      Result := Neg + Copy(Result, DecSepLen, DecPos + Position);
  end else
  begin
    Carry := False;
    PrevChar := 1;
    for I := DecPos + DecDigits downto (DecPos + DecSepLen + Position) do
    begin
      C := Result[I];
      PrevChar := I-1;
      if IsDecimalSeparator(Result, Dot, PrevChar) then
      begin
        Dec(PrevChar, DecSepLen);
        Dec(Position, DecSepLen);
      end;
      if (Byte(C) >= 53) or Carry then { if '5' or greater }
        RoundChar(PrevChar, Carry);
    end;
    while Carry do
    begin
      if PrevChar >= DecPos then
        Dec(Position);
      Dec(PrevChar);
      if PrevChar = 0 then
        break;
      if not IsDecimalSeparator(Result, Dot, PrevChar) then
        RoundChar(PrevChar, Carry);
    end;
    if Carry then
      Result := Neg + '1' + Copy(Result, 1, DecPos + Position)
    else
      Result := Neg + Copy(Result, 1, DecPos + Position);
  end;
end;

function TBcd.CompareTo(Right: TObject): Int32;
var
  LRight: TBcd;
begin
  if Right is TBcd then
    LRight := Right as TBcd
  else
    LRight := FromObject(Right);

  Result := Compare(Self, LRight);
end;

function TBcd.GetTypeCode: TypeCode;
begin
  Result := System.TypeCode.Object;
end;

function TBcd.ToBoolean(AProvider: IFormatProvider): System.Boolean;
begin
  Result := System.Boolean(not IsZero);
end;

function TBcd.ToByte(AProvider: IFormatProvider): System.Byte;
begin
  Result := ToInt64(AProvider);
end;

function TBcd.ToChar(AProvider: IFormatProvider): System.Char;
begin
  Result := ToString(AProvider)[1];
end;

function TBcd.ToDateTime(AProvider: IFormatProvider): System.DateTime;
begin
  Result := DateTime.FromOADate(Double(Self));
end;

function TBcd.ToDecimal(AProvider: IFormatProvider): System.Decimal;
begin
  Result := System.Decimal.Parse(ToString(AProvider));
end;

function TBcd.ToDouble(AProvider: IFormatProvider): System.Double;
begin
  Result := Double(Self);
end;

function TBcd.ToInt16(AProvider: IFormatProvider): System.Int16;
begin
  Result := ToInt64(AProvider);
end;

function TBcd.ToInt32(AProvider: IFormatProvider): System.Int32;
begin
  Result := ToInt64(AProvider);
end;

function TBcd.ToInt64(AProvider: IFormatProvider): System.Int64;
begin
  Result := ToInt64(Self, True);
end;

function TBcd.ToSByte(AProvider: IFormatProvider): System.SByte;
begin
  Result := ToInt64(AProvider);
end;

function TBcd.ToSingle(AProvider: IFormatProvider): System.Single;
begin
  Result := Double(Self);
end;

                                            
// Need to detemine if we can use any info from the IFormatProvider
// in our conversion to string
function TBcd.ToString(AProvider: IFormatProvider): System.String;
var
  I: Integer;
  DecPos: SmallInt;
  Negative: Boolean;
  C: Char;
  Dot: string;
begin
  if IsEmpty then
    Result := '0'
  else if (FPrecision = 0) or (FPrecision > MaxFMTBcdFractionSize) then
    OverFlowError(SBcdOverFlow)
  else
  begin
    Dot := DecimalSeparator;
    Negative := FSignSpecialPlaces and (1 shl 7) <> 0;
    DecPos := ShortInt(FPrecision - (FSignSpecialPlaces and 63));
    Result := '';
    for I := 0 to FPrecision - 1 do
    begin
      if I = DecPos then
      begin
        if I = 0 then
          Result := '0' + Dot
        else
          Result := Result + Dot;
      end;
      C := Char(GetBcdDigit(Self, I) + 48);
      { avoid leading 0's }
      if (Result <> '') or (C <> '0') or (I >= DecPos) then
        Result := Result + C;
    end;
    { if there is a decimal trim trailing '0's }
    if DecPos < FPrecision then
    begin
      while Result[Length(Result)] = '0' do
        Result := Copy(Result, 1, Length(Result) - 1);
      if IsDecimalSeparator(Result, Dot, Length(Result)) then
        Result := Copy(Result, 1, Length(Result) - Length(Dot));
    end;
    if Result = '' then
      Result := '0'
    else if Negative then
      Result := '-' + Result;
  end;
end;

function TBcd.ToString(Format: TFloatFormat; const APrecision, ADigits: Integer): string;
begin
  Result := BcdGeneralFormat(Self, APrecision, ADigits);
  case Format of
    ffExponent:
      Result := BcdScientificFormat(Self, APrecision, ADigits);
    ffCurrency:
      Result := BcdCurrencyFormat(Self, Result, APrecision, ADigits);
    ffFixed, ffNumber:
      Result := BcdFixedOrNumberFormat(Result, Format, APrecision, ADigits);
  end;
end;

function TBcd.ToType(AType: System.Type; AProvider: IFormatProvider): System.Object;
begin
  Result := Self;
  case System.Type.GetTypeCode(AType) of
    TypeCode.Boolean:
      Result := TObject(ToBoolean(AProvider));
    TypeCode.Byte:
      Result := TObject(ToByte(AProvider));
    TypeCode.Char:
      Result := TObject(ToChar(AProvider));
    TypeCode.DateTime:
      Result := TObject(ToDateTime(AProvider));
    TypeCode.Decimal:
      Result := TObject(ToDecimal(AProvider));
    TypeCode.Double:
      Result := TObject(ToDouble(AProvider));
    TypeCode.Empty:
      Result := nil;
    TypeCode.Int16:
      Result := TObject(ToInt16(AProvider));
    TypeCode.Int32:
      Result := TObject(ToInt32(AProvider));
    TypeCode.Int64:
      Result := TObject(ToInt64(AProvider));
    TypeCode.SByte:
      Result := TObject(ToSByte(AProvider));
    TypeCode.Single:
      Result := TObject(ToSingle(AProvider));
    TypeCode.String:
      Result := TObject(ToString(AProvider));
    TypeCode.UInt16:
      Result := TObject(ToUInt16(AProvider));
    TypeCode.UInt32:
      Result := TObject(ToUInt32(AProvider));
    TypeCode.UInt64:
      Result := TObject(ToUInt64(AProvider));
    TypeCode.Object:
      if not AType.IsInstanceOfType(Self) then
        raise System.InvalidCastException.Create;
  else
    raise System.InvalidCastException.Create;
  end;
end;

function TBcd.ToUInt16(AProvider: IFormatProvider): System.UInt16;
begin
  Result := ToInt32(AProvider);
end;

function TBcd.ToUInt32(AProvider: IFormatProvider): System.UInt32;
begin
  Result := ToInt64(AProvider);
end;

function TBcd.ToUInt64(AProvider: IFormatProvider): System.UInt64;
var
  LBcd: TBcd;
begin
  if Scale > 0 then
    LBcd := Normalize(FPrecision, 0)
  else
    LBcd := Self;
  Result := StrToUInt64(LBcd.ToString(AProvider));
end;

class function TBcd.FromBytes(const AValue: TBytes): TBcd;
begin
  if Length(AValue) < SizeOfTBcd then
    raise EConvertError.Create(SBufferNotBCD);
  Result.FPrecision := AValue[0];
  Result.FSignSpecialPlaces := AValue[1];
  Result.FFraction := Copy(AValue, 2, 32);
end;

class function TBcd.ToBytes(const Value: TBcd): TBytes;
var
  I: Integer;
begin
  SetLength(Result, SizeOfTBcd);
  Result[0] := Value.FPrecision;
  Result[1] := Value.FSignSpecialPlaces;
  for I := 0 to 31 do
    Result[I + 2] := Value.FFraction[I];
end;

class function TBcd.FromObject(AObject: System.Object): TBcd;
begin
  if AObject = nil then
    Result := Empty
  else if AObject is TBcd then
    Result := TBcd(AObject)
  else if AObject is DateTime then
    Result := DateTime(AObject).ToOADate
  else
    try
      Result := Parse(String(Variant(AObject)));
    except
      Result := Double(Variant(AObject));
    end;
end;

class function TBcd.ToInt64(const AValue: TBcd; Truncate: Boolean = False): Int64;
var
  LBcd: TBcd;
begin
  if (Truncate) and (AValue.Scale > 0 ) then
    LBcd := AValue.Normalize(AValue.FPrecision, 0)
  else
    LBcd := AValue;
  Result := StrToInt64(LBcd.ToString);
end;

class function TBcd.Parse(const AText: string): TBcd;
begin
  Result := Parse(AText, nil);
end;

                                         
// Need to detemine if we can use any info from the IFormatProvider
// in our conversion from string
class function TBcd.Parse(const AText: string; const AProvider: IFormatProvider): TBcd;
begin
  if not TryParse(AText, Result) then
    BcdErrorFmt(SInvalidBcdValue, AText);
end;

function TBcd.ToString: System.String;
begin
  Result := ToString(nil);
end;

class function TBcd.Compare(const Left, Right: TBcd): Integer;
var
  TempBcd1, TempBcd2: TBcd;
  Digits1,Digits2: ShortInt;
  Negative: Boolean;
begin
  if (Left.FSignSpecialPlaces and (1 shl 7)) <> (Right.FSignSpecialPlaces and (1 shl 7)) then
  begin  // if Negative setting doesn't match.
    if (Left.FSignSpecialPlaces and (1 shl 7)) <> 0 then
      Result := -1
    else
      Result := 1;
  end else
  begin  // both Negative or both Positive
    Negative := (Left.FSignSpecialPlaces and (1 shl 7)) <> 0;
    Digits1 := SignificantIntDigits(Left, SmallInt(Left.FPrecision - (Left.FSignSpecialPlaces and 63)));
    Digits2 := SignificantIntDigits(Right, SmallInt(Right.FPrecision - (Right.FSignSpecialPlaces and 63)));
    if Digits1 <> Digits2 then
    begin
      if Digits1 > Digits2 then
        Result := 1
      else
        Result := -1;
    end else
    begin
      NormalizeBcdPair(Left, Right, TempBcd1, TempBcd2);
      Result := CompareNormalizedFractions(TempBcd1, TempBcd2, TempBcd1.FPrecision, TempBcd2.FPrecision);
    end;
    if Negative then Result := -Result;
  end;
end;

class function TBcd.Equals(const Left, Right: TBcd): Boolean;
begin
  Result := Left = Right;
end;

function TBcd.Equals(AValue: TObject): Boolean;
begin
  Result := (AValue is TBcd) and (Self = TBcd(AValue));
end;

class operator TBcd.Add(const Left, Right: TBcd): TBcd;
var
  Bcd1, Bcd2: TBcd;
  Prec, Scale: Word;
  Neg1, Neg2: Boolean;
  Digits1, Digits2: Integer;
begin
  NormalizeBcdPair(Left, Right, Bcd1, Bcd2, 1);
  Prec := Bcd1.FPrecision;
  Scale := Bcd1.FSignSpecialPlaces;
  Neg1 := (Left.FSignSpecialPlaces and (1 shl 7)) <> 0;
  Neg2 := (Right.FSignSpecialPlaces and (1 shl 7)) <> 0;
  Result.FPrecision := Prec;
  if (Neg1 = Neg2) or ((Bcd1.FSignSpecialPlaces and 63) >= (Bcd2.FSignSpecialPlaces and 63)) then
    Result.FSignSpecialPlaces := Scale
  else
    Result.FSignSpecialPlaces := ReverseNegative(Scale);
  ZeroBcd(Result, True);
  if Neg1 = Neg2 then
    AddNormalizedFractions(Bcd1, Bcd2, Result)
  else
  begin
    Digits1 := SignificantIntDigits(Bcd1, Prec);
    Digits2 := SignificantIntDigits(Bcd2, Prec);
    if Digits1 > Digits2 then
      SubtractNormalizedFractions(Bcd1, Bcd2, Result)
    else if Digits2 > Digits1 then
    begin
      SubtractNormalizedFractions(Bcd2, Bcd1, Result);
      Result.FSignSpecialPlaces := ReverseNegative(Result.FSignSpecialPlaces);
    end
    else if CompareNormalizedFractions(Bcd1, Bcd2, Prec, Prec) >= 0 then
      SubtractNormalizedFractions(Bcd1, Bcd2, Result)
    else
    begin
      SubtractNormalizedFractions(Bcd2, Bcd1, Result);
      Result.FSignSpecialPlaces := ReverseNegative(Result.FSignSpecialPlaces);
    end;
  end;
end;

class operator TBcd.Subtract(const Left, Right: TBcd): TBcd;
var
  LBcd: TBcd;
begin
  LBcd := Right;
  LBcd.FSignSpecialPlaces := ReverseNegative(LBcd.FSignSpecialPlaces);
  Result := Left + LBcd;
end;

class operator TBcd.Multiply(const Left, Right: TBcd): TBcd;
begin
  Result := StringMultiply(Left.ToString, Right.ToString);
end;

class operator TBcd.Multiply(const Left: TBcd; Right: Double): TBcd;
begin
  Result := StringMultiply(Left.ToString, FloatToStr(Right));
end;

class operator TBcd.Multiply(const Left: TBcd; Right: string): TBcd;
begin
  Result := StringMultiply(Left.ToString, Right);
end;

class operator TBcd.Divide(const Left, Right: TBcd): TBcd;
begin
  Result := StringDivide(Left.ToString, Right.ToString);
end;

class operator TBcd.Divide(const Left: TBcd; Right: Double): TBcd;
begin
  Result := StringDivide(Left.ToString, FloatToStr(Right));
end;

class operator TBcd.Divide(const Left: TBcd; Right: string): TBcd;
begin
  Result := StringDivide(Left.ToString, Right);
end;

class operator TBcd.IntDivide(const Left, Right: TBcd): Integer;
begin
  Result := ToInt64(Left / Right);
end;

class operator TBcd.Equal(const Left, Right: TBcd): Boolean;
begin
  Result := Compare(Left, Right) = 0;
end;

class operator TBcd.NotEqual(const Left, Right: TBcd): Boolean;
begin
  Result := Compare(Left, Right) <> 0;
end;

class operator TBcd.LessThan(const Left, Right: TBcd): Boolean;
begin
  Result := Compare(Left, Right) < 0;
end;

class operator TBcd.LessThanOrEqual(const Left, Right: TBcd): Boolean;
begin
  Result := Compare(Left, Right) <= 0;
end;

class operator TBcd.GreaterThan(const Left, Right: TBcd): Boolean;
begin
  Result := Compare(Left, Right) > 0;
end;

class operator TBcd.GreaterThanOrEqual(const Left, Right: TBcd): Boolean;
begin
  Result := Compare(Left, Right) >= 0;
end;

class operator TBcd.Negative(const Value: TBcd): TBcd;
begin
  Result := Value;
  Result.FSignSpecialPlaces := ReverseNegative(Result.FSignSpecialPlaces);
end;

class operator TBcd.Implicit(const AValue: TBcd): Currency;
var
  Scale, I: Integer;
  Negative: Boolean;
  b: Byte;
begin
  Result := 0;
  Negative := (AValue.FSignSpecialPlaces and (1 shl 7)) <> 0;
  Scale := (AValue.FSignSpecialPlaces and 63);
  for I := 0 to AValue.FPrecision -1 do
  begin
    b := GetBcdDigit(AValue, I);
    if b <> 0 then
      Result := Result + PutCurrencyDigit(b, AValue.FPrecision - (Scale + I));
  end;
  if Scale > 4 then
  begin  { 0.12345 = 0.1234, but 0.123450000001 is rounded up to 0.1235 }
    b := GetBcdDigit(AValue, 4 + (AValue.FPrecision - Scale));
    if b >= 5 then
      if b > 5 then
        Result := Result + 0.0001
      else
        for I := 5 + (AValue.FPrecision - Scale)  to AValue.FPrecision -1 do
          if GetBcdDigit(AValue, I) <> 0 then
          begin
            Result := Result + 0.0001;
            break;
          end;
  end;
  if Negative then
    Result := -Result;
end;

class operator TBcd.Implicit(const AValue: Double): TBcd;
begin
  Result := Parse(AValue.ToString);
end;

class operator TBcd.Implicit(const AValue: Integer): TBcd;
begin
  Result := Parse(AValue.ToString);
end;

class operator TBcd.Implicit(const AValue: Int64): TBcd;
begin
  Result := Parse(AValue.ToString);
end;

class operator TBcd.Implicit(const AValue: Word): TBcd;
begin
  Result := Parse(AValue.ToString);
end;

class operator TBcd.Implicit(const AValue: LongWord): TBcd;
begin
  Result := Parse(AValue.ToString);
end;

class operator TBcd.Implicit(const AValue: UInt64): TBcd;
begin
  Result := Parse(AValue.ToString);
end;

class operator TBcd.Implicit(const AValue: Variant): TBcd;
var
  LData: TObject;
begin
  LData := TObject(AValue);
  if LData is TBcd then
    Result := TBcd(LData)
  else
    if not TryParse(AValue, Result) then
      raise System.InvalidCastException.Create;
end;

class operator TBcd.Implicit(const AValue: Currency): TBcd;
begin
  Result := TBcd.Create(AValue);
end;

class operator TBcd.Implicit(const AValue: TBcd): Double;
begin
  Result := StrToFloat(AValue.ToString);
end;

function TBcd.get_Fraction(Index: Integer): Byte;
begin
  Result := FFraction[Index];
end;

class function TBcd.LeftTrim(const Value: string): string;
begin
  Result := Value;
  while (Length(Result) > 1) and (Result[1] = '0') do
    Result := Copy(Result, 2, Length(Result) -1);
end;

class function TBcd.CompareDigits(S1, S2: string): Integer;
begin
  S1 := LeftTrim(S1);
  if Length(S1) > Length(S2) then
    Result := 1
  else if Length(S2) > Length(S1) then
    Result := -1
  else
    Result := CompareStr(S1, S2);
end;

class procedure TBcd.GetValueAndMultiplyOrder(A, B: string; var V, M: string;
  LA, LB: Integer; var Wid, Len, DecPos: Integer);
var
  DecimalPosA, DecimalPosB: Integer;
  Dot : string;
  DecimalLen: Integer;
begin
  Dot := DecimalSeparator;
  DecimalLen := Length(Dot);
  DecPos := 0;
  if CompareDigits(A,B) > 1 then
  begin
    V := A;
    M := B;
    Wid := LA;
    Len := LB;
  end else
  begin
    M := A;
    V := B;
    Wid := LB;
    Len := LA;
  end;
  { to get rid of GetDecimalPosition }
  DecimalPosA := Pos(Dot, V);
  DecimalPosB := Pos(Dot, M);
  if (DecimalPosA = 0) and (DecimalPosB = 0) then
    DecPos := _NoDecimal
  else
  begin
    if DecimalPosA > 0 then
    begin
      V := StringReplace(V, Dot, '', []);
      DecPos := Wid - DecimalPosA;
      Dec(Wid, DecimalLen);
    end;
    if DecimalPosB > 0 then
    begin
      M := StringReplace(M, Dot, '',[]);
      DecPos := DecPos + (Len - DecimalPosB - DecimalLen + 1);
      Dec(Len, DecimalLen);
    end;
  end;
end;

class function TBcd.AddChars(V, M: Char; var R: Byte): string;
var
  Value: Byte;
begin
  Value := Byte((Ord(V)-48) + (Ord(M)-48) + R);
  if Value > 9 then
  begin
    Result := Char(Byte(Value - 10) + 48);
    R := Byte(1);
  end else
  begin
    Result :=  Char(Byte(Value + 48));
    R := Byte(0);
  end;
  if Result = '' then Result := '0';
end;

class function TBcd.SubtractChars(V, M: Char; var R: Byte): string;
var
  Value: Byte;
  I: Integer;
begin
  Value := Byte((Ord(V)-48) - ((Ord(M)-48) + R));
  if Value > 9 then  // Byte is unsigned: values will be between 246-255
  begin
    Result := Char(Byte(10+Value) + 48);
    R := Byte(1);
  end else
  begin
    Result :=  Char(Byte(Value + 48));
    R := Byte(0);
  end;
end;

class function TBcd.AddStrings(const V, M: string): string;
var
  Digit: string;
  LenV, LenM, MaxDigits, I, DigitV, DigitM: Integer;
  R: Byte;           // Remainder
  CV, CM: Char;      // char from string A, string B
begin
  if (V = '') or (V = '0') then
  begin
    Result := M;
    Exit;
  end;
  if (M = '') or (M = '0') then
  begin
    Result := V;
    Exit;
  end;
  R := 0;
  LenV := Length(V);
  LenM := Length(M);
  MaxDigits := Max(LenV, LenM);
  Result := '';
  for I := 0 to MaxDigits - 1 do
  begin
    DigitV := LenV - I;
    DigitM := LenM - I;
    if I < LenV then CV := V[DigitV] else CV := '0';
    if I < LenM then CM := M[DigitM] else CM := '0';
    Digit := AddChars(CV, CM, R);
    Result := Digit + Result;
  end;
  if R > 0 then                          
    Result := '1' + Result;
end;

class function TBcd.SubtractStrings(const Value, Minus: string): string;
var
  Digit, V, M: string;
  LenV, LenM, MaxDigits, I, DigitV, DigitM: Integer;
  R: Byte;           // Remainder
  CV, CM: Char;      // char from string A, string B
begin
  if CompareDigits(Value, Minus) >= 0 then
  begin
    V := Value;
    M := Minus;
    Result := '';
  end else
  begin
    M := Value;
    V := Minus;
    Result := '-';
  end;
  if (V = '') or (M = '') then
  begin
    if V = '' then 
      Result := '-' + M 
    else
      Result := V;
  end;
  if (V = '0') or (M = '0') then
  begin
    if M = '0' then
      Result := V
    else if V = '0' then
      Result := '0'
    else
      Result := M;
    Exit;
  end;
  R := 0;
  LenV := Length(V);
  LenM := Length(M);
  MaxDigits := Max(LenV, LenM);
  Result := '';
  for I := 0 to MaxDigits - 1 do
  begin
    DigitV := LenV - I;
    DigitM := LenM - I;
    if I < LenV then
      CV := V[DigitV]
    else 
      CV := '0';
    if I < LenM then 
      CM := M[DigitM] 
    else 
      CM := '0';
    Digit := SubtractChars(CV, CM, R);
    Result := Digit + Result;
  end;
  if Result = '' then
    Result := '0';
end;

class function TBcd.InternalShortMultiply(const A, B: string): string;
var
  DecPos,W,L,I: Integer;
  S, SS, Times: LongWord;
  Value, Multiplier, Dot: string;
begin
  Dot := DecimalSeparator;
  GetValueAndMultiplyOrder(A, B, Value, Multiplier, Length(A), Length(B), W, L, DecPos);
  Times := 1;
  S := 0;
  for I := L downto 1 do
  begin
    SS := LongWord(LongWord((Ord(Multiplier[I])-Byte(48))) * LongWord(StrToInt64(Value)) * Times);
    S := SS + S;
    Times := Times * 10;
  end;
  Result := IntToStr(S);
  if DecPos <> _NoDecimal then
  begin
    I := Length(Result) - DecPos;
    if I = 0 then
      Result := '0' + Dot + Result
    else if I > 0 then
      Result := Copy(Result,1, I) + Dot + Copy(Result,I+1,DecPos)
    else if I < 0 then
      Result := Dot + StringOfChar('0', -I) + Result;
  end;
end;

class function TBcd.StringMultiplyByByte(const Value: string; B: Byte): string;
var
  I: SmallInt;
  R, SB: Byte;
begin
  R := 0;
  Result := '';
  for I := Length(Value) downto 1 do
  begin
    SB :=  ((Byte(Value[I]) - 48) *B) + R;
    R := SB Div 10;
    if R > 0 then
      SB := SB mod 10;
    Result := Char(Byte(48 + SB)) + Result;
  end;
  if R > 0 then
    Result := Char(Byte(48 + R)) + Result
end;

class function TBcd.InternalLongMultiply(const A, B: string): string;
const
  MaxSmall = 9;
var
  DecPos, W, L, I: Integer;
  Times, S, SS: string;
  Value, Multiplier, Dot: string;
  T1, T2: Integer;
begin
  Dot := DecimalSeparator;
  GetValueAndMultiplyOrder(A, B, Value, Multiplier, Length(A), Length(B), W, L, DecPos);
  T1 := Length(Value);
  T2 := Length(Multiplier);
  Times := '';
  S := '';
  for I := L downto 1 do
  begin
    if W < MaxSmall then
      SS := IntToStr(LongWord((Ord(Multiplier[I])-48) * StrToInt64(Value))) + Times
    else
      SS := StringMultiplyByByte(Value, Ord(Multiplier[I])-48) + Times;
    S := AddStrings(SS,S);
    Times := Times + '0';
  end;
  Result := LeftTrim(S);
  if DecPos <> _NoDecimal then
  begin
    I := Length(Result) - DecPos;
    if I = 0 then
      Result := '0' + Dot + Result
    else if I > 0 then
      Result := Copy(Result,1, I) + Dot + Copy(Result,I+1,DecPos)
    else if I < 0 then
      Result := Dot + StringOfChar('0', -I) + Result;
    if T1 + T2 > 1024 then Result := ''
  end;
end;

// Go through 2 strings and determine if total length > MaxDigits
class function TBcd.CanUseShort(A, B: string; MaxDigits: ShortInt): Boolean;
var
  Len, I: ShortInt;
  Dot: String;
begin
  Len := Length(A) + Length(B);
  Result := Len <= MaxDigits;
  if not Result then
  begin
    Dot := DecimalSeparator;
    if Pos(Dot, A) > 0 then
      Dec(Len, Length(Dot));
    if Pos(Dot, B) > 0 then
      Dec(Len, Length(Dot));
    Result := Len <= MaxDigits;
    if not Result then
    begin
      I := 1;
      while (Len > 0) and (A[I] = '0') and (I <= Length(A)) do
      begin
        Inc(I);
        Dec(Len);
      end;
      I := 1;
      while (Len > 0) and (B[I] = '0') and (I <= Length(B)) do
      begin
        Inc(I);
        Dec(Len);
      end;
      Result := Len <= MaxDigits;
    end;
  end;
end;

// Return True if S evaluates to 0
class function TBcd.BlankArgument(const S: string): Boolean;
var
  I, DecPos, Len, DecLen: Integer;
  Dot: string;
begin
  Dot := DecimalSeparator;
  Result := True;
  Len := Length(S);
  DecPos := Pos(Dot, S);
  DecLen := Length(Dot);
  if DecPos = 0 then
    Dec(DecPos, DecLen);
  for I := 1 to Len do
    if (S[I] <> '0') and ((I < DecPos) or (I >= DecPos + DecLen)) then
    begin
      Result := False;
      break;
    end;
end;

class function TBcd.StringMultiply(const Left, Right: string): TBcd;
var
  LLeft, LRight: string;
  NegCount: Integer;
begin
  NegCount := 0;

  if Left[1] = '-' then
  begin
    Inc(NegCount);
    LLeft := Copy(Left, 2, Length(Left) - 1);
  end
  else
    LLeft := Left;

  if Right[1] = '-' then
  begin
    Inc(NegCount);
    LRight := Copy(Right, 2, Length(Right) - 1);
  end
  else
    LRight := Right;

  Result := Parse(InternalMultiply(LLeft, LRight));
  if (NegCount mod 2) <> 0 then
    Result.FSignSpecialPlaces := (Result.FSignSpecialPlaces and 63) or (1 shl 7);
end;


class function TBcd.InternalMultiply(const A, B: string): string;
begin
  if BlankArgument(A) or BlankArgument(B) then
    Result := '0'
  else if CanUseShort(A, B, 9) then
    Result := InternalShortMultiply(A,B)
  else
    Result := InternalLongMultiply(A,B);
end;

class function TBcd.NextDigit(const V, D: string; var R: string): string;
begin
  R := V;
  Result := '0';
  while CompareDigits(R, D) >= 0 do
  begin
    Result := IntToStr(StrToInt64(Result) + 1);
    R := LeftTrim(SubtractStrings(R, D));
  end;
end;

class function TBcd.AdjustDecimalPosition(const Value: string;
  DecPos: SmallInt): string;
var
  Dot : string;
begin
  Dot := DecimalSeparator;
  Result := LeftTrim(Value);
  if DecPos = 0 then
    Result := '0' + Dot + Result
  else if DecPos > 0 then
    Result := '0' + Dot + StringOfChar('0', DecPos) + Result
  else // DecPos < 0 then
  begin
    if -DecPos >= Length(Result) then
      Result := Result + StringOfChar('0', (-DecPos)-Length(Result))
    else if -DecPos < Length(Result) then
    begin
      Result := Copy(Result, 1, -DecPos) + Dot + Copy(Result, (-DecPos)+1, Length(Result));
    end;
  end;
end;

class function TBcd.ValueOverOne(D: string): string;
var
  R: string;
  V: string;
  AddZeros, DecimalPos: SmallInt;
  Dot : string;
begin
  Dot := DecimalSeparator;
  DecimalPos := Pos(Dot, D);
  if DecimalPos > 0 then
  begin
    Result := '10';
    Dec(DecimalPos,2);  // 1/.2 = 5.0; 1/2.2 = .45;
    if DecimalPos = -1 then // D[1] is DecimalSeparator
    begin
      D := Copy(D, 2, Length(D) -1);
      while D[1] = '0' do
      begin
        Result := Result + '0';       // copy back later
        D := Copy(D, 2, Length(D) -1);
        Dec(DecimalPos);
      end;
    end else
      D := StringReplace(D, Dot, '', []);
  end else
  begin
    DecimalPos := Length(D) -1;
    Result := '1';
  end;
  if (D ='1') or (D = '1' + StringOfChar('0', Length(D) -1)) then
    Result := AdjustDecimalPosition(Result, DecimalPos -1)
  else
  begin
    V := '1';
    R := V;
    AddZeros := Length(V) -1;  // for divisor of 12345, add 4 zeros
    V := V + StringOfChar('0', AddZeros);
    if CompareDigits(V,D) < 0 then   // if still less add 1
      V := V + '0';
    Result := '';
    while (R <> '0') and (Length(Result) < (MaxFMTBcdFractionSize + AddZeros)) do
    begin
      Result := Result + NextDigit(V, D, R);
      V := R + '0';
    end;
    Result := AdjustDecimalPosition(Result, DecimalPos);
  end;
end;

class function TBcd.InternalLongDivide(A, B: string): string;
var
  Negative: Boolean;
  FinalDecimalPos, Decimals, DotExtra : Integer;
  Dot: string;
begin
  Dot := DecimalSeparator;
  DotExtra := Length(Dot) - 1;
  Result := '0';
  // save pos/minus info and remove '-'
  Negative := (A[1] <> B[1]) and ((A[1] = '-') or (B[1] = '-'));
  if A[1] = '-' then A := Copy(A, 2, Length(A)-1);
  if B[1] = '-' then B := Copy(B, 2, Length(B)-1);
  if A = '0' then
    Exit;
  while A[1] = '0' do A := Copy(A, 2, Length(A)-1);
  while B[1] = '0' do B := Copy(B, 2, Length(B)-1);
  Result := ValueOverOne(B);
  Result := InternalMultiply(A, Result);
  Decimals := Length(A) - Pos(Dot, A) - DotExtra;
  if Length(B) - Pos(Dot, B) - DotExtra > Decimals then
    Decimals := Length(B) - Pos(Dot, B) - DotExtra;
  FinalDecimalPos := Pos(Dot, Result);
  { if there are more than DecimalPos + 20 decimals, truncate }
  if (Length(Result) - FinalDecimalPos - DotExtra) > (Decimals + 20) then
    SetLength(Result, FinalDecimalPos + Decimals + 20 + DotExtra);
  if Negative then
    Result := '-' + Result;
end;

class function TBcd.InternalDivide(const A, B: string): string;
begin
  if BlankArgument(A) and BlankArgument(B) then
  begin
    if (A = '') or (A = '0') then
      Result := '0'
    else
      BcdDivZeroError;
  end
  else if B = '1' then
    Result := A
  else if B = '-1' then
    Result := '-' + A
  else if CompareStr(A,B) = 0 then
    Result := '1'
  else
    Result := InternalLongDivide(A,B);
end;

class function TBcd.StringDivide(const Left, Right: string): TBcd;
var
  LLeft, LRight: string;
  NegCount: Integer;
  MaxDecimals: Byte;
begin
  if (Right = '0') or (Right = '') then
    BcdDivZeroError;
  NegCount := 0;
  MaxDecimals := (Result.FSignSpecialPlaces and 63) + _DefaultDecimals;

  if Left[1] = '-' then
  begin
    Inc(NegCount);
    LLeft := Copy(Left, 2, Length(Left)-1);
  end
  else
    LLeft := Left;

  if Right[1] = '-' then
  begin
    Inc(NegCount);
    LRight := Copy(Right, 2, Length(Right)-1);
  end
  else
    LRight := Right;

  Result := Parse(RoundAt(InternalDivide(LLeft, LRight), MaxDecimals));
  if (NegCount mod 2) <> 0 then
    Result.FSignSpecialPlaces := (Result.FSignSpecialPlaces and 63) or (1 shl 7);
end;

class function TBcd.InvalidBcdString(Value: string): Boolean;
var
  I, DecPos, DecEnd: Integer;
  Dot: string;
begin
  Result := False;
  Dot := DecimalSeparator;
  DecPos := Pos(Dot, Value);
  if DecPos = 0 then
    DecEnd := DecPos
  else
    DecEnd := DecPos + Length(Dot);
  for I := 1 to Length(Value) do
    if (not (Value[I] in ['0'..'9', '-'])) and
       ((I < DecPos) or (I >= DecEnd))  then
    begin
      Result := True;
      break;
    end;
end;

class procedure TBcd.ZeroBcd(var Bcd: TBcd; FractionOnly: Boolean = False);
var
 I: Integer;
begin
  if not FractionOnly then
  begin
    Bcd.FPrecision := 10;
    Bcd.FSignSpecialPlaces := 2;
  end;
  for I := 0 to 31 do
    Bcd.FFraction[I] := 0;
end;

const 
  spaceChars = [ ' ', #6, #10, #13, #14];

class function TBcd.TryParse(const AValue: string; var Bcd: TBcd): Boolean;
var
  Neg: Boolean;
  ICopyDigits, NumDigits: Word;
  DecimalPos: SmallInt;
  Source: string;
  Nibble1, Nibble2: Byte;
  Dot: String;
begin
  Dot := DecimalSeparator;
  ZeroBcd(Bcd);
  if InvalidBcdString(AValue) then
  begin
    Result := False;
    exit;
  end;
  if (AValue = '0') or (AValue = '') then
  begin
    Result := True;
    Exit;
  end;
  Result := True;
  Neg := False;
  DecimalPos := Pos(Dot, AValue);
  if DecimalPos = 0 then
    DecimalPos := -1;

  NumDigits := Length(AValue);

  { Strip leading whitespace }
  iCopyDigits := 1;
  while (iCopyDigits <= NumDigits) and
    ((AValue[iCopyDigits] in spaceChars) or ((AValue[iCopyDigits] in ['0', '+', '-']))) do
  begin
    if AValue[iCopyDigits] = '-' then
      Neg := True;
    Inc(iCopyDigits);
    if DecimalPos > 0 then
      Dec(DecimalPos);
  end;
  NumDigits := NumDigits + 1 - ICopyDigits;
  Source := Copy(AValue, iCopyDigits, NumDigits);
  if (NumDigits = 0) or (AValue = '0') or (AValue = '') then
    Exit;

 { Strip trailing whitespace }
  ICopyDigits := NumDigits;
  while (Source[ICopyDigits] in spaceChars) do
    Dec(ICopyDigits);
  if ICopyDigits <> NumDigits then
  begin
    SetLength(Source, ICopyDigits);
    NumDigits := ICopyDigits;
  end;

  if (NumDigits > MaxFMTBcdFractionSize) then
  begin
    if (DecimalPos >= 0) and (DecimalPos <= MaxFMTBcdFractionSize) then
      NumDigits := MaxFMTBcdFractionSize // truncate to 64
    else
      BcdError(sBcdOverflow);
  end;

  if NumDigits > 0 then
  begin
    if DecimalPos > 0 then
    begin
      Source := StringReplace(Source, Dot, '', []);
      Dec(NumDigits);
      Dec(DecimalPos);
    end;
    if Length(Source) mod 2 = 1 then
    begin
      { enforce even # of nibbles }
      Source := '0' + Source;
      Inc(NumDigits);
      if DecimalPos >= 0 then
        Inc(DecimalPos);
    end;
    ICopyDigits := 1;
    while ICopyDigits <= NumDigits do
    begin
      Nibble1 := Byte(Ord(Source[ICopyDigits]) - 48);
      Nibble2 := Ord(Source[ICopyDigits+1]) - Ord('0');
      Nibble2 := Nibble2 and $0F; { just to be safe}
      PutTwoBcdDigits(Nibble1, Nibble2, Bcd, ICopyDigits-1);
      Inc(ICopyDigits, 2);
    end;
    Bcd.FPrecision := NumDigits;
    if DecimalPos >= 0 then
      Bcd.FSignSpecialPlaces := NumDigits - DecimalPos
    else
      Bcd.FSignSpecialPlaces := 0;
  end
  else
  begin
    Bcd.FPrecision := 10;
    Bcd.FSignSpecialPlaces := 2;
  end;

  if Neg then
    Bcd.FSignSpecialPlaces := (Bcd.FSignSpecialPlaces and 63) or (1 shl 7);
end;

class function TBcd.SignificantIntDigits(const BcdIn: TBcd; Digits: Word): Word;
var
  b: byte;
  I, J: Integer;
begin
  I :=0;
  Result := Digits;
  while Result > 0 do
  begin
    b := BcdIn.FFraction[I];
    if b = 0 then
    begin
      for J := 1 to 2 do
        if Result > 0 then
          Result := Result -1;
      if Result = 0 then
        break;
      Inc(I);
    end else
    begin
                                                                                        
      break;
    end;
  end;
end;

class procedure TBcd.AddSubtractNormalizedFractions(const BcdIn1, BcdIn2: TBcd; var BcdOut: TBcd; Subtract: Boolean);
var
  TwoNibbles1, TwoNibbles2, Nib1, Nib2, Remainder: Byte;
  SumNib1, SumNib2: ShortInt;
  I : Integer;
begin
  BcdOut.FPrecision := BcdIn1.FPrecision;
  if BcdIn1.FPrecision mod 2 = 0 then
    I := (BcdIn1.FPrecision div 2) -1
  else
    I := (BcdIn1.FPrecision div 2);
  Remainder := 0;
  while I >= 0 do
  begin
    TwoNibbles1 := BcdIn1.FFraction[I];
    TwoNibbles2 := BcdIn2.FFraction[I];
    Nib1 := Byte(Byte(TwoNibbles1 AND 15));
    Nib2 := Byte(Byte(TwoNibbles2 AND 15));
    if Subtract then
    begin
      SumNib1 := Nib1 - (Nib2 + Remainder);
      if SumNib1 < 0 then
      begin
        Remainder := 1;
        Inc(SumNib1, 10);
      end else
        Remainder := 0;
    end else
    begin
      SumNib1 := Nib1 + Nib2 + Remainder;
      Remainder := SumNib1 div 10;
      SumNib1 := SumNib1 mod 10;
    end;

    Nib1 := Byte(TwoNibbles1 SHR 4);
    Nib2 := Byte(TwoNibbles2 SHR 4);
    if Subtract then
    begin
      SumNib2 := Nib1 - (Nib2 + Remainder);
      if SumNib2 < 0 then
      begin
        Remainder := 1;
        Inc(SumNib2, 10);
      end else
        Remainder := 0;
    end else
    begin
      SumNib2 := Nib1 + Nib2 + Remainder;
      Remainder := SumNib2 div 10;
      SumNib2 := SumNib2 mod 10;
    end;
    Nib1 := SumNib2 SHL 4;
    Nib1 := Nib1 OR (Byte(SumNib1) AND 15);
    BcdOut.FFraction[I] := Nib1;
    Dec(I);
  end;
end;

class procedure TBcd.SubtractNormalizedFractions(const BcdIn1, BcdIn2: TBcd; var BcdOut: TBcd);
begin
  AddSubtractNormalizedFractions(BcdIn1, BcdIn2, BcdOut, True);
end;

class procedure TBcd.AddNormalizedFractions(const BcdIn1, BcdIn2: TBcd; var BcdOut: TBcd);
begin
  AddSubtractNormalizedFractions(BcdIn1, BcdIn2, BcdOut, False);
end;

class function TBcd.CompareNormalizedFractions(const BcdIn1, BcdIn2: TBcd; Digits1, Digits2: SmallInt): Integer;
var
  I, Count: SmallInt;
  N1, N2: Byte;
begin
  Count := Min(Digits1, Digits2) div 2;
  for I := 0 to Count - 1 do
    if BcdIn1.FFraction[I] <> BcdIn2.FFraction[I] then
    begin
      // compare first nibble
      N1 := BcdIn1.FFraction[I] shr 4;
      N2 := BcdIn2.FFraction[I] shr 4;
      Result := N1 - N2;
      if Result = 0 then // first nibble was the same, try second
      begin
        N1 := BcdIn1.FFraction[I] and $0f;
        N2 := BcdIn2.FFraction[I] and $0f;
        Result := N1 - N2;
      end;
      Exit;
    end;
  // if we got here, they matched except one has more digits -- check if remaining are 0
  Result := Digits1 - Digits2; // assume they are not all zeros
  if Digits1 > Digits2 then
  begin
    for I := Count to (Digits1 div 2) - 1 do
      if BcdIn1.FFraction[I] <> 0 then
        Exit;
  end else
    for I := Count to (Digits2 div 2) - 1 do
      if BcdIn2.FFraction[I] <> 0 then
        Exit;
  Result := 0; // they were all zeros, change result
end;

class function TBcd.NumberOfDigits(const ABcd: TBcd): Integer;
var
  P: Word;
begin
  Result := ABcd.FPrecision;
  P := 0;
  while (Result > 1) and (Abcd.FFraction[P] = 0) do
  begin
    Dec(Result, 2);   // decrement two nibbles per byte
    Inc(P);
  end;
end;

class function TBcd.CompactBcd(const ABcd: TBcd; const MinSize: Integer): TBcd;
var
  I, J, CharsToMove: Integer;
begin
  if ABcd.FPrecision <= MinSize then
  begin
    Result := ABcd;
    exit;
  end;
  Result.FPrecision := ABcd.FPrecision;
  Result.FSignSpecialPlaces := ABcd.FSignSpecialPlaces;
  ZeroBcd(Result, True);
  I := 0;
  while (Result.FPrecision > MinSize) and (ABcd.FFraction[I] = 0) do
  begin
    Dec(Result.FPrecision,2);
    Inc(I);
  end;
  CharsToMove := (2+ (Result.FPrecision + Result.Scale)) div 2;
  if CharsToMove > SizeOfFraction{of Result} then CharsToMove := SizeOfFraction{of Result};
  for J := 0 to CharsToMove - 1 do
    Result.FFraction[J] := ABcd.FFraction[I + J];
end;

class procedure TBcd.NormalizeBcdPair(const BcdIn1, BcdIn2: TBcd;
  var bcdOut1, bcdOut2: TBcd; ExtraDigits: Word = 0 );
var
  MaxDigits, MaxScale: Word;
  Bcd1, Bcd2: TBcd;

  { Guarantee Bcd has even number Precision }
  function AdjustNibbles(ABcd: TBcd): TBcd;
  var
    I, Start: Integer;
  begin
    Result := ABcd;
    if (ABcd.FPrecision mod 2) <> 0 then
    begin
      Result.FFraction[0] := 0;
      Result.FPrecision := ABcd.FPrecision + 1;
      MoveNibblesRight(Result, ABcd, ABcd.FPrecision);
    end;
    { Guarantee unused Nibbles are blank}
    Start := (Result.FPrecision div 2);
    for I := Start to SizeOfFraction{of Result} -1 do
      Result.FFraction[I] := 0;
  end;

begin
  Bcd1 := AdjustNibbles(BcdIn1);
  Bcd2 := AdjustNibbles(BcdIn2);
  if (Bcd1.FPrecision > 32) or (Bcd2.FPrecision > 32) then
  begin
    MaxDigits := Max(NumberOfDigits(bcdIn1), NumberOfDigits(bcdIn2));
    if MaxDigits < Bcd1.FPrecision then MaxDigits := Bcd1.FPrecision;
    if MaxDigits < Bcd2.FPrecision then MaxDigits := Bcd2.FPrecision;
    Bcd1 := CompactBcd(Bcd1, MaxDigits);
    Bcd2 := CompactBcd(Bcd2, MaxDigits);
  end;
  MaxDigits := Max(Bcd1.FPrecision, Bcd2.FPrecision);
  MaxScale := Max(Bcd1.Scale, Bcd2.Scale);
  { ensure that MaxDigits is large enough: for example, if Bcd1 is 6.0 and
    Bcd2 10.5, then MaxDigits needs to be 12, not 10 }
  while (MaxDigits < (SizeOfFraction{of Bcd1} * 2)) and
        ((MaxDigits - MaxScale < Bcd1.FPrecision - Bcd1.Scale) or
         (MaxDigits - MaxScale < Bcd2.FPrecision - Bcd2.Scale)) do
    Inc(MaxDigits, 2);
  BcdOut1 := Bcd1.Normalize(MaxDigits, MaxScale);
  BcdOut2 := Bcd2.Normalize(MaxDigits, MaxScale);
end;

{ ffGeneral - General number format. The value is converted to the shortest
  possible decimal string using fixed format. Trailing zeros
  are removed from the resulting string, and a decimal point appears only
  if necessary. The resulting string uses fixed point format if the number
  of digits to the left of the decimal point in the value is less than or
  equal to the specified precision.  Otherwise an exception is thrown }

class function TBcd.BcdGeneralFormat(const Bcd: TBcd;
  const Precision, Digits: Integer): string;
begin
  Result := Bcd.ToString;
end;

{ ffExponent - Scientific format. Not supported for FMTBcd -- Bcd is
  by definition fixed format }

class function TBcd.BcdScientificFormat(const Bcd: TBcd;
  const Precision, Digits: Integer): string;
begin
  BcdError(SInvalidFormatType);
end;

{ ffFixed - Fixed point format. The value is converted to a string of the
  form "-ddd.ddd...". The resulting string starts with a minus sign if the
  number is negative, and at least one digit always precedes the decimal
  point. The number of digits after the decimal point is given by the Digits
  parameter--it must be between 0 and 18. If the value has more decimal values
  than permitted by Digits, it is truncated.  If the number of digits to the
  left of the decimal point is greater than the specified precision, an
  exception is thrown
  ffNumber - Number format. The ffNumber format corresponds to the ffFixed
  format, except that the resulting string contains thousand separators. }

class function TBcd.BcdFixedOrNumberFormat(const Start: string;
  Format: TFloatFormat; const Precision, Digits: Integer): string;
var
  P, DecPos, DecLen, Len: Integer;
  AddCommaDigits, DecDigits, BufPos: Integer;
  Dot, Comma: string;
begin
  Dot := DecimalSeparator;
  Comma := ThousandSeparator;
  BufPos := 0;
  Result := Start;
  Len := Length(Start);
  P := 1; // position in source string
  DecDigits := -1;
  DecPos := Pos(Dot, Result);
  DecLen := Length(Dot);
  if Format = ffNumber then
  begin
    AddCommaDigits := DecPos;
    if AddCommaDigits > 0 then
      Dec(AddCommaDigits)
    else
      AddCommaDigits := Length(Result);
  end else
    AddCommaDigits := 0;
  if Start[1] = '-' then
  begin
    Inc(BufPos); // current char is ok
    Inc(P);
    if AddCommaDigits > 0 then
      Dec(AddCommaDigits);
  end;
  while P <= Len do
  begin
    Inc(BufPos); // current char is ok
    if (P >= DecPos) and (P < DecPos + DecLen) then
      DecDigits := 0
    else if DecDigits > -1 then
      Inc(DecDigits);
    Inc(P);
    if AddCommaDigits > 3 then
    begin
      Dec(AddCommaDigits);
      if (AddCommaDigits mod 3 = 0) then
      begin
        Insert(Comma, Result, BufPos + 1);
        Inc(BufPos, Length(Comma));
      end;
    end;
  end;
  if DecDigits = -1 then
  begin
    if Digits > 0 then
    begin
      Insert(Dot, Result, BufPos + 1);
      Inc(BufPos, DecLen);
    end;
    DecDigits := 0;
  end;
  if DecDigits < Digits then
    Result := Result + StringOfChar('0', Digits - DecDigits);
  if Pos(Dot, Result) = BufPos + 1 - DecLen then
    SetLength(Result, BufPos - DecLen);
  Result := RoundAt( Result, Digits);
end;

class function TBcd.BcdCurrencyFormat(const Bcd: TBcd; const Start: string;
  const Precision, Digits: Integer): string;
begin
  Result := BcdFixedOrNumberFormat(Start, ffNumber, Precision, Digits);
  if Bcd.IsNegative then
    Result := AddNegCurrencySymbol(Copy(Result, 2, Length(Result)),
      CurrencyString, NegCurrFormat)
  else
    Result := AddCurrencySymbol(Result, CurrencyString, CurrencyFormat);
end;

class function TBcd.ExtractMoneySymbol( var CurrencyPos: Integer; var HoldFormat: String): string;
var
  TempPos: Integer;
begin
  TempPos := CurrencyPos;
  Result := '$';
  while (CurrencyPos > 0) and (HoldFormat[CurrencyPos-1] = ' ') do
  begin
    Dec(CurrencyPos);
    Result := ' ' + Result;
  end;
  while (TempPos < Length(HoldFormat)) and (HoldFormat[TempPos+1] = ' ') do
  begin
    Inc(TempPos);
    Result := Result + ' ';
  end;
  HoldFormat := StringReplace(HoldFormat, Result, '', []);
  Result := StringReplace(Result, '$', CurrencyString, []);
end;

class procedure TBcd.CalcPrecisionAndDigits( const HoldFormat: string;
  var Precision, Digits, ReqIntDigits: Integer);
begin
  if Digits > 0 then
  begin
    ReqIntDigits := Digits -1;
    Precision := Length(HoldFormat) -1;
    Digits := Length(HoldFormat) - Digits;
  end
  else
  begin
    Precision := Length(HoldFormat);
    ReqIntDigits := Precision;
    Digits := 0;
  end;
end;

class function TBcd.PadInputString(var InputString: string;
  var Precision: Integer; const ReqIntDigits: Integer): Boolean;
var
  DecSep: string;
  IntDigits, PadCount: Integer;
begin
  Result := True;
  DecSep := DecimalSeparator;
  IntDigits := Pos(DecSep, InputString);
  if IntDigits = 0 then
    IntDigits := Length(InputString)
  else
    Dec(IntDigits);
  PadCount := ReqIntDigits - IntDigits;
  if PadCount > 0 then
  begin
    InputString := '1' + StringOfChar('0', PadCount -1) + InputString;
    Inc(Precision);
  end else
    Result := False;
end;

class procedure TBcd.AddCurrency(var Output: string;
  const CurrencyPos: Integer; const MoneySymbol: string);
begin
  if CurrencyPos = 1 then
    Output := MoneySymbol + Output
  else if CurrencyPos >= Length(Output) then
    Output := Output + MoneySymbol
  else
    Output := Copy(Output, 1, CurrencyPos -1 ) + MoneySymbol +
      Copy(Output, CurrencyPos, Length(Output));
end;

type
  TLiteralInfo = class
  private
    FValue: string;
    FPosition: Integer;
  public
    property Value: string read FValue write FValue;
    property Position: Integer read FPosition write FPosition;
    constructor Create(Val: string; Pos: Integer);
  end;

constructor TLiteralInfo.Create(Val: string; Pos: Integer);
begin
  inherited Create;
  FValue := Val;
  FPosition := Pos;
end;

const
  FormatChars = ['#', '0', ',', '.'];
  LiteralMarkers = [#39, '"'];

class procedure TBcd.ExtractLiterals(LiteralList: TList; var HoldFormat: string);
var
  PStart: Integer;
  C: Char;
  I, Pos, LiteralPos: Integer;
  LiteralString: string;
  InLiteral: Boolean;
begin
  InLiteral := False;
  LiteralPos := 0;
  Pos := 1;
  LiteralString := '';
  while Pos <= Length(HoldFormat) do
  begin
    C := HoldFormat[Pos];
    if (C in LiteralMarkers) then
      InLiteral := not InLiteral
    else if not (C in FormatChars) then
    begin
      LiteralPos := Pos - 1;
      PStart := Pos;
      while (InLiteral) or not (HoldFormat[Pos] in FormatChars) do
      begin
        Inc(Pos);
        if (Pos >= Length(HoldFormat)) or (HoldFormat[Pos] in LiteralMarkers) then
        begin
          InLiteral := False;
          break;
        end;
      end;
      LiteralString := Copy(HoldFormat, PStart, Pos-PStart);
    end;
    if (not InLiteral) and (LiteralString <> '') then
    begin
      LiteralList.Add(TLiteralInfo.Create(LiteralString, LiteralPos));
      LiteralString := '';
    end;
    Inc(Pos);
  end;
  for I := 0 to LiteralList.Count -1 do
    HoldFormat := StringReplace(HoldFormat, (LiteralList.Items[I] as TLiteralInfo).Value, '', []);
end;

class procedure TBcd.AddLiterals(LiteralList: TList; var Output: string; const Format: string);
var
  I, Add: Integer;
  Pos: Integer;
  LI: TLiteralInfo;
begin
  Add := (Length(Output)+1) - Length(Format);
  if Add < 0 then Add := 0;
  for I := 0 to LiteralList.Count -1 do
  begin
    LI := LiteralList.Items[I] as TLiteralInfo;
    Pos := LI.Position;
    if Pos = 0 then
      Output := LI.Value + Output
    else if (Pos + Add) < Length(Output) then
    begin
      Inc(Pos, Add);
      Output := Copy(Output, 1, Pos -1 ) + LI.Value +
           Copy(Output, Pos, length(Output) - (Pos -1));
    end else
      Output := Output + LI.Value;
    LI.Free;
  end;
end;

class function TBcd.FormatOneBcd(const Format: string; Bcd: TBcd): string;
var
  Dot: string;
  Precision, Digits, ReqDigits: Integer;
  TempPos, CurrencyPos: Integer;
  MoneySymbol: string;
  FFormat: TFloatFormat;
  LeftPadZeros, RightPadZeros, UseCommas: Boolean;
  Neg, HoldFormat: string;
  LiteralList: TList;
begin
  Dot := DecimalSeparator;
  Neg := '';
  LiteralList := TList.Create;
  try
    HoldFormat := Format;
    CurrencyPos := Pos('$', Format);
    if CurrencyPos > 0 then
      MoneySymbol := ExtractMoneySymbol(CurrencyPos, HoldFormat);
    ExtractLiterals(LiteralList,HoldFormat);
    UseCommas := (Pos(',', HoldFormat) > 0);
    if UseCommas then
      HoldFormat := StringReplace(HoldFormat, ',', '', []);
    Digits := Pos(Dot, HoldFormat);
    CalcPrecisionAndDigits(HoldFormat, Precision, Digits, ReqDigits);
    TempPos := Pos('0', HoldFormat);
    LeftPadZeros := (TempPos > 0) and (TempPos < ReqDigits);
    TempPos := Pos('0', Copy(HoldFormat, ReqDigits, Digits + 1));
    RightPadZeros := TempPos > 0;
    if UseCommas then
      FFormat := ffNumber
    else
      if RightPadZeros or (Digits < Bcd.Scale) then
        FFormat := ffFixed
      else
        FFormat := ffGeneral;
    Result := BcdGeneralFormat(Bcd, Precision, Digits);
    if Bcd.IsNegative then
    begin
      Neg := '-';
      Result := StringReplace(Result, Neg, '', []);
      Inc(CurrencyPos);
    end;
    if LeftPadZeros then
      LeftPadZeros := PadInputString(Result, Precision, ReqDigits);
    if FFormat <> ffGeneral then
      Result := BcdFixedOrNumberFormat(Result, FFormat, Precision, Digits);
    if LeftPadZeros then
      Result := Neg + '0' + Copy(Result, 2, Length(Result) -1)
    else
      Result := Neg + Result;
    if MoneySymbol <> '' then
      AddCurrency(Result, CurrencyPos, MoneySymbol);
    AddLiterals(LiteralList, Result, HoldFormat);
  finally
    LiteralList.Free;
  end;
end;

class function TBcd.GetFormat(const Format: string; Section: TFormatSection): string;
const
  Separator: Char = ';';
var
  InLiteral: Boolean;
  P, PThisSection, SectionCount, Len: Integer;
  SPos: string;
begin
  if Pos(Separator,Format) = 0 then
    Result := Format
  else
  begin
    PThisSection := 1;
    SectionCount := 0;
    P := PThisSection;
    InLiteral := False;
    Len := Length(Format);
    while P <= Len do
    begin
      if (Format[P] in LiteralMarkers) then
        InLiteral := not InLiteral
      else if (Format[P] = Separator) and (not InLiteral) then
      begin
        if Ord(Section) = SectionCount then
          Break
        else if SectionCount = 0 then // remember first section
          SPos := Copy(Format, PThisSection, P - PThisSection);
        PThisSection := P + 1;
        Inc(SectionCount);
      end;
      Inc(P);
    end;
    // if we get here, we reached the end of the format string
    if SectionCount = Ord(Section) then
      Result := Copy(Format, PThisSection, P - PThisSection)
    else
      Result := SPos;
  end;
end;

//==============================================================================

{ FMTBcd variant create utils }

function VarFMTBcdCreate(const AValue: string; Precision, Scale: Word): Variant; overload;
begin
  Result := Variant(TBcd.Create(AValue, Precision, Scale));
end;

function VarFMTBcdCreate(const AValue: Double; Precision, Scale: Word): Variant; overload;
begin
  Result := Variant(TBcd.Create(AValue, Precision, Scale));
end;

procedure VarFMTBcdCreate(var ADest: Variant; const ABcd: TBcd); overload;
begin
  ADest := Variant(ABcd);
end;

function VarFMTBcdCreate: Variant; overload;
begin
  VarFMTBcdCreate(Result, TBcd.Empty);
end;

function VarFMTBcdCreate(const ABcd: TBcd): Variant;
begin
  VarFMTBcdCreate(Result, ABcd);
end;

function VarIsFMTBcd(const AValue: Variant): Boolean;
begin
  Result := TObject(AValue) is TBcd;
end;

var
  FVarType: TVarType;

function VarFMTBcd: TVarType;
begin
  Result := FVarType;
end;

//==============================================================================

{ utility routines }

function StrToBcd(const AValue: string): TBcd;
begin
  Result := TBcd.Parse(AValue);
end;

procedure DoubleToBcd(const AValue: Double; var Bcd: TBcd); overload;
begin
  Bcd := AValue;
end;

function DoubleToBcd(const AValue: Double): TBcd; overload;
begin
  Result := AValue;
end;

function VarToBcd(const AValue: Variant): TBcd;
begin
  Result := AValue;
end;

function IntegerToBcd( const AValue: Integer): TBcd;
begin
  Result := TBcd(AValue);
end;

function BcdToDouble(const Bcd: TBcd): Double;
begin
  Result := Double(Bcd);
end;

function BcdToInteger(const Bcd: TBcd; Truncate: Boolean = False): Integer;
begin
  Result := TBcd.ToInt64(Bcd, Truncate);
end;

function RoundAt(const Value: string; Position: SmallInt): string;
begin
  Result := TBcd.RoundAt(Value, Position);
end;

function NullBcd: TBcd;
begin
  Result := TBcd.Empty;
end;

function TryStrToBcd(const AValue: string; var Bcd: TBcd): Boolean;
begin
  Result := TBcd.TryParse(AValue, Bcd);
end;

function NormalizeBcd(const InBcd: TBcd; var OutBcd: TBcd; const Prec, Scale: Word): Boolean;
begin
  OutBcd := InBcd.Normalize(Prec, Scale);
  Result := True;
end;

function BcdCompare(const Bcd1, Bcd2: TBcd): Integer;
begin
  Result := TBcd.Compare(Bcd1, Bcd2);
end;

procedure BcdSubtract(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd);
begin
  bcdOut := bcdIn1 - bcdIn2;
end;

procedure BcdMultiply(StringIn1, StringIn2: string; var bcdOut: TBcd); overload;
begin
  bcdOut := TBcd.StringMultiply(StringIn1, StringIn2);
end;

procedure BcdMultiply(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd);
begin
  bcdOut := bcdIn1 * bcdIn2;
end;

procedure BcdMultiply(const bcdIn: TBcd; const DoubleIn: Double; var bcdOut: TBcd);
begin
  bcdOut := bcdIn * DoubleIn;
end;

procedure BcdMultiply(const bcdIn: TBcd; const StringIn: string; var bcdOut: TBcd);
begin
  bcdOut := bcdIn * StringIn;
end;

procedure BcdDivide(Dividend, Divisor: string; var bcdOut: TBcd); overload;
begin
  bcdOut := TBcd.StringDivide(Dividend, Divisor);
end;

procedure BcdDivide(const Dividend, Divisor: TBcd; var bcdOut: TBcd);
begin
  bcdOut := Dividend / Divisor;
end;

procedure BcdDivide(const Dividend: TBcd; const Divisor: Double; var bcdOut: TBcd);
begin
  bcdOut := Dividend / Divisor;
end;

procedure BcdDivide(const Dividend: TBcd; const Divisor: string; var bcdOut: TBcd);
begin
  bcdOut := Dividend / Divisor;
end;

procedure BcdAdd(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd);
begin
  bcdOut := bcdIn1 + bcdIn2;
end;

function BcdToStr(const Bcd: TBcd): string;
begin
  Result := Bcd.ToString;
end;

function BcdPrecision(const Bcd: TBcd): Word;
begin
  Result := Bcd.SignificantDigits;
end;

function BcdScale(const Bcd: TBcd): Word;
begin
  Result := Bcd.Scale;
end;

function IsBcdNegative(const Bcd: TBcd): Boolean;
begin
  Result := Bcd.IsNegative;
end;

function CurrToBCD(const Curr: Currency; var BCD: TBcd; Precision: Integer = 32;
  Decimals: Integer = 4): Boolean;
begin
  Bcd := TBcd.Create(Curr, Precision, Decimals);
  Result := True;
end;

function BCDToCurr(const BCD: TBcd; var Curr: Currency): Boolean;
begin
  Curr := BCD;
  Result := True;
end;

function BcdToStrF(const Bcd: TBcd; Format: TFloatFormat; const Precision, Digits: Integer): string;
begin
  Result := Bcd.ToString(Format, Precision, Digits);
end;

function FormatBcd(const Format: string; Bcd: TBcd): string;
begin
  Result := Bcd.Format(Format);
end;

initialization
  FVarType := RegisterCustomVariantType(TypeOf(TBcd));
end.
