Contributor: SWAG SUPPORT TEAM
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 exit;
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.
{ DOCUMENTATION }
AJCBCD - Binary Coded Decimal (BCD) Unit
This unit was written using Borland International's Borland Pascal v7.0, and
the Object Windows Library (OWL)/Turbo Vision (TV) library objects provided
with that product.
I have not copyrighted this program, and donate it to the public domain. All
portions of this program may be used, modified, and/or distributed, in whole
or in part.
I wrote this unit to provide myself with some reusible functions that would
provide support for BCD math similar to what I've grown accustomed to with
the COBOL Packed Decimal (COMP-3) data type. Note that in true "Packed
Decimal", two decimal digits are "packed" into each data byte. I chose not
to implement my BCD support in that manner. I may be less efficient in terms
of space, but I simply placed a single decimal digit in each byte.
I am just a "hobby" programmer, having written nothing for anyone byt myself.
Therefore, this unit may not be "elegant"; and, there are certainly better
ways of implementing some of the routines that I coded (like perhaps coding
some in assembler which I'm NOT very good at). However, it has met my own
needs, and I'm actually a little proud of what I accomplished here
(especially in being able to figure out algorithms to multiply and divide!).
By the way, let me admit one thing right up front...I have NOT tested ALL of
the routines in this unit (in particular, the Divide routine). I clearly
marked all of the routines that have not been fully tested. You can assume
that all other routines HAVE been tested, because I used them in a real
application.
This might not be the best BCD routines available, but they might actually be
usefull to someone else--besides, it's free! I am open to suggestions,
comments, or enhancements (although, I can't promise quick turn around because
I have a real job, plus I teach, plus I have a family--then I code for fun
--in that order ). My CompuServe ID is 71331,501.
This unit exports some constants (described below). But, the big deal in
this unit is the Binary Coded Decimal object that this unit defines. This
object (TBCD) allows you to allocate a BCD data type of any number of digits.
This object then provides methods for adding, subtracting, multiplying,
and dividing to/from/by other numbers. It also has methods for altering
the number of digits stored as well as the precision (number of places after
the decimal place).
Constants
---------
DigitSize - Stores the size, in bytes, of each individual digit (currently
one byte).
bpw_Fixed - Passed to the PicSTR and STRPic methods (see the description of
PicSTR for an explanation of how to use this constant).
bpw_Variable - See bpw_Fixed above.
bpz_Blank - See bpw_Fixed above.
bpz_NotBlank - See bpw_Fixed above.
MaxBCDSize - Limits the maximum number of BCD digits that can be allocated
for a BCD object. Arbitrarily set to 100.
st_Blanks25 - A string constant containing 25 blanks. Used just as a
convenience in building the st_Blanks constant (see below).
st_Blanks - A String constant containing 255 blanks. Used simply as a
convenient reference/resource for lots of blanks (sort of like
the "SPACES" constant in COBOL).
RBCD - TStreamRec used for registering the TBCD object type for use with
streams.
Var
---
BCDZero - A PBCD object that is initialized to a value of zero in the unit's
initialization section. Used as a convenience whenever you need
a BCD object with a value of zero.
Type
----
TBCDArray - An array of "MaxBCDSize" (100) bytes. Allocated by the TBCD
object to store the BCD value. Each byte stores an individual
digit of the value.
TBCDSign - An enumerated data type used by the TBCD object to represent the
sign of the BCD value. Valid values are "BCDNegative" and
"BCDPositive".
TBCD
-----------------------------------------------------------------------------
TObject TBCD
旼컴컴커 旼컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴�
� � � BCDSize �
쳐컴컴캑 � Sign �
� Init � � Value �
�*Done � � Precision �
� Free � 쳐컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴�
읕컴컴켸 � InitBCD MultiplyByBCD �
� InitReal MultiplyByReal �
� InitPChar MultiplyByPChar �
� Done DivideByBCD �
� Load DivideByReal �
� Store DivideByPChar �
� GetValue AbsoluteValue �
� GetSign Increment �
� GetPrecision Decrement �
� GetBCDSize ShiftLeft �
� SetValueBCD ShiftRight �
� SetValueReal BCD2Int �
� SetValuePChar BCD2Real �
� SetSign PicStr �
� SetPrecision StrPic �
� SetBCDSize CompareBCD �
� AddBCD CompareReal �
� AddReal ComparePChar �
� AddPChar �
� SubtractBCD �
� SubtractReal �
� SubtractPChar �
읕컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴�
Fields ---------------------------------------------------------------------
BCDSize: Integer; Read Only
The size, in number of digits, of the BCD number. Count represents the
available space for digits, and does NOT include the decimal point, or sign.
Sign: TBCDSign; Read Only
The mathmatical sign of the current value (i.e., indicates whether the
current value is positive or negative).
Value: PBCDArray; Read Only
A pointer to a TBCDArray (an array of bytes) used to store the value of the
BCD number. Even though TBCDArray is defined with "MaxBCDSize" entries, only
BCDSize bytes are actually allocated from memory. Therefore, you must be
sure to be careful never to read or write to subscript values greater than
BCDSize. If you need to change the number of digits allocated you should use
the SetBCDSize method. The BCD value is stored in the array with the lowest
order digit in the BCDSize position and the highest order digit in the 1st
position. For example, if BCDSize is 5, Precision is 2, and the value being
stored is 2.35, then a 5-byte array would be allocated on the heap, and the
array values would be (in order from position 1 to 5) (0, 0, 2, 3, 5).
Precision: Byte; Read Only
This value represents the number of digits after the decimal point. Keep in
mind that there is no actual decimal point stored.
Methods ---------------------------------------------------------------------
InitBCD
constructor InitBCD(AVal: PBCD);
Sets BCDSize, Sign, and Precision to the same values as the BCD object
referred to by AVal. It then calls SetValueBCD passing AVal in order to
allocate a TBCDArray for Value, and copies the AVal^.Value into this object's
Value array.
InitReal
constructor InitReal(AVal: Real; APrec: byte; ASize: Integer);
Sets BCDSize to ASize, Precision to APrec, then calls SetValueReal(AVal) in
order to allocate a Value array and initialize it with the value in AVal.
InitPChar ** Not yet tested **
constructor InitPChar(AVal: PChar; APrec: byte; ASize: Integer);
Sets BCDSize to ASize, Precision to APrec, then calls SetValuePChar(AVal)
in order to allocate a Value array and initialize it with the value in AVal.
Done
destructor Done; virtual;
Frees the memory allocated for the Value array and calls "inherited Done".
Load
constructor Load(var S: TStream);
constructs and loads a BCD object from the stream S by first loading BCDSize,
Sign, the Value array, and last the Precision.
Store
procedure Store(var S: TStream);
Stores the BCD object on the stream S by storing the BCDSize, Sign, Value
array, and the Precision.
GetValue
function GetValue: PBCDArray;
Allocates a new TBCDArray of size BCDSize and copies the value in Value into
the new array, then returns a pointer to the new array. Note that it will
be the calling routine's responsibility for disposing the array pointed to by
the returned pointer (use GetBCDSize to determine how much memory to free).
FreeMem should be used for this disposal, not Dispose.
GetSign
function GetSign: TBCDSign;
Returns the sign of the BCD value. The sign is returned as a TBCDSign
value; either "BCDNegative", or "BCDPositive".
GetPrecision
function GetPrecision: Byte;
Returns a byte value equal to the Precision (number of decimal places) of the
BCD number.
GetBCDSize
function GetBCDSize: Inteteger;
Returns an integer value representing the number of BCD digits allocated in
the Value array.
SetValueBCD
procedure SetValueBCD(AVal: PBCD);
If Value is not nil, then the current Value array is freed. Next, a new array
of size BCDSize is allocated on the heap, by calling AVal^.GetValue. Next,
the copied value array is adjusted from the size and precision of AVal to
the BCDSize and Precision of this BCD object (if different). Lastly, the
sign of the value is copied by calling AVal^.GetSign.
SetValueReal
procedure SetValueReal(AVal: Real);
The current value array is initialized to all zero digits. AVal is converted
to a string, and that string is copied digit by digit into the array. If
AVal is less than zero then Sign is set to BCDNegative, otherwise it is set
to BCDPositive.
SetValuePChar ** Not Tested Yet **
procedcure SetValuePChar(AVal: PChar);
The current value array is initialized to all zero digits. AVal is copied
into the array digit by digit. This routine validity checking to verify that
the string actually represents a numeric value. The only character values
that are processed are: 1) numbers (0-9), 2) period (locates decimal point),
and 3) minus sign or parentheses to determine that the sign is negative.
Examples: "(123.45)" would be interpreted as negative 123.45; "123.45" would
be interpreted as positive 123.45; "-123.45" would be interpreted as negative
123.45. Likewise, "555-55-5555" would be interpreted as a negative
555555555; and "I'll have 2" would be interpreted as a positive 2. If there
are no number characters in the string at all, then the resulting value is
zero.
SetSign
procedure SetSign(ASign: TBCDSign);
Sets Sign to ASign (either BCDNegative or BCDPositive). Regardless of the
value of ASign, if the Value of the BCD is zero, then SetSign forces Sign to
be BCDPositive (in otherwords, BCD never stores a negative zero).
SetPrecision
procedure SetPrecision(APrec: Byte);
Sets Precision to APrec. It also shifts the value array left or right,
depending on whether the precision is being increased or decreased. If the
decimals are shifted left, dropping high order digits (hopefully zeros), and
padding zeros on the right. If the precision is being decreased, the digits
are shifted to the right, padding the high order digits with zeros, and
dropping low order digits. Note that the size of the value array is NOT
changed by this method.
SetBCDSize
procedure SetBCDSize(ASize: Integer);
Sets BCDSize to ASize. It also allocates a new value array of the new size,
and copies value from the original value array to the new one. The value
is copied right justified (in otherwords, high order digits are dropped
or padded with zeros depending on whether the new size is larger or smaller
than the old size). The original value array is freed, and Value is set to
point to the new value array.
AddBCD
procedure AddBCD(AVal: PBCD);
Adds AVal^.Value to Self.Value. This is a "signed add". By that I mean that the
signs of the two operands ARE taken into account when adding the two values
together. The result is stored in the Value array. Mathmatically, it might
be represented by the following formula: "Self := Self + AVal;"
AddReal
procedure AddReal(AVal: Real);
Converts AVal to a temporary PBCD object and calls AddBCD to add that
temporary BCD number to Self.
AddPChar ** Not yet tested **
procedure AddPChar(AVal: PChar);
Converts AVal to a temporary PBCD object and calls AddBCD to add that
temporary BCD number to Self.
SubtractBCD
procedure SubtractBCD(AVal: PBCD);
Subtracts AVal^.Value from Self.Value. This is a "signed subtract". By that
I mean that the signs of the two operands ARE taken into account when
subtracting the two values. The result is stored in the Value array.
Mathmatically, it might be represented by the following formula:
"Self := Self - AVal;"
SubtractReal ** Not yet tested **
procedure SubtractReal(AVal: Real);
Converts AVal to a temporary PBCD object and calls SubtractBCD to subtract
that temporary BCD number from Self.
SubtractPChar ** Not yet tested **
procedure SubtractPChar(AVal: PChar);
Converts AVal to a temporary PBCD object and calls SubtractBCD to subtract
that temporary BCD number from Self.
MultiplyByBCD
procedure MultiplyByBCD(AVal: PBCD);
Multiplies Self.Value by AVal^.Value. This is a "signed multiply". By that
I mean that the signs of the two operands ARE taken into account when
multiplying the two values. The result is stored in the Value array.
Mathmatically, it might be represented by the following formula:
"Self := Self * AVal;"
MultiplyByReal ** Not yet tested **
procedure MultiplyByReal(AVal: Real);
Converts AVal to a temporary PBCD object and calls MultiplyByBCD to
multiply Self by that temporary BCD number.
MultiplyByPChar ** Not yet tested **
procedure MultiplyByPChar(AVal: PChar);
Converts AVal to a temporary PBCD object and calls MultiplyByBCD to
mulitiply Self by that temporary BCD number.
DivideByBCD ** Not yet tested **
procedure DivideByBCD(AVal: PBCD);
Divides Self.Value by AVal^.Value. This is a "signed divide". By that
I mean that the signs of the two operands ARE taken into account when
dividing the two values. The result is stored in the Value array.
Mathmatically, it might be represented by the following formula:
"Self := Self/AVal;"
DivideByReal ** Not yet tested **
procedure DivideByReal(AVal: Real);
Converts AVal to a temporary PBCD object and calls DivideByBCD to divide
Self by that temporary BCD number.
DivideByPChar ** Not yet tested **
procedure DivideByPChar(AVal: Real);
Converts AVal to a temporary PBCD object and calls DivideByBCD to divide
Self by that temporary BCD number.
AbsoluteValue
procedure AbsoluteValue;
Calls SetSign to set Sign to BCDPositive, regardless of its current value.
Increment ** Not yet tested **
procedure Increment;
Adds 1 Value.
Decrement ** Not yet tested **
procedure Decrement;
Subtracts 1 from Value.
ShiftLeft
procedure ShiftLeft(ShiftAmount: Byte);
Shifts all of the digits left by ShiftAmount, dropping high order digits, and
padding the low order digits with zeros. The Precision of the number is NOT
altered. In effect, ShiftLeft multiplies Value by a power of 10.
ShiftRight
procedure ShiftRight(ShiftAmount: Byte);
Shifts all of the digits right by ShiftAmount, dropping low order digits, and
padding the high order digits with zeros. The Precision of the number is NOT
altered. In effect, ShiftRight divides Value by a power of 10.
BCD2Int ** Not yet tested **
function BCD2Int: LongInt;
Converts the BCD value (and it's sign) to a LongInt data value. Decimal
positions are simply truncated, not rounded. Range checking is not performed.
If the number of significant digits of the BCD number (not counting decimal
positions) is too large for a LongInt number, high order digits are lost,
and the resulting LongInt value will probably be meaningless.
BCD2Real ** Not yet tested **
function BCD2Real: Real;
Converts the BCD value (and it's sign) to a Real data value. Range checking
is not performed. If the number of significant digits of the BCD number is
too loarge for a Real number, the results are unpredictable, and will
probably be meaningless.
PicStr
function PicStr(picture: string;
Width: Integer; BlankWhenZero: Boolean): string;
PicStr converts the BCD number into a formatted Pascal string. If you are
familiar with the used of Edit Numeric Formatting in Cobol, then you're a
long ways toward understanding how to use this routine.
First, let's get the simple parameters out of the way...
Width indicates whether or not insignificant leading and trailing blanks
should be removed from the resulting string. If Width is equal to 0 then the
length of the resulting string will always equal the length of Picture,
regardless of any leading or trailing blanks in the result string. If Width
is equal to 1, then any leading and/or trailing blanks will be removed from
the resulting string before returning. For your convenience, two constants
have been defined for use with this parameter: bpw_Fixed = 0 and
bpw_Variable = 1.
BlankWhenZero indicates whether the entire result string should be forced to
completely blank, regardless of any formatting characters in Picture, if the
formatted value is logically equal to zero. The BCD value itself is NOT used
to make this determination. The determination is made by comparing the
result string to the string from formatting BCDZero (zero value) with the
same Picture string. If the two strings are equal, then this result string
is considered to be equal to zero. If BlankWhenZero is true, then such zero
valued results are forced to all blanks. If BlankWhenZero is false, the
the result string is left to whatever it becomes based on the Picture string.
If BlankWhenZero is true, and Width = bpw_Fixed, then the result string is
a string of blanks equal in length to the length of Picture. If Width =
bpw_Variable, the the result will be an empty strint (''). For example, if
the BCD number = 0.0023, and the formatted result is "0.00%", BlankWhenZero =
false would result in "0.00%", while BlankWhenZero = true would result in a
blank or empty string depending on Width. For your convenience, two constants
have been defined for use with this parameter: bpz_Blank = true, and
bpz_NotBlank = false.
Now, the more complicated part...picture...
The "picture" parameter is a string that provides a template for formatting
the value of the BCDnumber. The possible template characters are...
'9' - Fills with a digit from the value (or zero if no digit position
available in the BCD number)
'Z' - Just like '9', except that insignificant zeros (i.e., leading zeros)
are left blank.
'z' - Exactly the same as a capital "Z"
'$' - Just like 'Z', except that the right most unused (blank)
dollar-sign position is filled with a '$'. COBOL afficianados will
recognize this as a "floating dollar sign".
'-' - Just like 'Z', except that if the BCD number value is negative, then
the right most unused (blank) dash position is filled with a '-'.
COBOL afficianoados will recognize this as a "floating negative sign".
'(' - If the template contains a parenthesis, and the BCD number value is
negative, then the result string is surrounded with parenthesis.
')' - If the template contains a parenthesis, and the BCD number value is
negative, then the result string is surrounded with parenthesis.
'.' - Indicates the decimal point position, and is included in the result
string. If the template does not contain a period, then the decimal
position is assumed to be at the right end of the template, no
decimal point is included in the result string, and no decimal place
values are included in the result string.
',' - If any significant (non-zero) value positions precede the comma
position, then a comma is inserted at this position in the result
string. This would normally be used to format commas to separate
thousands positions in large numbers.
ANY other characters are simply inserted into the result string in their
relative position.
Some examples might help...
Value Picture String Fixed Result Variable Result
123.45 '$$$$$9.99' ' $123.45' '$123.45'
123456.78 '$$$$$9.99' '123456.78' '123456.78'
123456.78 '$$$$$$9.99' '$123456.78' '$123456.78'
123456.78 '$,$$$,$$9.99' '$123,456.78' '$123,456.78'
123.45 '9999' '0123' '0123'
-1234.6 '---,--9.99' ' -1,234.60' '-1,234.60'
-10.15 '(99.99)' '(10.15)' '(10.15)'
10.15 '(99.99)' ' 10.15 ' '10.15'
75 'z9.999%' '75.000%' '75.000%'
Got the idea? I hope so. I have developed a similar stand-alone routine
for formatting inteter and real numbers, and find it to be a VERY handy way
to nicely format my number values for presentation on the screen or on a
paper report.
StrPic ** Not yet tested **
function StrPic(dest: PChar; picture: string;
Width: Integer; BlankWhenZero: Boolean): PChar;
Calls PicStr(picture, Width, BlankWhenZero) to get a formatted Pascal string.
This string is converted to an null terminated string. StrLCopy is used to
copy that null terminated string to Dest, limited by Size. See PicStr for an
explanation of the use of picture, Width, and BlankWhenZero. StrPic returns
a pointer to dest.
CompareBCD
function CompareBCD(AVal: PBCD): Integer;
Compares the signed values of Self and AVal. CompareBCD returns -1 if Self
is less than AVal, returns +1 of Self is greater than AVal, and returns 0 if
the two values are equal.
CompareReal ** Not yet tested **
function CompareReal(AVal: Real): Integer;
Converts AVal to a temporary PBCD object and calls CompareBCD to perform the
actual comparison with that temporary BCD number. CompareReal returns the
value returned by CompareBCD.
ComparePChar ** Not yet tested **
function ComparePChar(AVal: PChar): Integer;
Converts AVal to a temporary PBCD object and calls CompareBCD to perform the
actual comparison with that temporary BCD number. ComparePChar returns the
value returned by CompareBCD.