stexpr.pas

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

        if (eTokenStr[1] = DecimalSeparator{'.'}) then
          eTokenStr := '0' + eTokenStr;
        {Val(eTokenStr, NumVal, Code);}
        TpVal(eTokenStr, NumVal, Code);
        if Code <> 0 then
          RaiseExprError(stscExprBadNum, FErrorPos);
        {put on operand stack}
        StackPush(NumVal);
        GetToken;
      end;
    ssIdent :
      {function call}
      GetFunction;
    ssLPar :
      begin
        {nested expression}
        GetToken;
        GetExpression;
        if (eToken <> ssRPar) then
          RaiseExprError(stscExprBadExp, FErrorPos);
        GetToken;
      end;
    ssPlus, ssMinus :
      begin
        {unary sign}
        SaveSign := eToken;
        GetToken;
        GetFactor;
        if (SaveSign = ssMinus) then
          {update operand stack}
          StackPush(-PopOperand);
      end;
  else
    RaiseExprError(stscExprOpndExp, FErrorPos);
  end;
end;

procedure TStExpression.GetExpression;
var
  SaveOp : TStToken;
begin
  GetTerm;
  while (True) do begin
    case eToken of
      ssPlus, ssMinus :
        begin
          SaveOp := eToken;
          GetToken;
          GetTerm;
          rhs := PopOperand;
          lhs := PopOperand;
          try
            case SaveOp of
              ssPlus  : StackPush(lhs+rhs);
              ssMinus : StackPush(lhs-rhs);
            end;
          except
            {note operand stack overflow not possible here}
            RaiseExprError(stscExprNumeric, FErrorPos);
          end;
        end;
    else
      Break;
    end;
  end;
end;

procedure TStExpression.GetFactor;
begin
  GetBase;
  if (eToken = ssPower) then begin
    GetToken;
    GetFactor;
    rhs := PopOperand;
    lhs := PopOperand;
    try
      StackPush(Power(lhs, rhs));
    except
      {note operand stack overflow not possible here}
      RaiseExprError(stscExprNumeric, FErrorPos);
    end;
  end;
end;

procedure TStExpression.GetFunction;
var
  I          : Integer;
  P1, P2, P3 : TStFloat;
  Ident      : PStIdentRec;
  St         : AnsiString;
begin
  St := eTokenStr;
  GetToken;

  {is this a request to add a constant? (=)}
  if FAllowEqual and (eTokenStr = '=') then begin
    GetToken;
    GetExpression;
    {leave result on the stack to be returned as the expression result}
    AddConstant(St, StackPeek);
    Exit;
  end;

  I := FindIdent(St);
  if I > -1 then begin
    Ident := eIdentList[I];
    case Ident^.Kind of
      ikConstant : StackPush(Ident^.Value);
      ikVariable : StackPush(PStFloat(Ident^.VarAddr)^);
      ikFunction :
        begin
          {place parameters on stack, if any}
          GetParams(Ident^.PCount);
          try
            case Ident^.PCount of
              0 : StackPush(TStFunction0Param(Ident^.Func0Addr));
              1 : begin
                    P1 := PopOperand;
                    StackPush(TStFunction1Param(Ident^.Func1Addr)(P1));
                  end;
              2 : begin
                    P2 := PopOperand;
                    P1 := PopOperand;
                    StackPush(TStFunction2Param(Ident^.Func2Addr)(P1, P2));
                  end;
              3 : begin
                    P3 := PopOperand;
                    P2 := PopOperand;
                    P1 := PopOperand;
                    StackPush(TStFunction3Param(Ident^.Func3Addr)(P1, P2, P3));
                  end;
            else
              RaiseExprError(stscExprNumeric, FErrorPos);
            end;
          except
            {note operand stack overflow or underflow not possible here}
            {translate RTL numeric errors into STEXPR error}
            RaiseExprError(stscExprNumeric, FErrorPos);
          end;
        end;
      ikMethod   :
        begin
          {place parameters on stack, if any}
          GetParams(Ident^.PCount);
          try
            case Ident^.PCount of
              0 : StackPush(TStMethod0Param(Ident^.Meth0Addr));
              1 : begin
                    P1 := PopOperand;
                    StackPush(TStMethod1Param(Ident^.Meth1Addr)(P1));
                  end;
              2 : begin
                    P2 := PopOperand;
                    P1 := PopOperand;
                    StackPush(TStMethod2Param(Ident^.Meth2Addr)(P1, P2));
                  end;
              3 : begin
                    P3 := PopOperand;
                    P2 := PopOperand;
                    P1 := PopOperand;
                    StackPush(TStMethod3Param(Ident^.Meth3Addr)(P1, P2, P3));
                  end;
            else
              RaiseExprError(stscExprNumeric, FErrorPos);
            end;
          except
            {note operand stack overflow or underflow not possible here}
            {translate RTL numeric errors into STEXPR error}
            RaiseExprError(stscExprNumeric, FErrorPos);
          end;
        end;
    end;
  end else begin

    if Assigned(FOnGetIdentValue) then begin
      P1 := 0;
      FOnGetIdentValue(Self, St, P1);
      StackPush(P1);
    end else
      RaiseExprError(stscExprUnkFunc, FErrorPos);
  end;
end;

procedure TStExpression.GetIdentList(S : TStrings);
var
  I    : Integer;
begin
  if Assigned(S) then begin
    S.Clear;
    for I := 0 to eIdentList.Count-1 do
      S.Add(PStIdentRec(eIdentList[I])^.Name);
  end;
end;

procedure TStExpression.GetParams(N : Integer);
begin
  if (N > 0) then begin
    if (eToken <> ssLPar) then
      RaiseExprError(stscExprLParExp, FErrorPos);
    while (N > 0) do begin
      GetToken;
      {evaluate parameter value and leave on stack}
      GetExpression;
      Dec(N);
      if (N > 0) then
        if (eToken <> ssComma) then
          RaiseExprError(stscExprCommExp, FErrorPos);
    end;
    if (eToken <> ssRPar) then
      RaiseExprError(stscExprRParExp, FErrorPos);
    GetToken;
  end;
end;

procedure TStExpression.GetTerm;
var
  SaveOp : TStToken;
begin
  GetFactor;
  while (True) do begin
    case eToken of
      ssTimes, ssDiv :
        begin
          SaveOp := eToken;
          GetToken;
          GetFactor;
          rhs := PopOperand;
          lhs := PopOperand;
          try
            case SaveOp of
              ssTimes :
                StackPush(lhs*rhs);
              ssDiv :
                StackPush(lhs/rhs);
            end;
          except
            {note operand stack overflow not possible here}
            RaiseExprError(stscExprNumeric, FErrorPos);
          end;
        end;
    else
      break;
    end;
  end;
end;

procedure TStExpression.GetToken;
var
  Done : Boolean;
  TT   : TStToken;
begin
  eToken := ssStart;
  eTokenStr := '';
  Done := False;

  while (not Done) do begin
    case eToken of
      ssStart :
        begin
          {save potential error column at start of eTokenStr}
          FErrorPos := eExprPos;
          if (eCurChar = ' ') or (eCurChar = ^I) then
            {skip leading whitespace}
          else if (eCurChar = #0) then begin
            {end of string}
            eToken := ssEol;
            Done := true;
          end else if (eCurChar in Alpha) then begin
            {start of identifier}
            eTokenStr := eTokenStr + LowerCase(eCurChar);
            eToken := ssInIdent;
          end else if (eCurChar in Numeric) then begin
            {start of value}
            eTokenStr := eTokenStr + eCurChar;
            eToken := ssInNum;
          end else begin
            {presumably a single character operator}
            eTokenStr := eTokenStr + eCurChar;
            {make sure it matches a known operator}
            for TT := ssLPar to ssPower do
              if (eCurChar = StExprOperators[TT]) then begin
                Done := True;
                eToken := TT;
                Break;
              end;
            if (not Done) then begin
              {error: unknown character}
              RaiseExprError(stscExprBadChar, FErrorPos);
            end;
            {move to next character}
            Inc(eExprPos);
            if (eExprPos > Length(FExpression)) then
              eCurChar := #0
            else
              eCurChar := FExpression[eExprPos];
          end;
        end;
      ssInIdent :
        if (eCurChar in AlphaNumeric) then
          {continuing in identifier}
          eTokenStr := eTokenStr + LowerCase(eCurChar)
        else begin
          {end of identifier}
          eToken := ssIdent;
          Done := True;
        end;
      ssInNum :
        if (eCurChar in Numeric) then
          {continuing in number}
          eTokenStr := eTokenStr + eCurChar
        else if (LowerCase(eCurChar) = 'e') then begin
          {start of exponent}
          eTokenStr := eTokenStr + LowerCase(eCurChar);
          eToken := ssInSign;
        end else begin
          {end of number}
          eToken := ssNum;
          Done := True;
        end;
      ssInSign :
        if (eCurChar in ['-', '+']) or (eCurChar in Numeric) then begin
          {have exponent sign or start of number}
          eTokenStr := eTokenStr + eCurChar;
          eToken := ssInExp;
        end else begin
          {error: started exponent but didn't finish}
          RaiseExprError(stscExprBadNum, FErrorPos);
        end;
      ssInExp :
        if (eCurChar in Numeric) then
          {continuing in number}
          eTokenStr := eTokenStr + eCurChar
        else begin
          {end of number}
          eToken := ssNum;
          Done := True;
        end;
    end;

    {get next character}
    if (not Done) then begin
      Inc(eExprPos);
      if (eExprPos > Length(FExpression)) then
        eCurChar := #0
      else
        eCurChar := FExpression[eExprPos];
    end;

  end;
end;

function TStExpression.PopOperand : TStFloat;
begin
  if StackEmpty then
    RaiseExprError(stscExprBadExp, FErrorPos);
  Result := StackPop;
end;

procedure TStExpression.RaiseExprError(Code : LongInt; Column : Integer);
var
  E : EStExprError;
begin
  {clear operand stack}
  StackClear;
  FLastError := Code;
  E := EStExprError.CreateResTPCol(Code, Column, 0);
  E.ErrorCode := Code;
  raise E;
end;

procedure TStExpression.RemoveIdentifier(const Name : AnsiString);
var
  I : Integer;
  S : AnsiString;
begin
  S := LowerCase(Name);
  I := FindIdent(S);
  if I > -1 then begin
    Dispose(PStIdentRec(eIdentList[I]));
    eIdentList.Delete(I);
  end;
end;

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

function TStExpression.StackCount : Integer;
begin
  Result := eStack.Count;
end;

function TStExpression.StackEmpty : Boolean;
begin
  Result := eStack.Count = 0;
end;

function TStExpression.StackPeek : TStFloat;
begin
  Result := PStFloat(eStack[eStack.Count-1])^;
end;

function TStExpression.StackPop : TStFloat;
var
  PF : PStFloat;
begin
  PF := PStFloat(eStack[eStack.Count-1]);
  Result := PF^;
  Dispose(PF);
  eStack.Delete(eStack.Count-1);
end;

procedure TStExpression.StackPush(const Value : TStFloat);
var
  PF : PStFloat;
begin
  New(PF);
  PF^ := Value;
  try
    eStack.Add(PF);
  except
    Dispose(PF);
    raise;
  end;
end;


{*** TStExpressionEdit ***}

procedure TStExpressionEdit.CMExit(var Msg : TMessage);
begin
  inherited;

  if FAutoEval then begin
    try
      DoEvaluate;
    except
      SetFocus;
      raise;
    end;
  end;
end;

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

  FExpr := TStExpression.Create(Self);
  FAutoEval := False;
end;

destructor TStExpressionEdit.Destroy;
begin
  FExpr.Free;

  inherited Destroy;
end;

procedure TStExpressionEdit.DoEvaluate;
var
  V : TStFloat;
begin
  if Text > '' then begin
    V := Evaluate;
    if FExpr.FLastError = 0 then
      Text := FloatToStr(V)
    else
      SelStart := FExpr.FErrorPos;
  end else
    Text := '0';
end;

function TStExpressionEdit.Evaluate : TStFloat;
begin
  Result := 0;
  FExpr.Expression := Text;
  try
    Result := FExpr.AnalyzeExpression;
  except
    on E : EStExprError do begin
      SelStart := FExpr.FErrorPos;
      if Assigned(FOnError) then
        FOnError(Self, E.ErrorCode, E.Message)
      else
        raise;
    end else
      raise;
  end;
end;

function TStExpressionEdit.GetOnAddIdentifier : TNotifyEvent;
begin
  Result := FExpr.OnAddIdentifier;
end;

function TStExpressionEdit.GetOnGetIdentValue : TStGetIdentValueEvent;
begin
  Result := FExpr.OnGetIdentValue;
end;

procedure TStExpressionEdit.KeyPress(var Key : Char);
begin
  if Key = #13 then begin
    DoEvaluate;
    Key := #0;
    SelStart := Length(Text);
  end;

  inherited KeyPress(Key);
end;

procedure TStExpressionEdit.SetOnAddIdentifier(Value : TNotifyEvent);
begin
  FExpr.OnAddIdentifier := Value;
end;

procedure TStExpressionEdit.SetOnGetIdentValue(Value : TStGetIdentValueEvent);
begin
  FExpr.OngetIdentValue := Value;
end;

{$IFNDEF VERSION4}
procedure GetListSep;
var
  SepBuf : array[0..1] of AnsiChar;
begin
  if GetLocaleInfo(GetThreadLocale, LOCALE_SLIST, SepBuf, SizeOf(SepBuf)) > 0 then
    ListSeparator := SepBuf[0]
  else
    ListSeparator := ',';
end;
{$ENDIF VERSION4}

initialization
{$IFNDEF VERSION4}
  GetListSep;
{$ENDIF VERSION4}
  Numeric := ['0'..'9', {'.'}DecimalSeparator];
  StExprOperators[ssComma] := ListSeparator;
end.