stbcd.pas

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

  else
    {positive}
    SectNum := 0;
  SectOfs := FindSection(SectNum);

  if SectOfs = 0 then
    {general floating point format}
    Result := StrGeneralBcd(B)

  else begin
    {scan the section once to determine critical format properties}
    ScanSection(SectOfs);

    if Exponent <> 0 then begin
      {round based on number of displayed digits}
      ActPlaces := Integer(MantissaDigits)-Exponent+ExpBias;
      if DigitCount-DecimalIndex < ActPlaces then begin
        RoundMantissa(UB, ActPlaces-(DigitCount-DecimalIndex));
        if UB[SigDigits] <> 0 then begin
          ShiftMantissaDown(UB, 1);
          inc(Exponent);
        end else if IsZeroMantissa(UB) then begin
          {rounded to zero, possibly use a different mask}
          Exponent := 0;
          goto Restart;
        end;
      end;
    end;

    {apply formatting}
    if Scientific then begin
      DigitPlace := DecimalIndex;
      DigitDelta := 0;
      if Exponent = 0 then
        {for input = 0, display E+00}
        Exponent := ExpBias+1
    end else begin
      if Exponent = 0 then
        {special case for input = 0}
        Exponent := ExpBias
      else if Exponent-ExpBias > MantissaDigits then begin
        {all digits are integer part}
        Result := StrGeneralBcd(B);
        Exit;
      end;
      DigitPlace := Exponent-ExpBias;
      DigitDelta := DigitPlace-DecimalIndex;
      if DigitPlace < DecimalIndex then
        DigitPlace := DecimalIndex;
    end;

    BufOfs := 0;
    UBOfs := MantissaDigits;

    if Sign <> 0 then
      if SectOfs = 1 then
        StoreChar('-');

    repeat
      Ch := Format[SectOfs];
      case Ch of
        {labels in ASCII order so 32-bit compiler generates better code}
        '"' :
          begin
            inc(SectOfs);
            while (SectOfs <= Length(Format)) and (Format[SectOfs] <> Ch) do begin
              StoreChar(Format[SectOfs]);
              inc(SectOfs);
            end;
            if SectOfs > Length(Format) then
              break;
          end;
        '#' :
          StoreDigit;

        '''' :
          begin
            inc(SectOfs);
            while (SectOfs <= Length(Format)) and (Format[SectOfs] <> Ch) do begin
              StoreChar(Format[SectOfs]);
              inc(SectOfs);
            end;
            if SectOfs > Length(Format) then
              break;
          end;

        '0' :
          StoreDigit;

        ';' :
          break;

        'E', 'e' :
          if SectOfs < Length(Format) then begin
            inc(SectOfs);
            case Format[SectOfs] of
              '-', '+' :
                begin
                  StoreChar(Ch);
                  Ch := Format[SectOfs];
                  ExpDigits := -1;
                  repeat
                    inc(ExpDigits);
                    inc(SectOfs);
                  until (SectOfs > Length(Format)) or (Format[SectOfs] <> '0');
                  if ExpDigits > 4 then
                    ExpDigits := 4;
                  dec(Exponent, ExpBias+DecimalIndex);
                  if (Exponent >= 0) and (Ch = '+') then
                    StoreChar('+');
                  if Exponent < 0 then begin
                    StoreChar('-');
                    Exponent := Abs(Exponent);
                  end;
                  Str(Exponent:ExpDigits, SExponent);
                  for I := 1 to ExpDigits do
                    if SExponent[I] = ' ' then
                      StoreChar('0')
                    else
                      StoreChar(SExponent[I]);
                end;
            else
              StoreChar(Ch);
              StoreChar(Format[SectOfs]);
            end;
          end else
            StoreChar(Ch);
      else
        {these characters are automatically inserted in StoreDigit};
        if not (Ch in [ThousandSeparator, DecimalSeparator]) then
          StoreChar(Ch);
      end;

      inc(SectOfs);
      if SectOfs > Length(Format) then
        break;
    until False;

    SetLength(Result, BufOfs);
    move(Buffer[0], Result[1], BufOfs);
  end;
end;

function FracBcd(const B : TBcd) : TBcd;
begin
  Result := SubBcd(B, IntBcd(B));
end;

function IsIntBcd(const B : TBcd) : Boolean;
var
{$IFNDEF UseAsm}
  I : Integer;
{$ENDIF}
  Exponent : Integer;
  Sign : Byte;
  UB : TUnpBcd;
begin
  Unpack(B, UB, Exponent, Sign);

  if Exponent = 0 then
    {0.0 has no fractional part}
    Result := True

  else if Exponent <= ExpBias then
    {value is less than one, but non-zero}
    Result := False

  else if Exponent-ExpBias >= MantissaDigits then
    {entire mantissa is non-fractional}
    Result := True

  else begin
    {see if any non-zero digits to left of decimal point}
{$IFDEF UseAsm}
      asm
        push edi
        lea edi,UB+1
        mov ecx,MantissaDigits+ExpBias
        sub ecx,Exponent
        xor al,al
        cld
        repe scasb
        jne @1
        inc al
@1:     mov Result,al
        pop edi
      end;
{$ELSE}
    for I := 1 to MantissaDigits-(Exponent-ExpBias) do
      if UB[I] <> 0 then begin
        Result := False;
        Exit;
      end;
    Result := True;
{$ENDIF}
  end;
end;

function IntBcd(const B : TBcd) : TBcd;
var
  Exponent : Integer;
  Sign : Byte;
  UB : TUnpBcd;
begin
  Unpack(B, UB, Exponent, Sign);

  if Exponent <= ExpBias then
    {value is less than one}
    SetZero(Result)

  else if Exponent-ExpBias >= MantissaDigits then
    {entire mantissa is integer part}
    Result := B

  else begin
    {clear fractional digits}
    FillChar(UB[1], MantissaDigits-(Exponent-ExpBias), 0);
    Pack(UB, Exponent, Sign, Result);
  end;
end;

function IntPowBcd(const B : TBcd; E : LongInt) : TBcd;
var
  I : LongInt;
  B1 : TBcd;
begin
  B1 := FastVal('1.0');
  Result := B1;
  for I := 1 to Abs(E) do
    Result := MulBcd(Result, B);
  if E < 0 then
    Result := DivBcd(B1, Result);
end;

function LnBcd20(const B : TBcd) : TBcd;
const
  Iterations = 9;
var
  Exponent, N, K : integer;
  BN, B025, B05, B1, AN, GN, Pow : TBcd;
  DN1, DN : array[0..Iterations] of TBcd;
begin
  {normalize input in range 0.10-0.99...}
  Exponent := B[0]-ExpBias;
  BN := B;
  BN[0] := ExpBias;

  {initialize some constants}
  B025 := FastVal('0.25');
  B05 := FastVal('0.5');
  B1 := FastVal('1.0');

  {compute initial terms of approximation}
  AN := MulBcd(B05, AddBcd(BN, B1));
  GN := SqrtBcd(BN);
  DN1[0] := AN;

  {converge on exact value}
  for N := 1 to Iterations do begin
    AN := MulBcd(B05, AddBcd(AN, GN));
    DN[0] := AN;
    Pow := B025;
    for K := 1 to N do begin
      DN[K] := DivBcd(SubBcd(DN[K-1], MulBcd(Pow, DN1[K-1])), SubBcd(B1, Pow));
      if K = N then
        break;
      Pow := MulBcd(Pow, B025);
    end;

    if N = Iterations then
      break;
    GN := SqrtBcd(MulBcd(AN, GN));
    DN1 := DN;
  end;
  Result := DivBcd(SubBcd(BN, B1), DN[Iterations]);

  {correct for normalization}
  Result := AddBcd(Result, MulBcd(LongBcd(Exponent), Ln10Bcd));
end;

function LnBcd10(const B : TBcd) : TBcd;
var
  Exponent : Integer;
  BN, B1, S, W, T, AW, BW : TBcd;
begin
  {normalize input in range 0.10-0.99...}
  Exponent := B[0]-ExpBias;
  BN := B;
  BN[0] := ExpBias;

  if CmpBcd(BN, FastVal('0.316227766016837933')) < 0 then begin
    {renormalize in range .316-3.16}
    dec(Exponent);
    inc(BN[0]);
  end;

  B1 := FastVal('1.0');
  S := DivBcd(SubBcd(BN, B1), AddBcd(BN, B1));
  W := MulBcd(S, S);

  T := MulBcd(W, FastVal('-0.741010784161919239'));
  T := MulBcd(W, AddBcd(T, FastVal('10.3338571514793865')));
  T := MulBcd(W, AddBcd(T, FastVal('-39.273741020315625')));
  T := MulBcd(W, AddBcd(T, FastVal('55.4085912041205931')));
  AW := AddBcd(T, FastVal('-26.0447002405557636'));

  T := MulBcd(W, AddBcd(W, FastVal('-19.3732345832854786')));
  T := MulBcd(W, AddBcd(T, FastVal('107.109789115668009')));
  T := MulBcd(W, AddBcd(T, FastVal('-244.303035341829542')));
  T := MulBcd(W, AddBcd(T, FastVal('245.347618868489348')));
  BW := AddBcd(T, FastVal('-89.9552077881033117'));

  T := MulBcd(W, DivBcd(AW, BW));
  T := MulBcd(S, AddBcd(T, FastVal('0.868588963806503655')));

  Result := MulBcd(AddBcd(T, LongBcd(Exponent)), Ln10Bcd);
end;

function LnBcd(const B : TBcd) : TBcd;
begin
  if (B[0] = 0) or (B[0] and SignBit <> 0) then
    {ln of zero or a negative number}
    RaiseBcdError(stscBcdBadInput);

  if BcdSize <= 10 then
    Result := LnBcd10(B)
  else
    Result := LnBcd20(B);
end;

function LongBcd(L : LongInt) : TBcd;
var
  S : string;
begin
  Str(L, S);
  Result := ValBcd(FastValPrep(S));
end;

function MulBcd(const B1, B2 : TBcd) : TBcd;
var
  E1, E2, Digits : Integer;
  S1, S2 : Byte;
{$IFNDEF UseAsm}
  I1, I2 : Integer;
  CP, CN : Byte;
  T, T1, T2 : Byte;
{$ENDIF}
  PB : PUnpBcd;
  UB1, UB2 : TUnpBcd;
  TB : TIntBcd;
begin
  if (B1[0] = 0) or (B2[0] = 0) then
    SetZero(Result)

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

    FillChar(TB, SizeOf(TIntBcd), 0);

    {multiply and sum the mantissas}
{$IFDEF UseAsm}
    asm
      push ebx
      push esi
      push edi
      lea ebx,UB1  {multiplier}
      lea edi,TB   {result}
      mov ecx,MantissaDigits

@1:   inc ebx      {next multiplier digit}
      inc edi      {next output digit}
      mov al,[ebx] {get next multiplier digit}
      or al,al     {if zero, nothing to do}
      jz @3

      push ecx     {save digit counter}
      mov dl,al    {save multiplier}
      lea esi,UB2+1 {multiplicand}
      mov ecx,MantissaDigits
      xor dh,dh

@2:   mov al,[esi] {next multiplicand digit}
      inc esi
      mul dl       {multiply by multiplier, overflow in ah}
      aam
      add al,[edi] {add previous result}
      aaa
      add al,dh    {add previous overflow}
      aaa
      mov [edi],al {store temporary result}
      inc edi
      mov dh,ah    {save overflow for next time}
      dec ecx
      jnz @2
      mov [edi],dh {save last overflow in next digit}
      sub edi,MantissaDigits {reset output offset for next multiplier}
      pop ecx

@3:   dec ecx      {next multiplier digit}
      jnz @1
      pop edi
      pop esi
      pop ebx
    end;
{$ELSE}
    for I1 := 1 to MantissaDigits do begin
      T1 := UB1[I1];
      if T1 <> 0 then begin
        CP := 0;
        for I2 := 1 to MantissaDigits do begin
          T := T1*UB2[I2];
          T2 := T mod 10;
          CN := T div 10;
          inc(T2, TB[I1+I2-1]);
          if T2 > 9 then begin
            dec(T2, 10);
            inc(CN);
          end;
          inc(T2, CP);
          if T2 > 9 then begin
            dec(T2, 10);
            inc(CN);
          end;
          TB[I1+I2-1] := T2;
          CP := CN;
        end;
        {store last carry in next digit of buffer}
        TB[I1+MantissaDigits] := CP;
      end;
    end;
{$ENDIF}

    {normalize the product}
    if TB[2*MantissaDigits] <> 0 then begin
      PB := PUnpBcd(@TB[MantissaDigits]);
      Digits := 0;
    end else begin
      PB := PUnpBcd(@TB[MantissaDigits-1]);
      Digits := -1;
    end;
    RoundMantissa(PB^, 0);
    if PB^[SigDigits] <> 0 then begin
      inc(PChar(PB));
      inc(Digits);
    end;
    {copy back to UB2}
    UB2 := PB^;

    {set sign and exponent}
    inc(E2, E1+Digits-ExpBias);
    if E2 > NoSignBit then
      {numeric overflow}
      RaiseBcdError(stscBcdOverflow);

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

function NegBcd(const B : TBcd) : TBcd;
begin
  Result := B;
  if B[0] <> 0 then
    Result[0] := B[0] xor SignBit;
end;

function PowBcd(const B, E : TBcd) : TBcd;
begin
  if E[0] = 0 then
    {anything raised to the zero power is 1.0}
    Result := FastVal('1.0')

  else if IsIntBcd(E) then
    {compute the power by simple multiplication}
    Result := IntPowBcd(B, TruncBcd(E))

  else begin
    if B[0] and SignBit <> 0 then
      {negative number raised to a non-integer power}
      RaiseBcdError(stscBcdBadInput);

    Result := ExpBcd(MulBcd(E, LnBcd(B)));
  end;
end;

function RoundBcd(const B : TBcd) : LongInt;
var
  Exponent, I : Integer;
  Sign : Byte;
  UB : TUnpBcd;
begin
  Unpack(B, UB, Exponent, Sign);

  Result := 0;
  if Exponent <> 0 then begin
    {Bcd is not zero}
    I := MantissaDigits;
    {add digits to left of decimal point}
    while (I >= 1) and (Exponent > ExpBias) do begin
      if Abs(Result) > MaxLongInt div 10 then
        {numeric overflow}
        RaiseBcdError(stscBcdOverflow);
      Result := 10*Result;
      if Sign <> 0 then begin
        if Result < -MaxLongInt-1+UB[I] then