stexpr.pas

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

  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.PCount := 3;
  IR^.Kind := ikFunction;
  IR^.Func3Addr := FunctionAddr;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

procedure TStExpression.AddInternalFunctions;
begin
  eBusyFlag := True;
  try
    {add function name and parameter count to list}
    AddFunction1Param('abs',     _Abs);
    AddFunction1Param('arctan',  _ArcTan);
    AddFunction1Param('cos',     _Cos);
    AddFunction1Param('exp',     _Exp);
    AddFunction1Param('frac',    _Frac);
    AddFunction1Param('int',     _Int);
    AddFunction1Param('trunc',   _Trunc);
    AddFunction1Param('ln',      _Ln);
    AddFunction0Param('pi',      _Pi);
    AddFunction1Param('round',   _Round);
    AddFunction1Param('sin',     _Sin);
    AddFunction1Param('sqr',     _Sqr);
    AddFunction1Param('sqrt',    _Sqrt);
    {$IFDEF UseMathUnit}
    AddFunction1Param('arccos',  _ArcCos);
    AddFunction1Param('arcsin',  _ArcSin);
    AddFunction2Param('arctan2', _ArcTan2);
    AddFunction1Param('tan',     _Tan);
    AddFunction1Param('cotan',   _Cotan);
    AddFunction2Param('hypot',   _Hypot);
    AddFunction1Param('cosh',    _Cosh);
    AddFunction1Param('sinh',    _Sinh);
    AddFunction1Param('tanh',    _Tanh);
    AddFunction1Param('arccosh', _ArcCosh);
    AddFunction1Param('arcsinh', _ArcSinh);
    AddFunction1Param('arctanh', _ArcTanh);
    AddFunction1Param('lnxp1',   _Lnxp1);
    AddFunction1Param('log10',   _Log10);
    AddFunction1Param('log2',    _Log2);
    AddFunction2Param('logn',    _LogN);
    AddFunction1Param('ceil',    _Ceil);
    AddFunction1Param('floor',   _Floor);
    {$ENDIF}
  finally
    eBusyFlag := False;
  end;
end;

procedure TStExpression.AddMethod0Param(const Name : AnsiString;
          MethodAddr : TStMethod0Param);
var
  IR : PStIdentRec;
begin
  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.PCount := 0;
  IR^.Kind := ikMethod;
  IR^.Meth0Addr := MethodAddr;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

procedure TStExpression.AddMethod1Param(const Name : AnsiString;
          MethodAddr : TStMethod1Param);
var
  IR : PStIdentRec;
begin
  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.PCount := 1;
  IR^.Kind := ikMethod;
  IR^.Meth1Addr := MethodAddr;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

procedure TStExpression.AddMethod2Param(const Name : AnsiString;
          MethodAddr : TStMethod2Param);
var
  IR : PStIdentRec;
begin
  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.PCount := 2;
  IR^.Kind := ikMethod;
  IR^.Meth2Addr := MethodAddr;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

procedure TStExpression.AddMethod3Param(const Name : AnsiString;
          MethodAddr : TStMethod3Param);
var
  IR : PStIdentRec;
begin
  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.PCount := 3;
  IR^.Kind := ikMethod;
  IR^.Meth3Addr := MethodAddr;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

procedure TStExpression.AddVariable(const Name : AnsiString; VariableAddr : PStFloat);
var
  IR : PStIdentRec;
begin
  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.Kind := ikVariable;
  IR^.VarAddr := VariableAddr;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

function TStExpression.AnalyzeExpression : TStFloat;
begin
  FLastError := 0;

  {error if nothing to do}
  if (Length(FExpression) = 0) then
    RaiseExprError(stscExprEmpty, 0);

  {clear operand stack}
  StackClear;

  {get the first character from the string}
  eExprPos := 1;
  eCurChar := FExpression[1];

  {get the first Token and start parsing}
  GetToken;
  GetExpression;

  {make sure expression is fully evaluated}
  if (eToken <> ssEol) or (StackCount <> 1) then
    RaiseExprError(stscExprBadExp, FErrorPos);

  Result := StackPop;
end;

procedure TStExpression.ClearIdentifiers;
var
  I : Integer;
begin
  for I := 0 to eIdentList.Count-1 do
    Dispose(PStIdentRec(eIdentList[I]));
  eIdentList.Clear;
end;

constructor TStExpression.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);

  eStack := TList.Create;
  eIdentList := TList.Create;

  FAllowEqual := True;

  AddInternalFunctions;
end;

destructor TStExpression.Destroy;
begin
  StackClear;
  eStack.Free;
  eStack := nil;

  ClearIdentifiers;
  eIdentList.Free;
  eIdentList := nil;

  inherited Destroy;
end;

procedure TStExpression.DoOnAddIdentifier;
begin
  if eBusyFlag then
    Exit;
  if Assigned(FOnAddIdentifier) then
    FOnAddIdentifier(Self);
end;

function TStExpression.FindIdent(Name : AnsiString) : Integer;
var
  I : Integer;
begin
  Result := -1;
  for I := 0 to eIdentList.Count-1 do begin
    if Name = PStIdentRec(eIdentList[I])^.Name then begin
      Result := I;
      Break;
    end;
  end;
end;

function TStExpression.GetAsInteger : Integer;
begin
  Result := Round(AnalyzeExpression);
end;

function TStExpression.GetAsString : AnsiString;
begin
  Result := FloatToStr(AnalyzeExpression);
end;

procedure TpVal(const S : AnsiString; var V : Extended; var Code : Integer);
{
Evaluate string as a floating point number, emulates Borlandish Pascal's
Val() intrinsic

Recognizes strings of the form:
[-/+](d*[.][d*]|[d*].d*)[(e|E)[-/+](d*)]

Parameters:
  S : string to convert
  V : Resultant Extended value
  Code: position in string where an error occured or
   --  0 if no error
   --  Length(S) + 1 if otherwise valid string terminates prematurely (e.g. "10.2e-")

  if Code <> 0 on return then the value of V is undefined
}

type
  { recognizer machine states }
  TNumConvertState = (ncStart, ncSign, ncWhole, ncDecimal, ncStartDecimal,
    ncFraction, ncE, ncExpSign, ncExponent, ncEndSpaces, ncBadChar);
const
  { valid stop states for machine }
  StopStates: set of TNumConvertState = [ncWhole, ncDecimal, ncFraction,
    ncExponent, ncEndSpaces];

var
  i        : Integer;        { general purpose counter }
  P        : PAnsiChar;      { current position in evaluated string }
  NegVal   : Boolean;        { is entire value negative? }
  NegExp   : Boolean;        { is exponent negative? }
  Exponent : LongInt;        { accumulator for exponent }
  Mantissa : Extended;       { mantissa }
  FracMul  : Extended;       { decimal place holder }
  State : TNumConvertState;  { current state of recognizer machine }


begin
{initializations}
  V := 0.0;
  Code := 0;

  State := ncStart;

  NegVal := False;
  NegExp := False;

  Mantissa := 0.0;
  FracMul  := 0.1;
  Exponent := 0;

{
Evaluate the string
When the loop completes (assuming no error)
  -- WholeVal will contain the absolute value of the mantissa
  -- Exponent will contain the absolute value of the exponent
  -- NegVal will be set True if the mantissa is negative
  -- NegExp will be set True if the exponent is negative

If an error occurs P will be pointing at the character that caused the problem,
or one past the end of the string if it terminates prematurely
}

  { keep going until run out of string or halt if unrecognized or out-of-place
    character detected }

  P := PAnsiChar(S);
  for i := 1 to Length(S) do begin
  case State of
    ncStart : begin
      if P^ = DecimalSeparator then begin
        State := ncStartDecimal;   { decimal point detected in mantissa }
      end else

      case P^ of
        ' ': begin
          {ignore}
        end;

        '+': begin
          State := ncSign;
        end;

        '-': begin
          NegVal := True;
          State := ncSign;
        end;

        'e', 'E': begin
          Mantissa := 0;
          State := ncE;     { exponent detected }
        end;

        '0'..'9': begin
          State := ncWhole;    { start of whole portion of mantissa }
          Mantissa := (Mantissa * 10) + (Ord(P^) - Ord('0'));
        end;

        else
          State := ncBadChar;
      end;

    end;

    ncSign : begin
      if P^ = DecimalSeparator then begin
        State := ncDecimal;   { decimal point detected in mantissa }
      end else

      case P^ of
        '0'..'9': begin
          State := ncWhole;    { start of whole portion of mantissa }
          Mantissa := (Mantissa * 10) + (Ord(P^) - Ord('0'));
        end;

        'e', 'E': begin
          Mantissa := 0;
          State := ncE;     { exponent detected }
        end;

        else
          State := ncBadChar;
      end;
    end;

    ncWhole : begin
      if P^ = DecimalSeparator then begin
        State := ncDecimal;   { decimal point detected in mantissa }
      end else

      case P^ of
        '0'..'9': begin
          Mantissa := (Mantissa * 10) + (Ord(P^) - Ord('0'));
        end;

        '.': begin
        end;

        'e', 'E': begin
          State := ncE;     { exponent detected }
        end;

        ' ': begin
          State := ncEndSpaces;
        end;

        else
          State := ncBadChar;
      end;
    end;

    ncDecimal : begin
      case P^ of
        '0'..'9': begin
          State := ncFraction; { start of fractional portion of mantissa }
          Mantissa := Mantissa + (FracMul * (Ord(P^) - Ord('0')));
          FracMul := FracMul * 0.1;
        end;

        'e', 'E': begin
          State := ncE;     { exponent detected }
        end;

        ' ': begin
          State := ncEndSpaces;
        end;

        else
          State := ncBadChar;
      end;

    end;

    ncStartDecimal : begin
      case P^ of
        '0'..'9': begin
          State := ncFraction; { start of fractional portion of mantissa }
          Mantissa := Mantissa + (FracMul * (Ord(P^) - Ord('0')));
          FracMul := FracMul * 0.1;
        end;

        ' ': begin
          State := ncEndSpaces;
        end;

        else
          State := ncBadChar;
      end;
    end;

    ncFraction : begin
      case P^ of
        '0'..'9': begin
          Mantissa := Mantissa + (FracMul * (Ord(P^) - Ord('0')));
          FracMul := FracMul * 0.1;
        end;

        'e', 'E': begin
          State := ncE;     { exponent detected }
        end;

        ' ': begin
          State := ncEndSpaces;
        end;

        else
          State := ncBadChar;
      end;
    end;

    ncE : begin
      case P^ of
        '0'..'9': begin
          State := ncExponent;  { start of exponent }
          Exponent := Exponent * 10 + (Ord(P^) - Ord('0'));
        end;

        '+': begin
          State := ncExpSign;
        end;

        '-': begin
          NegExp := True;   { exponent is negative }
          State := ncExpSign;
        end;

        else
          State := ncBadChar;
      end;
    end;

    ncExpSign : begin
      case P^ of
        '0'..'9': begin
          State := ncExponent;  { start of exponent }
          Exponent := Exponent * 10 + (Ord(P^) - Ord('0'));
        end;

        else
          State := ncBadChar;
      end;
    end;

    ncExponent : begin
      case P^ of
        '0'..'9': begin
          Exponent := Exponent * 10 + (Ord(P^) - Ord('0'));
        end;

        ' ': begin
          State := ncEndSpaces;
        end;

        else
          State := ncBadChar;
      end;
    end;

    ncEndSpaces : begin
      case P^ of
        ' ': begin
          {ignore}
        end;
        else
          State := ncBadChar;
      end;
    end;
  end;

    Inc(P);
    if State = ncBadChar then begin
      Code := i;
      Break;
    end;
  end;
{
Final calculations
}
  if not (State in StopStates) then begin
      Code := i;  { point to error }
  end else begin
    { negate if needed }
    if NegVal then
      Mantissa := -Mantissa;


    { apply exponent if any }
    if Exponent <> 0 then begin
      if NegExp then
        for i := 1 to Exponent do
          Mantissa := Mantissa * 0.1
      else
        for i := 1 to Exponent do
          Mantissa := Mantissa * 10.0;
    end;

    V := Mantissa;
  end;
end;


procedure TStExpression.GetBase;
var
  SaveSign : TStToken;
  Code     : Integer;
  NumVal   : TStFloat;
begin
  case eToken of
    ssNum :
      begin
        {evaluate real number string}