fmtbcd.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

  Output: string;
  NegCount: Integer;
begin
  NegCount := 0;
  if PChar(StringIn1)[0] = '-' then
  begin
    Inc(NegCount);
    StringIn1 := Copy(StringIn1, 2, Length(StringIn1)-1);
  end;
  if PChar(StringIn2)[0] = '-' then
  begin
    Inc(NegCount);
    StringIn2 := Copy(StringIn2, 2, Length(StringIn2)-1);
  end;
  Output := _Multiply(StringIn1, StringIn2);
  bcdOut := StrToBcd(Output);
  if (NegCount mod 2) <> 0 then
    bcdOut.SignSpecialPlaces := (bcdOut.SignSpecialPlaces and 63) or (1 shl 7);
end;

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

procedure BcdMultiply(const bcdIn: TBcd; const DoubleIn: Double; var bcdOut: TBcd);
begin
  BcdMultiply(BcdToStr(bcdIn), FloatToStr(DoubleIn), bcdOut);
end;

procedure BcdMultiply(const bcdIn: TBcd; const StringIn: string; var bcdOut: TBcd);
begin
  BcdMultiply(BcdToStr(bcdIn), StringIn, bcdOut);
end;

procedure BcdDivide(Dividend, Divisor: string; var bcdOut: TBcd); overload;
var
  Output: string;
  NegCount: Integer;
  MaxDecimals: Byte;
begin
  if (Divisor = '0') or (Divisor = '') then
    BcdError(SDivByZero);
  NegCount := 0;        
  MaxDecimals := bcdOut.signSpecialPlaces and 63;
  if MaxDecimals = 0 then MaxDecimals := _DefaultDecimals;
  if PChar(Dividend)[0] = '-' then
  begin
    Inc(NegCount);
    Dividend := Copy(Dividend, 2, Length(Dividend)-1);
  end;
  if PChar(Divisor)[0] = '-' then
  begin
    Inc(NegCount);
    Divisor := Copy(Divisor, 2, Length(Divisor)-1);
  end;
  Output := RoundAt(_Divide(Dividend, Divisor), MaxDecimals);
  bcdOut := StrToBcd(Output);
  if (NegCount mod 2) <> 0 then
    bcdOut.SignSpecialPlaces := (bcdOut.SignSpecialPlaces and 63) or (1 shl 7);
end;

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

procedure BcdDivide(const Dividend: TBcd; const Divisor: Double; var bcdOut: TBcd);
begin
  BcdDivide(BcdToStr(Dividend), FloatToStr(Divisor), bcdOut);
end;

procedure BcdDivide(const Dividend: TBcd; const Divisor: string; var bcdOut: TBcd);
begin
  BcdDivide(BcdToStr(Dividend), Divisor, bcdOut);
end;

procedure BcdAdd(const bcdIn1, bcdIn2: TBcd; var bcdOut: TBcd);
var
  bcd1, bcd2: TBcd;
  pIn1, pIn2, pOut: PChar;
  Prec, Scale: Word;
  Neg1, Neg2: Boolean;
  Digits1, Digits2: Integer;
begin
  NormalizeBcdPair(bcdIn1, bcdIn2, bcd1, bcd2, 1);
  Prec := bcd1.Precision;
  Scale := bcd1.SignSpecialPlaces;
  Neg1 := (BcdIn1.SignSpecialPlaces and (1 shl 7)) <> 0;
  Neg2 := (BcdIn2.SignSpecialPlaces and (1 shl 7)) <> 0;
  bcdOut.Precision := Prec;
  if (Neg1 = Neg2) or ((bcd1.SignSpecialPlaces and 63) >= (bcd2.SignSpecialPlaces and 63)) then
    bcdOut.SignSpecialPlaces := Scale
  else
    bcdOut.SignSpecialPlaces := ReverseNegative(Scale);
  pIn1 := PChar(@bcd1.Fraction);
  pIn2 := PChar(@bcd2.Fraction);
  pOut := PChar(@bcdOut.Fraction);
  FillChar(pOut^, SizeOf(bcdOut.Fraction), 0);
  if Neg1 = Neg2 then
    AddNormalizedFractions(pIn1, pIn2, pOut, prec)
  else
  begin
    Digits1 := SignificantIntDigits(pIn1, Prec);
    Digits2 := SignificantIntDigits(pIn2, Prec);
    if Digits1 > Digits2 then
      SubtractNormalizedFractions(pIn1,pIn2,pOut, Prec)
    else if Digits2 > Digits1 then
    begin
      SubtractNormalizedFractions(pIn2,pIn1,pOut,prec);
      bcdOut.SignSpecialPlaces := ReverseNegative(bcdOut.SignSpecialPlaces);
    end
    else if CompareNormalizedFractions(pIn1, pIn2, Prec, Prec) >= 0 then
      SubtractNormalizedFractions(pIn1,pIn2,pOut, prec)
    else
    begin
      SubtractNormalizedFractions(pIn2,pIn1,pOut,prec);
      bcdOut.SignSpecialPlaces := ReverseNegative(bcdOut.SignSpecialPlaces);
    end;
  end;
end;

function FractionToStr(const pIn: PChar; count: SmallInt;
         DecPosition: ShortInt; Negative: Boolean;
         StartWithDecimal: Boolean): string;
var
  NibblesIn, BytesIn, DigitsOut: Integer;
  P, POut: PChar;
  Dot: Char;

  procedure AddOneChar(Value: Char);
  begin
    P[0] := Value;
    Inc(P);
    Inc(DigitsOut);
  end;
  procedure AddDigit(Value: Char);
  begin
    if ((DecPosition > 0) and (NibblesIn  = DecPosition)) or
       ((NibblesIn = 0) and StartWithDecimal) then
    begin
      if DigitsOut = 0 then AddOneChar('0');
      AddOneChar(Dot);
    end;
    if (Value > #0) or (DigitsOut > 0) then
      AddOneChar(Char(Integer(Value)+48));
    Inc(NibblesIn);
  end;

begin
  POut := AllocMem(Count + 3);  // count + negative/decimal/zero
  try
    Dot := DecimalSeparator;
    P := POut;
    DigitsOut := 0;
    BytesIn := 0;
    NibblesIn := 0;
    while NibblesIn < Count do
    begin
      AddDigit(Char(Integer(pIn[BytesIn]) SHR 4));
      if NibblesIn < Count then
        AddDigit(Char(Integer(pIn[BytesIn]) AND 15));
      Inc(BytesIn);
    end;
    while (DecPosition > 0) and (NibblesIn  > DecPosition) and (DigitsOut > 1) do
    begin
      if POut[DigitsOut-1] = '0' then
      begin
        Dec(DigitsOut);
        POut[DigitsOut] := #0;
      end else
        break;
    end;
    if POut[DigitsOut-1] = Dot then
      Dec(DigitsOut);
    POut[DigitsOut] := #0;
    SetString(Result, POut, DigitsOut);
  finally
    FreeMem(POut, Count + 2);
  end;
  if Result = '' then Result := '0'
  else if Negative then Result := '-' + Result;
end;

function BcdToStr(const Bcd: TBcd): string;
var
  NumDigits: Integer;
  pStart: PChar;
  DecPos: SmallInt;
  Negative: Boolean;
begin
  if (Bcd.Precision = 0) or (Bcd.Precision > MaxFMTBcdFractionSize) then
    OverFlowError(SBcdOverFlow)
  else
  begin
    Negative := Bcd.SignSpecialPlaces and (1 shl 7) <> 0;
    NumDigits := Bcd.Precision;
    pStart := pCHAR(@Bcd.Fraction);   // move to fractions
    // use lower 6 bits of iSignSpecialPlaces.
    if (Bcd.SignSpecialPlaces and 63) > 0 then
    begin
      DecPos := ShortInt(NumDigits - (Bcd.SignSpecialPlaces and 63));
    end else
      DecPos := NumDigits + 1;     // out of range
    Result := FractionToStr(pStart, NumDigits, DecPos, Negative,
           (NumDigits = Bcd.SignSpecialPlaces and 63));
    if Result[1] in ['0', '-'] then
      if (Result = '-0') or (Result = '0.0') or (Result = '-0.0') then Result := '0';
  end;
end;

function BcdPrecision(const Bcd: TBcd): Word;
begin
  Result := Bcd.Precision - BcdScale(Bcd);
end;

function BcdScale(const Bcd: TBcd): Word;
begin
  Result := (Bcd.SignSpecialPlaces and 63);
end;

function IsBcdNegative(const Bcd: TBcd): Boolean;
begin
  Result := (Bcd.SignSpecialPlaces and (1 shl 7)) <> 0;
end;

function IsBcdZero(const Bcd: TBcd): Boolean;
var
  P: PChar;
  I, Scale: Integer;
begin
  Result := True;
  P := PChar(@Bcd.Fraction);
  I := 0;
  Scale := BcdScale(Bcd);
  while Result and (I < Scale div 2) do
  begin
    if Byte(P^) <> 0 then
      Result := False;
    Inc(P);
    Inc(I);
  end;
{ if odd nibble, check it }
  if Result and (Scale mod 2 > 0) then
    if (Byte(P^) SHR 4) > 0 then
      Result := False;
end;











function CurrToBCD(const Curr: Currency; var BCD: TBcd; Precision: Integer = 32;
  Decimals: Integer = 4): Boolean;
const
  Power10: array[0..3] of Single = (10000, 1000, 100, 10);
var
  Digits: array[0..63] of Byte;
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     ESI,EAX
        XCHG    ECX,EDX








        MOV     [ESI].TBcd.Precision,CL
        MOV     [ESI].TBcd.SignSpecialPlaces,DL
@@1:    SUB     EDX,4
        JE      @@3
        JA      @@2
        FILD    Curr  



        FDIV    Power10.Single[EDX*4+16]

        FISTP   Curr
        JMP     @@3
@@2:    DEC     ECX
        MOV     Digits.Byte[ECX],0
        DEC     EDX
        JNE     @@2
@@3:    MOV     EAX,Curr.Integer[0]
        MOV     EBX,Curr.Integer[4]
        OR      EBX,EBX
        JNS     @@4
        NEG     EBX
        NEG     EAX
        SBB     EBX,0
        OR      [ESI].TBcd.SignSpecialPlaces,80H
@@4:    MOV     EDI,10
@@5:    MOV     EDX,EAX
        OR      EDX,EBX
        JE      @@7
        XOR     EDX,EDX
        OR      EBX,EBX
        JE      @@6
        XCHG    EAX,EBX
        DIV     EDI
        XCHG    EAX,EBX
@@6:    DIV     EDI
@@7:    MOV     Digits.Byte[ECX-1],DL
        DEC     ECX
        JNE     @@5
        OR      EAX,EBX
        MOV     AL,0
        JNE     @@9
        MOV     CL,[ESI].TBcd.Precision
        INC     ECX
        SHR     ECX,1
@@8:    MOV     AX,Digits.Word[ECX*2-2]
        SHL     AL,4
        OR      AL,AH
        MOV     [ESI].TBcd.Fraction.Byte[ECX-1],AL
        DEC     ECX
        JNE     @@8
        MOV     AL,1
@@9:    POP     EDI
        POP     ESI
        POP     EBX
end;

function BCDToCurr(const BCD: TBcd; var Curr: Currency): Boolean;
const
  FConst10: Single = 10;
  CWNear: Word = $133F;
var
  CtrlWord: Word;
  Temp: Integer;
  Digits: array[0..63] of Byte;
asm
        PUSH    EBX
        PUSH    EDI
        PUSH    ESI










        XOR     EBX,EBX

        MOV     EDI,EAX
        MOV     ESI,EDX
        MOV     AL,0
        MOVZX   EDX,[EDI].TBcd.Precision
        OR      EDX,EDX
        JE      @@8
        LEA     ECX,[EDX+1]
        SHR     ECX,1
@@1:    MOV     AL,[EDI].TBcd.Fraction.Byte[ECX-1]
        MOV     AH,AL
        SHR     AL,4
        AND     AH,0FH
        MOV     Digits.Word[ECX*2-2],AX
        DEC     ECX
        JNE     @@1
        XOR     EAX,EAX
@@2:    MOV     AL,Digits.Byte[ECX]
        OR      AL,AL
        JNE     @@3
        INC     ECX
        CMP     ECX,EDX
        JNE     @@2
        FLDZ
        JMP     @@7
@@3:    MOV     Temp,EAX
        FILD    Temp
@@4:    INC     ECX
        CMP     ECX,EDX
        JE      @@5
        FMUL    [EBX].FConst10
        MOV     AL,Digits.Byte[ECX]
        MOV     Temp,EAX
        FIADD   Temp
        JMP     @@4
@@5:    MOV     AL,[EDI].TBcd.SignSpecialPlaces
        OR      AL,AL
        JNS     @@6
        FCHS
@@6:    AND     EAX,3FH
        SUB     EAX,4
        NEG     EAX
        CALL    FPower10
@@7:    FSTCW   CtrlWord
        FLDCW   [EBX].CWNear
        FISTP   [ESI].Currency
        FSTSW   AX
        NOT     AL
        AND     AL,1
        FCLEX
        FLDCW   CtrlWord
        FWAIT
@@8:
        POP     ESI
        POP     EDI
        POP     EBX
end;

procedure CopyByte(var Buffer: array of Char; const Byte: Char; var Pos: Integer);
begin
  Buffer[Pos] := Byte;
  Inc(Pos);
end;

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

function BcdGeneralFormat(const Bcd: TBcd; const Precision, Digits: Integer): string;
begin
  Result := BcdToStr(Bcd);
end;
  
{ ffExponent - Scientific format. Not supported for FMTBcd -- Bcd is 
  by definition fixed format }

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

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