📄 fmtbcd.pas
字号:
end;
if DecimalPos > 0 then
begin
Bcd.Precision := Byte(NumDigits-1);
if Neg then
Bcd.SignSpecialPlaces := ( 1 shl 7 ) + (BYTE(NumDigits - DecimalPos))
else
Bcd.SignSpecialPlaces := ( 0 shl 7 ) + (BYTE(NumDigits - DecimalPos));
end else
begin
Bcd.Precision := Byte(NumDigits);
if Neg then
Bcd.SignSpecialPlaces := (1 shl 7)
else
Bcd.SignSpecialPlaces := (0 shl 7);
end;
end;
function SignificantIntDigits(const pIn: PChar; Digits: Word): Word; pascal;
asm
PUSH ESI
PUSH EBX
MOV ESI, pIn
MOV CX,Digits // start with all digits
CLD
@@1: CMP CX,0 // if 0,
JE @@3 // then end
LODSB // load pIn BYTE into AL and
CMP AL,0 // if 0
JNE @@2
SUB CX,1 // then subtract 1 from CX
CMP CX,0 // make sure it's not 0
JE @@3
SUB CX,1 // subtract 1 again and
JMP @@1 // start again
@@2: SHR AL,4 // check last nibble
CMP AL,0 // if 0, then
JNE @@3
SUB CX,1 // subtract 1 more from CX
@@3: MOV Result,CX // Result is CX
POP EBX
POP ESI
end;
procedure SubtractNormalizedFractions(const pIn1, pIn2, pOut: PChar; Digits: SmallInt); pascal;
var
OddFlag: SmallInt;
begin
asm
PUSH ESI
PUSH EDI
PUSH EBX
PUSH ECX
PUSH EDX
MOV OddFlag,0 // Flag for odd # of Digits
MOV CX,Digits
MOV DH,0 // Remainder
MOV EDI,pOut
MOV EBX,pIn1
MOV ESI,pIn2
@@0: CMP CX,2
JBE @@2
ADD EDI,1
ADD ESI,1
ADD EBX,1
SUB CX,1
CMP CX,2
JNE @@1
MOV OddFlag,1 // there are odd # of digits
JMP @@2
@@1: SUB CX,1
JMP @@0
@@2: MOV CX,Digits
@@3: CMP CX,0 // at end?
JE @@5
CMP OddFlag,1
JNE @@12
MOV AH,0
MOV OddFlag,0
JMP @@13
@@12: MOV AL,[ESI]
MOV AH,[EBX]
AND AL,15 // get last nibble
AND AH,15 // values
MOV DL,AH
SUB DL,AL // SUBTRACT [ESI] FROM [EBX]
CALL _GetSubRemainder // get remainder and
MOV AH,DL // store in AH
SUB CX,1
CMP CX,0
JE @@4
@@13: MOV AL,[ESI] // AH now has last values added
MOV DL,[EBX] // so now get
SHR AL,4 // first
SHR DL,4 // values
SUB DL,AL // into DL
CALL _GetSubRemainder
SHL DL,4
OR DL,AH
MOV [EDI],DL
SUB EDI,1
SUB ESI,1
SUB EBX,1
SUB CX,1
JMP @@3
@@4: MOV DL,0 // if end is reached on odd nibble
OR DL,AH // OR with 0 and flush
MOV [EDI],DL
@@5: POP EDX
POP ECX
POP EBX
POP EDI
POP ESI
end;
end;
procedure AddNormalizedFractions(const pIn1, pIn2, pOut: PChar; Digits: SmallInt); pascal;
var
OddFlag: SmallInt;
begin
asm
PUSH ESI
PUSH EDI
PUSH EBX
PUSH ECX
PUSH EDX
MOV CX,Digits
MOV DH,0 // Remainder
MOV EDI,pOut
MOV EBX,pIn1
MOV ESI,pIn2
MOV OddFlag,0
@@0: CMP CX,2
JBE @@2
ADD EDI,1
ADD ESI,1
ADD EBX,1
SUB CX,1
CMP CX,2
JNE @@1
MOV OddFlag,1
JMP @@2
@@1: SUB CX,1
JMP @@0
@@2: MOV CX,Digits
@@3: CMP CX,0 // at end?
JE @@5
CMP OddFlag,1
JNE @@12
MOV AH,0
MOV OddFlag,0
JMP @@13
@@12: MOV AL,[ESI]
MOV AH,[EBX]
AND AL,15 // get last nibble
AND AH,15 // values
MOV DL,AH
ADD DL,AL // Add 2 values
CALL _GetRemainder // get remainder and
MOV AH,DL // store in AH
SUB CX,1
CMP CX,0
JE @@4
@@13: MOV AL,[ESI] // AH now has last values added
MOV DL,[EBX] // so now get
SHR AL,4 // first
SHR DL,4 // values
ADD DL,AL // into DL
CALL _GetRemainder
SHL DL,4
OR DL,AH
MOV [EDI],DL
SUB EDI,1
SUB ESI,1
SUB EBX,1
SUB CX,1
JMP @@3
@@4: MOV DL,0 // if end is reached on odd nibble
OR DL,AH // OR with 0 and flush
MOV [EDI],DL
@@5: POP EDX
POP ECX
POP EBX
POP EDI
POP ESI
end;
end;
// compare where both FRACTIONs have same # of Nibbles
function CompareNormalizedFractions(const pIn1, pIn2: PChar; Digits1, Digits2: SmallInt): Integer; pascal;
asm
PUSH ESI
PUSH EDI
PUSH EBX
PUSH EDX
MOV CX,Digits1
MOV DX,Digits2
MOV EDI,pIn2
MOV ESI,pIn1
MOV Result,0 // initialize Result to 0
CLD
@@1: CMP CX,0
JE @@7 // no more digits
LODSB // load [ESI] into AL
MOV AH,[EDI] // load [EDI] into AH
INC EDI // advance EDI
@@2: CMP AL,AH // start by comparing 2 nibbles at once
JNE @@3
SUB CX,1
SUB DX,1
CMP CX,0
JE @@7
SUB CX,1
SUB DX,1
JMP @@1
@@3: MOV BL,AH // don't appear to match:
MOV AH,AL // put first nibble of
SHR AH,4 // input1 into AH, and first nibble
MOV BH,BL // of input2 into bh,
SHR BH,4 // and them
CMP BH,AH //
JNE @@4 //
CMP CX,0 // make sure we didn't end on odd-nibble
JE @@7
MOV AH,AL // it's the 2nd nibble that's different
MOV BH,BL // so move 2nd nibble
AND AH,15 // for input1 and input2
AND BH,15 // into AH and BH
@@4: CMP BH,AH // we know they're not the same
JA @@6
@@5: MOV Result,1 // input1 > input2
JMP @@8
@@6: MOV Result,-1 // input2 > input1
JMP @@8
@@7: CMP DX,0
JLE @@8
MOV AH,[EDI] // Digits2 > Digits1:
INC EDI
SUB DX,2 // All must be 0 or Fail
CMP AH,0
JE @@7
CMP Result,0
JNE @@8
MOV Result,-1
@@8: POP EDX
POP EBX
POP EDI
POP ESI
end;
function ReverseNegative(SignSpecialPlaces: Byte): Byte;
begin
if (SignSpecialPlaces and (1 shl 7)) <> 0 then
Result := (SignSpecialPlaces and 63)
else
Result := (SignSpecialPlaces and 63) or (1 shl 7);
end;
{ Shift Fractions one Nibble to Left }
procedure MoveNibbles(var POut: PChar; const PIn: PChar; const Size: Byte);
var
I: Integer;
P1: PChar;
N1, N2: BYTE;
begin
I := 0;
P1 := PIn;
n1 := BYTE(POut^);
while I < Size do
begin
N2 := Byte(P1^);
POut^ := Char((Byte(N1 AND 15) SHL 4) OR Byte(N2 SHR 4));
N1 := N2;
Inc(POut);
Inc(P1);
Inc(I,2);
end;
end;
function NormalizeBcd(const InBcd: TBcd; var OutBcd: TBcd; const Prec, Scale: Word): Boolean;
var
PIn, POut: PChar;
I: Integer;
Start, DecDigits: SmallInt;
Negative: Boolean;
begin
Result := True;
if (Word(InBcd.Precision) = Prec) and (Word(InBcd.SignSpecialPlaces and 63) = Scale) then
OutBcd := InBcd
else
begin
Negative := InBcd.SignSpecialPlaces and (1 shl 7) <> 0;
DecDigits := InBcd.SignSpecialPlaces and 63;
OutBcd.Precision := Prec;
OutBcd.SignSpecialPlaces := Scale;
PIn := PChar(@InBcd.Fraction);
POut := PChar(@OutBcd.Fraction);
FillChar(POut^, SizeOf(OutBcd.Fraction), 0);
if (Prec < Word(InBcd.Precision)) and (SignificantIntDigits(pIn, Word(InBcd.Precision)) > Prec) then
Result := False
else
begin
{ Precision is IntegerDigits, Scale is Decimal Digits }
NormalizeFractions(PIn, SmallInt(InBcd.Precision - DecDigits),
DecDigits, Prec-(Scale and 63), Scale and 63, pOut);
if Negative and (OutBcd.SignSpecialPlaces and (1 shl 7) = 0) then
OutBcd.SignSpecialPlaces := ReverseNegative(OutBcd.SignSpecialPlaces);
end;
end;
{ Guarantee unused Nibbles are blank }
POut := PChar(@OutBcd.Fraction);
Start := OutBcd.Precision div 2;
if (OutBcd.Precision mod 2) = 1 then Inc(Start);
for I := Start to SizeOf(OutBcd.Fraction) -1 do
POut[I] := #0;
end;
function NumberOfDigits(const ABcd: TBcd): Integer;
var
PFractions: PChar;
begin
Result := ABcd.Precision;
PFractions := PChar(@Abcd.Fraction);
while (Result > 1) and (PFractions^ = #0) do
begin
Dec(Result, 2); // decrement two nibbles per byte
Inc(PFractions);
end;
end;
function CompactBcd(const ABcd: TBcd; const MinSize: Integer): TBcd;
var
PFractions, POut: PChar;
CharsToMove: Integer;
begin
if ABcd.Precision <= MinSize then
begin
Result := ABcd;
exit;
end;
Result.Precision := ABcd.Precision;
Result.SignSpecialPlaces := ABcd.SignSpecialPlaces;
POut := PChar(@Result.Fraction);
FillChar(pOut^, SizeOf(Result.Fraction), 0);
PFractions := PChar(@ABcd.Fraction);
while (Result.Precision > MinSize) and (PFractions^ = #0) do
begin
Dec(Result.Precision,2);
Inc(PFractions);
end;
CharsToMove := (2+ (Result.Precision + BcdScale(Result))) div 2;
if CharsToMove > SizeOf(Result.Fraction) then CharsToMove := SizeOf(Result.Fraction);
Move(PFractions^, POut^, CharsToMove);
end;
procedure NormalizeBcdPair(const BcdIn1, BcdIn2: TBcd; var bcdOut1, bcdOut2: TBcd; ExtraDigits: Word = 0 );
var
MaxDigits, MaxScale: Word;
Bcd1, Bcd2: TBcd;
{ Guarantee Bcd has even number Precision }
function AdjustNibbles(ABcd: TBcd): TBcd;
var
POut, PBcd: PChar;
I, Start: Integer;
begin
Result := ABcd;
if (ABcd.Precision mod 2) <> 0 then
begin
PBcd := PChar(@ABcd.Fraction);
POut := PChar(@Result.Fraction);
POut^ := #0;
Result.Precision := ABcd.Precision +1;
MoveNibbles(POut, PBcd, ABcd.Precision);
end;
{ Guarantee unused Nibbles are blank}
POut := PChar(@Result.Fraction);
Start := (Result.Precision div 2);
for I := Start to SizeOf(Result.Fraction) -1 do
POut[I] := #0;
end;
begin
Bcd1 := AdjustNibbles(BcdIn1);
Bcd2 := AdjustNibbles(BcdIn2);
if (Bcd1.Precision > 32) or (Bcd2.Precision > 32) then
begin
MaxDigits := Max(NumberOfDigits(bcdIn1), NumberOfDigits(bcdIn2));
if MaxDigits < Bcd1.Precision then MaxDigits := Bcd1.Precision;
if MaxDigits < Bcd2.Precision then MaxDigits := Bcd2.Precision;
Bcd1 := CompactBcd(Bcd1, MaxDigits);
Bcd2 := CompactBcd(Bcd2, MaxDigits);
end;
MaxDigits := Max(Bcd1.Precision, Bcd2.Precision);
MaxScale := Max(BcdScale(Bcd1), BcdScale(Bcd2));
{ ensure that MaxDigits is large enough: for example, if Bcd1 is 6.0 and
Bcd2 10.5, then MaxDigits needs to be 12, not 10 }
while (MaxDigits < (SizeOf(Bcd1.Fraction) * 2)) and
((MaxDigits - MaxScale < Bcd1.Precision - BcdScale(Bcd1)) or
(MaxDigits - MaxScale < Bcd2.Precision - BcdScale(Bcd2))) do
Inc(MaxDigits, 2);
NormalizeBcd(Bcd1, BcdOut1, MaxDigits, MaxScale);
NormalizeBcd(Bcd2, BcdOut2, MaxDigits, MaxScale);
end;
function BcdCompare(const Bcd1, Bcd2: TBcd): Integer;
var
TempBcd1, TempBcd2: TBcd;
PBcd1, PBcd2: PChar;
Digits1,Digits2: ShortInt;
Negative: Boolean;
begin
if (Bcd1.SignSpecialPlaces and (1 shl 7)) <> (Bcd2.SignSpecialPlaces and (1 shl 7)) then
begin // if Negative setting doesn't match.
if (Bcd1.SignSpecialPlaces and (1 shl 7)) <> 0 then
Result := -1
else
Result := 1;
end else
begin // both Negative or both Positive
Negative := (Bcd1.SignSpecialPlaces and (1 shl 7)) <> 0;
pBcd1 := pCHAR(@Bcd1.Fraction); // move to fractions
pBcd2 := pCHAR(@Bcd2.Fraction); // move to fractions
Digits1 := SignificantIntDigits(pBcd1, SmallInt(Bcd1.Precision - (Bcd1.SignSpecialPlaces and 63)));
Digits2 := SignificantIntDigits(pBcd2, SmallInt(Bcd2.Precision - (Bcd2.SignSpecialPlaces and 63)));
if Digits1 <> Digits2 then
begin
if Digits1 > Digits2 then
Result := 1
else
Result := -1;
end else
begin
NormalizeBcdPair(Bcd1, Bcd2, TempBcd1, TempBcd2);
PBcd1 := PChar(@TempBcd1.Fraction);
PBcd2 := PChar(@TempBcd2.Fraction);
Result := CompareNormalizedFractions(pBcd1, pBcd2, TempBcd1.Precision, TempBcd2.Precision);
end;
if Negative then Result := -Result;
end;
end;
procedure BcdSubtract(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd);
var
newBcd2: TBcd;
begin
newBcd2 := bcdIn2;
newBcd2.SignSpecialPlaces := ReverseNegative(newBcd2.SignSpecialPlaces);
BcdAdd(bcdIn1, newBcd2, bcdOut);
end;
procedure BcdMultiply(StringIn1, StringIn2: string; var bcdOut: TBcd); overload;
var
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -