lazarus/components/codetools/expreval.pas

{
/***************************************************************************
 *                                                                         *
 *   This source is free software; you can redistribute it and/or modify   *
 *   it under the terms of the GNU General Public License as published by  *
 *   the Free Software Foundation; either version 2 of the License, or     *
 *   (at your option) any later version.                                   *
 *                                                                         *
 ***************************************************************************/

  Author: Mattias Gaertner

  Abstract:
    Defines class TExpressionEvaluator
    Used by Code Tools for compiler directives. For example $IF expression.

    This class stores variables (case sensitive) of type string.
    Boolean values are '0' for false and true else (except empty '' which is
    invalid).
    The function Eval evaluates expressions and understands the operators
      AND, OR, XOR, NOT, (, ), =, <, >, <=, >=, <>
      defined()
      not defined V or undefined V
}
unit ExprEval;

{$ifdef FPC}{$mode objfpc}{$endif}{$H+}

{$I codetools.inc}

interface

uses
  {$IFDEF MEM_CHECK}
  MemCheck,
  {$ENDIF}
  Classes, SysUtils, KeyWordFuncLists, FileProcs;

const
  ExternalMacroStart = '#';

type
  TOnValuesChanged = procedure of object;
  TOnGetSameString = procedure(var s: string) of object;
  ArrayOfAnsiString = ^AnsiString;
  

  { TExpressionEvaluator }

  TExpressionEvaluator = class
  private
    FChangeStamp: integer;
    FErrorMsg: string;
    FErrorPos: integer;
    FNames, FValues: ArrayOfAnsiString; // always sorted in FNames and FNames uppercase
    FCount: integer;
    FCapacity: integer;
    OldExpr: string;
    OldCurPos, OldMax, OldAtomStart, OldAtomEnd, OldPriorAtomStart: integer;
    FOnChange: TOnValuesChanged;
    function ReadTilEndBracket:boolean;
    function CompAtom(const UpperCaseTag:string): boolean;
    function OldReadNextAtom:boolean;
    function EvalAtPos:string;
    function CompareValues(const v1, v2: string): integer;
    function GetVariables(const Name: string): string;
    procedure SetVariables(const Name: string; const Value: string);
    function IndexOfName(const VarName: string; InsertPos: boolean): integer;
    function IndexOfIdentifier(Identifier: PChar; InsertPos: boolean): integer;
    procedure Expand;
  public
    property Variables[const Name: string]: string
       read GetVariables write SetVariables;  default;
    property Count: integer read FCount;
    procedure Undefine(const Name: string);
    function IsDefined(const Name: string): boolean;
    function IsIdentifierDefined(Identifier: PChar): boolean;
    function Equals(AnExpressionEvaluator: TExpressionEvaluator): boolean; reintroduce;
    procedure Assign(SourceExpressionEvaluator: TExpressionEvaluator);
    procedure AssignTo(SL: TStringList);
    function Eval2(const Expression: string):string;
    function EvalPChar(Expression: PChar; ExprLen: PtrInt): string;
    function Eval(const Expression: string):string;
    property ErrorPosition: integer read FErrorPos write FErrorPos;
    property ErrorMsg: string read FErrorMsg write FErrorMsg;
    property OnChange: TOnValuesChanged read FOnChange write FOnChange;
    function Items(Index: integer): string;
    function Names(Index: integer): string;
    function Values(Index: integer): string;
    procedure Append(const Variable, Value: string);
    procedure Prepend(const Variable, Value: string);
    procedure Clear;
    function AsString: string;
    constructor Create;
    destructor Destroy; override;
    procedure RemoveDoubles(OnGetSameString: TOnGetSameString);
    procedure ConsistencyCheck;
    procedure WriteDebugReport;
    function CalcMemSize(WithNamesAndValues: boolean = true; Original: TExpressionEvaluator = nil): PtrUInt;
    property ChangeStamp: integer read FChangeStamp;
    procedure IncreaseChangeStamp; inline;
  end;

  { TExpressionSolver
    Checks if expression is always true 1, always false 0, or something }

  TExpressionSolver = class
  public
    //Defines: TStringToStringTree;
    //Undefines: TStringToStringTree;
    ErrorMsg: string; // last error message
    ErrorPos: integer;// last error position
    constructor Create;
    destructor Destroy; override;
    function Solve(const Expr: string; out ExprResult: string): boolean;
    function Solve(const Src: string; StartPos, EndPos: integer;
                  out ExprResult: string): boolean;
  end;


implementation

type
  TOperator = (
    opNone,
    opNot,
    opDefined,
    opUndefined,
    opDeclared,
    opLowerThan,
    opLowerOrEqual,
    opEqual,
    opNotEqual,
    opGreaterOrEqual,
    opGreaterThan,
    opAnd,
    opOr,
    opXor,
    opShl
    );
  TOperandValue = record
    Value: PChar;
    Len: PtrInt;
    Data: array[0..3] of char;
    Free: boolean;
  end;
const
  CleanOperandValue: TOperandValue = (Value:nil; Len:0; Data:#0#0#0#0; Free:false);

var
  IsWordChar, IsIdentifierChar, IsNumberBeginChar, IsNumberChar:
    array[#0..#255] of boolean;

procedure InternalInit;
var c:char;
begin
  for c:=#0 to #255 do begin
    IsWordChar[c]:=(c in ['a'..'z','A'..'Z','_']);
    IsNumberBeginChar[c]:=(c in ['0'..'9','$','%']);
    IsNumberChar[c]:=(c in ['0'..'9','.','E','e']);
    IsIdentifierChar[c]:=(c in ['a'..'z','A'..'Z','_','0'..'9']);
  end;
end;

procedure FreeOperandValue(var V: TOperandValue);
begin
  if V.Free then begin
    FreeMem(V.Value);
    V.Value:=nil;
    V.Free:=false;
  end;
end;

procedure SetOperandValueChar(var V: TOperandValue; const c: Char);
begin
  if V.Free then FreeOperandValue(V);
  V.Data[0]:=c;
  V.Value:=@V.Data[0];
  V.Len:=1;
end;

procedure SetOperandValueConst(var V: TOperandValue; const p: PChar);
begin
  if V.Free then FreeOperandValue(V);
  V.Len:=strlen(p);
  V.Value:=p;
end;

function CompareOperand(const Operand: TOperandValue; Value: PChar): integer;
var
  p: PChar;
  l: PtrInt;
begin
  if (Operand.Value<>nil) and (Operand.Len>0) then begin
    if Value<>nil then begin
      p:=Operand.Value;
      l:=Operand.Len;
      while (p^=Value^) and (l>0) do begin
        if Value^=#0 then begin
          // 'aaa'#0'b' 'aaa'
          exit(0);
        end;
        inc(p);
        inc(Value);
        dec(l);
      end;
      if l>0 then begin
        if p^<Value^ then begin
          // 'aaa' 'aab'
          Result:=1;
        end else begin
          // 'aab' 'aaa' or 'aaa' 'aa'
          Result:=-1;
        end;
      end else begin
        if Value=#0 then begin
          // 'aaa' 'aaa'
          Result:=0;
        end else begin
          // 'aa' 'aaa'
          Result:=1;
        end;
      end;
    end else begin
      // 'aaa' nil
      Result:=-1;
    end;
  end else begin
    if Value<>nil then begin
      // nil 'aaa'
      Result:=1;
    end else begin
      // nil nil
      Result:=0;
    end;
  end;
end;

function GetIdentifierLen(Identifier: PChar): integer;
var
  p: PChar;
begin
  Result:=0;
  p:=Identifier;
  if p=nil then exit;
  if not IsIdentStartChar[p^] then exit;
  inc(p);
  while IsIdentChar[p^] do inc(p);
  Result:=p-Identifier;
end;

function CompareIdentifiers(Identifier1, Identifier2: PChar): integer;
begin
  while (UpChars[Identifier1[0]]=UpChars[Identifier2[0]]) do begin
    if (IsIdentChar[Identifier1[0]]) then begin
      inc(Identifier1);
      inc(Identifier2);
    end else begin
      Result:=0; // for example  'aaA;' 'aAa;'
      exit;
    end;
  end;
  if (IsIdentChar[Identifier1[0]]) then begin
    if (IsIdentChar[Identifier2[0]]) then begin
      if UpChars[Identifier1[0]]>UpChars[Identifier2[0]] then
        Result:=-1 // for example  'aab' 'aaa'
      else
        Result:=1; // for example  'aaa' 'aab'
    end else begin
      Result:=-1; // for example  'aaa' 'aa;'
    end;
  end else begin
    if (IsIdentChar[Identifier2[0]]) then
      Result:=1 // for example  'aa;' 'aaa'
    else
      Result:=0; // for example  'aa;' 'aa,'
  end;
end;

function CompareNames(Name1: PChar; Name1Len: PtrInt;
  Name2: PChar; Name2Len: PtrInt): integer;
begin
  while (Name1Len>0) and (Name2Len>0) do begin
    if UpChars[Name1^]=UpChars[Name2^] then begin
      inc(Name1);
      dec(Name1Len);
      inc(Name2);
      dec(Name2Len);
    end else begin
      if UpChars[Name1^]<UpChars[Name2^] then
        Result:=1
      else
        Result:=-1;
      exit;
    end;
  end;
  if Name1Len>Name2Len then
    Result:=-1
  else if Name1Len<Name2Len then
    Result:=1
  else
    Result:=0;
end;

function CompareNames(const Name1, Name2: string): integer; inline;
begin
  Result:=CompareNames(PChar(Name1),length(Name1),PChar(Name2),length(Name2));
end;


{ TBooleanVariables }

procedure TExpressionEvaluator.Clear;
var i: integer;
begin
  if FCount=0 then exit;
  for i:=0 to FCount-1 do begin
    FNames[i]:='';
    FValues[i]:='';
  end;
  FCount:=0;
  if FNames<>nil then begin
    FreeMem(FNames);
    FNames:=nil;
  end;
  if FValues<>nil then begin
    FreeMem(FValues);
    FValues:=nil;
  end;
  FCapacity:=0;
  IncreaseChangeStamp;
end;

function TExpressionEvaluator.CompareValues(const v1, v2: string): integer;
// -1 : v1<v2
//  0 : v1=v2
//  1 : v1>v2
var len1,len2,a:integer;
  c1: Char;
  c2: Char;
  ValPos1: Integer;
  ValPos2: Integer;
begin
  len1:=length(v1);
  len2:=length(v2);
  ValPos1:=1;
  ValPos2:=1;
  if (len1>1) and (v1[ValPos1]='''') then begin
    inc(ValPos1);
    dec(Len1,2);
  end;
  if (len2>1) and (v2[ValPos2]='''') then begin
    inc(ValPos2);
    dec(Len2,2);
  end;
  if len1<len2 then Result:=-1
  else if len1>len2 then Result:=1
  else begin
    for a:=1 to len1 do begin
      c1:=v1[ValPos1];
      c2:=v2[ValPos2];
      if c1<c2 then begin
        Result:=-1;  exit;
      end;
      if c1>c2 then begin
        Result:=1;  exit;
      end;
      inc(ValPos1);
      inc(ValPos2);
    end;
    Result:=0;
  end;
end;

function TExpressionEvaluator.CompAtom(
  const UpperCaseTag: string): boolean;
// compare uppercase tag with case insensitive atom
var a,len:integer;
begin
  if (OldAtomEnd>OldMax+1) then begin
    Result:=false;  exit;
  end;
  len:=OldAtomEnd-OldAtomStart;
  if length(UpperCaseTag)<>len then begin
    Result:=false;  exit;
  end;
  for a:=1 to len do begin
    if (UpChars[OldExpr[OldAtomStart+a-1]]<>UpperCaseTag[a]) then begin
      Result:=false;  exit;
    end;
  end;
  Result:=true;
end;

constructor TExpressionEvaluator.Create;
begin
  inherited Create;
  FValues:=nil;
  FNames:=nil;
  FCount:=0;
end;

destructor TExpressionEvaluator.Destroy;
begin
  Clear;
  inherited Destroy;
end;

procedure TExpressionEvaluator.RemoveDoubles(OnGetSameString: TOnGetSameString);
var
  i: Integer;
begin
  for i:=0 to FCount-1 do begin
    OnGetSameString(FNames[i]);
    OnGetSameString(FValues[i]);
  end;
end;

function TExpressionEvaluator.Eval(const Expression: string): string;
//  1 = true
//  0 = syntax error
// -1 = false
var s:string;
begin
  OldExpr:=Expression;
  OldMax:=length(OldExpr);
  OldCurPos:=1;
  OldAtomStart:=-1;  OldAtomEnd:=-1;  OldPriorAtomStart:=-1;
  FErrorPos:=-1;
  s:=EvalAtPos;
  if FErrorPos>=0 then begin
    // error
    Result:='';  exit;
  end;
  Result:=s;
end;

function TExpressionEvaluator.Items(Index: integer): string;
begin
  Result:=FNames[Index]+'='+FValues[Index];
end;

function TExpressionEvaluator.Names(Index: integer): string;
begin
  Result:=FNames[Index];
end;

function TExpressionEvaluator.Values(Index: integer): string;
begin
  Result:=FValues[Index];
end;

procedure TExpressionEvaluator.Append(const Variable, Value: string);
begin
  Variables[Variable]:=Variables[Variable]+Value;
end;

procedure TExpressionEvaluator.Prepend(const Variable, Value: string);
begin
  Variables[Variable]:=Value+Variables[Variable];
end;

function TExpressionEvaluator.EvalAtPos: string;
var r: string;   // current result
  c,o1,o2: char;
  OldPos: integer;
  AtomCount: Integer;
  HasBracket: Boolean;
begin
  Result:='';
  AtomCount:=0;
  repeat
    if (not OldReadNextAtom) then exit;
    inc(AtomCount);
    c:=OldExpr[OldAtomStart];
    if IsWordChar[c] then begin
      // identifier or keyword
      if (CompAtom('AND')) then begin
        if (Result='') then FErrorPos:=OldCurPos
        else if (Result<>'0') then begin
          // true AND ...
          Result:=EvalAtPos();
          if FErrorPos>=0 then exit;
          if (Result='') then FErrorPos:=OldCurPos;
        end;
        exit;
      end else if (CompAtom('OR')) then begin
        if (Result='0') then begin
          // false OR ...
          Result:=EvalAtPos();
          if FErrorPos>=0 then exit;
          if (Result='') then FErrorPos:=OldCurPos;
        end else if (AtomCount<=1) then FErrorPos:=OldCurPos;
        exit;
      end else if (CompAtom('XOR')) then begin
        if (Result='') then begin
          FErrorPos:=OldCurPos;  exit;
        end;
        r:=Result;
        // true/false XOR ...
        Result:=EvalAtPos();
        if FErrorPos>=0 then exit;
        if (Result='') then begin
          FErrorPos:=OldCurPos;  exit;
        end;
        if (r='0') then begin
          if (Result='0') then Result:='0' else Result:='1';
        end else begin
          if (Result='0') then Result:='1' else Result:='0';
        end;
        exit;
      end else if (CompAtom('NOT')) then begin
        Result:=EvalAtPos();
        if FErrorPos>=0 then exit;
        // Note: for Delphi compatibility: "IF not UndefinedVariable" is valid
        if (Result='0') then Result:='1'
        else Result:='0';
        exit;
      end else if (CompAtom('DEFINED')) then begin
        // read DEFINED(identifier) or defined identifier
        if (Result<>'') or (not OldReadNextAtom) then begin
          FErrorPos:=OldCurPos;
          exit;
        end;
        HasBracket:=CompAtom('(');
        if HasBracket and (not OldReadNextAtom) then begin
          FErrorPos:=OldCurPos;
          exit;
        end;
        if IsDefined(copy(OldExpr,OldAtomStart,OldAtomEnd-OldAtomStart)) then
          Result:='1'
        else
          Result:='0';
        if HasBracket then begin
          if (not OldReadNextAtom) or (not CompAtom(')')) then begin
            FErrorPos:=OldCurPos;
            exit;
          end;
        end;
      end else if (CompAtom('DECLARED')) then begin
        // read DECLARED(identifier)
        if (Result<>'') or (not OldReadNextAtom) or (CompAtom('(')=false)
        or (not OldReadNextAtom) then begin
          FErrorPos:=OldCurPos;
          exit;
        end;
        if CompAtom('UNICODESTRING') then begin
          if IsDefined('FPC_HAS_UNICODESTRING') then
            Result:='1'
          else
            Result:='0';
        end else begin
          Result:='0';// this can only be answered by a real compiler
        end;
        if (not OldReadNextAtom) or (not CompAtom(')')) then begin
          FErrorPos:=OldCurPos;
          exit;
        end;
      end else if (CompAtom('UNDEFINED')) then begin
        // read UNDEFINED(identifier) or undefined identifier
        if (Result<>'') or (not OldReadNextAtom) then begin
          FErrorPos:=OldCurPos;
          exit;
        end;
        HasBracket:=CompAtom('(');
        if HasBracket and (not OldReadNextAtom) then begin
          FErrorPos:=OldCurPos;
          exit;
        end;
        Result:=Variables[copy(OldExpr,OldAtomStart,OldAtomEnd-OldAtomStart)];
        if Result<>'' then
          Result:='0'
        else
          Result:='1';
        if HasBracket then begin
          if (not OldReadNextAtom) or (not CompAtom(')')) then begin
            FErrorPos:=OldCurPos;
            exit;
          end;
        end;
      end else begin
        // Identifier
        if (Result<>'') then begin
          FErrorPos:=OldCurPos;
          exit;
        end else
          Result:=Variables[copy(OldExpr,OldAtomStart,OldAtomEnd-OldAtomStart)];
      end;
    end else if IsNumberBeginChar[c] then begin
      // number
      if (Result<>'') then begin
        FErrorPos:=OldCurPos;  exit;
      end else Result:=copy(OldExpr,OldAtomStart,OldAtomEnd-OldAtomStart);
    end else if c='''' then begin
      Result:=copy(OldExpr,OldAtomStart+1,OldAtomEnd-OldAtomStart-2);
    end else begin
      // operator
      case c of
      ')':exit;
      '(':begin
          OldPos:=OldAtomStart;
          // eval in brackets
          Result:=EvalAtPos();
          if FErrorPos>=0 then exit;
          // go behind brackets
          OldCurPos:=OldPos;
          if (not ReadTilEndBracket) then exit;
          inc(OldCurPos);
        end;
      '=','>','<':begin
          o1:=c;
          if OldAtomEnd=OldAtomStart+1 then begin
            r:=EvalAtPos();
            if FErrorPos>=0 then exit;
            case o1 of
            '=':if CompareValues(Result,r)=0 then Result:='1' else Result:='0';
            '>':if CompareValues(Result,r)=1 then Result:='1' else Result:='0';
            '<':if CompareValues(Result,r)=-1 then Result:='1' else Result:='0';
            end;
          end else begin
            o2:=OldExpr[OldAtomStart+1];
            r:=EvalAtPos();
            if FErrorPos>=0 then exit;
            if o1='<' then begin
              if o2='>' then begin
                if CompareValues(Result,r)<>0 then Result:='1' else Result:='0';
              end else if o2='=' then begin
                if CompareValues(Result,r)<=0 then Result:='1' else Result:='0';
              end else FErrorPos:=OldAtomStart;
            end else if o1='>' then begin
              if o2='=' then begin
                if CompareValues(Result,r)>=0 then Result:='1' else Result:='0';
              end else FErrorPos:=OldAtomStart;
            end else FErrorPos:=OldAtomStart;
          end;
          exit;
        end;
      '!':
        begin
          Result:=EvalAtPos();
          if FErrorPos>=0 then exit;
          if (Result='0') then Result:='1'
          else if (Result='') then FErrorPos:=OldCurPos
          else Result:='0';
          exit;
        end;
      else
        begin
          FErrorPos:=OldCurPos;
        end;
      end;
    end;
  until (FErrorPos>=0);
end;

procedure TExpressionEvaluator.Expand;
var
  NewSize: integer;
begin
  FCapacity:=(FCapacity shl 1)+10;
  NewSize:=SizeOf(AnsiString)*FCapacity;
  ReAllocMem(FValues,NewSize);
  ReAllocMem(FNames,NewSize);
end;

function TExpressionEvaluator.IndexOfName(
  const VarName: string; InsertPos: boolean): integer;
var l,r,m, cmp: integer;
begin
  if FCount=0 then begin
    if InsertPos then
      Result:=0
    else
      Result:=-1;
    exit;
  end;
  l:=0;
  r:=FCount-1;
  m:=0;
  cmp:=0;
  while l<=r do begin
    m:=(l+r) shr 1;
    cmp:=CompareNames(VarName,FNames[m]);
    if cmp>0 then
      l:=m+1
    else if cmp<0 then
      r:=m-1
    else begin
      Result:=m;
      exit;
    end;
  end;
  if InsertPos then begin
    if cmp>0 then inc(m);
    Result:=m;
  end else begin
    Result:=-1;
  end;
end;

function TExpressionEvaluator.IndexOfIdentifier(Identifier: PChar;
  InsertPos: boolean): integer;
var l,r,m, cmp: integer;
  IdentLen: Integer;
  CurName: String;
begin
  if FCount=0 then begin
    if InsertPos then
      Result:=0
    else
      Result:=-1;
    exit;
  end;
  l:=0;
  r:=FCount-1;
  m:=0;
  cmp:=0;
  IdentLen:=GetIdentifierLen(Identifier);
  while l<=r do begin
    m:=(l+r) shr 1;
    CurName:=FNames[m];
    cmp:=CompareNames(Identifier,IdentLen,PChar(CurName),length(CurName));
    if cmp>0 then
      l:=m+1
    else if cmp<0 then
      r:=m-1
    else begin
      Result:=m;
      exit;
    end;
  end;
  if InsertPos then begin
    if cmp>0 then inc(m);
    Result:=m;
  end else begin
    Result:=-1;
  end;
end;

function TExpressionEvaluator.GetVariables(const Name: string): string;
var i: integer;
begin
  i:=IndexOfName(Name,false);
  if (i>=0) then
    Result:=FValues[i]
  else 
    Result:='';
end;

function TExpressionEvaluator.IsDefined(const Name: string): boolean;
begin
  Result:=IndexOfName(Name,false)>=0;
end;

function TExpressionEvaluator.IsIdentifierDefined(Identifier: PChar): boolean;
begin
  Result:=IndexOfIdentifier(Identifier,false)>=0;
end;

function TExpressionEvaluator.OldReadNextAtom: boolean;
var c,o1,o2:char;
begin
  OldPriorAtomStart:=OldAtomStart;
  while (OldCurPos<=OldMax) do begin
    c:=OldExpr[OldCurPos];
    if (c<=' ') then inc(OldCurPos)
    else if IsWordChar[c] then begin
      // Identifier
      OldAtomStart:=OldCurPos;
      repeat
        inc(OldCurPos);
      until (OldCurPos>OldMax) or (not IsIdentifierChar[OldExpr[OldCurPos]]);
      OldAtomEnd:=OldCurPos;
      Result:=true;
      exit;
    end else if IsNumberBeginChar[c] then begin
      // Number
      OldAtomStart:=OldCurPos;
      repeat
        inc(OldCurPos);
      until (OldCurPos>OldMax) or (IsNumberChar[OldExpr[OldCurPos]]=false);
      OldAtomEnd:=OldCurPos;
      Result:=true;
      exit;
    end else if c='''' then begin
      // string
      OldAtomStart:=OldCurPos;
      repeat
        inc(OldCurPos);
        if OldExpr[OldCurPos]='''' then begin
          inc(OldCurPos);
          OldAtomEnd:=OldCurPos;
          Result:=true;
          exit;
        end;
        if OldCurPos>OldMax then begin
          OldAtomEnd:=OldCurPos;
          Result:=false;
          exit;
        end;
      until (OldCurPos>OldMax);
    end else begin
      // Symbol
      OldAtomStart:=OldCurPos;
      inc(OldCurPos);
      if (OldCurPos<=OldMax) then begin
        o1:=c;
        o2:=OldExpr[OldCurPos];
        if ((o2='=') and ((o1='<') or (o1='>')))
        or ((o1='<') and (o2='>'))
        then inc(OldCurPos);
      end;
      OldAtomEnd:=OldCurPos;
      Result:=true;
      exit;
    end;
  end;
  Result:=false;
end;

function TExpressionEvaluator.ReadTilEndBracket: boolean;
// true = end bracket found
// false = not found
var lvl:integer;
begin
  lvl:=0;
  while (OldCurPos<=OldMax) do begin
    if (OldExpr[OldCurPos]='(') then
      inc(lvl)
    else if (OldExpr[OldCurPos]=')') then begin
      dec(lvl);
      if (lvl=0) then begin
        Result:=true;  exit;
      end else if (lvl<0) then begin
        FErrorPos:=OldCurPos;
        Result:=true;  exit;
      end;
    end;
    inc(OldCurPos);
  end;
  Result:=false;
end;

procedure TExpressionEvaluator.Assign(
  SourceExpressionEvaluator: TExpressionEvaluator);
var i, Size: integer;
begin
  Clear;
  if SourceExpressionEvaluator<>nil then begin
    FCount:=SourceExpressionEvaluator.Count;
    Size:=SizeOf(AnsiString) * FCount;
    if Size>0 then begin
      GetMem(FNames,Size);
      FillByte(Pointer(FNames)^,Size,0);
      GetMem(FValues,Size);
      FillByte(Pointer(FValues)^,Size,0);
      FCapacity:=FCount;
      for i:=0 to FCount-1 do begin
        FNames[i]:=SourceExpressionEvaluator.FNames[i];
        FValues[i]:=SourceExpressionEvaluator.FValues[i];
      end;
    end;
    IncreaseChangeStamp;
  end;
  if Assigned(FOnChange) then FOnChange;
end;

procedure TExpressionEvaluator.SetVariables(const Name: string;
  const Value: string);
var i: integer;
  Size: Integer;
begin
  i:=IndexOfName(Name,true);
  if (i>=0) and (i<FCount) and (CompareNames(FNames[i],Name)=0) then begin
    // variable already exists -> replace value
    if FValues[i]<>Value then begin
      FValues[i]:=Value;
      IncreaseChangeStamp;
    end;
  end else begin
    // new variable
    if FCount=FCapacity then Expand;
    if i<0 then i:=0;
    if i<FCount then begin
      Size:=SizeOf(AnsiString)*(FCount-i);
      System.Move(PPointer(FNames)[i],PPointer(FNames)[i+1],Size);
      System.Move(PPointer(FValues)[i],PPointer(FValues)[i+1],Size);
    end;
    PPointer(FNames)[i]:=nil;
    PPointer(FValues)[i]:=nil;
    FNames[i]:=UpperCaseStr(Name);
    FValues[i]:=Value;
    inc(FCount);
    IncreaseChangeStamp;
  end;
end;

procedure TExpressionEvaluator.Undefine(const Name: string);
var i: integer;
  Size: Integer;
begin
  i:=IndexOfName(Name,false);
  if (i>=0) then begin
    FNames[i]:='';
    FValues[i]:='';
    dec(FCount);
    if FCount>i then begin
      Size:=SizeOf(AnsiString)*(FCount-i);
      System.Move(PPointer(FNames)[i+1],PPointer(FNames)[i],Size);
      System.Move(PPointer(FValues)[i+1],PPointer(FValues)[i],Size);
    end;
  end;
end;

function TExpressionEvaluator.Equals(
  AnExpressionEvaluator: TExpressionEvaluator): boolean;
var i: integer;
begin
  if (AnExpressionEvaluator=nil) or (AnExpressionEvaluator.Count<>FCount) then
  begin
    Result:=false;
    exit;
  end;
  for i:=0 to FCount-1 do begin
    if (FNames[i]<>AnExpressionEvaluator.FNames[i])
    or (FValues[i]<>AnExpressionEvaluator.FValues[i]) then begin
      Result:=false;
      exit;
    end;
  end;
  Result:=true;
end;

procedure TExpressionEvaluator.AssignTo(SL: TStringList);
var i: integer;
begin
  if SL=nil then exit;
  SL.Clear;
  for i:=0 to FCount-1 do
    SL.Add(FNames[i]+'='+FValues[i]);
end;

function TExpressionEvaluator.Eval2(const Expression: string): string;
begin
  if Expression='' then exit('0');
  Result:=EvalPChar(PChar(Expression),length(Expression));
end;

function TExpressionEvaluator.EvalPChar(Expression: PChar; ExprLen: PtrInt
  ): string;
{  1 = true
   0 = syntax error
  -1 = false

  brackets ()
  unary operators: not, defined, undefined
  binary operators: + - * / < <= = <> => > div mod and or xor shl shr
  functions: defined(), undefined(), declared()
}
type
  TOperandAndOperator = record
    Operand: TOperandValue;
    theOperator: PChar;
    OperatorLvl: integer;
  end;
  TExprStack = array[0..3] of TOperandAndOperator;

var
  Operand: TOperandValue;
  ExprStack: TExprStack;
  StackPtr: integer; // -1 = empty
  ExprEnd: Pointer;
  p, AtomStart: PChar;

  procedure FreeStack;
  begin
    while StackPtr>=0 do begin
      FreeOperandValue(ExprStack[StackPtr].Operand);
      dec(StackPtr);
    end;
  end;

  function GetAtom: string;
  begin
    Setlength(Result,p-AtomStart);
    if Result<>'' then
      System.Move(AtomStart^,Result[1],length(Result));
  end;

  procedure ReadNextAtom;
  begin
    // skip space
    while p^ in [' ',#9,#10,#13] do inc(p);
    if p>=ExprEnd then begin
      p:=ExprEnd;
      AtomStart:=p;
      exit;
    end;
    AtomStart:=p;
    case UpChars[p^] of
    'A'..'Z','_':
      begin
        while IsIdentChar[p^] do inc(p);
        if p>ExprEnd then p:=ExprEnd;
      end;
    '>':
      begin
        inc(p);
        case p^ of
        '=': inc(p); // >=
        end;
      end;
    '<':
      begin
        inc(p);
        case p^ of
        '>','=': inc(p); // <> <=
        end;
      end;
    else
      inc(p);
    end;
    DebugLn(['ReadNextAtom ',GetAtom]);
  end;

  procedure Error(NewErrorPos: PChar; const NewErrorMsg: string);
  begin
    if NewErrorPos<>nil then
      FErrorPos:=NewErrorPos-Expression
    else
      FErrorPos:=0;
    ErrorMsg:=NewErrorMsg;
    DebugLn(['Error ',ErrorMsg,' at ',ErrorPosition]);
  end;

  procedure ExpressionMissing(NewErrorPos: PChar);
  begin
    Error(NewErrorPos,'expression missing');
  end;

  procedure IdentifierMissing(NewErrorPos: PChar);
  begin
    Error(NewErrorPos,'identifier missing');
  end;

  procedure OperatorMissing(NewErrorPos: PChar);
  begin
    Error(NewErrorPos,'operator missing');
  end;

  procedure CharMissing(NewErrorPos: PChar; c: char);
  begin
    Error(NewErrorPos,c+' missing');
  end;

  procedure StrExpectedAtPos(NewErrorPos, ExpectedStr: PChar);
  var
    s: string;
    f: string;
  begin
    s:=ExpectedStr;
    f:=NewErrorPos^;
    Error(NewErrorPos,'expected '+s+', but found '+f);
  end;

  function ParseDefinedParams(out Operand: TOperandValue): boolean;
  // p is behind defined or undefined keyword
  // Operand: '1' or '-1'
  var
    NeedBracketClose: Boolean;
  begin
    Result:=false;
    DebugLn(['ParseDefinedParams AAA1 ',GetAtom]);
    ReadNextAtom;
    if AtomStart>=ExprEnd then begin
      IdentifierMissing(AtomStart);
      exit;
    end;
    NeedBracketClose:=false;
    DebugLn(['ParseDefinedParams AAA2 ',GetAtom]);
    if AtomStart^='(' then begin
      // defined(
      NeedBracketClose:=true;
      ReadNextAtom;
      DebugLn(['ParseDefinedParams AAA3 ',GetAtom]);
      // skip space
      if AtomStart>=ExprEnd then begin
        IdentifierMissing(AtomStart);
        exit;
      end;
    end;
    if not IsIdentifierChar[AtomStart^] then begin
      StrExpectedAtPos(AtomStart,'macro name');
      exit;
    end;
    if IsIdentifierDefined(AtomStart) then begin
      SetOperandValueChar(Operand,'1');
    end else begin
      SetOperandValueConst(Operand,'-1');
    end;
    if NeedBracketClose then begin
      // read bracket close
      ReadNextAtom;
      if AtomStart>=ExprEnd then begin
        CharMissing(ExprEnd,')');
        exit;
      end;
      if AtomStart^<>')' then begin
        StrExpectedAtPos(AtomStart,')');
        exit;
      end;
    end;
    Result:=true;
  end;

  function ReadOperand: boolean;
  { Examples:
     Variable
     not Variable
     not not undefined Variable
     defined(Variable)
  }
  var
    i: LongInt;
  begin
    Result:=false;
    if AtomStart>=ExprEnd then exit;
    DebugLn(['ReadOperand ',GetAtom]);
    case UpChars[AtomStart^] of
    'N':
      if CompareIdentifiers(AtomStart,'NOT')=0 then begin
        // not
        if not ReadOperand then exit;
        if (Operand.Len=1) and (Operand.Value^='1') then begin
          SetOperandValueConst(Operand,'-1');
        end else begin
          SetOperandValueChar(Operand,'1');
        end;
        exit(true);
      end;
    'D':
      if CompareIdentifiers(AtomStart,'DEFINED')=0 then begin
        // "defined V" or "defined(V)"
        if not ParseDefinedParams(Operand) then exit;
        exit(true);
      end;
    'U':
      if CompareIdentifiers(AtomStart,'UNDEFINED')=0 then begin
        // "undefined V" or "undefined(V)"
        if not ParseDefinedParams(Operand) then exit;
        if (Operand.Len=1) and (Operand.Value^='1') then begin
          SetOperandValueConst(Operand,'-1');
        end else begin
          SetOperandValueChar(Operand,'1');
        end;
        exit(true);
      end;
    end;
    if IsIdentStartChar[AtomStart^] then begin
      // identifier => return current value
      i:=IndexOfIdentifier(AtomStart,false);
      if i>=0 then begin
        if Operand.Free then FreeOperandValue(Operand);
        Operand.Value:=PChar(FValues[i]);
        Operand.Len:=length(FValues[i]);
      end;
      exit(true);
    end;
    // invalid operand
    IdentifierMissing(AtomStart);
  end;

  function ExecuteStack(LowerOrEqualOperatorLvl: integer): boolean;
  var
    Op: PChar;
  begin
    Result:=false;
    while (StackPtr>=0)
    and (ExprStack[StackPtr].OperatorLvl<=LowerOrEqualOperatorLvl) do begin
      // compute stack item
      Op:=ExprStack[StackPtr].theOperator;
      case UpChars[Op^] of
      '*':
        begin

        end;
      '/':
        begin

        end;
      '+':
        begin

        end;
      '-':
        begin

        end;
      '=':
        begin

        end;
      '<':
        case Op[1] of
        '>':
          begin
            // <>
          end;
        '=':
          begin
            //<=
          end;
        else
          // <
        end;
      '>':
        if Op[1]='=' then begin
          // >=
        end else begin
          // >
        end;
      'A': // AND
        begin

        end;
      'D': // DIV
        begin

        end;
      'M': // MOD
        begin

        end;
      'S':
        case UpChars[Op[1]] of
        'H': // SH
          case UpChars[Op[2]] of
          'L': // SHL
            begin

            end;
          'R': // SHR
            begin

            end;
          end;
        end;
      'O': // OR
        begin

        end;
      'X': // XOR
        begin

        end;
      end;
      dec(StackPtr);
    end;
    Result:=true;
  end;

var
  OperatorLvl: Integer;
begin
  p:=Expression;
  Result:='0';
  if p=nil then begin
    ExpressionMissing(p);
    exit;
  end;
  ExprEnd:=p+ExprLen;
  // skip space
  ReadNextAtom;
  if AtomStart>=ExprEnd then begin
    ExpressionMissing(AtomStart);
    exit;
  end;
  StackPtr:=-1;
  Operand:=CleanOperandValue;
  FErrorPos:=-1;
  fErrorMsg:='';
  while AtomStart<ExprEnd do begin
    // read operand
    if not ReadOperand then
      break;
    // read operator
    ReadNextAtom;
    if AtomStart>=ExprEnd then break;
    // level 0: NOT () DEFINED UNDEFINED DECLARED: handled by ReadOperand
    // level 1: * / DIV MOD AND SHL SHR
    // level 2: + - OR XOR
    // level 3: = < > <> >= <=
    OperatorLvl:=0;
    case UpChars[AtomStart^] of
    '*','/': if AtomStart-p=1 then OperatorLvl:=1;
    '+','-': if AtomStart-p=1 then OperatorLvl:=2;
    '=': if AtomStart-p=1 then OperatorLvl:=3;
    '<': if (AtomStart-p=1)
         or (AtomStart[2] in ['=','>']) then OperatorLvl:=3;
    '>': if (AtomStart-p=1)
         or (AtomStart[2]='=') then OperatorLvl:=3;
    'A': if CompareIdentifiers(AtomStart,'AND')=0 then OperatorLvl:=1;
    'D': if CompareIdentifiers(AtomStart,'DIV')=0 then OperatorLvl:=1;
    'M': if CompareIdentifiers(AtomStart,'MOD')=0 then OperatorLvl:=1;
    'S':
      case UpChars[AtomStart[1]] of
      'H': // SH
        case UpChars[AtomStart[2]] of
        'L': if p-AtomStart=3 then OperatorLvl:=1; // SHL
        'R': if p-AtomStart=3 then OperatorLvl:=1; // SHR
        end;
      end;
    'O':
      case UpChars[AtomStart[1]] of
      'R': if p-AtomStart=2 then OperatorLvl:=2;
      end;
    'X': if CompareIdentifiers(AtomStart,'XOR')=0 then OperatorLvl:=2;
    end;
    if OperatorLvl=0 then begin
      OperatorMissing(AtomStart);
      break;
    end;
    if not ExecuteStack(OperatorLvl) then break;
    // push onto stack
    inc(StackPtr);
    ExprStack[StackPtr].Operand:=Operand;
    ExprStack[StackPtr].OperatorLvl:=OperatorLvl;
    ExprStack[StackPtr].theOperator:=AtomStart;
    Operand:=CleanOperandValue;
    ReadNextAtom;
  end;
  if FErrorPos<0 then begin
    if ExecuteStack(4) then begin
      // set result
      SetLength(Result,Operand.Len);
      if Result<>'' then
        System.Move(Operand.Value^,Result[1],length(Result));
    end;
  end;
  // clean up
  FreeStack;
  FreeOperandValue(Operand);
end;

function TExpressionEvaluator.AsString: string;
var TxtLen, i, p: integer;
begin
  TxtLen:=FCount*3;
  for i:=0 to FCount-1 do
    inc(TxtLen,length(FNames[i])+length(FValues[i]));
  Setlength(Result,TxtLen);
  p:=1;
  for i:=0 to FCount-1 do begin
    Move(FNames[i][1],Result[p],length(FNames[i]));
    inc(p,length(FNames[i]));
    Result[p]:=' ';
    inc(p);
    if length(FValues[i])>0 then begin
      Move(FValues[i][1],Result[p],length(FValues[i]));
      inc(p,length(FValues[i]));
    end;
    Result[p]:=#13;
    inc(p);
    Result[p]:=#10;
    inc(p);
  end;
end;

procedure TExpressionEvaluator.ConsistencyCheck;
// 0 = ok
var i: integer;
begin
  if FCapacity<0 then
    RaiseCatchableException('');
  if FCapacity<FCount then
    RaiseCatchableException('');
  if FCount<0 then
    RaiseCatchableException('');
  if (FCapacity=0) and (FNames<>nil) then
    RaiseCatchableException('');
  if (FNames=nil) xor (FValues=nil) then
    RaiseCatchableException('');
  for i:=0 to FCount-1 do begin
    if not IsUpperCaseStr(FNames[i]) then
      RaiseCatchableException('');
    if (i>0) and (FNames[i-1]=FNames[i]) then
      RaiseCatchableException('');
    if (i>0) and (CompareNames(FNames[i-1],FNames[i])>0) then
      RaiseCatchableException('');
  end;
end;

procedure TExpressionEvaluator.WriteDebugReport;
begin
  DebugLn('[TExpressionEvaluator.WriteDebugReport] ');
  ConsistencyCheck;
end;

function TExpressionEvaluator.CalcMemSize(WithNamesAndValues: boolean;
  Original: TExpressionEvaluator): PtrUInt;
var
  i: Integer;
  j: LongInt;
begin
  Result:=PtrUInt(InstanceSize)
    +MemSizeString(OldExpr)
    +SizeOf(Pointer)*PtrUInt(FCount)*2;
  if WithNamesAndValues then begin
    for i:=0 to FCount-1 do begin
      if Original<>nil then begin
        j:=Original.IndexOfName(FNames[i],false);
        if j>=0 then begin
          if Pointer(FNames[i])=Pointer(Original.FNames[j]) then continue;
        end;
      end;
      inc(Result,MemSizeString(FNames[i]));
      inc(Result,MemSizeString(FValues[i]));
    end;
  end;
end;

procedure TExpressionEvaluator.IncreaseChangeStamp;
begin
  if FChangeStamp<High(Integer) then
    inc(FChangeStamp)
  else
    FChangeStamp:=Low(Integer);
end;


{ TExpressionSolver }

constructor TExpressionSolver.Create;
begin

end;

destructor TExpressionSolver.Destroy;
begin
  inherited Destroy;
end;

function TExpressionSolver.Solve(const Expr: string; out
  ExprResult: string): boolean;
begin
  Result:=Solve(Expr,1,length(Expr),ExprResult);
end;

function TExpressionSolver.Solve(const Src: string;
  StartPos, EndPos: integer; out ExprResult: string): boolean;
{ '' -> ''
  true = nonzero, false = zero
  defined(name)
  sizeof(type)
  unary operators: not, !
  binary operators: = <> >= <= > < and or xor shl shr
  round brackets ()
}
var
  AtomStart: LongInt;
  SrcPos: LongInt;

  function AtomIs(const s: shortstring): boolean;
  var
    len: Integer;
    i: Integer;
  begin
    len:=length(s);
    if (len<>SrcPos-AtomStart) then exit(false);
    if SrcPos>EndPos then exit(false);
    for i:=1 to len do
      if Src[AtomStart+i-1]<>s[i] then exit(false);
    Result:=true;
  end;

begin
  if StartPos>=EndPos then begin
    ExprResult:='';
    exit(true);
  end;
  SrcPos:=StartPos;
  AtomStart:=SrcPos;
  //ReadNextCAtom(Source,SrcPos,AtomStart);
  if AtomIs('!') then begin

  end;
end;

initialization
  InternalInit;

end.