DP Tool Club 17/CD_ASCQ_17_101194.iso/vrac/ajcbcd.zip/AJCBCD.PAS

Pascal/Delphi Source File | 1994-08-06 | 26KB | 970 lines

{************************************************}
{                                                }
{   AJC Binary Coded Decimal Unit                }
{                                                }
{   Author:  Andrew J. Cook                      }
{            Omaha, NE                           }
{            CompuServe ID:  71331,501           }
{                                                }
{   Written: May 1994                            }
{                                                }
{   Copyright:  None!  I hereby commit this unit }
{                      to the public domain.     }
{                                                }
{************************************************}

unit AJCBCD;

interface

uses Objects, Strings;

const
  DigitSize = SizeOf(Byte);
  bpw_Fixed = 0;
  bpw_Variable = 1;
  bpz_Blank = True;
  bpz_NotBlank = False;
  MaxBCDSize = 100;
  st_Blanks25 = '                         ';
  st_Blanks = st_Blanks25
            + st_Blanks25
            + st_Blanks25
            + st_Blanks25
            + st_Blanks25
            + st_Blanks25
            + st_Blanks25
            + st_Blanks25
            + st_Blanks25
            + st_Blanks25
            + st_Blanks25;

type
  PBCDArray = ^TBCDArray;
  TBCDArray = array[1..MaxBCDSize] of byte;

  TBCDSign = (BCDNegative, BCDPositive);

  PBCD = ^TBCD;
  TBCD = object(TObject)
    BCDSize:  Integer;
    Sign:  TBCDSign;
    Value:  PBCDArray;
    Precision: Byte;
    constructor InitBCD(AVal: PBCD);
    constructor InitReal(AVal: Real; APrec: Byte; ASize: Integer);
    constructor InitPChar(AVal: PChar; APrec: Byte; ASize: Integer);
    destructor Done; virtual;
    constructor Load(var S: TStream);
    procedure Store(var S: TStream);
    function GetValue: PBCDArray;
    function GetSign: TBCDSign;
    function GetPrecision: Byte;
    function GetBCDSize: Integer;
    procedure SetValueBCD(AVal: PBCD);
    procedure SetValueReal(AVal: Real);
    procedure SetValuePChar(AVal: PChar);
    procedure SetSign(ASign: TBCDSign);
    procedure SetPrecision(APrec: Byte);
    procedure SetBCDSize(ASize: Integer);
    procedure AddBCD(AVal: PBCD);
    procedure AddReal(AVal: Real);
    procedure AddPChar(AVal: PChar);
    procedure SubtractBCD(AVal: PBCD);
    procedure SubtractReal(AVal: Real);
    procedure SubtractPChar(AVal: PChar);
    procedure MultiplyByBCD(AVal: PBCD);
    procedure MultiplyByReal(AVal: Real; APrec: Byte);
    procedure MultiplyByPChar(AVal: PChar; APrec: Byte);
    procedure DivideByBCD(AVal: PBCD);
    procedure DivideByReal(AVal: Real; APrec: Byte);
    procedure DivideByPChar(AVal: PChar; APrec: Byte);
    procedure AbsoluteValue;
    procedure Increment;
    procedure Decrement;
    procedure ShiftLeft(ShiftAmount: Byte);
    procedure ShiftRight(ShiftAmount: Byte);
    function BCD2Int: LongInt;
    function BCD2Real: Real;
    function PicStr(picture: string;
                    Width: Integer; BlankWhenZero: Boolean): String;
    function StrPic(dest: PChar; picture: string;
                    Width: Integer; BlankWhenZero: Boolean;
                    Size: Integer): PChar;
    function CompareBCD(AVal: PBCD): Integer;
    function CompareReal(AVal: Real): Integer;
    function ComparePChar(AVal: PChar): Integer;
  end;

const

  RBCD:  TStreamRec = (ObjType:  60000;
                       VmtLink:  Ofs(TypeOf(TBCD)^);
                       Load:     @TBCD.Load;
                       Store:    @TBCD.Store);

var
  BCDZero:  PBCD;

implementation

{*********************************************************************}
{BCDAdd is a subroutine that adds the value in BCD2 to the value in   }
{BCD1.  It is a simple magnitude addition, as if the two numbers have }
{the same sign.  BCDAdd makes the following assumptions:              }
{  1) the calling routine will manage the proper sign of the result   }
{     of the addition.                                                }
{  2) the BCDSize of the two operands are equal                       }
{  3) the Precision of the two operands are equal                     }
{*********************************************************************}
procedure BCDAdd(BCD1, BCD2: PBCD);
var
  i:  integer;
  Carry:  Byte;
begin
  Carry := 0;
  for i := BCD1^.BCDSize downto 1 do
    begin
      BCD1^.Value^[i] := BCD1^.Value^[i] + BCD2^.Value^[i] + Carry;
      if BCD1^.Value^[i] > 9 then
        begin
          dec(BCD1^.Value^[i], 10);
          Carry := 1;
        end
      else
        Carry := 0;
    end;
end;

{**********************************************************************}
{BCDSubtraction is a subroutine that subtracts the value in BCD2 from  }
{the value in BCD1.  It is a simple magnitude subtraction, without     }
{regard to the sign of the operands.  BCDSubtract makes the following  }
{assumptions:                                                          }
{  1) the calling routine will manage the proper sign of the result    }
{     of the subtraction.                                              }
{  2) the BCDSize of the two operands are equal                        }
{  3) the Precision of the two operands are equal                      }
{  4) the magnitude of the value in BCD2 is less than or equal to the  }
{     magnitude of the value in BCD1 so that the routine can perform   }
{     a simple byte by byte subtraction                                }
{**********************************************************************}
procedure BCDSubtract(BCD1, BCD2: PBCD);
var
  i:  integer;
  Borrow:  Byte;
begin
  Borrow := 0;
  for i := BCD1^.GetBCDSize downto 1 do
    begin
      BCD1^.Value^[i] := BCD1^.Value^[i] + 10 - BCD2^.Value^[i] - Borrow;
      if BCD1^.Value^[i] >  9 then
        begin
          dec(BCD1^.Value^[i], 10);
          Borrow := 0;
        end
      else
        Borrow := 1;
    end;
end;

constructor TBCD.InitBCD(AVal: PBCD);
begin
  inherited Init;
  BCDSize := AVal^.GetBCDSize;
  GetMem(Value, BCDSize*DigitSize);
  Precision := AVal^.GetPrecision;
  SetValueBCD(AVal);
end;

constructor TBCD.InitReal(AVal: Real; APrec: Byte; ASize: Integer);
begin
  inherited Init;
  if ASize > MaxBCDSize then
    BCDSize := MaxBCDSize
  else
    BCDSize := ASize;
  GetMem(Value, ASize*DigitSize);
  Precision := APrec;
  SetValueReal(AVal);
end;

constructor TBCD.InitPChar(AVal: PChar; APrec: Byte; ASize: Integer);
begin
  inherited Init;
  if ASize > MaxBCDSize then
    BCDSize := MaxBCDSize
  else
    BCDSize := ASize;
  GetMem(Value, ASize*DigitSize);
  Precision := APrec;
  SetValuePChar(AVal);
end;

destructor TBCD.Done;
begin
  FreeMem(Value, BCDSize*DigitSize);
  inherited Done;
end;

constructor TBCD.Load(var S: TStream);
begin
  S.Read(BCDSize, SizeOf(BCDSize));
  S.Read(Sign, SizeOf(Sign));
  GetMem(Value, BCDSize*DigitSize);
  S.Read(Value^, BCDSize*DigitSize);
  S.Read(Precision, SizeOf(Precision));
end;

procedure TBCD.Store(var S: TStream);
begin
  S.Write(BCDSize, SizeOf(BCDSize));
  S.Write(Sign, SizeOf(Sign));
  S.Write(Value^, BCDSize*DigitSize);
  S.Write(Precision, SizeOf(Precision));
end;

function TBCD.GetValue: PBCDArray;
var
  WrkValue:  PBCDArray;
begin
  GetMem(WrkValue, BCDSize*DigitSize);
  Move(Value^, WrkValue^, BCDSize*DigitSize);
  GetValue := WrkValue;
end;

function TBCD.GetSign: TBCDSign;
begin
  GetSign := Sign;
end;

function TBCD.GetPrecision: Byte;
begin
  GetPrecision := Precision;
end;

function TBCD.GetBCDSize:  Integer;
begin
  GetBCDSize := BCDSize;
end;

procedure TBCD.SetValueBCD(AVal: PBCD);
var
  SaveSize:  Integer;
  SavePrecision:  Byte;
begin
  if AVal = nil then exit;

  FreeMem(Value, BCDSize*DigitSize);

  SaveSize := GetBCDSize;
  SavePrecision := GetPrecision;

  Value := AVal^.GetValue;
  BCDSize := AVal^.GetBCDSize;
  Precision := AVal^.GetPrecision;

  if Precision > SavePrecision then
    begin
      SetBCDSize(SaveSize);
      SetPrecision(SavePrecision);
    end
  else
    begin
      SetPrecision(SavePrecision);
      SetBCDSize(SaveSize);
    end;

    SetSign(AVal^.GetSign);
end;

procedure TBCD.SetSign(ASign: TBCDSign);
var
  i:  integer;
begin
  Sign := BCDPositive;
  if ASign = BCDPositive then exit;

  {allow negative sign only if value is non-zero}
  for i := GetBCDSize downto 1 do
    if Value^[i] <> 0 then
      begin
        Sign := BCDNegative;
        exit;
      end;
end;

procedure TBCD.SetValueReal(AVal: Real);
var
  i, BCDIndex:  integer;
  ValStr: String;
begin
  FillChar(Value^, BCDSize*DigitSize, #0);

  Str(abs(AVal):BCDSize:Precision, ValStr);
  BCDIndex := BCDSize;
  for i :=length(ValStr) downto 1 do
    if ValStr[i] in ['0'..'9'] then
      begin
        Value^[BCDIndex] := ord(ValStr[i]) - ord('0');
        dec(BCDIndex);
      end;

  if AVal < 0.0 then
    SetSign(BCDNegative)
  else
    SetSign(BCDPositive);
end;

procedure TBCD.SetValuePChar(AVal: PChar);
var
  i, BCDIndex:  integer;
  SavePrec: Byte;
  SaveSign: TBCDSign;
begin
  if AVal = nil then exit;

  SaveSign := BCDPositive;
  SavePrec := Precision;
  Precision := 0;

  FillChar(Value^, BCDSize*DigitSize, #0);

  if StrLen(AVal) = 0 then
    begin
      Precision := SavePrec;
      SetSign(BCDPositive);
      exit;
    end;

  BCDIndex := BCDSize;
  for i := StrLen(AVal) downto 0 do
    case AVal[i] of
      '0'..'9':     begin
                      Value^[BCDIndex] := ord(AVal[i]) - ord('0');
                      dec(BCDIndex);
                    end;
      '(',')','-':  begin
                      SaveSign := BCDNegative;
                    end;
      '.':          begin
                      Precision := BCDSize - BCDIndex;
                    end;
    end;  {case}

  SetPrecision(SavePrec);
  SetSign(SaveSign);
end;

procedure TBCD.SetPrecision(APrec: Byte);
begin
  if APrec = Precision then exit;
  if APrec < Precision then
    ShiftRight(Precision - APrec)
  else
    ShiftLeft(APrec - Precision);
  Precision := APrec;
end;

procedure TBCD.SetBCDSize(ASize: Integer);
var
  SaveSize:  Integer;
  WrkVal:  PBCDArray;
begin
  if ASize = GetBCDSize then exit;

  if ASize > MaxBCDSize then ASize := MaxBCDSize;

  GetMem(WrkVal, ASize*DigitSize);
  FillChar(WrkVal^, ASize*DigitSize, #0);

  if ASize < GetBCDSize then
    Move(Value^[(GetBCDSize-ASize)+1], WrkVal^, ASize*DigitSize)
  else if ASize > GetBCDSize then
    Move(Value^, WrkVal^[(ASize-GetBCDSize)+1], GetBCDSize);

  FreeMem(Value, GetBCDSize*DigitSize);
  Value := WrkVal;
  BCDSize := ASize;
end;

procedure TBCD.AddBCD(AVal: PBCD);
var
  WrkValue:  PBCD;
begin
  WrkValue := new(PBCD, InitBCD(AVal));
  WrkValue^.SetPrecision(Precision);
  WrkValue^.SetBCDSize(BCDSize);
  if GetSign <> AVal^.GetSign then
    if AVal^.GetSign = BCDNegative then
      begin
        WrkValue^.AbsoluteValue;
        BCDSubtract(@Self, WrkValue);
        Dispose(WrkValue, Done);
        exit;
      end
    else
      {AVal^.GetSign = BCDPositive}
      begin
        AbsoluteValue;
        BCDSubtract(WrkValue, @Self);
        SetValueBCD(WrkValue);
        Dispose(WrkValue, Done);
        exit;
      end;

  BCDAdd(@Self, WrkValue);
  Dispose(WrkValue, Done);
end;

procedure TBCD.AddReal(AVal: Real);
var
  WrkValue: PBCD;
begin
  WrkValue := new(PBCD, InitReal(AVal, GetPrecision, GetBCDSize));
  AddBCD(WrkValue);
  Dispose(WrkValue, Done);
end;

procedure TBCD.AddPChar(AVal: PChar);
var
  WrkValue: PBCD;
begin
  WrkValue := new(PBCD, InitPChar(AVal, GetPrecision, GetBCDSize));
  AddBCD(WrkValue);
  Dispose(WrkValue, Done);
end;

procedure TBCD.SubtractBCD(AVal: PBCD);
var
  WrkValue:  PBCD;
  SaveSign:  TBCDSign;
begin
  if AVal = nil then exit;

  WrkValue := new(PBCD, InitBCD(AVal));
  WrkValue^.SetPrecision(GetPrecision);
  WrkValue^.SetBCDSize(GetBCDSize);
  if GetSign <> AVal^.GetSign then
    begin
      WrkValue^.SetSign(Sign);
      BCDAdd(@Self, WrkValue);
      Dispose(WrkValue, Done);
      exit;
    end;

  SaveSign := Sign;
  AbsoluteValue;
  WrkValue^.AbsoluteValue;
  if CompareBCD(WrkValue) < 0 then
    begin
      BCDSubtract(WrkValue, @Self);
      SetValueBCD(WrkValue);
      if SaveSign = BCDNegative then
        SetSign(BCDPositive)
      else
        SetSign(BCDNegative);
    end
  else
    begin
      BCDSubtract(@Self, WrkValue);
      SetSign(SaveSign);
    end;

  Dispose(WrkValue, Done);
end;

procedure TBCD.SubtractReal(AVal: Real);
var
  WrkValue: PBCD;
begin
  WrkValue := new(PBCD, InitReal(AVal, GetPrecision, GetBCDSize));
  SubtractBCD(WrkValue);
  Dispose(WrkValue, Done);
end;

procedure TBCD.SubtractPChar(AVal: PChar);
var
  WrkValue: PBCD;
begin
  WrkValue := new(PBCD, InitPChar(AVal, GetPrecision, GetBCDSize));
  SubtractBCD(WrkValue);
  Dispose(WrkValue, Done);
end;

procedure TBCD.MultiplyByBCD(AVal: PBCD);
var
  NewSign:  TBCDSign;
  WrkValue:  PBCD;
  HighDigit, i, j:  integer;
  SavePrec:  Byte;
begin
  if AVal = nil then exit;

  if GetSign = AVal^.GetSign then
    NewSign := BCDPositive
  else
    NewSign := BCDNegative;
  AbsoluteValue;

  SavePrec := Precision;
  WrkValue := new(PBCD, InitReal(0, 0, GetBCDSize + AVal^.GetBCDSize));
  Precision := 0;
  i := 1;
  while (i < AVal^.GetBCDSize) and (AVal^.Value^[i] = 0) do
    inc(i);
  HighDigit := i;

  for i := AVal^.GetBCDSize downto HighDigit do
    begin
      if AVal^.Value^[i] <> 0 then
        for j := 1 to AVal^.Value^[i] do
          WrkValue^.AddBCD(@Self);
      ShiftLeft(1);
    end;

  WrkValue^.Precision := SavePrec + AVal^.GetPrecision;
  WrkValue^.SetPrecision(SavePrec);
  Precision := SavePrec;
  SetValueBCD(WrkValue);
  SetSign(NewSign);
end;

procedure TBCD.MultiplyByReal(AVal: Real; APrec: Byte);
var
  WrkVal:  PBCD;
begin
  WrkVal := new(PBCD, InitReal(AVal, APrec, GetBCDSize));
  MultiplyByBCD(WrkVal);
  Dispose(WrkVal, Done);
end;

procedure TBCD.MultiplyByPChar(AVal: PChar; APrec: Byte);
var
  WrkVal:  PBCD;
begin
  WrkVal := new(PBCD, InitPChar(AVal, APrec, GetBCDSize));
  MultiplyByBCD(WrkVal);
  Dispose(WrkVal, Done);
end;

procedure TBCD.DivideByBCD(AVal: PBCD);
var
  NewSign:  TBCDSign;
  WrkVal, WrkDiv, WrkQuo:  PBCD;
  HighDigit, i, j, IterationCount:  integer;
  TempPrec, QuotientPrec:  Byte;
begin
  if AVal = nil then exit;

  if AVal^.CompareReal(0.0) = 0 then exit;  {avoid zero divide}

  if GetSign = AVal^.GetSign then
    NewSign := BCDPositive
  else
    NewSign := BCDNegative;

  WrkVal := new(PBCD, InitBCD(@Self));
  WrkVal^.AbsoluteValue;

  WrkQuo := new(PBCD, InitReal(0, 0, GetBCDSize));

  i := 1;
  while (i < WrkVal^.GetBCDSize) and (WrkVal^.Value^[i] = 0) do
    inc(i);
  HighDigit := i;
  WrkVal^.SetPrecision(WrkVal^.GetPrecision+(HighDigit-1));
  TempPrec := WrkVal^.GetPrecision;
  WrkVal^.Precision := 0;

  WrkDiv := new(PBCD, InitBCD(AVal));
  WrkDiv^.AbsoluteValue;
  i := 1;
  while (i < WrkDiv^.GetBCDSize) and (WrkDiv^.Value^[i] = 0) do
    inc(i);
  HighDigit := i;
  WrkDiv^.ShiftLeft(HighDigit - 1);
  WrkDiv^.Precision := 0;

  QuotientPrec := TempPrec - AVal^.GetPrecision;
  IterationCount := WrkVal^.GetBCDSize - QuotientPrec + GetPrecision;

  for i := 1 to IterationCount do
    begin
      while CompareBCD(WrkDiv) > 0 do
        begin
          WrkVal^.SubtractBCD(WrkDiv);
          inc(WrkQuo^.Value^[WrkQuo^.GetBCDSize]);
        end;
      WrkDiv^.ShiftRight(1);
      WrkQuo^.ShiftLeft(1);
    end;

  WrkQuo^.Precision := QuotientPrec;
  SetValueBCD(WrkQuo);
  SetSign(NewSign);

  Dispose(WrkVal, Done);
  Dispose(WrkQuo, Done);
  Dispose(WrkDiv, Done);
end;

procedure TBCD.DivideByReal(AVal: Real; APrec: Byte);
var
  WrkVal:  PBCD;
begin
  WrkVal := new(PBCD, InitReal(AVal, APrec, GetBCDSize));
  DivideByBCD(WrkVal);
  Dispose(WrkVal, Done);
end;

procedure TBCD.DivideByPChar(AVal: PChar; APrec: Byte);
var
  WrkVal: PBCD;
begin
  WrkVal := new(PBCD, InitPChar(AVal, APrec, GetBCDSize));
  DivideByBCD(WrkVal);
  Dispose(WrkVal, Done);
end;

procedure TBCD.AbsoluteValue;
begin
  SetSign(BCDPositive);
end;

procedure TBCD.Increment;
begin
  AddReal(1);
end;

procedure TBCD.Decrement;
begin
  SubtractReal(1);
end;

procedure TBCD.ShiftLeft(ShiftAmount: Byte);
var
  i:  integer;
begin
  if ShiftAmount = 0 then exit;
  for i := 1 to (BCDSize - ShiftAmount) do
    Value^[i] := Value^[i+ShiftAmount];
  for i := ((BCDSize - ShiftAmount) + 1) to BCDSize do
    Value^[i] := 0;
end;

procedure TBCD.ShiftRight(ShiftAmount: Byte);
var
  i:  integer;
begin
  if ShiftAmount = 0 then exit;
  for i := BCDSize downto (ShiftAmount + 1) do
    Value^[i] := Value^[i - ShiftAmount];
  for i := ShiftAmount downto 1 do
    Value^[i] := 0;
end;

function TBCD.BCD2Int: LongInt;
var
  i:  integer;
  wrkLongInt:  LongInt;
begin
  BCD2Int := 0;
  if Precision = GetBCDSize then exit;

  wrkLongInt := 0;
  i := 1;
  repeat
    wrkLongInt := wrkLongInt * 10;
    wrkLongInt := wrkLongInt + Value^[i];
    inc(i);
  until i = (GetBCDSize - GetPrecision);
  if GetSign = BCDNegative then
    BCD2Int := -wrkLongInt
  else
    BCD2Int := wrkLongInt;
end;

function TBCD.BCD2Real: Real;
var
  i:  integer;
  wrkIntegerPart, wrkFractionPart:  real;
begin
  BCD2Real := 0.0;
  wrkIntegerPart := 0;
  wrkFractionPart := 0;

  if GetPrecision < GetBCDSize then
    begin
      i := 1;
      repeat
        wrkIntegerPart := wrkIntegerPart * 10.0;
        wrkIntegerPart := wrkIntegerPart + Value^[i];
        inc(i);
      until i = (GetBCDSize - GetPrecision + 1);
    end;

  if Precision > 0 then
    begin
      i := GetBCDSize;
      repeat
        wrkFractionPart := wrkFractionPart + Value^[i];
        wrkFractionPart := wrkFractionPart / 10.0;
        dec(i);
      until i = (GetBCDSize - GetPrecision);
    end;

  if GetSign = BCDNegative then
    BCD2Real := -(wrkIntegerPart + wrkFractionPart)
  else
    BCD2Real := (wrkIntegerPart + wrkFractionPart);
end;

function TBCD.PicStr(picture: string;
                     Width: Integer; BlankWhenZero: Boolean): String;

var
   integer_str, decimal_str, pic_str, val_str:  string;
   decimal_encountered, significant_digits_encountered:  boolean;
   number_of_digits, number_of_integer_digits, number_of_decimal_digits,
   sub_pic, sub_val, i:  integer;

begin    {pic}
  decimal_encountered := false;
  number_of_digits := 0;
  number_of_integer_digits := 0;
  for i := 1 to length(picture) do
    if upcase(picture[i]) in ['$', '-', '9', 'Z'] then
      begin
        inc(number_of_digits);
        if not decimal_encountered then
          inc(number_of_integer_digits);
      end
    else if picture[i] = '.' then
       decimal_encountered := true;
  number_of_decimal_digits := number_of_digits - number_of_integer_digits;

  integer_str := '';
  for i := (GetBCDSize - GetPrecision) downto 1 do
    integer_str := char(ord('0')+Value^[i]) + integer_str;
  if length(integer_str) > number_of_integer_digits then
    delete(integer_str, 1, length(integer_str)-number_of_integer_digits)
  else
    while length(integer_str) < number_of_integer_digits do
      integer_str := '0' + integer_str;

  decimal_str := '';
  for i := (GetBCDSize - GetPrecision + 1) to GetBCDSize do
    decimal_str := decimal_str + char(ord('0')+Value^[i]);
  if length(decimal_str) > number_of_decimal_digits then
    delete(decimal_str, number_of_decimal_digits+1, 255)
  else
    while length(decimal_str) < number_of_decimal_digits do
      decimal_str := decimal_str + '0';

  val_str := integer_str + decimal_str;

  pic_str := copy(st_Blanks, 1, length(picture));

  significant_digits_encountered := false;
  sub_pic := 1;
  sub_val := 1;
  while sub_pic <= length(picture) do
    begin
      if val_str[sub_val] in ['1'..'9']then
        significant_digits_encountered := true;
      if upcase(picture[sub_pic]) in ['(', ')'] then
        if Sign = BCDNegative then
          begin
            pic_str[sub_pic] := upcase(picture[sub_pic]);
            sub_pic := sub_pic + 1;
          end
        else
          begin
            pic_str[sub_pic] := ' ';
            sub_pic := sub_pic + 1;
          end
      else if upcase(picture[sub_pic]) in ['Z', '$', '-'] then
        begin
          if significant_digits_encountered then
            pic_str[sub_pic] := val_str[sub_val]
          else
            pic_str[sub_pic] := ' ';
          sub_pic := sub_pic + 1;
          sub_val := sub_val + 1;
        end
      else if picture[sub_pic] = '.' then
        begin
          pic_str[sub_pic] := '.';
          sub_pic := sub_pic + 1;
          significant_digits_encountered := true;
        end
      else if picture[sub_pic] = '9' then
        begin
          pic_str[sub_pic] := val_str[sub_val];
          if pic_str[sub_pic] = ' ' then pic_str[sub_pic] := '0';
          sub_pic := sub_pic + 1;
          sub_val := sub_val + 1;
          significant_digits_encountered := true;
        end
      else if picture[sub_pic] = ',' then
        begin
          if pic_str[sub_pic - 1] = ' ' then
            pic_str[sub_pic] := ' '
          else
            pic_str[sub_pic] := ',';
          sub_pic := sub_pic + 1;
        end
      else
        begin
          pic_str[sub_pic] := upcase(picture[sub_pic]);
          sub_pic := sub_pic + 1;
        end;
    end;

  if Sign = BCDNegative then
    begin
      sub_pic := 0;
      while (sub_pic < length(picture)) and
            (picture[sub_pic + 1] in ['(', '-', ',']) do
        sub_pic := sub_pic + 1;
      while (sub_pic > 0) and
            (pic_str[sub_pic] <> ' ') do
        sub_pic := sub_pic - 1;
      if (sub_pic > 0) and
         (picture[sub_pic] <> '(') then
        pic_str[sub_pic] := '-';
    end;

  sub_pic := 0;
  while (sub_pic < length(picture)) and
        (picture[sub_pic + 1] in ['(', '$', ',']) do
    sub_pic := sub_pic + 1;

  while (sub_pic > 0) and
        (pic_str[sub_pic] <> ' ') do
    sub_pic := sub_pic - 1;

  if (sub_pic > 0) and
     (picture[sub_pic] <> '(') then
    pic_str[sub_pic] := '$';

  if (BlankWhenZero) and (pic_str = BCDZero^.PicStr(picture, bpw_Fixed, false)) then
    pic_str := copy(st_Blanks, 1, length(picture));

  if Width = bpw_fixed then
    PicStr := pic_str
  else
    begin
      if pic_str[1] = ' ' then
        begin
          sub_pic := 1;
          while (sub_pic < length(pic_str)) and
                (pic_str[sub_pic] = ' ') do
            inc(sub_pic);
          if pic_str[sub_pic] <> ' ' then dec(sub_pic);
          delete(pic_str, 1, sub_pic);
        end;
      if pic_str[length(pic_str)] = ' ' then
        begin
          sub_pic := length(pic_str);
          while (sub_pic > 1) and
                (pic_str[sub_pic] = ' ') do
            dec(sub_pic);
          if pic_str[sub_pic] <> ' ' then inc(sub_pic);
          delete(pic_str, sub_pic, 255);
        end;
      PicStr := pic_str;
    end;
end;

function TBCD.StrPic(dest: PChar; picture: string;
                     Width: Integer; BlankWhenZero: Boolean;
                     Size: Integer): PChar;
var
  WrkStr:  array[0..300] of char;
begin
  if dest = nil then
    begin
      StrPic := nil;
      exit;
    end;

  StrPCopy(WrkStr, PicStr(picture, Width, BlankWhenZero));
  StrLCopy(dest, WrkStr, Size);
  StrPic := dest;
end;

function TBCD.CompareBCD(AVal: PBCD): Integer;
var
  i:  integer;
  BCD1, BCD2: PBCD;
begin
  if AVal = nil then exit;

  if GetSign < AVal^.GetSign then
    begin
      CompareBCD := -1;
      exit;
    end
  else if GetSign > AVal^.GetSign then
    begin
      CompareBCD := +1;
      exit;
    end;

  BCD1 := new(PBCD, InitBCD(@Self));
  BCD2 := new(PBCD, InitBCD(AVal));
  if GetBCDSize > AVal^.GetBCDSize then
    BCD2^.SetBCDSize(GetBCDSize)
  else
    BCD1^.SetBCDSize(AVal^.GetBCDSize);

  CompareBCD := 0;
  for i := 1 to BCD1^.GetBCDSize do
    begin
      if BCD1^.Value^[i] < BCD2^.Value^[i] then
        begin
          if BCD1^.GetSign = BCDNegative then
            CompareBCD := +1
          else
            CompareBCD := -1;
          Dispose(BCD1, Done);
          Dispose(BCD2, Done);
          exit;
        end
      else if BCD1^.Value^[i] > BCD2^.Value^[i] then
        begin
          if BCD1^.GetSign = BCDNegative then
            CompareBCD := -1
          else
            CompareBCD := +1;
          Dispose(BCD1, Done);
          Dispose(BCD2, Done);
          exit;
        end;
    end;
end;

function TBCD.CompareReal(AVal: Real): Integer;
var
  WrkVal: PBCD;
begin
  WrkVal := new(PBCD, InitReal(AVal, GetPrecision, GetBCDSize));
  CompareReal := CompareBCD(WrkVal);
  Dispose(WrkVal, Done);
end;

function TBCD.ComparePChar(AVal: PChar): Integer;
var
  WrkVal: PBCD;
begin
  WrkVal := new(PBCD, InitPChar(AVal, GetPrecision, GetBCDSize));
  ComparePChar := CompareBCD(WrkVal);
  Dispose(WrkVal, Done);
end;

begin
  BCDZero := new(PBCD, InitReal(0.0, 2, 3));
  RegisterType(RBCD);
end.