stbcd.pas

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

          {numeric overflow}
          RaiseBcdError(stscBcdOverflow);
        dec(Result, UB[I]);
      end else begin
        if Result > MaxLongInt-UB[I] then
          {numeric overflow}
          RaiseBcdError(stscBcdOverflow);
        inc(Result, UB[I]);
      end;
      dec(I);
      dec(Exponent);
    end;

    {round last digit}
    if (I >= 1) and (Exponent = ExpBias) and (UB[I] >= 5) then begin
      if Sign <> 0 then begin
        if Result = -MaxLongInt-1 then
          {numeric overflow}
          RaiseBcdError(stscBcdOverflow);
        dec(Result);
      end else begin
        if Result = MaxLongInt then
          {numeric overflow}
          RaiseBcdError(stscBcdOverflow);
        inc(Result);
      end;
    end;

  end;
end;

function RoundDigitsBcd(const B : TBcd; Digits : Cardinal) : TBcd;
var
  Exponent : Integer;
  Sign : Byte;
  UB : TUnpBcd;
begin
  if B[0] = 0 then
    {input is zero}
    SetZero(Result)

  else if Digits >= MantissaDigits then
    {no actual rounding}
    Result := B

  else begin
    Unpack(B, UB, Exponent, Sign);

    {treat 0 digits same as 1}
    if Digits = 0 then
      Digits := 1;

    RoundMantissa(UB, MantissaDigits-Digits);
    if UB[SigDigits] <> 0 then begin
      ShiftMantissaDown(UB, 1);
      inc(Exponent);
    end else if IsZeroMantissa(UB) then
      Exponent := 0;

    Pack(UB, Exponent, Sign, Result);
  end;
end;

function RoundPlacesBcd(const B : TBcd; Places : Cardinal) : TBcd;
var
  Exponent, ActPlaces : Integer;
  Sign : Byte;
  UB : TUnpBcd;
begin
  if B[0] = 0 then
    {input is zero}
    SetZero(Result)

  else begin
    ActPlaces := Integer(MantissaDigits)-(B[0] and NoSignBit)+ExpBias;

    if LongInt(Places) >= ActPlaces then
      {no actual rounding}
      Result := B

    else begin
      Unpack(B, UB, Exponent, Sign);

      RoundMantissa(UB, ActPlaces-LongInt(Places));
      if UB[SigDigits] <> 0 then begin
        ShiftMantissaDown(UB, 1);
        inc(Exponent);
      end else if IsZeroMantissa(UB) then
        Exponent := 0;

      Pack(UB, Exponent, Sign, Result);
    end;
  end;
end;

function SqrtBcd(const B : TBcd) : TBcd;
var
  Exponent, I, Iterations : Integer;
  BN, B05 : TBcd;
begin
  if B[0] and SignBit <> 0 then
    {square root of a negative number}
    RaiseBcdError(stscBcdBadInput);

  if B[0] = 0 then begin
    {done for input of zero}
    SetZero(Result);
    Exit;
  end;

  {normalize input}
  Exponent := B[0]-ExpBias;
  BN := B;
  BN[0] := ExpBias;

  {create reused constant bcd}
  B05 := FastVal('0.5');

  {compute initial approximation of sqrt}
  Result := AddBcd(MulBcd(FastVal('0.894470'), BN),
                          FastVal('0.223607'));

  if BcdSize <= 10 then
    Iterations := 3
  else
    Iterations := 5;

  {iterate to accurate normalized sqrt, Result = 0.5*((BN/Result)+Result)}
  for I := 1 to Iterations do
    Result := MulBcd(AddBcd(DivBcd(BN, Result), Result), B05);

  {final correction Result = (0.5*(BN/Result-Result))+Result}
  Result := AddBcd(MulBcd(SubBcd(DivBcd(BN, Result), Result), B05), Result);

  if Odd(Exponent) then begin
    Result := MulBcd(Result,
      FastVal('0.31622776601683793319988935444327185337')); {Sqrt(0.1)}
    inc(Exponent);
  end;

  inc(Result[0], Exponent shr 1);
end;

function StrBcd(const B : TBcd; Width, Places : Cardinal) : string;
var
  I, O, Exponent, ActWidth, Digits, DecimalPos : Integer;
  Sign : Byte;
  UB : TUnpBcd;

  procedure AddChar(Ch : Char);
  begin
    Result[O] := Ch;
    inc(O);
  end;

begin
  Unpack(B, UB, Exponent, Sign);

  if Exponent = 0 then begin
    {ensure mantissa is set to zero}
    FillChar(UB[1], SigDigits, 0);
    {fool the rest of the function}
    Exponent := ExpBias+1;
  end;

  {ActWidth is the non-padded width}
  {it has at least one digit before decimal point}
  ActWidth := 1;
  if Exponent > ExpBias+1 then
    {add other digits before decimal point}
    inc(ActWidth, Exponent-ExpBias-1);

  {add digits after decimal point}
  inc(ActWidth, Places);

  {see how many digits from mantissa to use}
  if Exponent < ExpBias+1 then begin
    Digits := LongInt(Places)-(ExpBias-Exponent);
    if Digits < 0 then
      Digits := 0;
  end else
    Digits := ActWidth;

  if Places <> 0 then
    {add one for decimal point}
    inc(ActWidth);

  if Sign <> 0 then
    {add one for minus sign}
    inc(ActWidth);

  if Digits < MantissaDigits then begin
    {need to round}
    RoundMantissa(UB, MantissaDigits-Digits);
    if UB[SigDigits] <> 0 then begin
      ShiftMantissaDown(UB, 1);
      inc(Exponent);
      inc(Digits);
      if Exponent > ExpBias+1 then
        inc(ActWidth);
    end;
  end else
    {use all mantissa digits}
    Digits := MantissaDigits;

  {adjust and limit Width}
  if Width = 0 then
    Width := ActWidth;
{$IFDEF WStrings}
  if Width > 255 then
    Width := 255;
{$ENDIF}
  SetLength(Result, Width);

  if LongInt(Width) < ActWidth then begin
    {result won't fit in specified width}
    FillChar(Result[1], Length(Result), OverflowChar);
    Exit;
  end;

  if LongInt(Width) > ActWidth then begin
    {store leading spaces}
    FillChar(Result[1], LongInt(Width)-ActWidth, ' ');
    O := LongInt(Width)-ActWidth+1;
  end else
    O := 1;

  if Sign <> 0 then
    AddChar('-');

  if Exponent < ExpBias+1 then begin
    {number is less than 1}
    AddChar('0');
    if Exponent <> 0 then begin
      AddChar(DecimalSeparator);
      for I := 1 to ExpBias-Exponent do
        if O <= LongInt(Width) then
          AddChar('0');
    end;
  end;

  if Places = 0 then
    {no decimal point}
    DecimalPos := 0
  else
    DecimalPos := Width-Places;

  {add digits from the mantissa}
  if Digits <> 0 then begin
    I := SigDigits;
    if UB[I] = 0 then
      dec(I);
    while (Digits > 0) and (O <= LongInt(Width)) do begin
      if O = DecimalPos then
        AddChar(DecimalSeparator);
      AddChar(Char(UB[I]+Byte('0')));
      dec(I);
      dec(Digits);
    end;
  end;

  {add trailing zeros, if any}
  while O <= LongInt(Width) do begin
    if O = DecimalPos then
      AddChar(DecimalSeparator);
    if O <= LongInt(Width) then
      AddChar('0');
  end;
end;

function StrExpBcd(const B : TBcd; Width : Cardinal) : string;
const
  MinWidth = 8;
  MaxWidth = MantissaDigits+6;
var
  I, O, Exponent : Integer;
  Sign : Byte;
  UB : TUnpBcd;

  procedure AddChar(Ch : Char);
  begin
    Result[O] := Ch;
    inc(O);
  end;

begin
  Unpack(B, UB, Exponent, Sign);

  {validate and adjust Width}
  if Width = 0 then
    Width := MaxWidth
  else if Width < MinWidth then
    Width := MinWidth;
{$IFDEF WStrings}
  if Width > 255 then
    Width := 255;
{$ENDIF}
  SetLength(Result, Width);

  {store leading spaces}
  if Width > MaxWidth then begin
    FillChar(Result[1], Width-MaxWidth, ' ');
    O := Width-MaxWidth+1;
  end else
    O := 1;

  {store sign}
  if Sign <> 0 then
    AddChar('-')
  else
    AddChar(' ');

  if Exponent = 0 then begin
    {ensure mantissa is set to zero}
    FillChar(UB[1], SigDigits, 0);
    {force Exponent to display as 0}
    Exponent := ExpBias+1;

  end else if Width < MaxWidth then begin
    {need to round}
    RoundMantissa(UB, MaxWidth-Width);
    if UB[SigDigits] <> 0 then begin
      ShiftMantissaDown(UB, 1);
      inc(Exponent);
    end;
  end;

  {copy mantissa to string}
  I := MantissaDigits;
  AddChar(Char(UB[I]+Byte('0')));
  dec(I);
  AddChar(DecimalSeparator);
  while O < LongInt(Width-3) do begin
    AddChar(Char(UB[I]+Byte('0')));
    dec(I);
  end;

  {store exponent}
  AddChar('E');
  if Exponent < ExpBias+1 then begin
    AddChar('-');
    Exponent := ExpBias+1-Exponent;
  end else begin
    AddChar('+');
    dec(Exponent, ExpBias+1);
  end;
  AddChar(Char((Exponent div 10)+Byte('0')));
  AddChar(Char((Exponent mod 10)+Byte('0')));
end;

function SubBcd(const B1, B2 : TBcd) : TBcd;
begin
  Result := AddBcd(B1, NegBcd(B2));
end;

function TruncBcd(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
          {numeric overflow}
          RaiseBcdError(stscBcdOverflow);
        dec(Result, UB[I]);
      end else begin
        if Result > MaxLongInt-UB[I] then
          {numeric overflow}
          RaiseBcdError(stscBcdOverflow);
        inc(Result, UB[I]);
      end;

      dec(I);
      dec(Exponent);
    end;
  end;
end;

function ValBcd(const S : string) : TBcd;
var
  I, O, Digits, Exponent : Integer;
  Sign : Byte;
  ExpSigned, Rounded : Boolean;
  UB : TUnpBcd;

  function SChar(I : Integer) : Char;
  begin
    if I > Length(S) then
      Result := #0
    else
      Result := S[I];
  end;

  function IsDigit(Ch : Char) : Boolean;
  begin
    Result := (Ch >= '0') and (Ch <= '9');
  end;

  procedure AddDigit(Ch : Char);
  begin
    if O > 0 then begin
      UB[O] := Byte(Ch)-Byte('0');
      dec(O);
    end else if not Rounded then begin
      {got more significant digits than will fit, must round}
      Rounded := True;
      UB[0] := Byte(Ch)-Byte('0');
      RoundMantissa(UB, 0);
      if UB[SigDigits] <> 0 then begin
        ShiftMantissaDown(UB, 1);
        inc(Digits);
      end;
    end;
  end;

begin
  FillChar(UB, SizeOf(TUnpBcd), 0);

  I := 1;  {input position}
  O := MantissaDigits; {output position}
  Exponent := 0;
  Sign := 0;
  Rounded := False;

  {digits before dot, or negative digits after dot in case of 0.0000n}
  Digits := 0;

  {skip leading spaces}
  while SChar(I) = ' ' do
    inc(I);

  {get sign if any}
  case SChar(I) of
    '+' :
      {skip +}
      inc(I);
    '-' :
      begin
        {negative number}
        Sign := SignBit;
        inc(I);
      end;
  end;

  {handle first digit}
  if SChar(I) <> DecimalSeparator then begin
    if not IsDigit(SChar(I)) then
      RaiseBcdError(stscBcdBadFormat);

    {skip leading zeros}
    while SChar(I) = '0' do
      inc(I);

    {add significant digits}
    while IsDigit(SChar(I)) do begin
      AddDigit(SChar(I));
      inc(I);
      inc(Digits);
    end;
  end;

  {handle dot}
  if SChar(I) = DecimalSeparator then begin
    inc(I);
    if Digits = 0 then begin
      {no digits before dot, skip zeros after dot}
      while SChar(I) = '0' do begin
        inc(I);
        dec(Digits);
      end;
    end;

    {add significant digits}
    while IsDigit(SChar(I)) do begin
      AddDigit(SChar(I));
      inc(I);
    end;
  end;

  {handle exponent}
  case SChar(I) of
    'e', 'E' :
      begin
        inc(I);
        ExpSigned := False;
        case SChar(I) of
          '+' :
            {skip +}
            inc(I);