1 {
2 /***************************************************************************
3  *                                                                         *
4  *   This source is free software; you can redistribute it and/or modify   *
5  *   it under the terms of the GNU General Public License as published by  *
6  *   the Free Software Foundation; either version 2 of the License, or     *
7  *   (at your option) any later version.                                   *
8  *                                                                         *
9  ***************************************************************************/
10 
11   Author: Mattias Gaertner
12 
13   Abstract:
14     Defines class TExpressionEvaluator
15     Used by Code Tools for compiler directives. For example $IF expression.
16 
17     This class stores variables (case sensitive) of type string.
18     Boolean values are '0' for false and true else (except empty '' which is
19     invalid).
20     The function Eval evaluates expressions and understands the operators
21       AND, OR, XOR, NOT, (, ), =, <, >, <=, >=, <>
22       defined()
23       not defined V or undefined V
24 }
25 unit ExprEval;
26 
27 {$ifdef FPC}{$mode objfpc}{$endif}{$H+}
28 
29 {$I codetools.inc}
30 
31 { $DEFINE VerboseExprEval}
32 
33 interface
34 
35 uses
36   {$IFDEF MEM_CHECK}
37   MemCheck,
38   {$ENDIF}
39   Classes, SysUtils, KeyWordFuncLists, FileProcs, LazDbgLog;
40 
41 const
42   ExternalMacroStart = '#';
43 
44 //----------------------------------------------------------------------------
45 // compiler switches
46 const
47   CompilerSwitchesNames: array['A'..'Z'] of shortstring=(
48          'ALIGN'          // A
49         ,'BOOLEVAL'       // B
50         ,'ASSERTIONS'     // C
51         ,'DEBUGINFO'      // D
52         ,'EXTENSION'      // E
53         ,''               // F
54         ,'IMPORTEDDATA'   // G
55         ,'LONGSTRINGS'    // H
56         ,'IOCHECKS'       // I
57         ,'WRITEABLECONST' // J
58         ,''               // K
59         ,'LOCALSYMBOLS'   // L
60         ,'TYPEINFO'       // M
61         ,''               // N
62         ,'OPTIMIZATION'   // O
63         ,'OPENSTRINGS'    // P
64         ,'OVERFLOWCHECKS' // Q
65         ,'RANGECHECKS'    // R
66         ,''               // S
67         ,'TYPEADDRESS'    // T
68         ,'SAFEDIVIDE'     // U
69         ,'VARSTRINGCHECKS'// V
70         ,'STACKFRAMES'    // W
71         ,'EXTENDEDSYNTAX' // X
72         ,'REFERENCEINFO'  // Y
73         ,''               // Z
74      );
75 
76 type
77   TOnValuesChanged = procedure of object;
78   TOnGetSameString = procedure(var s: string) of object;
79   ArrayOfAnsiString = ^AnsiString;
80 
81   TEvalOperand = record
82     Value: PChar;
83     Len: PtrInt;
84     Data: array[0..3] of char;
85     Free: boolean;
86   end;
87   PEvalOperand = ^TEvalOperand;
88 
89   { TExpressionEvaluator }
90 
91   TExpressionEvaluator = class
92   private
93     FChangeStamp: integer;
94     FErrorMsg: string;
95     FErrorPos: integer;
96     FNames, FValues: ArrayOfAnsiString; // always sorted in FNames and FNames uppercase
97     FCount: integer;
98     FCapacity: integer;
99     OldExpr: string;
100     OldCurPos, OldMax, OldAtomStart, OldAtomEnd, OldPriorAtomStart: integer;
101     FOnChange: TOnValuesChanged;
OldReadTilEndBracketnull102     function OldReadTilEndBracket:boolean;
CompAtomnull103     function CompAtom(const UpperCaseTag:string): boolean;
OldReadNextAtomnull104     function OldReadNextAtom:boolean;
EvalAtPosnull105     function EvalAtPos:string;
CompareValuesnull106     function CompareValues(const v1, v2: string): integer;
GetVariablesnull107     function GetVariables(const Name: string): string;
108     procedure SetVariables(const Name: string; const Value: string);
IndexOfNamenull109     function IndexOfName(VarName: PChar; VarLen: integer; InsertPos: boolean): integer;
IndexOfIdentifiernull110     function IndexOfIdentifier(Identifier: PChar; InsertPos: boolean): integer;
111     procedure Expand;
112   public
113     property Variables[const Name: string]: string
114        read GetVariables write SetVariables;  default;
115     property Count: integer read FCount;
116     procedure Undefine(const Name: string);
IsDefinednull117     function IsDefined(const Name: string): boolean; inline;
IsIdentifierDefinednull118     function IsIdentifierDefined(Identifier: PChar): boolean; inline;
Equalsnull119     function Equals(AnExpressionEvaluator: TExpressionEvaluator): boolean; reintroduce;
120     procedure Assign(SourceExpressionEvaluator: TExpressionEvaluator);
121     procedure AssignTo(SL: TStringList);
Evalnull122     function Eval(const Expression: string; AllowExternalMacro: boolean = false):string;
EvalPCharnull123     function EvalPChar(Expression: PChar; ExprLen: PtrInt;
124                        out Operand: TEvalOperand; AllowExternalMacro: boolean = false): boolean;// true if expression valid
EvalBooleannull125     function EvalBoolean(Expression: PChar; ExprLen: PtrInt; AllowExternalMacro: boolean = false): boolean;
EvalOldnull126     function EvalOld(const Expression: string):string;
127     property ErrorPosition: integer read FErrorPos write FErrorPos;
128     property ErrorMsg: string read FErrorMsg write FErrorMsg;
129     property OnChange: TOnValuesChanged read FOnChange write FOnChange;
Itemsnull130     function Items(Index: integer): string;
Namesnull131     function Names(Index: integer): string;
Valuesnull132     function Values(Index: integer): string;
133     procedure Append(const Variable, Value: string);
134     procedure Prepend(const Variable, Value: string);
135     procedure Clear;
AsStringnull136     function AsString: string;
137     constructor Create;
138     destructor Destroy; override;
139     procedure RemoveDoubles(OnGetSameString: TOnGetSameString);
140     procedure ConsistencyCheck;
141     procedure WriteDebugReport;
CalcMemSizenull142     function CalcMemSize(WithNamesAndValues: boolean = true; Original: TExpressionEvaluator = nil): PtrUInt;
143     property ChangeStamp: integer read FChangeStamp;
144     procedure IncreaseChangeStamp; inline;
145   end;
146 
147 procedure FreeEvalOperand(var V: TEvalOperand);
148 procedure ClearEvalOperand(out V: TEvalOperand); inline;
EvalOperandIsTruenull149 function EvalOperandIsTrue(const V: TEvalOperand): boolean; inline;
EvalOperandToInt64null150 function EvalOperandToInt64(const V: TEvalOperand): int64;
CompareEvalOperandnull151 function CompareEvalOperand(const Operand: TEvalOperand; Value: PChar): integer;
CompareNamesnull152 function CompareNames(Name1: PChar; Name1Len: PtrInt;
153                       Name2: PChar; Name2Len: PtrInt): integer;
CompareNamesnull154 function CompareNames(const Name1, Name2: string): integer; inline;
155 
156 implementation
157 
158 var
159   IsWordChar, IsIdentifierChar, IsNumberBeginChar, IsNumberChar:
160     array[#0..#255] of boolean;
161 
162 procedure InternalInit;
163 var c:char;
164 begin
165   for c:=#0 to #255 do begin
166     IsWordChar[c]:=(c in ['a'..'z','A'..'Z','_']);
167     IsNumberBeginChar[c]:=(c in ['0'..'9','$','%']);
168     IsNumberChar[c]:=(c in ['0'..'9','.','E','e']);
169     IsIdentifierChar[c]:=(c in ['a'..'z','A'..'Z','_','0'..'9']);
170   end;
171 end;
172 
173 procedure FreeEvalOperand(var V: TEvalOperand);
174 begin
175   if V.Free then begin
176     FreeMem(V.Value);
177     V.Free:=false;
178     V.Value:=nil;
179     V.Len:=0;
180   end;
181 end;
182 
183 procedure ClearEvalOperand(out V: TEvalOperand); inline;
184 begin
185   V.Free:=false;
186   V.Value:=nil;
187   V.Len:=0;
188 end;
189 
EvalOperandIsTruenull190 function EvalOperandIsTrue(const V: TEvalOperand): boolean; inline;
191 begin
192   Result:=not ((V.Len=1) and (V.Value^='0'));
193 end;
194 
EvalOperandToInt64null195 function EvalOperandToInt64(const V: TEvalOperand): int64;
196 var
197   p: PChar;
198   l: PtrInt;
199   Negated: Boolean;
200   c: Char;
201 begin
202   Result:=0;
203   p:=V.Value;
204   l:=V.Len;
205   if l=0 then exit;
206   if p^='-' then begin
207     Negated:=true;
208     inc(p);
209     dec(l);
210   end else
211     Negated:=false;
212   if p^='$' then begin
213     // hex number
214     if l<15 then begin
215       while l>0 do begin
216         c:=p^;
217         case c of
218         '0'..'9': Result:=Result*16+ord(p^)-ord('0');
219         'a'..'f': Result:=Result*16+ord(p^)-ord('a')+10;
220         'A'..'Z': Result:=Result*16+ord(p^)-ord('A')+10;
221         else
222           break;
223         end;
224         inc(p);
225         dec(l);
226       end;
227     end else begin
228       try
229         while l>0 do begin
230           c:=p^;
231           case c of
232           '0'..'9': Result:=Result*16+ord(p^)-ord('0');
233           'a'..'f': Result:=Result*16+ord(p^)-ord('a')+10;
234           'A'..'Z': Result:=Result*16+ord(p^)-ord('A')+10;
235           else
236             break;
237           end;
238           inc(p);
239           dec(l);
240         end;
241       except
242       end;
243     end;
244   end else begin
245     // decimal number
246     if l<15 then begin
247       while l>0 do begin
248         c:=p^;
249         if c in ['0'..'9'] then
250           Result:=Result*10+ord(c)-ord('0')
251         else
252           break;
253         inc(p);
254         dec(l);
255       end;
256     end else begin
257       try
258         while l>0 do begin
259           c:=p^;
260           if c in ['0'..'9'] then
261             Result:=Result*10+ord(c)-ord('0')
262           else
263             break;
264           inc(p);
265           dec(l);
266         end;
267       except
268       end;
269     end;
270   end;
271   if Negated then Result:=-Result;
272 end;
273 
274 procedure SetOperandValueStringConst(var V: TEvalOperand;
275   StartPos, EndPos: PChar);
276 var
277   l: PtrInt;
278   p: PChar;
279   DstPos: PChar;
280 begin
281   l:=0;
282   p:=StartPos;
283   if p^<>'''' then begin
284     if V.Free then FreeEvalOperand(V);
285     V.Len:=0;
286     V.Value:=nil;
287     exit;
288   end;
289   inc(p);
290   while p<EndPos do begin
291     if p^='''' then begin
292       inc(p);
293       if (p^<>'''') or (p=EndPos) then break;
294     end;
295     inc(p);
296     inc(l);
297   end;
298   if l<5 then begin
299     // short string
300     if V.Free then FreeEvalOperand(V);
301     V.Value:=@V.Data[0];
302   end else begin
303     // big string
304     if V.Free then
305       ReAllocMem(V.Value,l)
306     else begin
307       Getmem(V.Value,l);
308       V.Free:=true;
309     end;
310   end;
311   V.Len:=l;
312   // copy content
313   p:=StartPos+1;
314   DstPos:=V.Value;
315   while p<EndPos do begin
316     if p^='''' then begin
317       inc(p);
318       if (p^<>'''') or (p=EndPos) then break;
319     end;
320     DstPos^:=p^;
321     inc(p);
322     inc(DstPos);
323   end;
324 end;
325 
326 procedure SetOperandValueChar(var V: TEvalOperand; const c: Char);
327 begin
328   if V.Free then FreeEvalOperand(V);
329   V.Data[0]:=c;
330   V.Value:=@V.Data[0];
331   V.Len:=1;
332 end;
333 
334 procedure SetOperandValueConst(var V: TEvalOperand; const p: PChar);
335 begin
336   if V.Free then FreeEvalOperand(V);
337   V.Len:=strlen(p);
338   V.Value:=p;
339 end;
340 
341 procedure SetOperandValueInt64(var V: TEvalOperand; i : int64);
342 const
343   HexChrs: array[0..15] of char = '0123456789ABCDEF';
344 var
345   j: Integer;
346   k: Integer;
347   i2: Int64;
348 begin
349   if (i>=-999) and (i<=9999) then begin
350     // small number => save in data
351     if V.Free then FreeEvalOperand(V);
352     V.Value:=@V.Data[0];
353     V.Len:=0;
354     if i<0 then begin
355       // sign
356       V.Data[0]:='-';
357       inc(V.Len);
358       i:=-i;
359     end;
360     if i<10 then
361       j:=1
362     else if i<100 then
363       j:=2
364     else if i<1000 then
365       j:=3
366     else
367       j:=4;
368     inc(V.Len,j);
369     k:=V.Len-1;
370     repeat
371       V.Data[k]:=HexChrs[i mod 10];
372       dec(j);
373       if j=0 then break;
374       i:=i div 10;
375       dec(k);
376     until false;
377   end else begin
378     // big number => save as hex number
379     // calculate needed mem
380     i2:=i;
381     j:=1; // $
382     if i2<0 then begin
383       i2:=-i2;
384       inc(j);
385     end;
386     while i2>0 do begin
387       i2:=i2 shr 4;
388       inc(j);
389     end;
390     V.Len:=j;
391     // allocate mem
392     if V.Free then begin
393       ReAllocMem(V.Value,j);
394     end else begin
395       V.Free:=true;
396       Getmem(V.Value,j);
397     end;
398     // write number
399     if i<0 then i:=-i;
400     while i>0 do begin
401       i:=i shr 4;
402       dec(j);
403       V.Value[j]:=HexChrs[i and $f];
404     end;
405     // write $
406     dec(j);
407     V.Value[j]:='$';
408     // write minus sign
409     if j=0 then
410       V.Value[j]:='-';
411   end;
412 end;
413 
CompareEvalOperandnull414 function CompareEvalOperand(const Operand: TEvalOperand; Value: PChar): integer;
415 var
416   p: PChar;
417   l: PtrInt;
418 begin
419   if (Operand.Value<>nil) and (Operand.Len>0) then begin
420     if Value<>nil then begin
421       p:=Operand.Value;
422       l:=Operand.Len;
423       while (p^=Value^) and (l>0) do begin
424         if Value^=#0 then begin
425           // 'aaa'#0'b' 'aaa'
426           exit(0);
427         end;
428         inc(p);
429         inc(Value);
430         dec(l);
431       end;
432       if l>0 then begin
433         if p^<Value^ then begin
434           // 'aaa' 'aab'
435           Result:=1;
436         end else begin
437           // 'aab' 'aaa' or 'aaa' 'aa'
438           Result:=-1;
439         end;
440       end else begin
441         if Value=#0 then begin
442           // 'aaa' 'aaa'
443           Result:=0;
444         end else begin
445           // 'aa' 'aaa'
446           Result:=1;
447         end;
448       end;
449     end else begin
450       // 'aaa' nil
451       Result:=-1;
452     end;
453   end else begin
454     if Value<>nil then begin
455       // nil 'aaa'
456       Result:=1;
457     end else begin
458       // nil nil
459       Result:=0;
460     end;
461   end;
462 end;
463 
OperandsAreEqualnull464 function OperandsAreEqual(const Op1, Op2: TEvalOperand): boolean;
465 var
466   i: Integer;
467 begin
468   Result:=false;
469   if Op1.Len<>Op2.Len then exit;
470   i:=Op1.Len-1;
471   while i>=0 do begin
472     if Op1.Value[i]<>Op2.Value[i] then exit;
473     dec(i);
474   end;
475   Result:=true;
476 end;
477 
GetIdentifierLennull478 function GetIdentifierLen(Identifier: PChar): integer;
479 var
480   p: PChar;
481 begin
482   Result:=0;
483   p:=Identifier;
484   if p=nil then exit;
485   if not IsIdentStartChar[p^] then exit;
486   inc(p);
487   while IsIdentChar[p^] do inc(p);
488   Result:=p-Identifier;
489 end;
490 
CompareIdentifiersnull491 function CompareIdentifiers(Identifier1, Identifier2: PChar): integer;
492 begin
493   while (UpChars[Identifier1[0]]=UpChars[Identifier2[0]]) do begin
494     if (IsIdentChar[Identifier1[0]]) then begin
495       inc(Identifier1);
496       inc(Identifier2);
497     end else begin
498       Result:=0; // for example  'aaA;' 'aAa;'
499       exit;
500     end;
501   end;
502   if (IsIdentChar[Identifier1[0]]) then begin
503     if (IsIdentChar[Identifier2[0]]) then begin
504       if UpChars[Identifier1[0]]>UpChars[Identifier2[0]] then
505         Result:=-1 // for example  'aab' 'aaa'
506       else
507         Result:=1; // for example  'aaa' 'aab'
508     end else begin
509       Result:=-1; // for example  'aaa' 'aa;'
510     end;
511   end else begin
512     if (IsIdentChar[Identifier2[0]]) then
513       Result:=1 // for example  'aa;' 'aaa'
514     else
515       Result:=0; // for example  'aa;' 'aa,'
516   end;
517 end;
518 
CompareNamesnull519 function CompareNames(Name1: PChar; Name1Len: PtrInt;
520   Name2: PChar; Name2Len: PtrInt): integer;
521 begin
522   while (Name1Len>0) and (Name2Len>0) do begin
523     if UpChars[Name1^]=UpChars[Name2^] then begin
524       inc(Name1);
525       dec(Name1Len);
526       inc(Name2);
527       dec(Name2Len);
528     end else begin
529       if UpChars[Name1^]<UpChars[Name2^] then
530         Result:=1
531       else
532         Result:=-1;
533       exit;
534     end;
535   end;
536   if Name1Len>Name2Len then
537     Result:=-1
538   else if Name1Len<Name2Len then
539     Result:=1
540   else
541     Result:=0;
542 end;
543 
CompareNamesnull544 function CompareNames(const Name1, Name2: string): integer; inline;
545 begin
546   Result:=CompareNames(PChar(Name1),length(Name1),PChar(Name2),length(Name2));
547 end;
548 
549 
550 { TBooleanVariables }
551 
552 procedure TExpressionEvaluator.Clear;
553 var i: integer;
554 begin
555   if FCount=0 then exit;
556   for i:=0 to FCount-1 do begin
557     FNames[i]:='';
558     FValues[i]:='';
559   end;
560   FCount:=0;
561   if FNames<>nil then begin
562     FreeMem(FNames);
563     FNames:=nil;
564   end;
565   if FValues<>nil then begin
566     FreeMem(FValues);
567     FValues:=nil;
568   end;
569   FCapacity:=0;
570   IncreaseChangeStamp;
571 end;
572 
CompareValuesnull573 function TExpressionEvaluator.CompareValues(const v1, v2: string): integer;
574 // -1 : v1<v2
575 //  0 : v1=v2
576 //  1 : v1>v2
577 var len1,len2,a:integer;
578   c1: Char;
579   c2: Char;
580   ValPos1: Integer;
581   ValPos2: Integer;
582 begin
583   len1:=length(v1);
584   len2:=length(v2);
585   ValPos1:=1;
586   ValPos2:=1;
587   if (len1>1) and (v1[ValPos1]='''') then begin
588     inc(ValPos1);
589     dec(Len1,2);
590   end;
591   if (len2>1) and (v2[ValPos2]='''') then begin
592     inc(ValPos2);
593     dec(Len2,2);
594   end;
595   if len1<len2 then Result:=-1
596   else if len1>len2 then Result:=1
597   else begin
598     for a:=1 to len1 do begin
599       c1:=v1[ValPos1];
600       c2:=v2[ValPos2];
601       if c1<c2 then begin
602         Result:=-1;  exit;
603       end;
604       if c1>c2 then begin
605         Result:=1;  exit;
606       end;
607       inc(ValPos1);
608       inc(ValPos2);
609     end;
610     Result:=0;
611   end;
612 end;
613 
CompAtomnull614 function TExpressionEvaluator.CompAtom(
615   const UpperCaseTag: string): boolean;
616 // compare uppercase tag with case insensitive atom
617 var a,len:integer;
618 begin
619   if (OldAtomEnd>OldMax+1) then begin
620     Result:=false;  exit;
621   end;
622   len:=OldAtomEnd-OldAtomStart;
623   if length(UpperCaseTag)<>len then begin
624     Result:=false;  exit;
625   end;
626   for a:=1 to len do begin
627     if (UpChars[OldExpr[OldAtomStart+a-1]]<>UpperCaseTag[a]) then begin
628       Result:=false;  exit;
629     end;
630   end;
631   Result:=true;
632 end;
633 
634 constructor TExpressionEvaluator.Create;
635 begin
636   inherited Create;
637   FValues:=nil;
638   FNames:=nil;
639   FCount:=0;
640 end;
641 
642 destructor TExpressionEvaluator.Destroy;
643 begin
644   Clear;
645   inherited Destroy;
646 end;
647 
648 procedure TExpressionEvaluator.RemoveDoubles(OnGetSameString: TOnGetSameString);
649 var
650   i: Integer;
651 begin
652   for i:=0 to FCount-1 do begin
653     OnGetSameString(FNames[i]);
654     OnGetSameString(FValues[i]);
655   end;
656 end;
657 
TExpressionEvaluator.EvalOldnull658 function TExpressionEvaluator.EvalOld(const Expression: string): string;
659 //  1 = true
660 //  0 = syntax error
661 // -1 = false
662 var s:string;
663 begin
664   OldExpr:=Expression;
665   OldMax:=length(OldExpr);
666   OldCurPos:=1;
667   OldAtomStart:=-1;  OldAtomEnd:=-1;  OldPriorAtomStart:=-1;
668   FErrorPos:=-1;
669   s:=EvalAtPos;
670   if FErrorPos>=0 then begin
671     // error
672     Result:='';  exit;
673   end;
674   Result:=s;
675 end;
676 
TExpressionEvaluator.Itemsnull677 function TExpressionEvaluator.Items(Index: integer): string;
678 begin
679   Result:=FNames[Index]+'='+FValues[Index];
680 end;
681 
Namesnull682 function TExpressionEvaluator.Names(Index: integer): string;
683 begin
684   Result:=FNames[Index];
685 end;
686 
Valuesnull687 function TExpressionEvaluator.Values(Index: integer): string;
688 begin
689   Result:=FValues[Index];
690 end;
691 
692 procedure TExpressionEvaluator.Append(const Variable, Value: string);
693 begin
694   Variables[Variable]:=Variables[Variable]+Value;
695 end;
696 
697 procedure TExpressionEvaluator.Prepend(const Variable, Value: string);
698 begin
699   Variables[Variable]:=Value+Variables[Variable];
700 end;
701 
TExpressionEvaluator.EvalAtPosnull702 function TExpressionEvaluator.EvalAtPos: string;
703 var r: string;   // current result
704   c,o1,o2: char;
705   OldPos: integer;
706   AtomCount: Integer;
707   HasBracket: Boolean;
708 begin
709   Result:='';
710   AtomCount:=0;
711   repeat
712     if (not OldReadNextAtom) then exit;
713     inc(AtomCount);
714     c:=OldExpr[OldAtomStart];
715     if IsWordChar[c] then begin
716       // identifier or keyword
717       if (CompAtom('AND')) then begin
718         if (Result='') then FErrorPos:=OldCurPos
719         else if (Result<>'0') then begin
720           // true AND ...
721           Result:=EvalAtPos();
722           if FErrorPos>=0 then exit;
723           if (Result='') then FErrorPos:=OldCurPos;
724         end;
725         exit;
726       end else if (CompAtom('OR')) then begin
727         if (Result='0') then begin
728           // false OR ...
729           Result:=EvalAtPos();
730           if FErrorPos>=0 then exit;
731           if (Result='') then FErrorPos:=OldCurPos;
732         end else if (AtomCount<=1) then FErrorPos:=OldCurPos;
733         exit;
734       end else if (CompAtom('XOR')) then begin
735         if (Result='') then begin
736           FErrorPos:=OldCurPos;  exit;
737         end;
738         r:=Result;
739         // true/false XOR ...
740         Result:=EvalAtPos();
741         if FErrorPos>=0 then exit;
742         if (Result='') then begin
743           FErrorPos:=OldCurPos;  exit;
744         end;
745         if (r='0') then begin
746           if (Result='0') then Result:='0' else Result:='1';
747         end else begin
748           if (Result='0') then Result:='1' else Result:='0';
749         end;
750         exit;
751       end else if (CompAtom('NOT')) then begin
752         Result:=EvalAtPos();
753         if FErrorPos>=0 then exit;
754         // Note: for Delphi compatibility: "IF not UndefinedVariable" is valid
755         if (Result='0') then Result:='1'
756         else Result:='0';
757         exit;
758       end else if (CompAtom('DEFINED')) then begin
759         // read DEFINED(identifier) or defined identifier
760         if (Result<>'') or (not OldReadNextAtom) then begin
761           FErrorPos:=OldCurPos;
762           exit;
763         end;
764         HasBracket:=CompAtom('(');
765         if HasBracket and (not OldReadNextAtom) then begin
766           FErrorPos:=OldCurPos;
767           exit;
768         end;
769         if IsDefined(copy(OldExpr,OldAtomStart,OldAtomEnd-OldAtomStart)) then
770           Result:='1'
771         else
772           Result:='0';
773         if HasBracket then begin
774           if (not OldReadNextAtom) or (not CompAtom(')')) then begin
775             FErrorPos:=OldCurPos;
776             exit;
777           end;
778         end;
779       end else if (CompAtom('DECLARED')) then begin
780         // read DECLARED(identifier)
781         if (Result<>'') or (not OldReadNextAtom) or (CompAtom('(')=false)
782         or (not OldReadNextAtom) then begin
783           FErrorPos:=OldCurPos;
784           exit;
785         end;
786         if CompAtom('UNICODESTRING') then begin
787           if IsDefined('FPC_HAS_UNICODESTRING') then
788             Result:='1'
789           else
790             Result:='0';
791         end else begin
792           Result:='0';// this can only be answered by a real compiler
793         end;
794         if (not OldReadNextAtom) or (not CompAtom(')')) then begin
795           FErrorPos:=OldCurPos;
796           exit;
797         end;
798       end else if (CompAtom('UNDEFINED')) then begin
799         // read UNDEFINED(identifier) or undefined identifier
800         if (Result<>'') or (not OldReadNextAtom) then begin
801           FErrorPos:=OldCurPos;
802           exit;
803         end;
804         HasBracket:=CompAtom('(');
805         if HasBracket and (not OldReadNextAtom) then begin
806           FErrorPos:=OldCurPos;
807           exit;
808         end;
809         Result:=Variables[copy(OldExpr,OldAtomStart,OldAtomEnd-OldAtomStart)];
810         if Result<>'' then
811           Result:='0'
812         else
813           Result:='1';
814         if HasBracket then begin
815           if (not OldReadNextAtom) or (not CompAtom(')')) then begin
816             FErrorPos:=OldCurPos;
817             exit;
818           end;
819         end;
820       end else begin
821         // Identifier
822         if (Result<>'') then begin
823           FErrorPos:=OldCurPos;
824           exit;
825         end else
826           Result:=Variables[copy(OldExpr,OldAtomStart,OldAtomEnd-OldAtomStart)];
827       end;
828     end else if IsNumberBeginChar[c] then begin
829       // number
830       if (Result<>'') then begin
831         FErrorPos:=OldCurPos;  exit;
832       end else Result:=copy(OldExpr,OldAtomStart,OldAtomEnd-OldAtomStart);
833     end else if c='''' then begin
834       Result:=copy(OldExpr,OldAtomStart+1,OldAtomEnd-OldAtomStart-2);
835     end else begin
836       // operator
837       case c of
838       ')':exit;
839       '(':begin
840           OldPos:=OldAtomStart;
841           // eval in brackets
842           Result:=EvalAtPos();
843           if FErrorPos>=0 then exit;
844           // go behind brackets
845           OldCurPos:=OldPos;
846           if (not OldReadTilEndBracket) then exit;
847           inc(OldCurPos);
848         end;
849       '=','>','<':begin
850           o1:=c;
851           if OldAtomEnd=OldAtomStart+1 then begin
852             r:=EvalAtPos();
853             if FErrorPos>=0 then exit;
854             case o1 of
855             '=':if CompareValues(Result,r)=0 then Result:='1' else Result:='0';
856             '>':if CompareValues(Result,r)=1 then Result:='1' else Result:='0';
857             '<':if CompareValues(Result,r)=-1 then Result:='1' else Result:='0';
858             end;
859           end else begin
860             o2:=OldExpr[OldAtomStart+1];
861             r:=EvalAtPos();
862             if FErrorPos>=0 then exit;
863             if o1='<' then begin
864               if o2='>' then begin
865                 if CompareValues(Result,r)<>0 then Result:='1' else Result:='0';
866               end else if o2='=' then begin
867                 if CompareValues(Result,r)<=0 then Result:='1' else Result:='0';
868               end else FErrorPos:=OldAtomStart;
869             end else if o1='>' then begin
870               if o2='=' then begin
871                 if CompareValues(Result,r)>=0 then Result:='1' else Result:='0';
872               end else FErrorPos:=OldAtomStart;
873             end else FErrorPos:=OldAtomStart;
874           end;
875           exit;
876         end;
877       '!':
878         begin
879           Result:=EvalAtPos();
880           if FErrorPos>=0 then exit;
881           if (Result='0') then Result:='1'
882           else if (Result='') then FErrorPos:=OldCurPos
883           else Result:='0';
884           exit;
885         end;
886       else
887         begin
888           FErrorPos:=OldCurPos;
889         end;
890       end;
891     end;
892   until (FErrorPos>=0);
893 end;
894 
895 procedure TExpressionEvaluator.Expand;
896 var
897   NewSize: integer;
898 begin
899   FCapacity:=(FCapacity shl 1)+10;
900   NewSize:=SizeOf(AnsiString)*FCapacity;
901   ReAllocMem(FValues,NewSize);
902   ReAllocMem(FNames,NewSize);
903 end;
904 
IndexOfNamenull905 function TExpressionEvaluator.IndexOfName(VarName: PChar; VarLen: integer;
906   InsertPos: boolean): integer;
907 var l,r,m, cmp: integer;
908 begin
909   if FCount=0 then begin
910     if InsertPos then
911       Result:=0
912     else
913       Result:=-1;
914     exit;
915   end;
916   l:=0;
917   r:=FCount-1;
918   m:=0;
919   cmp:=0;
920   while l<=r do begin
921     m:=(l+r) shr 1;
922     cmp:=CompareNames(VarName,VarLen,PChar(FNames[m]),length(FNames[m]));
923     if cmp>0 then
924       l:=m+1
925     else if cmp<0 then
926       r:=m-1
927     else begin
928       Result:=m;
929       exit;
930     end;
931   end;
932   if InsertPos then begin
933     if cmp>0 then inc(m);
934     Result:=m;
935   end else begin
936     Result:=-1;
937   end;
938 end;
939 
TExpressionEvaluator.IndexOfIdentifiernull940 function TExpressionEvaluator.IndexOfIdentifier(Identifier: PChar;
941   InsertPos: boolean): integer;
942 var l,r,m, cmp: integer;
943   IdentLen: Integer;
944   CurName: String;
945 begin
946   if FCount=0 then begin
947     if InsertPos then
948       Result:=0
949     else
950       Result:=-1;
951     exit;
952   end;
953   l:=0;
954   r:=FCount-1;
955   m:=0;
956   cmp:=0;
957   IdentLen:=GetIdentifierLen(Identifier);
958   while l<=r do begin
959     m:=(l+r) shr 1;
960     CurName:=FNames[m];
961     cmp:=CompareNames(Identifier,IdentLen,PChar(CurName),length(CurName));
962     if cmp>0 then
963       l:=m+1
964     else if cmp<0 then
965       r:=m-1
966     else begin
967       Result:=m;
968       exit;
969     end;
970   end;
971   if InsertPos then begin
972     if cmp>0 then inc(m);
973     Result:=m;
974   end else begin
975     Result:=-1;
976   end;
977 end;
978 
TExpressionEvaluator.GetVariablesnull979 function TExpressionEvaluator.GetVariables(const Name: string): string;
980 var i: integer;
981 begin
982   i:=IndexOfName(PChar(Name),length(Name),false);
983   if (i>=0) then
984     Result:=FValues[i]
985   else
986     Result:='';
987 end;
988 
TExpressionEvaluator.IsDefinednull989 function TExpressionEvaluator.IsDefined(const Name: string): boolean;
990 begin
991   Result:=IndexOfName(PChar(Name),length(Name),false)>=0;
992 end;
993 
IsIdentifierDefinednull994 function TExpressionEvaluator.IsIdentifierDefined(Identifier: PChar): boolean;
995 begin
996   Result:=IndexOfIdentifier(Identifier,false)>=0;
997 end;
998 
TExpressionEvaluator.OldReadNextAtomnull999 function TExpressionEvaluator.OldReadNextAtom: boolean;
1000 var c,o1,o2:char;
1001 begin
1002   OldPriorAtomStart:=OldAtomStart;
1003   while (OldCurPos<=OldMax) do begin
1004     c:=OldExpr[OldCurPos];
1005     if (c<=' ') then inc(OldCurPos)
1006     else if IsWordChar[c] then begin
1007       // Identifier
1008       OldAtomStart:=OldCurPos;
1009       repeat
1010         inc(OldCurPos);
1011       until (OldCurPos>OldMax) or (not IsIdentifierChar[OldExpr[OldCurPos]]);
1012       OldAtomEnd:=OldCurPos;
1013       Result:=true;
1014       exit;
1015     end else if IsNumberBeginChar[c] then begin
1016       // Number
1017       OldAtomStart:=OldCurPos;
1018       repeat
1019         inc(OldCurPos);
1020       until (OldCurPos>OldMax) or (IsNumberChar[OldExpr[OldCurPos]]=false);
1021       OldAtomEnd:=OldCurPos;
1022       Result:=true;
1023       exit;
1024     end else if c='''' then begin
1025       // string
1026       OldAtomStart:=OldCurPos;
1027       repeat
1028         inc(OldCurPos);
1029         if OldExpr[OldCurPos]='''' then begin
1030           inc(OldCurPos);
1031           OldAtomEnd:=OldCurPos;
1032           Result:=true;
1033           exit;
1034         end;
1035         if OldCurPos>OldMax then begin
1036           OldAtomEnd:=OldCurPos;
1037           Result:=false;
1038           exit;
1039         end;
1040       until (OldCurPos>OldMax);
1041     end else begin
1042       // Symbol
1043       OldAtomStart:=OldCurPos;
1044       inc(OldCurPos);
1045       if (OldCurPos<=OldMax) then begin
1046         o1:=c;
1047         o2:=OldExpr[OldCurPos];
1048         if ((o2='=') and ((o1='<') or (o1='>')))
1049         or ((o1='<') and (o2='>'))
1050         then inc(OldCurPos);
1051       end;
1052       OldAtomEnd:=OldCurPos;
1053       Result:=true;
1054       exit;
1055     end;
1056   end;
1057   Result:=false;
1058 end;
1059 
OldReadTilEndBracketnull1060 function TExpressionEvaluator.OldReadTilEndBracket: boolean;
1061 // true = end bracket found
1062 // false = not found
1063 var lvl:integer;
1064 begin
1065   lvl:=0;
1066   while (OldCurPos<=OldMax) do begin
1067     if (OldExpr[OldCurPos]='(') then
1068       inc(lvl)
1069     else if (OldExpr[OldCurPos]=')') then begin
1070       dec(lvl);
1071       if (lvl=0) then begin
1072         Result:=true;  exit;
1073       end else if (lvl<0) then begin
1074         FErrorPos:=OldCurPos;
1075         Result:=true;  exit;
1076       end;
1077     end;
1078     inc(OldCurPos);
1079   end;
1080   Result:=false;
1081 end;
1082 
1083 procedure TExpressionEvaluator.Assign(
1084   SourceExpressionEvaluator: TExpressionEvaluator);
1085 var i, Size: integer;
1086 begin
1087   Clear;
1088   if SourceExpressionEvaluator<>nil then begin
1089     FCount:=SourceExpressionEvaluator.Count;
1090     Size:=SizeOf(AnsiString) * FCount;
1091     if Size>0 then begin
1092       GetMem(FNames,Size);
1093       FillByte(Pointer(FNames)^,Size,0);
1094       GetMem(FValues,Size);
1095       FillByte(Pointer(FValues)^,Size,0);
1096       FCapacity:=FCount;
1097       for i:=0 to FCount-1 do begin
1098         FNames[i]:=SourceExpressionEvaluator.FNames[i];
1099         FValues[i]:=SourceExpressionEvaluator.FValues[i];
1100       end;
1101     end;
1102     IncreaseChangeStamp;
1103   end;
1104   if Assigned(FOnChange) then FOnChange;
1105 end;
1106 
1107 procedure TExpressionEvaluator.SetVariables(const Name: string;
1108   const Value: string);
1109 var i: integer;
1110   Size: Integer;
1111 begin
1112   i:=IndexOfName(PChar(Name),length(Name),true);
1113   if (i>=0) and (i<FCount) and (CompareNames(FNames[i],Name)=0) then begin
1114     // variable already exists -> replace value
1115     if FValues[i]<>Value then begin
1116       FValues[i]:=Value;
1117       IncreaseChangeStamp;
1118     end;
1119   end else begin
1120     // new variable
1121     if FCount=FCapacity then Expand;
1122     if i<0 then i:=0;
1123     if i<FCount then begin
1124       Size:=SizeOf(AnsiString)*(FCount-i);
1125       System.Move(PPointer(FNames)[i],PPointer(FNames)[i+1],Size);
1126       System.Move(PPointer(FValues)[i],PPointer(FValues)[i+1],Size);
1127     end;
1128     PPointer(FNames)[i]:=nil;
1129     PPointer(FValues)[i]:=nil;
1130     FNames[i]:=UpperCaseStr(Name);
1131     FValues[i]:=Value;
1132     inc(FCount);
1133     IncreaseChangeStamp;
1134   end;
1135 end;
1136 
1137 procedure TExpressionEvaluator.Undefine(const Name: string);
1138 var i: integer;
1139   Size: Integer;
1140 begin
1141   i:=IndexOfName(PChar(Name),length(Name),false);
1142   if (i>=0) then begin
1143     FNames[i]:='';
1144     FValues[i]:='';
1145     dec(FCount);
1146     if FCount>i then begin
1147       Size:=SizeOf(AnsiString)*(FCount-i);
1148       System.Move(PPointer(FNames)[i+1],PPointer(FNames)[i],Size);
1149       System.Move(PPointer(FValues)[i+1],PPointer(FValues)[i],Size);
1150     end;
1151   end;
1152 end;
1153 
Equalsnull1154 function TExpressionEvaluator.Equals(
1155   AnExpressionEvaluator: TExpressionEvaluator): boolean;
1156 var i: integer;
1157 begin
1158   if (AnExpressionEvaluator=nil) or (AnExpressionEvaluator.Count<>FCount) then
1159   begin
1160     Result:=false;
1161     exit;
1162   end;
1163   for i:=0 to FCount-1 do begin
1164     if (FNames[i]<>AnExpressionEvaluator.FNames[i])
1165     or (FValues[i]<>AnExpressionEvaluator.FValues[i]) then begin
1166       Result:=false;
1167       exit;
1168     end;
1169   end;
1170   Result:=true;
1171 end;
1172 
1173 procedure TExpressionEvaluator.AssignTo(SL: TStringList);
1174 var i: integer;
1175 begin
1176   if SL=nil then exit;
1177   SL.Clear;
1178   for i:=0 to FCount-1 do
1179     SL.Add(FNames[i]+'='+FValues[i]);
1180 end;
1181 
TExpressionEvaluator.Evalnull1182 function TExpressionEvaluator.Eval(const Expression: string;
1183   AllowExternalMacro: boolean): string;
1184 {  0 = false
1185    else true }
1186 var
1187   Operand: TEvalOperand;
1188 begin
1189   if Expression='' then exit('0');
1190   if not EvalPChar(PChar(Expression),length(Expression),Operand,AllowExternalMacro) then
1191     Result:=''
1192   else begin
1193     SetLength(Result,Operand.Len);
1194     if Result<>'' then
1195       System.Move(Operand.Value^,Result[1],length(Result));
1196   end;
1197   FreeEvalOperand(Operand);
1198 end;
1199 
EvalPCharnull1200 function TExpressionEvaluator.EvalPChar(Expression: PChar; ExprLen: PtrInt; out
1201   Operand: TEvalOperand; AllowExternalMacro: boolean): boolean;
1202 {  0 = false
1203    else true
1204 
1205   brackets ()
1206   constants: false, true
1207   unary operators: not, defined, undefined
1208   binary operators: + - * / < <= = <> => > div mod and or xor shl shr
1209   functions: defined(), undefined(), declared(), sizeof()=1, option(),
1210     high(), low()
1211 }
1212 type
1213   TOperandAndOperator = record
1214     Operand: TEvalOperand;
1215     theOperator: PChar;
1216     OperatorLvl: integer;
1217   end;
1218   TExprStack = array[0..3] of TOperandAndOperator;
1219 
1220 var
1221   ExprStack: TExprStack;
1222   StackPtr: integer; // -1 = empty
1223   ExprEnd: PChar;
1224   p, AtomStart: PChar;
1225 
1226   procedure FreeStack;
1227   begin
1228     while StackPtr>=0 do begin
1229       FreeEvalOperand(ExprStack[StackPtr].Operand);
1230       dec(StackPtr);
1231     end;
1232   end;
1233 
GetAtomnull1234   function GetAtom: string;
1235   begin
1236     Setlength(Result,p-AtomStart);
1237     if Result<>'' then
1238       System.Move(AtomStart^,Result[1],length(Result));
1239   end;
1240 
1241   procedure ReadNextAtom;
1242   var
1243     Float: Boolean;
1244     Exponent: Boolean;
1245   begin
1246     // skip space
1247     while p^ in [' ',#9,#10,#13] do inc(p);
1248     if p>=ExprEnd then begin
1249       p:=ExprEnd;
1250       AtomStart:=p;
1251       exit;
1252     end;
1253     AtomStart:=p;
1254     case UpChars[p^] of
1255     'A'..'Z','_':
1256       begin
1257         while IsIdentChar[p^] do inc(p);
1258         if p>ExprEnd then p:=ExprEnd;
1259       end;
1260     '0'..'9':
1261       begin
1262         inc(p);
1263         Float:=false;
1264         Exponent:=false;
1265         repeat
1266           case p^ of
1267           '0'..'9': inc(p);
1268           '.':
1269             if Float then
1270               break
1271             else begin
1272               Float:=true;
1273               inc(p);
1274             end;
1275           'e','E':
1276             if Exponent or (not Float) then
1277               break
1278             else begin
1279               Exponent:=true;
1280               inc(p);
1281             end;
1282           else
1283             break;
1284           end;
1285         until p>=ExprEnd;
1286       end;
1287     '$':
1288       begin
1289         inc(p);
1290         while IsHexNumberChar[p^] do inc(p);
1291       end;
1292     '>':
1293       begin
1294         inc(p);
1295         case p^ of
1296         '=','>': inc(p); // >= >>
1297         end;
1298       end;
1299     '<':
1300       begin
1301         inc(p);
1302         case p^ of
1303         '<','>','=': inc(p); // <> <= <<
1304         end;
1305       end;
1306     '''':
1307       begin
1308         inc(p);
1309         while (p<=ExprEnd) do begin
1310           if p^='''' then begin
1311             inc(p);
1312             if p^<>'''' then break;
1313             inc(p);
1314           end else begin
1315             inc(p);
1316           end;
1317         end;
1318       end;
1319     else
1320       inc(p);
1321     end;
1322     {$IFDEF VerboseExprEval}
1323     DebugLn(['ReadNextAtom ',GetAtom]);
1324     {$ENDIF}
1325   end;
1326 
1327   procedure Error(NewErrorPos: PChar; const NewErrorMsg: string);
1328   begin
1329     if NewErrorPos<>nil then
1330       FErrorPos:=NewErrorPos-Expression
1331     else
1332       FErrorPos:=0;
1333     ErrorMsg:=NewErrorMsg;
1334     {$IFDEF VerboseExprEval}
1335     DebugLn(['Error ',ErrorMsg,' at ',ErrorPosition]);
1336     {$ENDIF}
1337   end;
1338 
1339   procedure Error(NewErrorPos: PChar; E: Exception);
1340   begin
1341     Error(NewErrorPos,E.Message);
1342   end;
1343 
1344   procedure ExpressionMissing(NewErrorPos: PChar);
1345   begin
1346     Error(NewErrorPos,'expression missing');
1347   end;
1348 
1349   procedure IdentifierMissing(NewErrorPos: PChar);
1350   begin
1351     Error(NewErrorPos,'identifier missing');
1352   end;
1353 
1354   procedure OperatorMissing(NewErrorPos: PChar);
1355   begin
1356     Error(NewErrorPos,'operator missing');
1357   end;
1358 
1359   procedure CharMissing(NewErrorPos: PChar; c: char);
1360   begin
1361     Error(NewErrorPos,c+' missing');
1362   end;
1363 
1364   procedure BracketMissing(NewErrorPos: PChar);
1365   begin
1366     Error(NewErrorPos,'closing bracket without opening bracket');
1367   end;
1368 
1369   procedure StrExpectedAtPos(NewErrorPos, ExpectedStr: PChar);
1370   var
1371     s: string;
1372     f: string;
1373   begin
1374     s:=ExpectedStr;
1375     if ExprEnd>NewErrorPos then begin
1376       SetLength(f,ExprEnd-NewErrorPos);
1377       System.Move(NewErrorPos^,f[1],ExprEnd-NewErrorPos);
1378       Error(NewErrorPos,'expected '+s+', but found '+f);
1379     end else begin
1380       Error(NewErrorPos,'expected '+s);
1381     end;
1382   end;
1383 
ReadTilEndBracketnull1384   function ReadTilEndBracket: boolean;
1385   // start on bracket open
1386   // ends on bracket close
1387   var
1388     BracketLvl: Integer;
1389     BracketOpen: PChar;
1390   begin
1391     BracketOpen:=AtomStart;
1392     BracketLvl:=0;
1393     while AtomStart<ExprEnd do begin
1394       case AtomStart^ of
1395       '(': inc(BracketLvl);
1396       ')':
1397         begin
1398           dec(BracketLvl);
1399           if BracketLvl=0 then exit(true);
1400         end;
1401       end;
1402       ReadNextAtom;
1403     end;
1404     BracketMissing(BracketOpen);
1405     Result:=false;
1406   end;
1407 
ParseDefinedParamsnull1408   function ParseDefinedParams(var Operand: TEvalOperand): boolean;
1409   // p is behind defined or undefined keyword
1410   // Operand: '1' or '-1'
1411   var
1412     NameStart: PChar;
1413   begin
1414     Result:=false;
1415     ReadNextAtom;
1416     if AtomStart>=ExprEnd then begin
1417       IdentifierMissing(AtomStart);
1418       exit;
1419     end;
1420     if IsIdentifierChar[AtomStart^] then begin
1421       if IsIdentifierDefined(AtomStart) then begin
1422         SetOperandValueChar(Operand,'1');
1423       end else begin
1424         SetOperandValueConst(Operand,'0');
1425       end;
1426     end else if AtomStart^='(' then begin
1427       ReadNextAtom;
1428       if p=AtomStart then begin
1429         StrExpectedAtPos(AtomStart,'macro name');
1430         exit;
1431       end;
1432       if AtomStart^=')' then begin
1433         SetOperandValueConst(Operand,'0');
1434         exit(true);
1435       end;
1436       NameStart:=AtomStart;
1437       if (AtomStart^=ExternalMacroStart) and AllowExternalMacro then begin
1438         inc(AtomStart);
1439         p:=AtomStart;
1440       end;
1441       if not IsIdentStartChar[AtomStart^] then begin
1442         StrExpectedAtPos(AtomStart,'macro name');
1443         exit;
1444       end;
1445       while IsIdentifierChar[p^] do inc(p);
1446       if IndexOfName(NameStart,p-NameStart,false)>=0 then begin
1447         SetOperandValueConst(Operand,'1');
1448       end else begin
1449         SetOperandValueConst(Operand,'0');
1450       end;
1451       ReadNextAtom;
1452       if AtomStart^<>')' then begin
1453         StrExpectedAtPos(AtomStart,')');
1454         exit;
1455       end;
1456     end else begin
1457       StrExpectedAtPos(AtomStart,'macro name');
1458       exit;
1459     end;
1460     Result:=true;
1461   end;
1462 
ParseOptionParamsnull1463   function ParseOptionParams(var Operand: TEvalOperand): boolean;
1464   // p is behind option keyword
1465   // Operand: '1' or '-1'
1466   begin
1467     Result:=false;
1468     ReadNextAtom;
1469     if AtomStart>=ExprEnd then begin
1470       CharMissing(ExprEnd,'(');
1471       exit;
1472     end;
1473     if AtomStart^<>'(' then begin
1474       StrExpectedAtPos(AtomStart,'(');
1475       exit;
1476     end;
1477     ReadNextAtom;
1478     if not IsIdentifierChar[AtomStart^] then begin
1479       StrExpectedAtPos(AtomStart,'option name');
1480       exit;
1481     end;
1482     SetOperandValueChar(Operand,'1');  // ToDo: check the right flag
1483     ReadNextAtom;
1484     if AtomStart>=ExprEnd then begin
1485       CharMissing(ExprEnd,')');
1486       exit;
1487     end;
1488     if AtomStart^<>')' then begin
1489       StrExpectedAtPos(AtomStart,')');
1490       exit;
1491     end;
1492     Result:=true;
1493   end;
1494 
ReadOperandnull1495   function ReadOperand: boolean;
1496   { Examples:
1497      Variable
1498      not Variable
1499      not not undefined Variable
1500      defined(Variable)
1501      !Variable
1502      unicodestring
1503      123
1504      $45
1505      'Abc'
1506      (expression)
1507   }
1508   var
1509     i: LongInt;
1510     BracketStart: PChar;
1511   begin
1512     Result:=false;
1513     if AtomStart>=ExprEnd then exit;
1514     {$IFDEF VerboseExprEval}
1515     DebugLn(['ReadOperand ',GetAtom]);
1516     {$ENDIF}
1517     case UpChars[AtomStart^] of
1518     'N':
1519       if CompareIdentifiers(AtomStart,'NOT')=0 then begin
1520         // not
1521         ReadNextAtom;
1522         if not ReadOperand() then exit;
1523         if (Operand.Len=1) and (Operand.Value^='0') then begin
1524           SetOperandValueChar(Operand,'1');
1525         end else begin
1526           SetOperandValueChar(Operand,'0');
1527         end;
1528         exit(true);
1529       end;
1530     'D':
1531       if CompareIdentifiers(AtomStart,'DEFINED')=0 then begin
1532         // "defined V" or "defined(V)"
1533         if not ParseDefinedParams(Operand) then exit;
1534         exit(true);
1535       end
1536       else if CompareIdentifiers(AtomStart,'DECLARED')=0 then begin
1537         // should check if a pascal identifier is already declared
1538         // can not do this here => return always true
1539         if not ParseDefinedParams(Operand) then exit;
1540         SetOperandValueChar(Operand,'1');
1541         exit(true);
1542       end;
1543     'H':
1544       if CompareIdentifiers(AtomStart,'HIGH')=0 then begin
1545         ReadNextAtom;
1546         if AtomStart^<>'(' then StrExpectedAtPos(AtomStart,'(');
1547         if not ReadTilEndBracket then exit;
1548         SetOperandValueChar(Operand,'0');
1549         exit(true);
1550       end;
1551     'L':
1552       if CompareIdentifiers(AtomStart,'LOW')=0 then begin
1553         ReadNextAtom;
1554         if AtomStart^<>'(' then StrExpectedAtPos(AtomStart,'(');
1555         if not ReadTilEndBracket then exit;
1556         SetOperandValueChar(Operand,'0');
1557         exit(true);
1558       end;
1559     'O':
1560       if CompareIdentifiers(AtomStart,'OPTION')=0 then begin
1561         ReadNextAtom;
1562         if not ParseOptionParams(Operand) then exit;
1563         exit(true);
1564       end;
1565     'S':
1566       if CompareIdentifiers(AtomStart,'SIZEOF')=0 then begin
1567         ReadNextAtom;
1568         if AtomStart^<>'(' then StrExpectedAtPos(AtomStart,'(');
1569         if not ReadTilEndBracket then exit;
1570         SetOperandValueChar(Operand,'1');
1571         exit(true);
1572       end;
1573     'U':
1574       if CompareIdentifiers(AtomStart,'UNDEFINED')=0 then begin
1575         // "undefined V" or "undefined(V)"
1576         if not ParseDefinedParams(Operand) then exit;
1577         if (Operand.Len=1) and (Operand.Value^='0') then begin
1578           SetOperandValueChar(Operand,'1');
1579         end else begin
1580           SetOperandValueChar(Operand,'0');
1581         end;
1582         exit(true);
1583       end
1584       else if CompareIdentifiers(AtomStart,'UNICODESTRING')=0 then begin
1585         // unicodestring
1586         if IsIdentifierDefined('FPC_HAS_UNICODESTRING') then begin
1587           SetOperandValueChar(Operand,'1');
1588         end else begin
1589           SetOperandValueChar(Operand,'0');
1590         end;
1591         exit(true);
1592       end;
1593     '!':
1594       if p-AtomStart=1 then begin
1595         // not
1596         ReadNextAtom;
1597         if not ReadOperand() then exit;
1598         if (Operand.Len=1) and (Operand.Value^='0') then begin
1599           SetOperandValueChar(Operand,'1');
1600         end else begin
1601           SetOperandValueChar(Operand,'0');
1602         end;
1603         exit(true);
1604       end;
1605     '0'..'9','$':
1606       begin
1607         // number
1608         if Operand.Free then FreeEvalOperand(Operand);
1609         Operand.Value:=AtomStart;
1610         Operand.Len:=p-AtomStart;
1611         exit(true);
1612       end;
1613     '''':
1614       begin
1615         SetOperandValueStringConst(Operand,AtomStart,p);
1616         exit(true);
1617       end;
1618     '(':
1619       begin
1620         BracketStart:=AtomStart;
1621         ReadNextAtom;
1622         if AtomStart>=ExprEnd then exit;
1623         {$IFDEF VerboseExprEval}
1624         DebugLn(['ReadOperand BRACKET OPEN']);
1625         {$ENDIF}
1626         if not EvalPChar(AtomStart,ExprLen-(AtomStart-Expression),Operand) then
1627           exit;
1628         {$IFDEF VerboseExprEval}
1629         DebugLn(['ReadOperand BRACKET CLOSED => skip bracket']);
1630         {$ENDIF}
1631         AtomStart:=BracketStart;
1632         p:=AtomStart+1;
1633         if not ReadTilEndBracket then exit;
1634         exit(true);
1635       end;
1636     end;
1637     if IsIdentStartChar[AtomStart^] then begin
1638       // identifier => return current value
1639       i:=IndexOfIdentifier(AtomStart,false);
1640       if i>=0 then begin
1641         if Operand.Free then FreeEvalOperand(Operand);
1642         Operand.Value:=PChar(FValues[i]);
1643         Operand.Len:=length(FValues[i]);
1644       end;
1645       exit(true);
1646     end;
1647     // invalid operand
1648     IdentifierMissing(AtomStart);
1649   end;
1650 
ExecuteStacknull1651   function ExecuteStack(LowerOrEqualOperatorLvl: integer): boolean;
1652   var
1653     Op: PChar;
1654     Number1: Int64;
1655     Number2: Int64;
1656     NumberResult: Int64;
1657     StackOperand: PEvalOperand;
1658   begin
1659     Result:=true;
1660     while (StackPtr>=0)
1661     and (ExprStack[StackPtr].OperatorLvl<=LowerOrEqualOperatorLvl) do begin
1662       try
1663         // compute stack item
1664         Op:=ExprStack[StackPtr].theOperator;
1665         StackOperand:=@ExprStack[StackPtr].Operand;
1666         {$IFDEF VerboseExprEval}
1667         DebugLn(['ExecuteStack Operator^=',ExprStack[StackPtr].theOperator^]);
1668         {$ENDIF}
1669         case UpChars[Op^] of
1670         '*': // multiply
1671           begin
1672             Number1:=EvalOperandToInt64(StackOperand^);
1673             Number2:=EvalOperandToInt64(Operand);
1674             NumberResult:=Number1*Number2;
1675             SetOperandValueInt64(Operand,NumberResult);
1676           end;
1677         '+': // Add
1678           begin
1679             Number1:=EvalOperandToInt64(StackOperand^);
1680             Number2:=EvalOperandToInt64(Operand);
1681             NumberResult:=Number1+Number2;
1682             SetOperandValueInt64(Operand,NumberResult);
1683           end;
1684         '-': // subtract
1685           begin
1686             Number1:=EvalOperandToInt64(StackOperand^);
1687             Number2:=EvalOperandToInt64(Operand);
1688             NumberResult:=Number1-Number2;
1689             SetOperandValueInt64(Operand,NumberResult);
1690           end;
1691         '=':
1692           if OperandsAreEqual(StackOperand^,Operand) then begin
1693             SetOperandValueChar(Operand,'1');
1694           end else begin
1695             SetOperandValueChar(Operand,'0');
1696           end;
1697         '<':
1698           case Op[1] of
1699           '>': // <>
1700             if OperandsAreEqual(StackOperand^,Operand) then begin
1701               SetOperandValueChar(Operand,'0');
1702             end else begin
1703               SetOperandValueChar(Operand,'1');
1704             end;
1705           '=':
1706             begin
1707               // <=
1708               Number1:=EvalOperandToInt64(StackOperand^);
1709               Number2:=EvalOperandToInt64(Operand);
1710               if Number1<=Number2 then
1711                 SetOperandValueChar(Operand,'1')
1712               else
1713                 SetOperandValueChar(Operand,'0');
1714             end;
1715           '<':
1716             begin
1717               // <<
1718               Number1:=EvalOperandToInt64(StackOperand^);
1719               Number2:=EvalOperandToInt64(Operand);
1720               NumberResult:=Number1 shl Number2;
1721               SetOperandValueInt64(Operand,NumberResult);
1722             end;
1723           else
1724             // <
1725             Number1:=EvalOperandToInt64(StackOperand^);
1726             Number2:=EvalOperandToInt64(Operand);
1727             if Number1<Number2 then
1728               SetOperandValueChar(Operand,'1')
1729             else
1730               SetOperandValueChar(Operand,'0');
1731           end;
1732         '>':
1733           case Op[1] of
1734           '=':
1735             begin
1736               // >=
1737               Number1:=EvalOperandToInt64(StackOperand^);
1738               Number2:=EvalOperandToInt64(Operand);
1739               if Number1>=Number2 then
1740                 SetOperandValueChar(Operand,'1')
1741               else
1742                 SetOperandValueChar(Operand,'0');
1743             end;
1744           '>':
1745             begin
1746               // >>
1747               Number1:=EvalOperandToInt64(StackOperand^);
1748               Number2:=EvalOperandToInt64(Operand);
1749               NumberResult:=Number1 shr Number2;
1750               SetOperandValueInt64(Operand,NumberResult);
1751             end;
1752           else
1753             // >
1754             Number1:=EvalOperandToInt64(StackOperand^);
1755             Number2:=EvalOperandToInt64(Operand);
1756             if Number1>Number2 then
1757               SetOperandValueChar(Operand,'1')
1758             else
1759               SetOperandValueChar(Operand,'0');
1760           end;
1761         'A': // AND
1762           begin
1763             if EvalOperandIsTrue(StackOperand^) and EvalOperandIsTrue(Operand) then
1764               SetOperandValueChar(Operand,'1')
1765             else
1766               SetOperandValueChar(Operand,'0');
1767           end;
1768         'D': // DIV
1769           begin
1770             Number1:=EvalOperandToInt64(StackOperand^);
1771             Number2:=EvalOperandToInt64(Operand);
1772             NumberResult:=Number1 div Number2;
1773             SetOperandValueInt64(Operand,NumberResult);
1774           end;
1775         'M': // MOD
1776           begin
1777             Number1:=EvalOperandToInt64(StackOperand^);
1778             Number2:=EvalOperandToInt64(Operand);
1779             NumberResult:=Number1 mod Number2;
1780             SetOperandValueInt64(Operand,NumberResult);
1781           end;
1782         'S':
1783           case UpChars[Op[1]] of
1784           'H': // SH
1785             case UpChars[Op[2]] of
1786             'L': // SHL
1787               begin
1788                 Number1:=EvalOperandToInt64(StackOperand^);
1789                 Number2:=EvalOperandToInt64(Operand);
1790                 NumberResult:=Number1 shl Number2;
1791                 SetOperandValueInt64(Operand,NumberResult);
1792               end;
1793             'R': // SHR
1794               begin
1795                 Number1:=EvalOperandToInt64(StackOperand^);
1796                 Number2:=EvalOperandToInt64(Operand);
1797                 NumberResult:=Number1 shr Number2;
1798                 SetOperandValueInt64(Operand,NumberResult);
1799               end;
1800             end;
1801           end;
1802         'O': // OR
1803           begin
1804             if EvalOperandIsTrue(StackOperand^) or EvalOperandIsTrue(Operand) then
1805               SetOperandValueChar(Operand,'1')
1806             else
1807               SetOperandValueChar(Operand,'0');
1808           end;
1809         'X': // XOR
1810           begin
1811             if EvalOperandIsTrue(StackOperand^) xor EvalOperandIsTrue(Operand) then
1812               SetOperandValueChar(Operand,'1')
1813             else
1814               SetOperandValueChar(Operand,'0');
1815           end;
1816         end;
1817 
1818       except
1819         on E: Exception do begin
1820           Result:=false;
1821           Error(AtomStart,E);
1822         end;
1823       end;
1824       if not Result then exit;
1825       FreeEvalOperand(ExprStack[StackPtr].Operand);
1826       dec(StackPtr);
1827     end;
1828   end;
1829 
1830 var
1831   OperatorLvl: Integer;
1832 begin
1833   p:=Expression;
1834   Result:=false;
1835   ClearEvalOperand(Operand);
1836   if p=nil then begin
1837     ExpressionMissing(p);
1838     exit;
1839   end;
1840   ExprEnd:=p+ExprLen;
1841   ReadNextAtom;
1842   if AtomStart>=ExprEnd then begin
1843     ExpressionMissing(AtomStart);
1844     exit;
1845   end;
1846   StackPtr:=-1;
1847   FErrorPos:=-1;
1848   fErrorMsg:='';
1849   try
1850     while AtomStart<ExprEnd do begin
1851       // read operand
1852       if not ReadOperand then
1853         break;
1854       // read operator
1855       ReadNextAtom;
1856       if AtomStart>=ExprEnd then break;
1857       // level 0: NOT () DEFINED UNDEFINED DECLARED: handled by ReadOperand
1858       // level 1: * / DIV MOD AND SHL SHR << >>
1859       // level 2: + - OR XOR
1860       // level 3: = < > <> >= <=
1861       OperatorLvl:=0;
1862       case UpChars[AtomStart^] of
1863       ')': break;
1864       '*','/': if p-AtomStart=1 then OperatorLvl:=1;
1865       '+','-': if p-AtomStart=1 then OperatorLvl:=2;
1866       '=': if p-AtomStart=1 then OperatorLvl:=3;
1867       '<': if (p-AtomStart=1)
1868            or (AtomStart[1] in ['=','>']) then
1869              OperatorLvl:=3
1870            else if AtomStart[1]='<' then
1871              OperatorLvl:=1;
1872       '>': if (p-AtomStart=1)
1873            or (AtomStart[1]='=') then
1874              OperatorLvl:=3
1875            else if AtomStart[1]='>' then
1876              OperatorLvl:=1;
1877       'A':
1878         if CompareIdentifiers(AtomStart,'AND')=0 then begin
1879           OperatorLvl:=1;
1880           if not EvalOperandIsTrue(Operand) then begin
1881             SetOperandValueChar(Operand,'0');
1882             break;
1883           end;
1884         end;
1885       'D': if CompareIdentifiers(AtomStart,'DIV')=0 then OperatorLvl:=1;
1886       'M': if CompareIdentifiers(AtomStart,'MOD')=0 then OperatorLvl:=1;
1887       'S':
1888         case UpChars[AtomStart[1]] of
1889         'H': // SH
1890           case UpChars[AtomStart[2]] of
1891           'L': if p-AtomStart=3 then OperatorLvl:=1; // SHL
1892           'R': if p-AtomStart=3 then OperatorLvl:=1; // SHR
1893           end;
1894         end;
1895       'O':
1896         case UpChars[AtomStart[1]] of
1897         'R':
1898           if p-AtomStart=2 then begin
1899             OperatorLvl:=2;
1900             if EvalOperandIsTrue(Operand) then begin
1901               SetOperandValueChar(Operand,'1');
1902               break;
1903             end;
1904           end;
1905         end;
1906       'X': if CompareIdentifiers(AtomStart,'XOR')=0 then OperatorLvl:=2;
1907       end;
1908       if OperatorLvl=0 then begin
1909         OperatorMissing(AtomStart);
1910         break;
1911       end;
1912       if not ExecuteStack(OperatorLvl) then break;
1913       // push onto stack
1914       inc(StackPtr);
1915       ExprStack[StackPtr].Operand:=Operand;
1916       ExprStack[StackPtr].OperatorLvl:=OperatorLvl;
1917       ExprStack[StackPtr].theOperator:=AtomStart;
1918       ClearEvalOperand(Operand);
1919       ReadNextAtom;
1920     end;
1921     if FErrorPos<0 then begin
1922       Result:=ExecuteStack(4);
1923     end;
1924   finally
1925     // clean up
1926     FreeStack;
1927   end;
1928 end;
1929 
EvalBooleannull1930 function TExpressionEvaluator.EvalBoolean(Expression: PChar; ExprLen: PtrInt;
1931   AllowExternalMacro: boolean): boolean;
1932 var
1933   Operand: TEvalOperand;
1934 begin
1935   Result:=EvalPChar(Expression,ExprLen,Operand,AllowExternalMacro)
1936        and EvalOperandIsTrue(Operand);
1937   FreeEvalOperand(Operand);
1938 end;
1939 
AsStringnull1940 function TExpressionEvaluator.AsString: string;
1941 var TxtLen, i, p: integer;
1942   s: String;
1943 begin
1944   TxtLen:=0;
1945   for i:=0 to FCount-1 do begin
1946     inc(TxtLen,length(FNames[i])+2);
1947     s:=FValues[i];
1948     if s<>'' then
1949       inc(TxtLen,length(s)+1);
1950   end;
1951   Setlength(Result,TxtLen);
1952   p:=1;
1953   for i:=0 to FCount-1 do begin
1954     Move(FNames[i][1],Result[p],length(FNames[i]));
1955     inc(p,length(FNames[i]));
1956     s:=FValues[i];
1957     if length(s)>0 then begin
1958       Result[p]:='=';
1959       inc(p);
1960       Move(FValues[i][1],Result[p],length(FValues[i]));
1961       inc(p,length(FValues[i]));
1962     end;
1963     Result[p]:=#13;
1964     inc(p);
1965     Result[p]:=#10;
1966     inc(p);
1967   end;
1968 end;
1969 
1970 procedure TExpressionEvaluator.ConsistencyCheck;
1971 // 0 = ok
1972 var i: integer;
1973 begin
1974   if FCapacity<0 then
1975     RaiseCatchableException('');
1976   if FCapacity<FCount then
1977     RaiseCatchableException('');
1978   if FCount<0 then
1979     RaiseCatchableException('');
1980   if (FCapacity=0) and (FNames<>nil) then
1981     RaiseCatchableException('');
1982   if (FNames=nil) xor (FValues=nil) then
1983     RaiseCatchableException('');
1984   for i:=0 to FCount-1 do begin
1985     if not IsUpperCaseStr(FNames[i]) then
1986       RaiseCatchableException('');
1987     if (i>0) and (FNames[i-1]=FNames[i]) then
1988       RaiseCatchableException('');
1989     if (i>0) and (CompareNames(FNames[i-1],FNames[i])>0) then
1990       RaiseCatchableException('');
1991   end;
1992 end;
1993 
1994 procedure TExpressionEvaluator.WriteDebugReport;
1995 var
1996   i: Integer;
1997 begin
1998   DebugLn('[TExpressionEvaluator.WriteDebugReport] ');
1999   ConsistencyCheck;
2000   for i:=0 to Count-1 do
2001     debugln('  ',Items(i));
2002 end;
2003 
CalcMemSizenull2004 function TExpressionEvaluator.CalcMemSize(WithNamesAndValues: boolean;
2005   Original: TExpressionEvaluator): PtrUInt;
2006 var
2007   i: Integer;
2008   j: LongInt;
2009 begin
2010   Result:=PtrUInt(InstanceSize)
2011     +MemSizeString(OldExpr)
2012     +SizeOf(Pointer)*PtrUInt(FCount)*2;
2013   if WithNamesAndValues then begin
2014     for i:=0 to FCount-1 do begin
2015       if Original<>nil then begin
2016         j:=Original.IndexOfName(PChar(FNames[i]),length(FNames[i]),false);
2017         if j>=0 then begin
2018           if Pointer(FNames[i])=Pointer(Original.FNames[j]) then continue;
2019         end;
2020       end;
2021       inc(Result,MemSizeString(FNames[i]));
2022       inc(Result,MemSizeString(FValues[i]));
2023     end;
2024   end;
2025 end;
2026 
2027 procedure TExpressionEvaluator.IncreaseChangeStamp;
2028 begin
2029   if FChangeStamp<High(Integer) then
2030     inc(FChangeStamp)
2031   else
2032     FChangeStamp:=Low(Integer);
2033 end;
2034 
2035 
2036 initialization
2037   InternalInit;
2038 
2039 end.
2040 
2041