fmtbcd.pas

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

      MOV       Result,True       // otherwise, it's true.
@@6:  POP       EDI
      POP       EDX
      POP       ECX
      POP       EBX
      POP       EAX
  end;
end;

// Return True if S evaluates to 0
function BlankArgument(const S: string): Boolean;
var
  I: Integer;
begin
  Result := True;
  for I := 1 to Length(S) do
    if not (S[I] in ['0', '.']) then
    begin
      Result := False;
      break;
    end;
end;

function _Multiply(const A, B: string): string;
begin
  if BlankArgument(A) or BlankArgument(B) then
    Result := '0'
  else if CanUseShort(PChar(A), PChar(B), 9) then
    Result := _ShortMultiply(A,B)
  else
    Result := _LongMultiply(A,B);
end;

function NextDigit(const V, D: string; var R: string): string;
begin
  R := V;
  Result := '0';
  while CompareDigits(R, D) >= 0 do
  begin
    Result := IntToStr(StrToInt(Result) + 1);
    R := LeftTrim(SubtractStrings(R, D));
  end;
end;

function AdjustDecimalPosition(const Value: string; DecPos: SmallInt): string;
var
  Dot : Char;
begin
  Dot := DecimalSeparator;
  Result := Value;
  while Result[1] = '0' do 
    Result := Copy(Result, 2, length(Result) -1);
  if DecPos = 0 then
    Result := '0.' + Result
  else if DecPos > 0 then
    Result := '0' + Dot + StringOfChar('0', DecPos) + Result
  else // DecPos < 0 then
  begin
    if -DecPos >= Length(Result) then
      Result := Result + StringOfChar('0', (-DecPos)-Length(Result))
    else if -DecPos < Length(Result) then
    begin
      Result := Copy(Result, 1, -DecPos) + Dot + Copy(Result, (-DecPos)+1, Length(Result));
    end;
  end;
end;

function ValueOverOne(D: string): string;
var
  R: string;
  V: string;
  AddZeros, DecimalPos: SmallInt;
  Dot : Char;
begin
  Dot := DecimalSeparator;
  DecimalPos := Pos(Dot, D);
  if DecimalPos > 0 then
  begin
    Result := '10';
    Dec(DecimalPos,2);  // 1/.2 = 5.0; 1/2.2 = .45;
    if PChar(D)[0]= Dot then
    begin
      D := Copy(D, 2, Length(D) -1);
      while PChar(D)[0] = '0' do
      begin
        Result := Result + '0';       // copy back later
        D := Copy(D, 2, Length(D) -1);
        Dec(DecimalPos);
      end;
    end else
    D := StringReplace(D, Dot, '', []);
  end else
  begin
    DecimalPos := Length(D) -1;
    Result := '1';
  end;
  if (D ='1') or (D = '1' + StringOfChar('0', Length(D) -1)) then
    Result := AdjustDecimalPosition(Result, DecimalPos -1)
  else
  begin
    V := '1';
    R := V;
    AddZeros := Length(V) -1;  // for divisor of 12345, add 4 zeros
    V := V + StringOfChar('0', AddZeros);
    if CompareDigits(V,D) < 0 then   // if still ess add 1
      V := V + '0';
    Result := '';
    while (R <> '0') and (Length(Result) < (MaxFMTBcdFractionSize + AddZeros)) do
    begin
      Result := Result + NextDigit(V, D, R);
      V := R + '0';
    end;
    Result := AdjustDecimalPosition(Result, DecimalPos);
  end;
end;

function _LongDivide(A, B: string): string;
var
  Negative: Boolean;
begin
  // save pos/minus info and remove '-'
  Negative := (PChar(A)[0] <> PChar(B)[0]) and
           ((PChar(A)[0] = '-') or (PChar(A)[0] = '-'));
  if PChar(A)[0] = '-' then A := Copy(A, 2, Length(A)-1);
  if PChar(B)[0] = '-' then B := Copy(B, 2, Length(B)-1);
  while PChar(A)[0] = '0' do A := Copy(A, 2, Length(A)-1);
  while PChar(B)[0] = '0' do B := Copy(B, 2, Length(B)-1);
  Result := ValueOverOne(B);
  Result := _Multiply(A, Result);
  if Negative then
    Result := '-' + Result;
end;

function _Divide(const A, B: string): string;
begin
  if BlankArgument(A) and BlankArgument(B) then
  begin
    if (A = '') or (A = '0') then
      Result := '0'
    else
      BcdError(SDivByZero);
  end
  else if B = '1' then
    Result := A
  else if B = '-1' then
    Result := '-' + A
  else if CompareStr(A,B) = 0 then
    Result := '1'
  else
    Result := _LongDivide(A,B);
end;

procedure _GetRemainder;
asm
        ADD     DL,DH            // Add remainder
        CMP     DL,10            // if over 10
        JB      @@1
        MOV     DH,1             // then remainder of 1
        SUB     DL,10            // and subtract 10 from value
        JMP     @@2
@@1:    MOV     DH,0             // otherwise remainder of 0
@@2:
end;

procedure _GetSubRemainder;
asm
        SUB     DL,DH            // Subtract remainder
        CMP     DL,10            // if less than 0
        JBE     @@1              //
        MOV     DH,1             // then remainder of 1
        ADD     DL,10            // and ADD 10 to value
        JMP     @@2
@@1:    MOV     DH,0             // otherwise remainder of 0
@@2:
end;

procedure _CopyBytes;
asm
@@1:    CMP     CL,0                // set # of bytes to copy
        JBE     @@2                 // so just
        LODSB                       // copy all bytes
        SUB     CL,2
        STOSB                       // from in to out
        CMP     CL,0
        JLE     @@2
        JMP     @@1
@@2:
end;

procedure _CopyOddFractions;
asm
@@1:    CMP     CL,CH            // splitting nibbles:
        JAE     @@4
        MOV     AH,DL            // DL contains last nibble
        ADD     CL,1
        CMP     CL,CH
        JNE     @@2
        MOV     AL,0
        JMP     @@3
@@2:    LODSB
        MOV     DL,AL           // save off nibble
        SHR     AL,4            // get 1st Nibble of new byte
@@3:    AND     AH,15           // get 2nd Nibble of saved byte
        SHL     AH,4            // make 2nd Nibble of saved 1st Nibble of new
        OR      AH,AL           // make 1st Nibble of new 2nd Nibble of new
        MOV     AL,AH
        STOSB
        ADD     CL,1
        JMP     @@1
@@4:
end;

procedure _CopyRestBlank;
asm
@@1:    CMP     CL,1
        JBE     @@2
        MOV     AL,0
        STOSB
        SUB     CL,2
        JMP     @@1
@@2:
end;

procedure NormalizeFractions(const pIn: PChar; InPrec, InScale, OutPrec, outScale: ShortInt; pOut: PChar); pascal;
asm
  // setup
        PUSH    ESI
        PUSH    EDI
        PUSH    EBX
        PUSH    ECX
        PUSH    EDX
        MOV     EDI,pOut
        MOV     ESI,pIn
        MOV     CL,OutPrec
        MOV     CH,OutScale
        CMP     CL,InPrec
        JA      @@6                // if OutPrec > InPrec ...
        CMP     CL,InPrec
        JE      @@4                // if OutPrec = InPrec, move to CheckScale
        MOV     AH,InPrec
        SUB     AH,OutPrec
        MOV     CL,InPrec
// Case where Output precision is less than input: cut it down
@@0:    CMP     AH,0
        JE      @@9
        LODSB
        CMP     AL,0
        JE      @@1
        MOV     [EDI],AL
        ADD     EDI,1
@@1:    SUB     AH,1
        CMP     AH,0
        JE      @@2
        SUB     AH,1
        SUB     CL,2
        JMP     @@0
@@2:    MOV     DL,AL              // save byte to DL: splitting required
        CMP     CH,InScale         // CH contains OutScale
        JBE     @@3
        MOV     CH,InScale         // # of digits to store =
@@3:    ADD     CH,OutPrec         // Min(InScale,OutScale) + OutPrec
        MOV     CL,0               // nothing stored yet
        CALL    _CopyOddFractions;
        MOV     CL,OutScale
        CMP     CL,InScale
        JBE     @@12
        SUB     CL,InScale
        CALL    _CopyRestBlank;
        JMP     @@12
@@4:    ADD     CL,InScale         // case where outputsize = input size, so just copy bytes
@@5:    CALL    _CopyBytes          // Otherwise, copy only Prec bytes
        CMP     CH,InScale
        JE      @@12
        MOV     CL,CH
        CALL    _CopyRestBlank
        JMP     @@12
// case where additional blank nibbles to prefixed to Fractions
@@6:    SUB     CL,InPrec
@@7:    CMP     CL,0
        JE      @@9
        SUB     CL,1
        CMP     CL,0
        JE      @@8
        MOV     AL,0                // add two blank nibbles
        STOSB
        SUB     CL,1
        JMP     @@7
@@8:    LODSB
        MOV     DL,AL                // save copy of input byte
        SHR     AL,4                 // get first nibble
        OR      AL,0
        STOSB
        MOV     AL,DL
        MOV     AH,InPrec
        MOV     OutPrec,AH
        MOV     CL,1               // 1 nibble stored already
        JMP     @@2
//      even # of fractions to copy
@@9:    MOV     CH,OutScale         // CL must be set to scale values to be copies.
        MOV     CL,InPrec
        CMP     CH,InScale
        JAE     @@10
        ADD     CL,CH
        JMP     @@11
@@10:   ADD     CL,InScale
@@11:   CALL    _CopyBytes
        MOV     CL,OutPrec
        CMP     CL,InPrec
        JBE     @@12
        SUB     CL,InPrec
        CALL    _CopyRestBlank;
@@12:   POP     EDX
        POP     ECX
        POP     EBX
        POP     EDI
        POP     ESI
end;

procedure StrToFraction(pTo: PChar; pFrom: PChar; count: SmallInt); pascal;
var
  Dot: Char;
begin
  Dot := DecimalSeparator;
  asm
   // From bytes to nibbles, both left aligned
        PUSH    ESI
        PUSH    EDI
        PUSH    EBX
        MOV     ESI,pFrom  // move pFrom to ESI
        MOV     EDI,pTo    // move pTo to EDI
        XOR     ECX,ECX    // set ECX to 0
        MOV     CX,count   // store count in CX
        MOV     DL,0       // Flag: when to store
        CLD
@@1:    LODSB              // moves [ESI] into al
        CMP     AL,Dot
        JE      @@4
        SUB     AL,'0'
        CMP     DL,0
        JNE     @@2
        SHL     AL,4
        MOV     AH,AL
        JMP     @@3
@@2:    OR      AL,AH     // takes AH and ors in AL
        STOSB             // always moves AL into [EDI]
@@3:    NOT     dl        // flip all bits
@@4:    LOOP    @@1       // decrements cx and checks if it's 0
        CMP     DL,0      // are any bytes left unstored?
        JE      @@5
        MOV     AL,AH     // if so, move to al
        STOSB             // and store to [EDI]
@@5:    POP     EBX
        POP     EDI
        POP     ESI
  end;
end;

function InvalidBcdString(PValue: PChar): Boolean; 
var
  Dot: Char;
  P: PChar;
begin
  Dot := DecimalSeparator;
  P := PValue;
  Result := False;
  while P^ <> #0 do
  begin
    if not (P^ in ['0'..'9', '-', Dot]) then
    begin
      Result := True;
      break;
    end;
    Inc(P);
  end;
end;

function TryStrToBcd(const AValue: string; var Bcd: TBcd): Boolean;
const
  spaceChars: set of Char = [ ' ', #6, #10, #13, #14];
  digits: set of Char = ['0'..'9'];
var
  Neg: Boolean;
  NumDigits, DecimalPos: Word;
  pTmp, pSource: PChar;
  Dot : Char;
begin
  Dot := DecimalSeparator;
  if InvalidBcdString(PChar(AValue)) then
  begin
    Result := False;
    exit;
  end;
  if (AValue = '0') or (AValue = '') then
  begin
    Result := True;
    Bcd.Precision := 8;
    Bcd.SignSpecialPlaces := 2;
    pSource := PChar(@Bcd.Fraction);
    FillChar(PSource^, SizeOf(Bcd.Fraction), 0);
    Exit
  end;
  Result := True;
  Neg := False;
  DecimalPos := Pos(Dot, AValue);

  pSource := pCHAR(AValue);
  { Strip leading whitespace }
  while (pSource^ in spaceChars) or (pSource^ = '0') do
  begin
    Inc(pSource);
    if DecimalPos > 0 then Dec(DecimalPos);
  end;

  { Strip trailing whitespace }
  pTmp := @pSource[ StrLen( pSource ) -1 ];
  while pTmp^ in spaceChars do
  begin
    pTmp^ := #0;
    Dec(pTmp);
  end;

  { Is the number negative? }
  if pSource^ = '-' then
  begin
    Neg := TRUE;
    if DecimalPos > 0 then Dec(DecimalPos);
  end;
  if (pSource^ = '-') or (pSource^ ='+') then
    Inc(pSource);

  { Clear structure }
  pTmp := pCHAR(@Bcd.Fraction);
  FillChar(pTmp^, SizeOf(Bcd.Fraction), 0);
  if (pSource[0] = '0') then
  begin
    Inc(PSource);  // '0.' scenario
    if DecimalPos > 0 then Dec(DecimalPos);
  end;
  NumDigits := StrLen(pSource);
  if (NumDigits > MaxFMTBcdFractionSize) then
  begin
    if (DecimalPos > 0) and (DecimalPos <= MaxFMTBcdFractionSize) then
      NumDigits := MaxFMTBcdFractionSize // truncate to 64
    else begin
      Bcd.Precision := NumDigits;
      Exit;
    end;
  end;

  if NumDigits > 0 then
    StrToFraction(pTmp, pSource, SmallInt(NumDigits))
  else begin
    Bcd.Precision := 10;
    Bcd.SignSpecialPlaces := 2;