vg2bcdutils.pas

Midas.dll全部源码

procedure AddMantissas2(const Mantissa1: TMantissa2; var Mantissa2: TMantissa2);
asm
       PUSH    ESI
       XCHG    EDI, EDX     // Initialize and save EDI
       MOV     ESI, EAX
       MOV     ECX, MantissaSize2 - 1
       ADD     ESI, ECX
       ADD     EDI, ECX
       INC     ECX
       CLC
       STD
@@1:   LODSB
       ADC     AL,BYTE PTR [EDI]
       AAA
       STOSB
       DEC     ECX
       JNZ     @@1
       JNC     @@2
       CALL    BcdOverflow
@@2:   CLD
       MOV     EDI, EDX     // Restore EDI
       POP     ESI
end;

procedure SubMantissas(const Mantissa1: TMantissa; var Mantissa2: TMantissa);
asm
        PUSH    ESI
        MOV     ESI, EAX
        XCHG    EDI, EDX     // Initialize and save EDI
        MOV     ECX, MantissaSize - 1
        ADD     ESI, ECX
        ADD     EDI, ECX
        INC     ECX
        CLC
        STD
@@1:    MOV     AL, BYTE PTR [EDI]
        SBB     AL, BYTE PTR [ESI]
        AAS
        STOSB
        DEC     ESI
        LOOP    @@1
        JNC     @@2
        CALL    BcdUnderflow
@@2:    CLD
        MOV     EDI, EDX     // Restore EDI
        POP     ESI
end;

{
procedure RoundMantissa(var Mantissa: TMantissa; Last: Integer);
asm
        PUSH    EDI
        MOV     EDI, EAX
        MOV     ECX, MantissaSize
        ADD     EDI, ECX
        DEC     EDI
        XOR     AL,AL
        STD
        REPE    SCASB
        JE      @@2
        INC     EDI          // Last non-zero digit
        SUB     ECX, EDX     // Number of digits to empty
        JLE     @@2
        XOR     AL, AL       // Set to zero emptied digits
        REP     STOSB
        MOV     ECX, EDX     // Number of digits to be adjusted
        XCHG    AL, BYTE PTR [EDI]
        DEC     EDI
        ADD     AL, 5
        AAA                  // CF initialized
@@1:    MOV     AL, BYTE PTR [EDI]
        ADC     AL, 0
        AAA
        STOSB
        JNC     @@2
        LOOP    @@1
@@2:    CLD
        POP     EDI
end;
}

procedure NegMantissa(var Mantissa: TMantissa);
asm
        PUSH    EDI
        MOV     EDI, EAX
        MOV     ECX, MantissaSize - 1
        ADD     EDI, ECX
        INC     ECX
        XOR     DH, DH
        CLC
        STD
@@1:    MOV     AL, DH
        SBB     AL, BYTE PTR [EDI]
        AAS
        STOSB
        LOOP    @@1
        CLD
        POP     EDI
end;

function IsZeroMantissa(const Mantissa: TMantissa) : Boolean;
asm
        MOV     EDX, EDI
        MOV     EDI, EAX
        XOR     EAX, EAX
        MOV     ECX, MantissaSize
        REPE    SCASB
        JNE     @@1
        INC     EAX
@@1:    MOV     EDI, EDX
end;

function AddFMTBCD(const Value1, Value2: FMTBCD): FMTBCD;
var
  S1, S2: Boolean;
  M: array [0..1] of TMantissa;
  Cmp: Integer;
begin
  if Value1.iPrecision = 0 then
    Result := Value2
  else if Value2.iPrecision = 0 then
    Result := Value1
  else begin
    ZeroMem(@M, SizeOf(M));
    ZeroMem(@Result, SizeOf(FMTBCD));

    UnpackFMTBCD(Value1, M[0], S1);
    UnpackFMTBCD(Value2, M[1], S2);

    if S1 = S2 then
      AddMantissas(M[0], M[1])
    else begin
      Cmp := CompareChars(M[0], M[1], MantissaSize);
      if Cmp <> 0 then
      begin
        SubMantissas(M[0], M[1]);
        if Cmp > 0 then
        begin
          NegMantissa(M[1]);
          S2 := S1;
        end;
      end else
        Exit;
    end;
    PackFMTBCD(M[1], S2, Result);
  end;
end;

function SubFMTBCD(const Value1, Value2: FMTBCD): FMTBCD;
begin
  Result := AddFMTBCD(Value1, NegFMTBCD(Value2));
end;

procedure MulMantissas(const Mantissa1: TMantissa; var Mantissa2: TMantissa);
var
  I, J, K: Integer;
  ACM: Byte;
  T: array [0..1] of TMantissa2;
begin
  ZeroMem(@T, MantissaSize2);
  ACM := 0;
  for I := MantissaSize - 1 downto 0 do
    if Mantissa2[I] <> 0 then
    begin
      ZeroMem(@T[1], MantissaSize2);
      for J := MantissaSize - 1 downto 0 do
      begin
        K := MantissaSize + J - (MantissaSize - I - 1);
        T[1][K] := Mantissa2[I] * Mantissa1[J] + ACM;
        ACM := 0;
        if T[1][K] >= 10 then
        begin
          ACM := T[1][K] div 10 ;
          Dec(T[1][K], ACM * 10);
        end;
      end;
      AddMantissas2(T[1], T[0]);
    end;
  if ACM > 0 then BCDOverflow;

  I := MantissaSize + MantissaSize div 2;
  if T[0][I + 1] > 4 then
  begin
    T[0][I + 1] := 0;
    repeat
      Inc(T[0][I]);
      if T[0][I] >= 10 then Dec(T[0][I], 10);
      Dec(I);
      if I < 0 then BCDOverflow;
    until T[0][I] < 10;
  end;

  Mantissa2 := PMantissa(@T[0][MantissaSize div 2])^;
end;

function MulFMTBCD(const Value1, Value2: FMTBCD): FMTBCD;
var
  S1, S2: Boolean;
  M: array [0..1] of TMantissa;
begin
  ZeroMem(@M, SizeOf(M));
  UnpackFMTBCD(Value1, M[0], S1);
  UnpackFMTBCD(Value2, M[1], S2);
  MulMantissas(M[0], M[1]);
  PackFMTBCD(M[1], S1 xor S2, Result);
end;

procedure SubMantissas2(var Mantissa1: TMantissa; const Mantissa2: TMantissa);
asm
        PUSH    ESI
        MOV     EDI, EAX
        XCHG    ESI, EDX     // Initialize and save EDI
        MOV     ECX, MantissaSize - 1
        ADD     ESI, ECX
        ADD     EDI, ECX
        INC     ECX
        CLC
        STD
@@1:    MOV     AL, BYTE PTR [EDI]
        SBB     AL, BYTE PTR [ESI]
        AAS
        STOSB
        DEC     ESI
        LOOP    @@1
@@2:    CLD
        MOV     EDI, EDX     // Restore EDI
        POP     ESI
end;

function DivMantissas(var Mantissa1: TMantissa; Mantissa2: TMantissa; var Remainder: Boolean): TMantissa;
var
  I: Integer;
  F: Boolean;
  D: TMantissa;
begin
  ZeroMem(@D, MantissaSize);
  ZeroMem(@Result, MantissaSize);
  D[MantissaSize div 2 - 1] := 1; // D := 1
  I := 0;
  F := True;
  Remainder := False;
  while (F) and (I < MantissaSize div 2 - 1) do // D*10 Mantissa2*10
  begin
    Inc(I);
    D[MantissaSize div 2 - I] := 0;
    D[MantissaSize div 2 - I - 1 ] := 1;
    if Mantissa2[0] <> 0 then BCDOverflow;
    Move(Mantissa2[1], Mantissa2[0], MantissaSize - 1);
    Mantissa2[MantissaSize - 1] := 0;
    F := CompareChars(Mantissa2, Mantissa1, MantissaSize) < 0;
  end;

  // Prepare for division
  if (I > 0) and (I < MantissaSize div 2) then
  begin
    Move(Mantissa2[0], Mantissa2[1], MantissaSize - 1);
    Mantissa2[0] := 0;
    if I > 0 then
    begin
      D[MantissaSize div 2 -I - 1 ] := 0;
      Dec(I);
      D[MantissaSize div 2 - 1 - I] := 1;
    end;
  end;

  // Integer division
  while I >= 0 do
  begin
    SubMantissas2(Mantissa1, Mantissa2);
    AddMantissas(D, Result);
    if IsZeroMantissa(Mantissa1) then Exit;
    if CompareChars(Mantissa1, Mantissa2, MantissaSize) < 0 then
    begin
       if I > 0 then
       begin
         D[MantissaSize div 2 - I - 1] := 0;
         Dec(I);
         D[MantissaSize div 2 - I - 1] := 1;
         Move(Mantissa2[0], Mantissa2[1], MantissaSize - 1);
         Mantissa2[0] := 0;
         if IsZeroMantissa(Mantissa2) then Exit;
         if CompareChars(Mantissa1, Mantissa2, MantissaSize) < 0 then Break;
      end else
        Break;
    end;
  end;
  Remainder := True;
end;

function DivFMTBCD(const Value1, Value2: FMTBCD): FMTBCD;
var
  I: Integer;
  S1, S2, F: Boolean;
  A, B, R, R1: TMantissa;
begin
  ZeroMem(@A,  MantissaSize);
  ZeroMem(@B,  MantissaSize);
  ZeroMem(@R,  MantissaSize);
  ZeroMem(@R1, MantissaSize);

  UnpackFMTBCD(Value2, B, S2);
  if IsZeroMantissa(B) then BcdZeroDivide;

  UnpackFMTBCD(Value1, A, S1);
  if IsZeroMantissa(A) then
  begin
    SetZeroBCD(Result);
    Exit;
  end;

  I := CompareChars(A, B, MantissaSize);
  if I = 0 then
  begin
    PDWORD(@Result)^ := $00100001;
    Exit;
  end;

  F := I > 0;

  if F then
    R := DivMantissas(A, B, F) // Integer division
  else
    F := True;

  if F then                    // Reminder division
  begin
    F := False;
    I := 0;
    while not F do
    begin
      F := CompareChars(A, B, MantissaSize) < 0;
      while F do
      begin
        if A[0] = 0 then
        begin
          Move(A[1], A[0], MantissaSize - 1);
          Inc(I);
          F := CompareChars(A, B, MantissaSize) < 0;
        end else begin
          F := True;
          Break;
        end;
      end;
      if F then Break;

      // I - number of shifts
      R1 := DivMantissas(A, B, F);
      Move(R1[0], R1[I], MantissaSize - I);
      ZeroMem(@R1[0], I);
      AddMantissas(R1, R);
      F := (not F) or (I > 31);
    end;
  end;
  PackFMTBCD(R, S1 xor S2, Result);
end;

end.