[Back to MATH SWAG index] [Back to Main SWAG index] [Original]
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 <grin>). 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