dbf_prscore.pas

tDBF is new ver, this is BDS 2007 insta

            end;
          '-':
            begin
              Inc(I2);
              if (AnExpr[I2] = '-') and FWordsList.Search(PChar('--'), I) then
                Inc(I2);
            end;
          '^', '/', '\', '*', '(', ')', '%', '~', '$':
            Inc(I2);
          '0'..'9':
            ReadConstant(AnExpr, false);
        else
          begin
            Inc(I2);
          end;
        end;
    end;
  end;

begin
  I2 := 1;
  S := Trim(AnExpression);
  Len := Length(S);
  repeat
    ReadWord(S);
    W := Trim(Copy(S, I1, I2 - I1));
    if isConstant then
    begin
      if W[1] = HexChar then
      begin
        // convert hexadecimal to decimal
        W[1] := '$';
        W := IntToStr(StrToInt(W));
      end;
      if (W[1] = '''') or (W[1] = '"') then
        TempWord := TStringConstant.Create(W)
      else begin
        DecSep := Pos(FDecimalSeparator, W);
        if (DecSep > 0) then
        begin
{$IFDEF ENG_NUMBERS}
          // we'll have to convert FDecimalSeparator into DecimalSeparator
          // otherwise the OS will not understand what we mean
          W[DecSep] := DecimalSeparator;
{$ENDIF}
          TempWord := TFloatConstant.Create(W, W)
        end else begin
          TempWord := TIntegerConstant.Create(StrToInt(W));
        end;
      end;
      DestCollection.Add(TempWord);
      FConstantsList.Add(TempWord);
    end
    else if Length(W) > 0 then
      if FWordsList.Search(PChar(W), I) then
      begin
        DestCollection.Add(FWordsList.Items[I])
      end else begin
        // unknown variable -> fire event
        HandleUnknownVariable(W);
        // try to search again
        if FWordsList.Search(PChar(W), I) then
        begin
          DestCollection.Add(FWordsList.Items[I])
        end else begin
          raise EParserException.Create('Unknown variable '''+W+''' found.');
        end;
      end;
  until I2 > Len;
end;

procedure TCustomExpressionParser.Check(AnExprList: TExprCollection);
var
  I, J, K, L: Integer;
begin
  AnExprList.Check;
  with AnExprList do
  begin
    I := 0;
    while I < Count do
    begin
      {----CHECK ON DOUBLE MINUS OR DOUBLE PLUS----}
      if ((TExprWord(Items[I]).Name = '-') or
        (TExprWord(Items[I]).Name = '+'))
        and ((I = 0) or
        (TExprWord(Items[I - 1]).ResultType = etComma) or
        (TExprWord(Items[I - 1]).ResultType = etLeftBracket) or
        (TExprWord(Items[I - 1]).IsOperator and (TExprWord(Items[I - 1]).MaxFunctionArg
        = 2))) then
      begin
        {replace e.g. ----1 with +1}
        if TExprWord(Items[I]).Name = '-' then
          K := -1
        else
          K := 1;
        L := 1;
        while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-')
          or (TExprWord(Items[I + L]).Name = '+')) and ((I + L = 0) or
          (TExprWord(Items[I + L - 1]).ResultType = etComma) or
          (TExprWord(Items[I + L - 1]).ResultType = etLeftBracket) or
          (TExprWord(Items[I + L - 1]).IsOperator and (TExprWord(Items[I + L -
          1]).MaxFunctionArg = 2))) do
        begin
          if TExprWord(Items[I + L]).Name = '-' then
            K := -1 * K;
          Inc(L);
        end;
        if L > 0 then
        begin
          Dec(L);
          for J := I + 1 to Count - 1 - L do
            Items[J] := Items[J + L];
          Count := Count - L;
        end;
        if K = -1 then
        begin
          if FWordsList.Search(pchar('-@'), J) then
            Items[I] := FWordsList.Items[J];
        end
        else if FWordsList.Search(pchar('+@'), J) then
          Items[I] := FWordsList.Items[J];
      end;
      {----CHECK ON DOUBLE NOT----}
      if (TExprWord(Items[I]).Name = 'not')
        and ((I = 0) or
        (TExprWord(Items[I - 1]).ResultType = etLeftBracket) or
        TExprWord(Items[I - 1]).IsOperator) then
      begin
        {replace e.g. not not 1 with 1}
        K := -1;
        L := 1;
        while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and ((I
          + L = 0) or
          (TExprWord(Items[I + L - 1]).ResultType = etLeftBracket) or
          TExprWord(Items[I + L - 1]).IsOperator) do
        begin
          K := -K;
          Inc(L);
        end;
        if L > 0 then
        begin
          if K = 1 then
          begin //remove all
            for J := I to Count - 1 - L do
              Items[J] := Items[J + L];
            Count := Count - L;
          end
          else
          begin //keep one
            Dec(L);
            for J := I + 1 to Count - 1 - L do
              Items[J] := Items[J + L];
            Count := Count - L;
          end
        end;
      end;
      {-----MISC CHECKS-----}
      if (TExprWord(Items[I]).IsVariable) and ((I < Count - 1) and
        (TExprWord(Items[I + 1]).IsVariable)) then
        raise EParserException.Create('Missing operator between '''+TExprWord(Items[I]).Name+''' and '''+TExprWord(Items[I]).Name+'''');
      if (TExprWord(Items[I]).ResultType = etLeftBracket) and (I >= Count - 1) then
        raise EParserException.Create('Missing closing bracket');
      if (TExprWord(Items[I]).ResultType = etRightBracket) and ((I < Count - 1) and
        (TExprWord(Items[I + 1]).ResultType = etLeftBracket)) then
        raise EParserException.Create('Missing operator between )(');
      if (TExprWord(Items[I]).ResultType = etRightBracket) and ((I < Count - 1) and
        (TExprWord(Items[I + 1]).IsVariable)) then
        raise EParserException.Create('Missing operator between ) and constant/variable');
      if (TExprWord(Items[I]).ResultType = etLeftBracket) and ((I > 0) and
        (TExprWord(Items[I - 1]).IsVariable)) then
        raise EParserException.Create('Missing operator between constant/variable and (');

      {-----CHECK ON INTPOWER------}
      if (TExprWord(Items[I]).Name = '^') and ((I < Count - 1) and
          (TExprWord(Items[I + 1]).ClassType = TIntegerConstant)) then
        if FWordsList.Search(PChar('^@'), J) then
          Items[I] := FWordsList.Items[J]; //use the faster intPower if possible
      Inc(I);
    end;
  end;
end;

procedure TCustomExpressionParser.EvaluateCurrent;
var
  TempRec: PExpressionRec;
begin
  if FCurrentRec <> nil then
  begin
    // get current record
    TempRec := FCurrentRec;
    // execute list
    repeat
      with TempRec^ do
      begin
        // do we need to reset pointer?
        if ResetDest then
          Res.MemoryPos^ := Res.Memory^;

        Oper(TempRec);

        // goto next
        TempRec := Next;
      end;
    until TempRec = nil;
  end;
end;

function TCustomExpressionParser.DefineFunction(AFunctName, AShortName, ADescription, ATypeSpec: string;
  AMinFunctionArg: Integer; AResultType: TExpressionType; AFuncAddress: TExprFunc): TExprWord;
begin
  Result := TFunction.Create(AFunctName, AShortName, ATypeSpec, AMinFunctionArg, AResultType, AFuncAddress, ADescription);
  FWordsList.Add(Result);
end;

function TCustomExpressionParser.DefineIntegerVariable(AVarName: string; AValue: PInteger): TExprWord;
begin
  Result := TIntegerVariable.Create(AVarName, AValue);
  FWordsList.Add(Result);
end;

{$ifdef SUPPORT_INT64}

function TCustomExpressionParser.DefineLargeIntVariable(AVarName: string; AValue: PLargeInt): TExprWord;
begin
  Result := TLargeIntVariable.Create(AVarName, AValue);
  FWordsList.Add(Result);
end;

{$endif}

function TCustomExpressionParser.DefineDateTimeVariable(AVarName: string; AValue: PDateTimeRec): TExprWord;
begin
  Result := TDateTimeVariable.Create(AVarName, AValue);
  FWordsList.Add(Result);
end;

function TCustomExpressionParser.DefineBooleanVariable(AVarName: string; AValue: PBoolean): TExprWord;
begin
  Result := TBooleanVariable.Create(AVarName, AValue);
  FWordsList.Add(Result);
end;

function TCustomExpressionParser.DefineFloatVariable(AVarName: string; AValue: PDouble): TExprWord;
begin
  Result := TFloatVariable.Create(AVarName, AValue);
  FWordsList.Add(Result);
end;

function TCustomExpressionParser.DefineStringVariable(AVarName: string; AValue: PPChar): TExprWord;
begin
  Result := TStringVariable.Create(AVarName, AValue);
  FWordsList.Add(Result);
end;

{
procedure TCustomExpressionParser.GetGeneratedVars(AList: TList);
var
  I: Integer;
begin
  AList.Clear;
  with FWordsList do
    for I := 0 to Count - 1 do
    begin
      if TObject(Items[I]).ClassType = TGeneratedVariable then
        AList.Add(Items[I]);
    end;
end;
}

function TCustomExpressionParser.GetResultType: TExpressionType;
begin
  Result := etUnknown;
  if FCurrentRec <> nil then
  begin
    //LAST operand should be boolean -otherwise If(,,) doesn't work
    while (FLastRec^.Next <> nil) do
      FLastRec := FLastRec^.Next;
    if FLastRec^.ExprWord <> nil then
      Result := FLastRec^.ExprWord.ResultType;
  end;
end;

function TCustomExpressionParser.MakeRec: PExpressionRec;
var
  I: Integer;
begin
  New(Result);
  Result^.Oper := nil;
  Result^.AuxData := nil;
  Result^.WantsFunction := false;
  for I := 0 to MaxArg - 1 do
  begin
    Result^.Args[I] := nil;
    Result^.ArgsPos[I] := nil;
    Result^.ArgsSize[I] := 0;
    Result^.ArgsType[I] := etUnknown;
    Result^.ArgList[I] := nil;
  end;
  Result^.Res := nil;
  Result^.Next := nil;
  Result^.ExprWord := nil;
  Result^.ResetDest := false;
end;

procedure TCustomExpressionParser.Evaluate(AnExpression: string);
begin
  if Length(AnExpression) > 0 then
  begin
    AddExpression(AnExpression);
    EvaluateCurrent;
  end;
end;

function TCustomExpressionParser.AddExpression(AnExpression: string): Integer;
begin
  if Length(AnExpression) > 0 then
  begin
    Result := 0;
    CompileExpression(AnExpression);
  end else
    Result := -1;
  //CurrentIndex := Result;
end;

procedure TCustomExpressionParser.ClearExpressions;
begin
  DisposeList(FCurrentRec);
  FCurrentRec := nil;
  FLastRec := nil;
end;

function TCustomExpressionParser.GetFunctionDescription(AFunction: string):
  string;
var
  S: string;
  p, I: Integer;
begin
  S := AFunction;
  p := Pos('(', S);
  if p > 0 then
    S := Copy(S, 1, p - 1);
  if FWordsList.Search(pchar(S), I) then
    Result := TExprWord(FWordsList.Items[I]).Description
  else
    Result := EmptyStr;
end;

procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings);
var
  I, J: Integer;
  S: string;
begin
  with FWordsList do
    for I := 0 to Count - 1 do
      with TExprWord(FWordsList.Items[I]) do
        if Length(Description) > 0 then
        begin
          S := Name;
          if MaxFunctionArg > 0 then
          begin
            S := S + '(';
            for J := 0 to MaxFunctionArg - 2 do
              S := S + ArgSeparator;
            S := S + ')';
          end;
          AList.Add(S);
        end;
end;


//--Expression functions-----------------------------------------------------

procedure FuncFloatToStr(Param: PExpressionRec);
var
  width, numDigits, resWidth: Integer;
  extVal: Extended;
begin
  with Param^ do
  begin
    // get params;
    numDigits := 0;
    if Args[1] <> nil then
      width := PInteger(Args[1])^
    else
      width := 18;
    if Args[2] <> nil then
      numDigits := PInteger(Args[2])^;
    // convert to string
    Res.AssureSpace(width);
    extVal := PDouble(Args[0])^;
    resWidth := FloatToText(Res.MemoryPos^, extVal, {$ifndef FPC_VERSION}fvExtended,{$endif} ffFixed, 18, numDigits);
    // always use dot as decimal separator
    if numDigits > 0 then
      Res.MemoryPos^[resWidth-numDigits-1] := '.';
    // result width smaller than requested width? -> add space to compensate
    if (Args[1] <> nil) and (resWidth < width) then
    begin
      // move string so that it's right-aligned
      Move(Res.MemoryPos^^, (Res.MemoryPos^)[width-resWidth], resWidth);
      // fill gap with spaces
      FillChar(Res.MemoryPos^^, width-resWidth, ' ');
      // resWidth has been padded, update
      resWidth := width;
    end else if resWidth > width then begin
      // result width more than requested width, cut
      resWidth := width;
    end;
    // advance pointer
    Inc(Res.MemoryPos^, resWidth);
    // null-terminate
    Res.MemoryPos^^ := #0;
  end;
end;

procedure FuncIntToStr_Gen(Param: PExpressionRec; Val: {$ifdef SUPPORT_INT64}Int64{$else}Integer{$endif});
var
  width: Integer;
begin
  with Param^ do
  begin
    // width specified?
    if Args[1] <> nil then
    begin
      // convert to string
      width := PInteger(Args[1])^;
{$ifdef SUPPORT_INT64}
      GetStrFromInt64_Width
{$else}
      GetStrFromInt_Width
{$endif}
        (Val, width, Res.MemoryPos^, #32);
      // advance pointer
      Inc(Res.MemoryPos^, width);
      // need to add decimal?
      if Args[2] <> nil then
      begin
        // get number of digits
        width := PInteger(Args[2])^;
        // add decimal dot
        Res.MemoryPos^^ := '.';
        Inc(Res.MemoryPos^);
        // add zeroes
        FillChar(Res.MemoryPos^^, width, '0');
        // go to end