stbcd.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

    stc
@1: mov al,[edi]
    adc al,0
    aaa
    mov [edi],al
    inc edi
    jnc @3
    dec ecx
    jnz @1
@2: inc byte ptr [edi]
@3: pop edi
  end;
{$ELSE}
  C := 1;
  for I := Start+1 to MantissaDigits do begin
    inc(UB[I], C);
    if UB[I] > 9 then begin
      dec(UB[I], 10);
      C := 1;
    end else
      {done rounding}
      Exit;
  end;
  {set overflow digit if we get here}
  inc(UB[SigDigits]);
{$ENDIF}
end;

procedure ShiftMantissaDown(var UB : TUnpBcd; Shift : Integer);
begin
  if Shift > MantissaDigits then
    {UB disappears when shifted}
    FillChar(UB[0], SigDigits+1, 0)

  else if Shift > 0 then begin
    Move(UB[Shift], UB[0], SigDigits+1-Shift);
    FillChar(UB[SigDigits+1-Shift], Shift, 0);
  end;
end;

procedure SubMantissas(const UB1 : TUnpBcd; var UB2 : TUnpBcd);
{$IFDEF UseAsm}
  asm
    push esi
    push edi
    mov esi,UB1
    mov edi,UB2
    {inc esi}
    {inc edi}
    mov ecx,SigDigits
    clc
@1: mov al,[edi]  {UB2}
    sbb al,[esi]  {UB2-UB1-CF}
    aas
    mov [edi],al  {update UB2}
    inc edi
    inc esi
    dec ecx
    jnz @1
    jnc @2
    inc byte ptr [edi]
@2: pop edi
    pop esi
  end;
{$ELSE}
var
  I : Integer;
  T, C : ShortInt;
begin
  C := 0;
  for I := 0 to MantissaDigits do begin
    T := UB2[I]-UB1[I]-C;
    if T < 0 then begin
      C := 1;
      inc(T, 10);
    end else
      C := 0;
    UB2[I] := T;
  end;
  UB2[SigDigits] := C;
end;
{$ENDIF}

procedure Unpack(const B : TBcd; var UB : TUnpBcd;
                 var Exponent : Integer; var Sign : Byte);
{$IFNDEF UseAsm}
var
  I : Integer;
{$ENDIF}
begin
{$IFDEF UseAsm}
  asm
    {$IFDEF VER140}
    push ecx  { get round a compiler bug in D6 }
    {$ENDIF}
    push esi
    push edi
    mov esi,B
    mov edi,UB
    inc esi
    inc edi
    mov ecx,BcdSize-1
@1: mov al,[esi]
    inc esi
    mov ah,al
    and al,$0F
    shr ah,4
    mov [edi],ax
    inc edi
    inc edi
    dec ecx
    jnz @1
    xor al,al
    mov [edi],al
    pop edi
    pop esi
    {$IFDEF VER140}
    pop ecx  { get round a compiler bug in D6 }
    {$ENDIF}
  end;
{$ELSE}
  {unpack digits}
  for I := 1 to BcdSize-1 do begin
    UB[2*I-1] := B[I] and $F;
    UB[2*I] := B[I] shr 4;
  end;
  {set last overflow digit to zero}
  UB[2*BcdSize-1] := 0;
{$ENDIF}

  {copy sign/exponent}
  UB[0] := 0;
  Exponent := B[0] and NoSignBit;
  Sign := B[0] and SignBit;
end;

{----------------------------------------------------------------------}

function AbsBcd(const B : TBcd) : TBcd;
begin
  Result := B;
  Result[0] := B[0] and noSignBit;
end;

function AddBcd(const B1, B2 : TBcd) : TBcd;
var
  E1, E2 : Integer;
  S1, S2 : Byte;
  UB1, UB2 : TUnpBcd;
begin
  if B1[0] = 0 then
    Result :=  B2

  else if B2[0] = 0 then
    Result := B1

  else begin
    Unpack(B1, UB1, E1, S1);
    Unpack(B2, UB2, E2, S2);

    If E1 < E2 then begin
      {shift UB1's mantissa to account for smaller exponent}
      RoundMantissa(UB1, E2-E1-1);
      ShiftMantissaDown(UB1, E2-E1);
    end else if E1 > E2 then begin
      {shift UB2's mantissa to account for smaller exponent}
      RoundMantissa(UB2, E1-E2-1);
      ShiftMantissaDown(UB2, E1-E2);
      E2 := E1;
    end;

    if S1 <> S2 then begin
      {differing signs}
      SubMantissas(UB1, UB2);
      if UB2[SigDigits] <> 0 then begin
        {negative result}
        S2 := S2 xor SignBit;
        UB2[SigDigits] := 0;
        NegMantissa(UB2);
      end;
      {shift to get rid of any leading zeros}
      NormalizeMantissa(UB2, E2);
    end else begin
      {same signs}
      AddMantissas(UB1, UB2);
      if UB2[SigDigits] = 0 then
        RoundMantissa(UB2, 0);
      if UB2[SigDigits] <> 0 then begin
        {temporary overflow}
        RoundMantissa(UB2, 1);
        ShiftMantissaDown(UB2, 1);
        inc(E2);
        if E2 > NoSignBit then
          {numeric overflow}
          RaiseBcdError(stscBcdOverflow);
      end;
    end;

    {set sign and exponent}
    if E2 = 0 then
      UB2[0] := 0
    else
      UB2[0] := S2 or E2;

    Pack(UB2, E2, S2, Result);
  end;
end;

function BcdExt(const B : TBcd) : Extended;
var
  Code : Integer;
  S : string[59];
begin
  S := StrExpBcd(B, 0);
  if (DecimalSeparator <> '.') then begin
    while (pos(DecimalSeparator, S) > 0) do
      S[pos(DecimalSeparator, S)] := '.';
  end;
  Val(S, Result, Code);
end;

procedure ConvertBcd(const SrcB; SrcSize : Byte; var DestB; DestSize : Byte);
label
  Repack;
type
  TBA = array[0..40] of Byte; {largest BCD size times 2}
  PBA = ^TBA;
var
  I, O, Exponent : Integer;
  PS : PBA;
  C : Byte;
begin
  if (SrcSize = 0) or (DestSize = 0) then
    exit;

  Exponent := TBA(SrcB)[0] and NoSignBit;

  {transfer mantissa}
  if SrcSize <= DestSize then begin
    {dest is at least as big as src}
    FillChar(TBA(DestB)[1], DestSize-SrcSize, 0);
    Move(TBA(SrcB)[1], TBA(DestB)[DestSize-SrcSize+1], SrcSize-1);

  end else begin
    {need to round src before copying to dest}
    GetMem(PS, 2*SrcSize);

    {unpack digits}
    for I := 1 to SrcSize-1 do begin
      PS^[2*I-1] := TBA(SrcB)[I] and $F;
      PS^[2*I] := TBA(SrcB)[I] shr 4;
    end;
    {set last overflow digit to zero}
    PS^[2*SrcSize-1] := 0;
    {O is a shift used when rounding causes an overflow}
    O := 0;

    {round src starting at most significant lost digit}
    if PS^[SrcSize-DestSize] >= 5 then begin
      {rounding has an effect}
      C := 1;
      for I := SrcSize-DestSize+1 to 2*(SrcSize-1) do begin
        inc(PS^[I], C);
        if PS^[I] > 9 then begin
          dec(PS^[I], 10);
          C := 1;
        end else
          {done rounding}
          goto Repack;
      end;
      {set overflow digit if we get here}
      PS^[2*SrcSize-1] := 1;
      inc(Exponent);
      O := 1;
    end;

Repack:
    {repack into same buffer taking account of overflow offset}
    for I := 1 to SrcSize-1 do
      PS^[I] := PS^[2*I-1+O] or (PS^[2*I+O] shl 4);

    {copy rounded src into dest}
    Move(PS^[SrcSize-DestSize+1], TBA(DestB)[1], DestSize-1);

    FreeMem(PS, 2*SrcSize);
  end;

  {copy sign/exponent}
  TBA(DestB)[0] := Exponent or (TBA(SrcB)[0] and SignBit);
end;

function EqDigitsBcd(const B1, B2 : TBcd; Digits : Cardinal) : Boolean;
begin
  Result := (CmpBcd(RoundDigitsBcd(B1, Digits), RoundDigitsBcd(B2, Digits)) = 0);
end;

function EqPlacesBcd(const B1, B2 : TBcd; Digits : Cardinal) : Boolean;
begin
  Result := (CmpBcd(RoundPlacesBcd(B1, Digits), RoundPlacesBcd(B2, Digits)) = 0);
end;

function CmpBcd(const B1, B2 : TBcd) : Integer;
var
{$IFNDEF UseAsm}
  I : Integer;
{$ENDIF}
  E1, E2 : Integer;
  S1, S2 : Byte;
  UB1, UB2 : TUnpBcd;
begin
  Unpack(B1, UB1, E1, S1);
  Unpack(B2, UB2, E2, S2);

  if S1 <> S2 then
    {signs differ}
    Result := Integer(S2)-S1

  else begin
    {signs the same}
    if E1 <> E2 then
      {exponents differ}
      Result := E1-E2

    else if E1 = 0 then
      {both numbers are zero}
      Result := 0

    else begin
      {exponents the same, compare the mantissas}
{$IFDEF UseAsm}
      asm
        push esi
        push edi
        lea esi,UB1+MantissaDigits
        lea edi,UB2+MantissaDigits
        mov ecx,MantissaDigits
@1:     mov al,[esi]
        sub al,[edi]
        jnz @2
        dec esi
        dec edi
        dec ecx
        jnz @1
@2:     movsx eax,al
        mov Result,eax
        pop edi
        pop esi
      end;
{$ELSE}
      for I := MantissaDigits downto 1 do begin
        Result := Integer(UB1[I])-UB2[I];
        if Result <> 0 then
          break;
      end;
{$ENDIF}
    end;

    if S1 <> 0 then
      {both numbers negative, reverse the result}
      Result := -Result;
  end;
end;

function ModBcd(const B1, B2 : TBcd) : TBcd;
  {-Return B1 mod B2}
begin
  Result := IntBcd(DivBcd(B1, B2));
end;

function DivBcd(const B1, B2 : TBcd) : TBcd;
{$IFNDEF UseAsm}
label
  StoreDigit;
{$ENDIF}
var
{$IFNDEF UseAsm}
  DivIntoCount, I, R : Integer;
  T, C : ShortInt;
  DDigit, NDigit : Byte;
{$ENDIF}
  E1, E2, DivDigits, N : Integer;
  S1, S2 : Byte;
  UB1, UB2 : TUnpBcd;
  TB : TIntBcd;
begin
  if B2[0] = 0 then
    {divide by zero}
    RaiseBcdError(stscBcdDivByZero);

  if B1[0] = 0 then
    {numerator is zero, return zero}
    SetZero(Result)

  else begin
    Unpack(B1, UB1, E1, S1);
    Unpack(B2, UB2, E2, S2);

    {TB is the extended numerator}
    FillChar(TB, 2*BcdSize, 0);
    Move(UB1[1], TB[2*BcdSize], SigDigits);

    {UB1 is now used to store the result}

    {count significant mantissa digits in divisor}
{$IFDEF UseAsm}
  asm
    push edi
    lea edi,UB2+1
    mov ecx,SigDigits
    xor al,al
    repe scasb
    mov DivDigits,ecx
    pop edi
  end;
{$ELSE}
    DivDigits := 0;
    for I := 1 to MantissaDigits do
      if UB2[I] <> 0 then begin
        DivDigits := SigDigits-I;
        break;
      end;
{$ENDIF}

    if DivDigits = 0 then
      {divide by zero, shouldn't have gotten here, but just in case...}
      RaiseBcdError(stscBcdDivByZero);

{$IFDEF UseAsm}
  asm
    push ebx
    push esi
    push edi
    mov ecx,SigDigits             {number of digits in result}
    lea edi,UB1+SigDigits         {edi points to MSD of result}
    lea esi,TB+2*MantissaDigits+1 {esi points to MSD of numerator}
    mov dh,byte ptr DivDigits     {keep DivDigits in dh}

@1: push ecx                      {save result counter}
    push edi                      {save result position}
    mov ebx,esi                   {save numerator position}
    xor dl,dl                     {dl = number of times divisor fits into numerator}

@2: cmp byte ptr [esi+1],0        {check for remainder in numerator}
    jnz @4                        {divisor guaranteed to fit again}
    xor ecx,ecx
    mov cl,dh                     {ecx = number of divisor digits}
    lea edi,UB2+MantissaDigits    {last digit of divisor}

@3: mov al,[esi]                  {al = numerator digit}
    dec esi
    mov ah,[edi]                  {ah = divisor digit}
    dec edi
    cmp al,ah
    ja @4                         {divisor fits if numerator digit > divisor}
    jb @7                         {doesn't fit if numerator digit < divisor}
    dec ecx
    jnz @3

@4: inc dl                        {increment number of times divisor fits}
    mov edi,ebx                   {restore numerator position to edi}
    xor ecx,ecx
    mov cl,dh                     {ecx = number of divisor digits}
    lea esi,UB2+MantissaDigits    {esi points to MSD of divisor}
    dec ecx
    sub esi,ecx                   {first significant digit of divisor}
    sub edi,ecx                   {first active digit of numerator}
    inc ecx
    clc                           {no carry to start}

@5: mov al,[edi]                  {al = digit from numerator}
    sbb al,[esi]                  {subtract divisor from numerator}
    aas
    mov [edi],al                  {store back to numerator}
    inc esi
    inc edi
    dec ecx
    jnz @5
    jnc @6
    dec byte ptr [edi]            {reduce last digit for borrow}

@6: mov esi,ebx                   {restore numerator position to esi}
    jmp @2                        {see if divisor fits in numerator again}

@7: mov esi,ebx                   {restore numerator position to esi}
    pop edi                       {restore result position}
    pop ecx                       {restore result counter}
    mov [edi],dl                  {store times divisor went into numerator}
    dec edi                       {next result digit}
    dec esi                       {next numerator digit}
    dec ecx
    jnz @1                        {compute next result digit}

    pop edi
    pop esi
    pop ebx
  end;
{$ELSE}
    {start with most significant digit of numerator}
    N := 2*MantissaDigits+1;

    {iterate until the result mantissa is filled}
    for R := SigDigits downto 1 do begin
      DivIntoCount := 0;

      repeat