vg2bcdutils.pas

Midas.dll全部源码

{$I hb.inc}
{$D-,L-}

unit vg2BCDUtils;

interface
uses SysUtils,hbConsts;

type

  TMantissa = array [0..63] of Byte;
  TMantissa2 = array [0..127] of Byte;

  PMantissa = ^TMantissa;
  pFMTBcd=^FMTBcd;
  FMTBcd=record
    iPrecision:Byte;
    iSignSpecialPlaces:Byte;
    iFraction:array[$0..$1F] of Byte;
  end;

  EBcdZeroDivide = class(EZeroDivide);
  EBcdOverflow   = class(EOverflow);
  EBcdUnderflow  = class(EUnderflow);

procedure BcdZeroDivide;
procedure BcdOverflow;
procedure BcdUnderflow;

function FMTBCDToCurr(const BCD: FMTBcd; var Curr: Currency): Boolean;
function CurrToFMTBCD(Curr: Currency; var BCD: FMTBcd; Precision,Decimals: Integer): Boolean;
procedure UnpackFMTBCD(const BCD: FMTBCD; var Mantissa: TMantissa; var Negative: Boolean);
procedure PackFMTBCD(const Mantissa: TMantissa; Negative: Boolean; var BCD: FMTBCD);
function CompareFMTBCD(const Value1, Value2: FMTBCD): Integer;
procedure SetZeroBcd(var BCD: FMTBCD);
function IsNegativeFMTBCD(const BCD: FMTBCD): Boolean;
function IsPositiveFMTBCD(const BCD: FMTBCD): Boolean;
function NegFMTBCD(const BCD: FMTBCD): FMTBCD;
function AbsFMTBCD(const BCD: FMTBCD): FMTBCD;
function AddFMTBCD(const Value1, Value2: FMTBCD): FMTBCD;
function SubFMTBCD(const Value1, Value2: FMTBCD): FMTBCD;
function MulFMTBCD(const Value1, Value2: FMTBCD): FMTBCD;
function DivFMTBCD(const Value1, Value2: FMTBCD): FMTBCD;
implementation
uses Windows, vg3SysUtils;  
const
  SignBit             = $80;
  NoSignBit           = $7F;
  MantissaSize        = SizeOf(TMantissa);
  MantissaSize2       = MantissaSize * 2;

procedure BcdZeroDivide;
begin

  raise EBcdOverflow.Create(SZeroDivide);
end;

procedure BcdOverflow;
begin
  raise EBcdOverflow.Create(SOverflow);
end;

procedure BcdUnderflow;
begin
  raise EBcdOverflow.Create(SUnderflow);
end;

function FMTBCDToCurr(const BCD: FMTBcd; var Curr: Currency): Boolean;
const
  FConst10: Single = 10;
  CWNear: Word = $133F;
var
  CtrlWord: Word;
  Temp: Integer;
  Mantissa: TMantissa;
asm
        PUSH    EBX
        PUSH    ESI
        MOV     EBX,EAX
        MOV     ESI,EDX
        MOV     AL,0
        MOVZX   EDX,[EBX].FMTBcd.iPrecision
        OR      EDX,EDX
        JE      @@8
        LEA     ECX,[EDX+1]
        SHR     ECX,1
@@1:    MOV     AL,[EBX].FMTBcd.iFraction.Byte[ECX-1]
        MOV     AH,AL
        SHR     AL,4
        AND     AH,0FH
        MOV     Mantissa.Word[ECX*2-2],AX
        DEC     ECX
        JNE     @@1
        XOR     EAX,EAX
@@2:    MOV     AL,Mantissa.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    FConst10
        MOV     AL,Mantissa.Byte[ECX]
        MOV     Temp,EAX
        FIADD   Temp
        JMP     @@4
@@5:    MOV     AL,[EBX].FMTBcd.iSignSpecialPlaces
        OR      AL,AL
        JNS     @@6
        FCHS
@@6:    AND     EAX,3FH
        SUB     EAX,4
        NEG     EAX
        CALL    FPower10
@@7:    FSTCW   CtrlWord
        FLDCW   CWNear
        FISTP   [ESI].Currency
        FSTSW   AX
        NOT     AL
        AND     AL,1
        FCLEX
        FLDCW   CtrlWord
        FWAIT
@@8:    POP     ESI
        POP     EBX
end;

function CurrToFMTBCD(Curr: Currency; var BCD: FMTBcd; Precision,
  Decimals: Integer): Boolean;
const
  Power10: array[0..3] of Single = (10000, 1000, 100, 10);
var
  Mantissa: TMantissa;
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     ESI,EAX
        XCHG    ECX,EDX
        MOV     [ESI].FMTBcd.iPrecision,CL
        MOV     [ESI].FMTBcd.iSignSpecialPlaces,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     Mantissa.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].FMTBcd.iSignSpecialPlaces,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     Mantissa.Byte[ECX-1],DL
        DEC     ECX
        JNE     @@5
        OR      EAX,EBX
        MOV     AL,0
        JNE     @@9
        MOV     CL,[ESI].FMTBcd.iPrecision
        INC     ECX
        SHR     ECX,1
@@8:    MOV     AX,Mantissa.Word[ECX*2-2]
        SHL     AL,4
        OR      AL,AH
        MOV     [ESI].FMTBcd.iFraction.Byte[ECX-1],AL
        DEC     ECX
        JNE     @@8
        MOV     AL,1
@@9:    POP     EDI
        POP     ESI
        POP     EBX
end;

procedure UnpackFMTBCD(const BCD: FMTBCD; var Mantissa: TMantissa; var Negative: Boolean);
asm
        PUSH    EBX
        PUSH    ESI
        MOV     EBX,EAX
        MOV     ESI,EDX
        MOVZX   EDX,[EBX].FMTBcd.iPrecision
        OR      EDX,EDX
        JE      @@3
        MOV     AL,[EBX].FMTBcd.iSignSpecialPlaces
        MOV     AH,AL
        AND     AL,SignBit
        SHR     AL, 7
        MOV     BYTE PTR [ECX], AL
        MOVZX   ECX,AH
        AND     CL,00111111b
        ADD     ESI, ECX
        ADD     ESI, 32
        SUB     ESI, EDX
        LEA     ECX,[EDX+1]
        SHR     ECX,1
@@1:    MOV     AL,[EBX].FMTBcd.iFraction.Byte[ECX-1]
        MOV     AH,AL
        SHR     AL,4
        AND     AH,0FH
        MOV     ESI.Word[ECX*2-2],AX
        DEC     ECX
        JNE     @@1
@@3:    POP     ESI
        POP     EBX
end;

procedure PackFMTBCD(const Mantissa: TMantissa; Negative: Boolean; var BCD: FMTBCD);
asm
        PUSH    EDI
        PUSH    ESI
        MOV     EDI,EAX       // Mantissa
        MOV     ESI,ECX       // BCD
        XOR     EAX,EAX
        OR      DL,DL         // Sign
        JZ      @@1
        MOV     AL, SignBit
@@1:    MOV     [ESI].FmtBcd.iSignSpecialPlaces, AL
        MOV     AL,AH
        MOV     ECX, MantissaSize
        MOV     EDX,EDI
        ADD     EDX,MantissaSize / 2
        REPE    SCASB
        DEC     EDI           // Seeking for first non-zero
        CMP     CL,32
        JB      @@2
        MOV     CL,32
@@2:    MOV     [ESI].FMTBcd.iPrecision,CL
        SUB     EDX,EDI
        JB      @@3
        OR      [ESI].FmtBcd.iSignSpecialPlaces, DL
@@3:    INC     ECX
        SHR     ECX,1
        NEG     EDX
        ADD     EDX,32
        SHR     EDX,1
        ADD     ESI, EDX
@@4:    MOV     AX, WORD PTR [EDI]
        SHL     AL,4
        OR      AL,AH
        MOV     BYTE PTR [ESI], AL
        INC     ESI
        INC     EDI
        INC     EDI
        LOOP    @@4
        POP     ESI
        POP     EDI
end;

function CompareFMTBCD(const Value1, Value2: FMTBCD): Integer;
var
  Sign1, Sign2, Tmp: Boolean;
  M: array [0..1] of TMantissa;
begin
  Sign1 := (Value1.iSignSpecialPlaces and SignBit) = 0;
  Sign2 := (Value2.iSignSpecialPlaces and SignBit) = 0;
  Result := 0;
  if Sign1 and not Sign2 then
    Inc(Result)
  else if not Sign1 and Sign2 then
    Dec(Result)
  else begin
    ZeroMem(@M, SizeOf(M));
    UnpackFMTBCD(Value1, M[0], Tmp);
    UnpackFMTBCD(Value2, M[1], Tmp);
    Result := CompareChars(M[0], M[1], MantissaSize);
    if not (Sign1 or Sign2) then
      Result := - Result;
  end;
end;

procedure SetZeroBcd(var BCD: FMTBCD);
asm
        MOV     DWORD PTR [EAX],1
end;

function IsNegativeFMTBCD(const BCD: FMTBCD): Boolean;
asm
        XOR     ECX,ECX
        TEST    BYTE PTR [EAX].FMTBcd.iSignSpecialPlaces, SignBit
        MOV     EAX,ECX
        JNE     @@1
        INC     EAX
@@1:
end;

function IsPositiveFMTBCD(const BCD: FMTBCD): Boolean;
asm
        XOR     ECX,ECX
        TEST    BYTE PTR [EAX].FMTBcd.iSignSpecialPlaces, SignBit
        MOV     EAX,ECX
        JE      @@1
        INC     EAX
@@1:
end;

function NegFMTBCD(const BCD: FMTBCD): FMTBCD;
begin
  Result := BCD;
  Result.iSignSpecialPlaces := Result.iSignSpecialPlaces xor SignBit;
end;

{ Calculates negative }

function AbsFMTBCD(const BCD: FMTBCD): FMTBCD;
begin
  Result := BCD;
  Result.iSignSpecialPlaces := Result.iSignSpecialPlaces and NoSignBit;
end;

procedure AddMantissas(const Mantissa1: TMantissa; var Mantissa2: TMantissa);
asm
        PUSH    ESI
        XCHG    EDI, EDX     // Initialize and save EDI
        MOV     ESI, EAX
        MOV     ECX, MantissaSize - 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;