stbcd.pas

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

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StBCD.pas 4.03                              *}
{*********************************************************}
{* SysTools: BCD arithmetic functions                    *}
{*********************************************************}

{$I StDefine.inc}

{Notes:
  The BCD format matches that defined by Turbo Pascal 3.0. It is as follows:

     LSB                      MSB (most significant byte at end)
      |<------ Mantissa ------>|
    1  2  3  4  5  6  7  8  9 10  <- Byte #
   sE ML ML ML ML ML ML ML ML ML
    ^                         ^^--- Less significant digit
    |                         |---- More significant digit
    |
    v
    7 6 5 4 3 2 1 0 <-- Bit # (in Byte 1)
    s E E E E E E E
    ^ <--exponent->
    |       |
    |       |--- exponent has offset of $3F (eg, $41 means 10^2 = 100)
    |----------- sign bit (0 = positive, 1 = negative)

   Unpacked BCD format
   -------------------
   Many of the routines that follow work with these reals in an unpacked
   format. That is, before an arithmetic operation is performed, the mantissas
   are expanded (unpacked) so that there is one digit per byte. After unpacking,
   the reals look like this:

     LSB                                                MSB
      |<------------------ mantissa --------------------->|
    1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20
   sE 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 0d 00
                                                         ^^
                                                         ||---- Digit
                                                         |----- 0
   Byte 1 is unchanged.
   Bytes 2-19 contain the digits in the mantissa, LSB first. The high
     nibble of each byte is 0, and the low nibble contains the digit.
   Byte 20, sometimes used to keep track of overflow, is set to 0.

   The constant BcdSize determines the size and accuracy of the Bcd
   routines. It can be any value in the range 4-20 bytes. The default
   value of 10 gives 18 digits of accuracy. A size of 20 gives 38 digits
   of accuracy.

   The BCD routines are thread-aware; all temporary variables are local.

   STBCD uses the DecimalSeparator global variable from the SYSUTILS unit
   wherever it needs a decimal point. As such the formatting of BCD
   strings is aware of international differences.

   The transcendental routines (Sqrt, Ln, Exp, Pow) are accurate for
   all but 1 or 2 of the available digits of storage. For BcdSize =
   10, this means 16-17 accurate digits; for BcdSize = 20, this means
   36-37 accurate digits. The last digit or two is lost to roundoff
   errors during the calculations.

   Algorithms used for transcendental routines (depending on BcdSize):
     Sqrt:
       Herron's iterative approximation
     Exp:
       <= 10 bytes, Chebyshev polynomials per Cody and Waite
       > 10 bytes, traditional series expansion
     Ln:
       <= 10 bytes, Chebyshev polynomials of rational approximation
         per Cody and Waite
       > 10 bytes, Carlson's iterative approximation
     Pow:
       straight multiplication for integer powers
       use of Exp and Ln for non-integer powers

   Computation of Exp and Ln for BcdSize > 10 bytes is quite slow. Exp
   takes up to 30 terms to fill in all the digits when BcdSize = 20.
   Ln takes 9 iterations for BcdSize = 20, but each iteration is complicated
   and involves a sqrt, a divide, and other simpler operations.

   FormatBcd mimics the FormatFloat routine from the SYSUTILS unit.
   StrGeneralBcd mimics the FloatToStrF routine with the ffGeneral option.
   See the documentation for those routines for more information.
}


unit StBCD;

interface

uses
  Windows,
  SysUtils,
  StConst,
  StBase,
 {$IFOPT H+}
  StStrL;
 {$ELSE}
  StStrS;
 {$ENDIF}

const
  BcdSize = 10;                   {bytes in BCD, valid range 4-20}
  {.Z+}
  MantissaDigits = 2*(BcdSize-1); {digits in mantissa}
  OverflowChar = '*';             {character used to fill an overflow string}
  {.Z-}

type
  TBcd = array[0..BcdSize-1] of Byte;

var
  {these values are set up by the initialization block}
  ZeroBcd : TBcd;
  MinBcd  : TBcd;
  MaxBcd  : TBcd;
  BadBcd  : TBcd;
  PiBcd   : TBcd;
  eBcd    : TBcd;
  Ln10Bcd : TBcd;

{$IFNDEF CBuilder}
function AddBcd(const B1, B2 : TBcd) : TBcd;
  {-Return B1+B2}
function SubBcd(const B1, B2 : TBcd) : TBcd;
  {-Return B1-B2}
function MulBcd(const B1, B2 : TBcd) : TBcd;
  {-Return B1*B2}
function DivBcd(const B1, B2 : TBcd) : TBcd;
  {-Return B1/B2}
function ModBcd(const B1, B2 : TBcd) : TBcd;
  {-Return B1 mod B2}
function NegBcd(const B : TBcd) : TBcd;
  {-Return the negative of B}
function AbsBcd(const B : TBcd) : TBcd;
  {-Return the absolute value of B}
function FracBcd(const B : TBcd) : TBcd;
  {-Return the fractional part of B}
function IntBcd(const B : TBcd) : TBcd;
  {-Return the integer part of B, as a BCD real}
function RoundDigitsBcd(const B : TBcd; Digits : Cardinal) : TBcd;
  {-Return B rounded to specified total digits of accuracy}
function RoundPlacesBcd(const B : TBcd; Places : Cardinal) : TBcd;
  {-Return B rounded to specified decimal places of accuracy}
function ValBcd(const S : string) : TBcd;
  {-Convert a string to a BCD}
function LongBcd(L : LongInt) : TBcd;
  {-Convert a long integer to a BCD}
function ExtBcd(E : Extended) : TBcd;
  {-Convert an extended real to a BCD}
function ExpBcd(const B : TBcd) : TBcd;
  {-Return e**B}
function LnBcd(const B : TBcd) : TBcd;
  {-Return natural log of B}
function IntPowBcd(const B : TBcd; E : LongInt) : TBcd;
  {-Return B**E, where E is an integer}
function PowBcd(const B, E : TBcd) : TBcd;
  {-Return B**E}
function SqrtBcd(const B : TBcd) : TBcd;
  {-Return the square root of B}
{$ENDIF}

function CmpBcd(const B1, B2 : TBcd) : Integer;
  {-Return <0 if B1<B2, =0 if B1=B2, >0 if B1>B2}
function EqDigitsBcd(const B1, B2 : TBcd; Digits : Cardinal) : Boolean;
  {-Return True if B1 and B2 are equal after rounding to specified digits}
function EqPlacesBcd(const B1, B2 : TBcd; Digits : Cardinal) : Boolean;
  {-Return True if B1 and B2 are equal after rounding to specified decimal places}
function IsIntBcd(const B : TBcd) : Boolean;
  {-Return True if B has no fractional part (may still not fit into a LongInt)}
function TruncBcd(const B : TBcd) : LongInt;
  {-Return B after discarding its fractional part}
function BcdExt(const B : TBcd) : Extended;
  {-Convert B to an extended real}
function RoundBcd(const B : TBcd) : LongInt;
  {-Round B rounded to the nearest integer}
function StrBcd(const B : TBcd; Width, Places : Cardinal) : string;
  {-Convert BCD to a string in floating point format}
function StrExpBcd(const B : TBcd; Width : Cardinal) : string;
  {-Convert BCD to a string in scientific format}
function FormatBcd(const Format: string; const B : TBcd): string;
  {-Format a BCD like FormatFloat does for Extended}
function StrGeneralBcd(const B : TBcd) : string;
  {-Format a BCD like FloatToStrF does with ffGeneral format, MantissaDigits
    for Precision, and zero for Digits}
function FloatFormBcd(const Mask : string; B : TBCD;
                      const LtCurr, RtCurr : string;
                      Sep, DecPt : AnsiChar) : string;
  {-Returns a formatted string with digits from B merged into the Mask}
procedure ConvertBcd(const SrcB; SrcSize : Byte; var DestB; DestSize : Byte);
  {-Convert a BCD of one size to another size}

{the following routines are provided to support C++Builder}
{$IFDEF CBuilder}
procedure AddBcd_C(const B1, B2 : TBcd; var Res : TBcd);
procedure SubBcd_C(const B1, B2 : TBcd; var Res : TBcd);
procedure MulBcd_C(const B1, B2 : TBcd; var Res : TBcd);
procedure DivBcd_C(const B1, B2 : TBcd; var Res : TBcd);
procedure ModBcd_C(const B1, B2 : TBcd; var Res : TBcd);
procedure NegBcd_C(const B : TBcd; var Res : TBcd);
procedure AbsBcd_C(const B : TBcd; var Res : TBcd);
procedure FracBcd_C(const B : TBcd; var Res : TBcd);
procedure IntBcd_C(const B : TBcd; var Res : TBcd);
procedure RoundDigitsBcd_C(const B : TBcd; Digits : Cardinal; var Res : TBcd);
procedure RoundPlacesBcd_C(const B : TBcd; Places : Cardinal; var Res : TBcd);
procedure ValBcd_C(const S : string; var Res : TBcd);
procedure LongBcd_C(L : LongInt; var Res : TBcd);
procedure ExtBcd_C(E : Extended; var Res : TBcd);
procedure ExpBcd_C(const B : TBcd; var Res : TBcd);
procedure LnBcd_C(const B : TBcd; var Res : TBcd);
procedure IntPowBcd_C(const B : TBcd; E : LongInt; var Res : TBcd);
procedure PowBcd_C(const B, E : TBcd; var Res : TBcd);
procedure SqrtBcd_C(const B : TBcd; var Res : TBcd);
{$ENDIF}

{the following function is interfaced to avoid hints from the compiler}
{for its non use when the BcdSize constant is set a value less than 11}
{$IFNDEF CBuilder}
function LnBcd20(const B : TBcd) : TBcd;
{$ENDIF}

{=========================================================}

implementation

{Define to use assembly language in primitive routines below}
{$DEFINE UseAsm}

const
  NoSignBit = $7F;                {mask to get just the exponent}
  SignBit   = $80;                {mask to get just the sign}
  ExpBias   = $3F;                {bias added to actual exponent value}
  SigDigits = MantissaDigits+1;   {counts overflow digit}

type
  TUnpBcd = array[0..SigDigits] of Byte;   {unpacked BCD}
  PUnpBcd = ^TUnpBcd;
  TIntBcd = array[0..4*BcdSize-1] of Byte; {double size buffer for mult/div}

{$IFDEF CBuilder}
function AddBcd(const B1, B2 : TBcd) : TBcd; forward;
function SubBcd(const B1, B2 : TBcd) : TBcd; forward;
function MulBcd(const B1, B2 : TBcd) : TBcd; forward;
function DivBcd(const B1, B2 : TBcd) : TBcd; forward;
function ModBcd(const B1, B2 : TBcd) : TBcd; forward;
function NegBcd(const B : TBcd) : TBcd; forward;
function AbsBcd(const B : TBcd) : TBcd; forward;
function FracBcd(const B : TBcd) : TBcd; forward;
function IntBcd(const B : TBcd) : TBcd; forward;
function RoundDigitsBcd(const B : TBcd; Digits : Cardinal) : TBcd; forward;
function RoundPlacesBcd(const B : TBcd; Places : Cardinal) : TBcd; forward;
function ValBcd(const S : string) : TBcd; forward;
function LongBcd(L : LongInt) : TBcd; forward;
function ExtBcd(E : Extended) : TBcd; forward;
function ExpBcd(const B : TBcd) : TBcd; forward;
function LnBcd(const B : TBcd) : TBcd; forward;
function IntPowBcd(const B : TBcd; E : LongInt) : TBcd; forward;
function PowBcd(const B, E : TBcd) : TBcd; forward;
function SqrtBcd(const B : TBcd) : TBcd; forward;
{$ENDIF}

function FastValPrep(S : ShortString) : ShortString;
var
  I : LongInt;
begin
  I := Pos('.', S);
  if I > 0 then
    S[I] := DecimalSeparator;
  Result := S;
end;

procedure RaiseBcdError(Code : LongInt);
var
  E : EStBCDError;
begin
  E := EStBCDError.CreateResTP(Code, 0);
  E.ErrorCode := Code;
  raise E;
end;

procedure AddMantissas(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,[esi]  {UB1}
    inc esi
    adc al,[edi]  {UB1+UB2+CF}
    aaa
    mov [edi],al  {update UB2}
    inc edi
    dec ecx
    jnz @1
    jnc @2
    inc byte ptr [edi]
@2: pop edi
    pop esi
  end;
{$ELSE}
var
  I : Integer;
  T, C : Byte;
begin
  C := 0;
  for I := 0 to MantissaDigits do begin
    T := UB2[I]+UB1[I]+C;
    if T > 9 then begin
      C := 1;
      dec(T, 10);
    end else
      C := 0;
    UB2[I] := T;
  end;
  UB2[SigDigits] := C;
end;
{$ENDIF}

function IsZeroMantissa(const UB : TUnpBcd) : Boolean;
{$IFDEF UseAsm}
 asm
   push edi
   mov edi,UB
   {inc edi}
   xor al,al
   mov ecx,SigDigits
   repe scasb
   jne @1
   inc al
@1:pop edi
 end;
{$ELSE}
var
  I : Integer;
begin
  for I := 0 to MantissaDigits do
    if UB[I] <> 0 then begin
      Result := False;
      Exit;
    end;
  Result := True;
end;
{$ENDIF}

procedure NegMantissa(var UB : TUnpBcd);
{$IFDEF UseAsm}
  asm
    push edi
    mov edi,UB
    {inc edi}
    mov ecx,SigDigits
    xor dh,dh
    clc
@1: mov al,dh
    sbb al,[edi]
    aas
    mov [edi],al
    inc edi
    dec ecx
    jnz @1
    pop edi
  end;
{$ELSE}
var
  I : Integer;
  C : Byte;
begin
  C := 1;
  for I := 0 to MantissaDigits do begin
    UB[I] := 9+C-UB[I];
    if UB[I] > 9 then begin
      dec(UB[I], 10);
      C := 1;
    end else
      C := 0;
  end;
end;
{$ENDIF}

procedure NormalizeMantissa(var UB : TunpBcd; var E : Integer);
var
  I, Shift : Integer;
begin
  {find most significant non-zero digit}
  for I := MantissaDigits downto 0 do
    if UB[I] <> 0 then begin
      Shift := MantissaDigits-I;
      if Shift >= E then begin
        {number disappears}
        E := 0;
        FillChar(UB[0], SigDigits, 0);
      end else if Shift <> 0 then begin
        dec(E, Shift);
        move(UB[0], UB[Shift], SigDigits-Shift);
        FillChar(UB[0], Shift, 0);
      end;
      Exit;
    end;
  {mantissa is all zeros}
  E := 0;
end;

procedure SetZero(var B : TBcd);
begin
  FillChar(B, SizeOf(TBcd), 0);
end;

procedure Pack(const UB : TUnpBcd; Exponent : Integer; Sign : Byte;
               var B : TBcd);
{$IFNDEF UseAsm}
var
  I : Integer;
{$ENDIF}
begin
  if Exponent <= 0 then
    SetZero(B)

  else begin
    B[0] := Sign or Exponent;
    {repack digits}
{$IFDEF UseAsm}
    asm
      push esi
      push edi
      mov esi,UB
      mov edi,B
      inc esi
      inc edi
      mov ecx,BcdSize-1
@1:   mov ax,[esi]
      inc esi
      inc esi
      shl ah,4
      or  al,ah
      mov [edi],al
      inc edi
      dec ecx
      jnz @1
      pop edi
      pop esi
    end;
{$ELSE}
    for I := 1 to BcdSize-1 do
      B[I] := UB[2*I-1] or (UB[2*I] shl 4);
    {overflow digit ignored}
{$ENDIF}
  end;
end;

procedure RoundMantissa(var UB : TUnpBcd; Start : Integer);
var
{$IFNDEF UseAsm}
  I : Integer;
{$ENDIF}
  C : Byte;
begin
  if Start > MantissaDigits then begin
    Start := SigDigits;
    C := 0;
  end else
    C := UB[Start];
  FillChar(UB[1], Start, 0);
  if C < 5 then
    Exit;
{$IFDEF UseAsm}
  asm
    push edi
    mov edi,UB
    mov eax,Start
    add edi,eax
    inc edi
    mov ecx,MantissaDigits
    sub ecx,eax
    jle  @2