src/shared/exoma.pas

   1 (* Copyright (C)  DooM 2D:Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, either version 3 of the License, or
   6  * (at your option) any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15  *)
  16 {$INCLUDE a_modes.inc}
  17 unit exoma;
  18
  19 interface
  20
  21 uses
  22   typinfo, Variants, hashtable, xparser;
  23
  24
  25 // ////////////////////////////////////////////////////////////////////////// //
  26 type
  27   TPropHash = class
  28   private
  29     mClass: TClass;
  30     mNames: THashStrInt;
  31     pl: PPropList;
  32     pc: Integer;
  33
  34   public
  35     constructor Create (aklass: TClass);
  36     destructor Destroy (); override;
  37
  38     function get (obj: TObject; const fldname: AnsiString; out v: Variant): Boolean;
  39     function put (obj: TObject; const fldname: AnsiString; var v: Variant): Boolean;
  40   end;
  41
  42
  43 // ////////////////////////////////////////////////////////////////////////// //
  44 type
  45   TExprScope = class
  46   public
  47     function getObj (const aname: AnsiString): TObject; virtual;
  48     function getField (obj: TObject; const afldname: AnsiString): Variant; virtual;
  49     procedure setField (obj: TObject; const afldname: AnsiString; var aval: Variant); virtual;
  50   end;
  51
  52   TExprBase = class
  53   public
  54     class function coerce2bool (var v0: Variant): Boolean;
  55     class function toInt (var v: Variant): LongInt;
  56   public
  57     class procedure error ();
  58     class function parse (pr: TTextParser; allowAssign: Boolean=false): TExprBase;
  59     class function parse (const str: AnsiString; allowAssign: Boolean=false): TExprBase;
  60     class function parseStatList (const str: AnsiString): TExprBase;
  61   public
  62     function value (scope: TExprScope): Variant; virtual; abstract;
  63     procedure assign (scope: TExprScope; var v: Variant); virtual;
  64     function clone (): TExprBase; virtual; abstract;
  65   end;
  66
  67   TExprStatList = class(TExprBase)
  68   private
  69     mList: array of TExprBase;
  70   public
  71     constructor Create ();
  72     destructor Destroy (); override;
  73     function value (scope: TExprScope): Variant; override;
  74     function toString (): AnsiString; override;
  75     function clone (): TExprBase; override;
  76   end;
  77
  78   TObjExpr = class(TExprBase)
  79   private
  80     mName: AnsiString;
  81   public
  82     constructor Create (const aval: AnsiString);
  83
  84     function value (scope: TExprScope): Variant; override;
  85     function toString (): AnsiString; override;
  86     function clone (): TExprBase; override;
  87   end;
  88
  89   TLitExpr = class(TExprBase)
  90   private
  91     mValue: Variant;
  92   public
  93     constructor Create (aval: Boolean);
  94     constructor Create (aval: LongInt);
  95     constructor Create (const aval: AnsiString);
  96
  97     function value (scope: TExprScope): Variant; override;
  98     function toString (): AnsiString; override;
  99     function clone (): TExprBase; override;
 100   end;
 101
 102   TUnExpr = class(TExprBase)
 103   private
 104     mOp0: TExprBase;
 105   public
 106     constructor Create (aop0: TExprBase);
 107     destructor Destroy (); override;
 108     function clone (): TExprBase; override;
 109   end;
 110
 111   TUnExprNeg = class(TUnExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 112   TUnExprNot = class(TUnExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 113
 114   TDotExpr = class(TExprBase)
 115   private
 116     mOp0: TExprBase;
 117     mField: AnsiString;
 118   public
 119     constructor Create (aop0: TExprBase; const afield: AnsiString);
 120     function value (scope: TExprScope): Variant; override;
 121     procedure assign (scope: TExprScope; var v: Variant); override;
 122     function toString (): AnsiString; override;
 123     function clone (): TExprBase; override;
 124   end;
 125
 126   TBinExpr = class(TExprBase)
 127   private
 128     mOp0, mOp1: TExprBase;
 129   private
 130     class procedure coerce (var v0, v1: Variant); // modifies both variants
 131   public
 132     constructor Create (aop0, aop1: TExprBase);
 133     destructor Destroy (); override;
 134     function clone (): TExprBase; override;
 135   end;
 136
 137   TBinExprAdd = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 138   TBinExprSub = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 139   TBinExprMul = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 140   TBinExprDiv = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 141   TBinExprMod = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 142
 143   TBinExprLogAnd = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 144   TBinExprLogOr = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 145
 146   TBinExprCmpLess = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 147   TBinExprCmpGreat = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 148   TBinExprCmpLessEqu = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 149   TBinExprCmpGreatEqu = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 150   TBinExprCmpEqu = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 151   TBinExprCmpNotEqu = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 152
 153   TBinAssign = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
 154
 155
 156 // ////////////////////////////////////////////////////////////////////////// //
 157 function typeKind2Str (t: TTypeKind): AnsiString;
 158
 159
 160 implementation
 161
 162 uses
 163   SysUtils, utils;
 164
 165
 166 // ////////////////////////////////////////////////////////////////////////// //
 167 function typeKind2Str (t: TTypeKind): AnsiString;
 168 begin
 169   case t of
 170     tkUnknown: result := 'Unknown';
 171     tkInteger: result := 'Integer';
 172     tkChar: result := 'AnsiChar';
 173     tkEnumeration: result := 'Enumeration';
 174     tkFloat: result := 'Float';
 175     tkSet: result := 'Set';
 176     tkMethod: result := 'Method';
 177     tkSString: result := 'ShortString';
 178     tkLString: result := 'LString';
 179     tkAString: result := 'AnsiString';
 180     tkWString: result := 'WideString';
 181     tkVariant: result := 'Variant';
 182     tkArray: result := 'Array';
 183     tkRecord: result := 'Record';
 184     tkInterface: result := 'Interface';
 185     tkClass: result := 'Class';
 186     tkObject: result := 'Object';
 187     tkWChar: result := 'WideChar';
 188     tkBool: result := 'Boolean';
 189     tkInt64: result := 'Int64';
 190     tkQWord: result := 'UInt64';
 191     tkDynArray: result := 'DynArray';
 192     tkInterfaceRaw: result := 'InterfaceRaw';
 193     tkProcVar: result := 'ProcVar';
 194     tkUString: result := 'UString';
 195     tkUChar: result := 'UChar';
 196     tkHelper: result := 'Helper';
 197     tkFile: result := 'File';
 198     tkClassRef: result := 'ClassRef';
 199     tkPointer: result := 'Pointer';
 200     else result := '<unknown>';
 201   end;
 202 end;
 203
 204
 205 // ////////////////////////////////////////////////////////////////////////// //
 206 (*
 207 procedure dumpPublishedProperties (obj: TObject);
 208 var
 209   pt: PTypeData;
 210   pi: PTypeInfo;
 211   i, j: Integer;
 212   pp: PPropList;
 213 begin
 214   if (obj = nil) then exit;
 215   //e_LogWritefln('Object of type ''%s'':', [obj.ClassName]);
 216   pi := obj.ClassInfo;
 217   pt := GetTypeData(pi);
 218   //e_LogWritefln('property count: %s', [pt.PropCount]);
 219   GetMem(pp, pt^.PropCount*sizeof(Pointer));
 220   try
 221     j := GetPropList(pi, [tkInteger, tkBool, tkSString, tkLString, tkAString, tkSet, tkEnumeration], pp);
 222     //e_LogWritefln('ordinal property count: %s', [j]);
 223     for i := 0 to j-1 do
 224     begin
 225       {
 226       if (typinfo.PropType(obj, pp^[i].name) in [tkSString, tkLString, tkAString]) then
 227       begin
 228         e_LogWritefln('  #%s: <%s>; type: %s; value: <%s>', [i+1, pp^[i].name, typeKind2Str(typinfo.PropType(obj, pp^[i].name)), GetStrProp(obj, pp^[i])]);
 229       end
 230       else if (typinfo.PropType(obj, pp^[i].name) = tkSet) then
 231       begin
 232         e_LogWritefln('  #%s: <%s>; type: %s; value: %s', [i+1, pp^[i].name, typeKind2Str(typinfo.PropType(obj, pp^[i].name)), GetSetProp(obj, pp^[i], true)]);
 233       end
 234       else if (typinfo.PropType(obj, pp^[i].name) = tkEnumeration) then
 235       begin
 236         e_LogWritefln('  #%s: <%s>; type: %s; value: <%s>', [i+1, pp^[i].name, typeKind2Str(typinfo.PropType(obj, pp^[i].name)), GetEnumProp(obj, pp^[i])]);
 237       end
 238       else
 239       begin
 240         e_LogWritefln('  #%s: <%s>; type: %s; value: %s', [i+1, pp^[i].name, typeKind2Str(typinfo.PropType(obj, pp^[i].name)), GetOrdProp(obj, pp^[i])]);
 241       end;
 242       }
 243     end;
 244   finally
 245     FreeMem(pp);
 246   end;
 247 end;
 248 *)
 249
 250
 251 // ////////////////////////////////////////////////////////////////////////// //
 252 constructor TPropHash.Create (aklass: TClass);
 253 var
 254   pi: PTypeInfo;
 255   pt: PTypeData;
 256   idx: Integer;
 257 begin
 258   mClass := aklass;
 259   mNames := hashNewStrInt();
 260   pi := aklass.ClassInfo;
 261   pt := GetTypeData(pi);
 262   GetMem(pl, pt^.PropCount*sizeof(Pointer));
 263   pc := GetPropList(pi, [tkInteger, tkBool, tkSString, tkLString, tkAString, {tkSet,} tkEnumeration], pl);
 264   for idx := 0 to pc-1 do mNames.put(pl^[idx].name, idx);
 265 end;
 266
 267 destructor TPropHash.Destroy ();
 268 begin
 269   mNames.Free();
 270   mNames := nil;
 271   if (pl <> nil) then FreeMem(pl);
 272   pl := nil;
 273   pc := 0;
 274   mClass := nil;
 275 end;
 276
 277 function TPropHash.get (obj: TObject; const fldname: AnsiString; out v: Variant): Boolean;
 278 var
 279   idx: Integer;
 280 begin
 281   result := false;
 282   if mNames.get(fldname, idx) then
 283   begin
 284     result := true;
 285     case pl^[idx].PropType.Kind of
 286       tkSString, tkLString, tkAString: v := GetStrProp(obj, pl^[idx]);
 287       tkEnumeration: v := GetEnumProp(obj, pl^[idx]);
 288       tkBool: if (GetOrdProp(obj, pl^[idx]) = 0) then v := false else v := true;
 289       tkInteger, tkChar: v := LongInt(GetOrdProp(obj, pl^[idx]));
 290       //tkFloat: result := 'Float';
 291       //tkClass: result := 'Class';
 292       //tkInt64: result := 'Int64';
 293       //tkClassRef: result := 'ClassRef';
 294       else result := false;
 295     end;
 296     if result then exit;
 297   end;
 298   v := Unassigned;
 299 end;
 300
 301 function TPropHash.put (obj: TObject; const fldname: AnsiString; var v: Variant): Boolean;
 302 var
 303   idx: Integer;
 304 begin
 305   result := false;
 306   if mNames.get(fldname, idx) then
 307   begin
 308     result := true;
 309     case pl^[idx].PropType.Kind of
 310       tkSString, tkLString, tkAString: SetStrProp(obj, pl^[idx], VarToStr(v));
 311       tkEnumeration: SetEnumProp(obj, pl^[idx], VarToStr(v));
 312       tkBool: if TExprBase.coerce2bool(v) then SetOrdProp(obj, pl^[idx], 1) else SetOrdProp(obj, pl^[idx], 0);
 313       tkInteger, tkChar: SetOrdProp(obj, pl^[idx], TExprBase.toInt(v));
 314       //tkFloat: result := 'Float';
 315       //tkClass: result := 'Class';
 316       //tkInt64: result := 'Int64';
 317       //tkClassRef: result := 'ClassRef';
 318       else result := false;
 319     end;
 320     if result then exit;
 321   end;
 322 end;
 323
 324
 325 // ////////////////////////////////////////////////////////////////////////// //
 326 function TExprScope.getObj (const aname: AnsiString): TObject; begin result := nil; TExprBase.error(); end;
 327 function TExprScope.getField (obj: TObject; const afldname: AnsiString): Variant; begin result := Unassigned; TExprBase.error(); end;
 328 procedure TExprScope.setField (obj: TObject; const afldname: AnsiString; var aval: Variant); begin TExprBase.error(); end;
 329
 330
 331 // ////////////////////////////////////////////////////////////////////////// //
 332 class procedure TExprBase.error (); begin raise Exception.Create('math error'); end;
 333
 334 class function TExprBase.coerce2bool (var v0: Variant): Boolean;
 335 begin
 336   case varType(v0) of
 337     varEmpty: result := false;
 338     varNull: result := false;
 339     varSingle: result := (Single(v0) <> 0.0);
 340     varDouble: result := (Double(v0) <> 0.0);
 341     varString: result := (Length(AnsiString(v0)) <> 0);
 342     varBoolean: result := Boolean(v0);
 343     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := (LongInt(v0) <> 0);
 344     varInt64: result := (Int64(v0) <> 0);
 345     varQWord: result := (UInt64(v0) <> 0);
 346     else begin result := false; error(); end;
 347   end;
 348 end;
 349
 350 class function TExprBase.toInt (var v: Variant): LongInt;
 351 begin
 352   case varType(v) of
 353     varSingle: result := trunc(Single(v));
 354     varDouble: result := trunc(Double(v));
 355     varBoolean: if Boolean(v) then result := 1 else result := 0;
 356     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(v);
 357     varInt64: result := LongInt(Int64(v));
 358     else begin result := 0; TExprBase.error(); end;
 359   end;
 360 end;
 361
 362 procedure TExprBase.assign (scope: TExprScope; var v: Variant); begin error(); end;
 363
 364
 365 // ////////////////////////////////////////////////////////////////////////// //
 366 constructor TExprStatList.Create (); begin mList := nil; end;
 367 destructor TExprStatList.Destroy (); var f: Integer; begin for f := 0 to High(mList) do mList[f].Free(); mList := nil; end;
 368
 369 function TExprStatList.value (scope: TExprScope): Variant;
 370 var
 371   f: Integer;
 372 begin
 373   result := false;
 374   for f := 0 to High(mList) do result := mList[f].value(scope);
 375 end;
 376 function TExprStatList.toString (): AnsiString;
 377 var
 378   f: Integer;
 379 begin
 380   result := '';
 381   for f := 0 to High(mList) do result += mList[f].toString()+';';
 382 end;
 383 function TExprStatList.clone (): TExprBase;
 384 var
 385   r: TExprStatList;
 386   f: Integer;
 387 begin
 388   r := TExprStatList.Create();
 389   SetLength(r.mList, Length(mList));
 390   for f := 0 to High(mList) do r.mList[f] := nil;
 391   try
 392     for f := 0 to High(mList) do r.mList[f] := mList[f].clone();
 393   except
 394     r.Free();
 395   end;
 396   result := r;
 397 end;
 398
 399
 400 // ////////////////////////////////////////////////////////////////////////// //
 401 constructor TObjExpr.Create (const aval: AnsiString); begin mName := aval; end;
 402 function TObjExpr.value (scope: TExprScope): Variant; begin result := UInt64(PtrUInt(Pointer(scope.getObj(mName)))); end;
 403 function TObjExpr.toString (): AnsiString; begin result := mName; end;
 404 function TObjExpr.clone (): TExprBase; begin result := TObjExpr.Create(mName); end;
 405
 406
 407 // ////////////////////////////////////////////////////////////////////////// //
 408 constructor TLitExpr.Create (aval: Boolean); begin mValue := aval; end;
 409 constructor TLitExpr.Create (aval: LongInt); begin mValue := aval; end;
 410 constructor TLitExpr.Create (const aval: AnsiString); begin mValue := aval; end;
 411 function TLitExpr.value (scope: TExprScope): Variant; begin result := mValue; end;
 412 function TLitExpr.toString (): AnsiString; begin result := VarToStr(mValue); end;
 413 function TLitExpr.clone (): TExprBase; begin result := TLitExpr.Create(0); (result as TLitExpr).mValue := mValue; end;
 414
 415
 416 // ////////////////////////////////////////////////////////////////////////// //
 417 constructor TUnExpr.Create (aop0: TExprBase); begin mOp0 := aop0; end;
 418 destructor TUnExpr.Destroy (); begin mOp0.Free(); inherited; end;
 419 function TUnExpr.clone (): TExprBase; begin result := (self.ClassType.Create() as TUnExpr); (result as TUnExpr).mOp0 := mOp0.clone(); end;
 420
 421 function TUnExprNeg.value (scope: TExprScope): Variant;
 422 begin
 423   result := mOp0.value(scope);
 424   case varType(result) of
 425     varSingle: result := -Single(result);
 426     varDouble: result := -Double(result);
 427     varShortInt, varSmallInt, varInteger, varByte, varWord: result := -LongInt(result);
 428     varInt64: result := -Int64(result);
 429     varLongWord: result := -LongInt(result);
 430     else error();
 431   end;
 432 end;
 433
 434 function TUnExprNeg.toString (): AnsiString; begin result := '-('+mOp0.toString()+')'; end;
 435
 436 function TUnExprNot.value (scope: TExprScope): Variant;
 437 begin
 438   result := mOp0.value(scope);
 439   result := not coerce2bool(result);
 440 end;
 441
 442 function TUnExprNot.toString (): AnsiString; begin result := '!('+mOp0.toString()+')'; end;
 443
 444
 445 // ////////////////////////////////////////////////////////////////////////// //
 446 constructor TDotExpr.Create (aop0: TExprBase; const afield: AnsiString);
 447 begin
 448   mOp0 := aop0;
 449   mField := afield;
 450 end;
 451
 452 function TDotExpr.value (scope: TExprScope): Variant;
 453 begin
 454   result := mOp0.value(scope);
 455   if (varType(result) <> varQWord) then error();
 456   result := scope.getField(TObject(PtrUInt(UInt64(result))), mField);
 457 end;
 458
 459 procedure TDotExpr.assign (scope: TExprScope; var v: Variant);
 460 var
 461   o: Variant;
 462 begin
 463   o := mOp0.value(scope);
 464   if (varType(o) <> varQWord) then error();
 465   scope.setField(TObject(PtrUInt(UInt64(o))), mField, v);
 466 end;
 467
 468 function TDotExpr.clone (): TExprBase; begin result := TDotExpr.Create(mOp0, mField); end;
 469
 470 function TDotExpr.toString (): AnsiString; begin result := mOp0.toString()+'.'+mField; end;
 471
 472
 473 // ////////////////////////////////////////////////////////////////////////// //
 474 constructor TBinExpr.Create (aop0, aop1: TExprBase); begin mOp0 := aop0; mOp1 := aop1; end;
 475 destructor TBinExpr.Destroy (); begin mOp1.Free(); mOp0.Free(); inherited; end;
 476 function TBinExpr.clone (): TExprBase; begin result := (self.ClassType.Create() as TBinExpr); (result as TBinExpr).mOp0 := mOp0.clone(); (result as TBinExpr).mOp1 := mOp1.clone(); end;
 477
 478 class procedure TBinExpr.coerce (var v0, v1: Variant);
 479   function isFloat (var v: Variant): Boolean; inline;
 480   begin
 481     case varType(v) of
 482       varSingle, varDouble: result := true;
 483       else result := false;
 484     end;
 485   end;
 486
 487   function isInt (var v: Variant): Boolean; inline;
 488   begin
 489     case varType(v) of
 490       varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := true;
 491       else result := false;
 492     end;
 493   end;
 494
 495   function isBool (var v: Variant): Boolean; inline;
 496   begin
 497     result := (varType(v) = varBoolean);
 498   end;
 499
 500   function isStr (var v: Variant): Boolean; inline;
 501   begin
 502     result := (varType(v) = varString);
 503   end;
 504
 505 begin
 506   if (varType(v0) <> varType(v1)) then
 507   begin
 508     if isStr(v0) or isStr(v1) then
 509     begin
 510            if isFloat(v0) then v0 := formatstrf('%s', [Double(v0)])
 511       else if isInt(v0) then v0 := formatstrf('%s', [LongInt(v0)])
 512       else if isBool(v0) then v0 := formatstrf('%s', [Boolean(v0)])
 513       else if isStr(v0) then begin end
 514       else error();
 515            if isFloat(v1) then v1 := formatstrf('%s', [Double(v1)])
 516       else if isInt(v1) then v1 := formatstrf('%s', [LongInt(v1)])
 517       else if isBool(v1) then v1 := formatstrf('%s', [Boolean(v1)])
 518       else if isStr(v0) then begin end
 519       else error();
 520     end
 521     else if isFloat(v0) or isFloat(v1) then
 522     begin
 523            if isFloat(v0) or isInt(v0) then v0 := Double(v0)
 524       else if isBool(v0) then begin if Boolean(v0) then v0 := Double(1.0) else v0 := Double(0.0); end
 525       else error();
 526            if isFloat(v1) or isInt(v1) then v1 := Double(v1)
 527       else if isBool(v1) then begin if Boolean(v1) then v1 := Double(1.0) else v1 := Double(0.0); end
 528       else error();
 529     end
 530     else if isInt(v0) or isInt(v1) then
 531     begin
 532            if isBool(v0) then begin if Boolean(v0) then v0 := LongInt(1) else v0 := LongInt(0); end
 533       else if isFloat(v0) then v0 := LongInt(trunc(Double(v0)))
 534       else if isInt(v0) then begin end
 535       else error();
 536            if isBool(v1) then begin if Boolean(v1) then v1 := LongInt(1) else v1 := LongInt(0); end
 537       else if isFloat(v1) then v1 := LongInt(trunc(Double(v1)))
 538       else if isInt(v1) then begin end
 539       else error();
 540     end
 541     else
 542     begin
 543       error();
 544     end;
 545   end;
 546 end;
 547
 548
 549 // ////////////////////////////////////////////////////////////////////////// //
 550 function TBinExprAdd.value (scope: TExprScope): Variant;
 551 var
 552   r1: Variant;
 553 begin
 554   result := mOp0.value(scope);
 555   r1 := mOp1.value(scope);
 556   coerce(result, r1);
 557   case varType(result) of
 558     varSingle, varDouble: result := Double(result)+Double(r1);
 559     varString: result := AnsiString(result)+AnsiString(r1);
 560     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result)+LongInt(r1);
 561     varInt64: result := Int64(result)+Int64(r1);
 562     else error();
 563   end;
 564 end;
 565 function TBinExprAdd.toString (): AnsiString; begin result := '('+mOp0.toString()+'+'+mOp1.toString+')'; end;
 566
 567 function TBinExprSub.value (scope: TExprScope): Variant;
 568 var
 569   r1: Variant;
 570 begin
 571   result := mOp0.value(scope);
 572   r1 := mOp1.value(scope);
 573   coerce(result, r1);
 574   case varType(result) of
 575     varSingle, varDouble: result := Double(result)-Double(r1);
 576     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result)-LongInt(r1);
 577     varInt64: result := Int64(result)-Int64(r1);
 578     else error();
 579   end;
 580 end;
 581 function TBinExprSub.toString (): AnsiString; begin result := '('+mOp0.toString()+'-'+mOp1.toString+')'; end;
 582
 583 function TBinExprMul.value (scope: TExprScope): Variant;
 584 var
 585   r1: Variant;
 586 begin
 587   result := mOp0.value(scope);
 588   r1 := mOp1.value(scope);
 589   coerce(result, r1);
 590   case varType(result) of
 591     varSingle, varDouble: result := Double(result)*Double(r1);
 592     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result)*LongInt(r1);
 593     varInt64: result := Int64(result)*Int64(r1);
 594     else error();
 595   end;
 596 end;
 597 function TBinExprMul.toString (): AnsiString; begin result := '('+mOp0.toString()+'*'+mOp1.toString+')'; end;
 598
 599 function TBinExprDiv.value (scope: TExprScope): Variant;
 600 var
 601   r1: Variant;
 602 begin
 603   result := mOp0.value(scope);
 604   r1 := mOp1.value(scope);
 605   coerce(result, r1);
 606   case varType(result) of
 607     varSingle, varDouble: result := Double(result)/Double(r1);
 608     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result) div LongInt(r1);
 609     varInt64: result := Int64(result) div Int64(r1);
 610     else error();
 611   end;
 612 end;
 613 function TBinExprDiv.toString (): AnsiString; begin result := '('+mOp0.toString()+'/'+mOp1.toString+')'; end;
 614
 615 function TBinExprMod.value (scope: TExprScope): Variant;
 616 var
 617   r1: Variant;
 618 begin
 619   result := mOp0.value(scope);
 620   r1 := mOp1.value(scope);
 621   coerce(result, r1);
 622   case varType(result) of
 623     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result) mod LongInt(r1);
 624     varInt64: result := Int64(result) mod Int64(r1);
 625     else error();
 626   end;
 627 end;
 628 function TBinExprMod.toString (): AnsiString; begin result := '('+mOp0.toString()+'%'+mOp1.toString+')'; end;
 629
 630 function TBinExprLogAnd.value (scope: TExprScope): Variant;
 631 begin
 632   result := mOp0.value(scope);
 633   if not coerce2bool(result) then begin result := false; exit; end;
 634   result := mOp1.value(scope);
 635   result := coerce2bool(result);
 636 end;
 637 function TBinExprLogAnd.toString (): AnsiString; begin result := '('+mOp0.toString()+'&&'+mOp1.toString+')'; end;
 638
 639 function TBinExprLogOr.value (scope: TExprScope): Variant;
 640 begin
 641   result := mOp0.value(scope);
 642   if coerce2bool(result) then begin result := true; exit; end;
 643   result := mOp1.value(scope);
 644   result := coerce2bool(result);
 645 end;
 646 function TBinExprLogOr.toString (): AnsiString; begin result := '('+mOp0.toString()+'||'+mOp1.toString+')'; end;
 647
 648 function TBinExprCmpLess.value (scope: TExprScope): Variant;
 649 var
 650   r1: Variant;
 651 begin
 652   result := mOp0.value(scope);
 653   r1 := mOp1.value(scope);
 654   coerce(result, r1);
 655   case varType(result) of
 656     varSingle, varDouble: result := Boolean(Double(result) < Double(r1));
 657     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) < LongInt(r1));
 658     varInt64: result := Boolean(Int64(result) < Int64(r1));
 659     varString: result := Boolean(AnsiString(result) < AnsiString(r1));
 660     else error();
 661   end;
 662 end;
 663 function TBinExprCmpLess.toString (): AnsiString; begin result := '('+mOp0.toString()+'<'+mOp1.toString+')'; end;
 664
 665 function TBinExprCmpGreat.value (scope: TExprScope): Variant;
 666 var
 667   r1: Variant;
 668 begin
 669   result := mOp0.value(scope);
 670   r1 := mOp1.value(scope);
 671   coerce(result, r1);
 672   case varType(result) of
 673     varSingle, varDouble: result := Boolean(Double(result) > Double(r1));
 674     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) > LongInt(r1));
 675     varInt64: result := Boolean(Int64(result) > Int64(r1));
 676     varString: result := Boolean(AnsiString(result) > AnsiString(r1));
 677     else error();
 678   end;
 679 end;
 680 function TBinExprCmpGreat.toString (): AnsiString; begin result := '('+mOp0.toString()+'>'+mOp1.toString+')'; end;
 681
 682 function TBinExprCmpLessEqu.value (scope: TExprScope): Variant;
 683 var
 684   r1: Variant;
 685 begin
 686   result := mOp0.value(scope);
 687   r1 := mOp1.value(scope);
 688   coerce(result, r1);
 689   case varType(result) of
 690     varSingle, varDouble: result := Boolean(Double(result) <= Double(r1));
 691     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) <= LongInt(r1));
 692     varInt64: result := Boolean(Int64(result) <= Int64(r1));
 693     varString: result := Boolean(AnsiString(result) <= AnsiString(r1));
 694     else error();
 695   end;
 696 end;
 697 function TBinExprCmpLessEqu.toString (): AnsiString; begin result := '('+mOp0.toString()+'<='+mOp1.toString+')'; end;
 698
 699 function TBinExprCmpGreatEqu.value (scope: TExprScope): Variant;
 700 var
 701   r1: Variant;
 702 begin
 703   result := mOp0.value(scope);
 704   r1 := mOp1.value(scope);
 705   coerce(result, r1);
 706   case varType(result) of
 707     varSingle, varDouble: result := Boolean(Double(result) >= Double(r1));
 708     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) >= LongInt(r1));
 709     varInt64: result := Boolean(Int64(result) >= Int64(r1));
 710     varString: result := Boolean(AnsiString(result) >= AnsiString(r1));
 711     else error();
 712   end;
 713 end;
 714 function TBinExprCmpGreatEqu.toString (): AnsiString; begin result := '('+mOp0.toString()+'>='+mOp1.toString+')'; end;
 715
 716 function TBinExprCmpEqu.value (scope: TExprScope): Variant;
 717 var
 718   r1: Variant;
 719 begin
 720   result := mOp0.value(scope);
 721   r1 := mOp1.value(scope);
 722   coerce(result, r1);
 723   case varType(result) of
 724     varSingle, varDouble: result := Boolean(Double(result) = Double(r1));
 725     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) = LongInt(r1));
 726     varInt64: result := Boolean(Int64(result) = Int64(r1));
 727     varString: result := Boolean(AnsiString(result) = AnsiString(r1));
 728     varBoolean: result := (Boolean(result) = Boolean(r1));
 729     varQWord: result := (UInt64(result) = UInt64(r1));
 730     else error();
 731   end;
 732 end;
 733 function TBinExprCmpEqu.toString (): AnsiString; begin result := '('+mOp0.toString()+'=='+mOp1.toString+')'; end;
 734
 735 function TBinExprCmpNotEqu.value (scope: TExprScope): Variant;
 736 var
 737   r1: Variant;
 738 begin
 739   result := mOp0.value(scope);
 740   r1 := mOp1.value(scope);
 741   coerce(result, r1);
 742   case varType(result) of
 743     varSingle, varDouble: result := Boolean(Double(result) <> Double(r1));
 744     varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) <> LongInt(r1));
 745     varInt64: result := Boolean(Int64(result) <> Int64(r1));
 746     varString: result := Boolean(AnsiString(result) <> AnsiString(r1));
 747     varBoolean: result := (Boolean(result) <> Boolean(r1));
 748     varQWord: result := (UInt64(result) <> UInt64(r1));
 749     else error();
 750   end;
 751 end;
 752 function TBinExprCmpNotEqu.toString (): AnsiString; begin result := '('+mOp0.toString()+'<>'+mOp1.toString+')'; end;
 753
 754
 755 // ////////////////////////////////////////////////////////////////////////// //
 756 function TBinAssign.value (scope: TExprScope): Variant;
 757 begin
 758   result := mOp1.value(scope);
 759   mOp0.assign(scope, result);
 760 end;
 761
 762 function TBinAssign.toString (): AnsiString; begin result := mOp0.toString()+'='+mOp1.toString(); end;
 763
 764
 765 // ////////////////////////////////////////////////////////////////////////// //
 766 class function TExprBase.parse (const str: AnsiString; allowAssign: Boolean=false): TExprBase;
 767 var
 768   pr: TTextParser;
 769 begin
 770   pr := TStrTextParser.Create(str);
 771   try
 772     result := parse(pr, allowAssign);
 773     if (pr.tokType <> pr.TTEOF) then begin result.Free(); error(); end;
 774   finally
 775     pr.Free();
 776   end;
 777 end;
 778
 779 class function TExprBase.parseStatList (const str: AnsiString): TExprBase;
 780 var
 781   pr: TTextParser;
 782   r: TExprStatList;
 783   e: TExprBase;
 784 begin
 785   pr := TStrTextParser.Create(str);
 786   if (pr.tokType = pr.TTEOF) then begin pr.Free(); result := nil; exit; end;
 787   r := TExprStatList.Create();
 788   result := nil;
 789   try
 790     while true do
 791     begin
 792       while pr.eatTT(pr.TTSemi) do begin end;
 793       if (pr.tokType = pr.TTEOF) then break;
 794       e := parse(pr, true);
 795       if (e = nil) then break;
 796       SetLength(r.mList, Length(r.mList)+1);
 797       r.mList[High(r.mList)] := e;
 798       if (pr.tokType = pr.TTEOF) then break;
 799       pr.expectTT(pr.TTSemi);
 800     end;
 801     result := r;
 802     r := nil;
 803   finally
 804     r.Free();
 805     pr.Free();
 806   end;
 807 end;
 808
 809
 810 class function TExprBase.parse (pr: TTextParser; allowAssign: Boolean=false): TExprBase;
 811
 812   function expr (): TExprBase; forward;
 813
 814   function doTerm (): TExprBase;
 815   begin
 816     result := nil;
 817     try
 818       if pr.eatDelim('(') then begin result := expr(); pr.expectDelim(')'); exit; end;
 819       if pr.eatDelim('!') then begin result := expr(); result := TUnExprNot.Create(result); exit; end;
 820       if pr.eatDelim('-') then begin result := expr(); result := TUnExprNeg.Create(result); exit; end;
 821       if pr.eatDelim('+') then begin result := expr(); exit; end;
 822       if (pr.tokType = pr.TTInt) then begin result := TLitExpr.Create(pr.expectInt()); exit; end;
 823       if (pr.tokType = pr.TTStr) then begin result := TLitExpr.Create(pr.expectStr(true)); exit; end;
 824       if (pr.tokType = pr.TTId) then
 825       begin
 826         if (pr.tokStr = 'true') then begin result := TLitExpr.Create(true); pr.skipToken(); exit; end;
 827         if (pr.tokStr = 'false') then begin result := TLitExpr.Create(false); pr.skipToken(); exit; end;
 828         if (CompareText(pr.tokStr, 'true') = 0) or (CompareText(pr.tokStr, 'false') = 0) then error();
 829         result := TObjExpr.Create(pr.expectId());
 830         while (pr.tokType = pr.TTDelim) and (pr.tokChar = '.') do
 831         begin
 832           pr.skipToken();
 833           result := TDotExpr.Create(result, pr.expectId());
 834         end;
 835         exit;
 836       end;
 837     except
 838       result.Free();
 839       raise;
 840     end;
 841     error();
 842   end;
 843
 844   function doMulDiv (): TExprBase;
 845   begin
 846     result := doTerm();
 847     try
 848       while true do
 849       begin
 850              if pr.eatDelim('*') then result := TBinExprMul.Create(result, doTerm())
 851         else if pr.eatDelim('/') then result := TBinExprDiv.Create(result, doTerm())
 852         else if pr.eatDelim('%') then result := TBinExprMod.Create(result, doTerm())
 853         else break;
 854       end;
 855     except
 856       result.Free();
 857       raise;
 858     end;
 859   end;
 860
 861   function doPlusMinus (): TExprBase;
 862   begin
 863     result := doMulDiv();
 864     try
 865       while true do
 866       begin
 867              if pr.eatDelim('+') then result := TBinExprAdd.Create(result, doMulDiv())
 868         else if pr.eatDelim('-') then result := TBinExprSub.Create(result, doMulDiv())
 869         else break;
 870       end;
 871     except
 872       result.Free();
 873       raise;
 874     end;
 875   end;
 876
 877   function doCmp (): TExprBase;
 878   begin
 879     result := doPlusMinus();
 880     try
 881       while true do
 882       begin
 883              if pr.eatDelim('<') then result := TBinExprCmpLess.Create(result, doPlusMinus())
 884         else if pr.eatDelim('>') then result := TBinExprCmpGreat.Create(result, doPlusMinus())
 885         else if pr.eatTT(pr.TTLessEqu) then result := TBinExprCmpLessEqu.Create(result, doPlusMinus())
 886         else if pr.eatTT(pr.TTGreatEqu) then result := TBinExprCmpGreatEqu.Create(result, doPlusMinus())
 887         else break;
 888       end;
 889     except
 890       result.Free();
 891       raise;
 892     end;
 893   end;
 894
 895   function doCmpEqu (): TExprBase;
 896   begin
 897     result := doCmp();
 898     try
 899       while true do
 900       begin
 901              if pr.eatTT(pr.TTEqu) then result := TBinExprCmpEqu.Create(result, doCmp())
 902         else if pr.eatTT(pr.TTNotEqu) then result := TBinExprCmpNotEqu.Create(result, doCmp())
 903         else break;
 904       end;
 905     except
 906       result.Free();
 907       raise;
 908     end;
 909   end;
 910
 911   function doLogAnd (): TExprBase;
 912   begin
 913     result := doCmpEqu();
 914     try
 915       while true do
 916       begin
 917         if pr.eatTT(pr.TTLogAnd) then result := TBinExprLogAnd.Create(result, doCmpEqu()) else break;
 918       end;
 919     except
 920       result.Free();
 921       raise;
 922     end;
 923   end;
 924
 925   function doLogOr (): TExprBase;
 926   begin
 927     result := doLogAnd();
 928     try
 929       while true do
 930       begin
 931         if pr.eatTT(pr.TTLogOr) then result := TBinExprLogOr.Create(result, doLogAnd()) else break;
 932       end;
 933     except
 934       result.Free();
 935       raise;
 936     end;
 937   end;
 938
 939   // funcall, [], dot
 940   // !, ~
 941   // *, /, %
 942   // +, -
 943   // <<, >>
 944   // <, <=, >, >=
 945   // ==, !=
 946   // &
 947   // ^
 948   // |
 949   // &&
 950   // ||
 951
 952   function expr (): TExprBase;
 953   var
 954     neg: Boolean = false;
 955   begin
 956          if pr.eatDelim('-') then neg := true
 957     else if pr.eatDelim('+') then neg := false;
 958     result := doLogOr();
 959     if neg then result := TUnExprNeg.Create(result);
 960   end;
 961
 962 var
 963   oas: Boolean;
 964 begin
 965   if (pr = nil) or (pr.tokType = pr.TTEOF) then begin result := nil; exit; end;
 966   oas := pr.allowSignedNumbers;
 967   pr.allowSignedNumbers := false;
 968   try
 969     result := expr();
 970     if allowAssign and pr.eatDelim('=') then
 971     try
 972       result := TBinAssign.Create(result, expr());
 973     except
 974       result.Free();
 975     end;
 976   finally
 977     pr.allowSignedNumbers := oas;
 978   end;
 979 end;
 980
 981
 982 {
 983     varEmpty:
 984     varNull:
 985     varSingle:
 986     varDouble:
 987     varDecimal:
 988     varCurrency:
 989     varDate:
 990     varOleStr:
 991     varStrArg:
 992     varString:
 993     varDispatch:
 994     varBoolean:
 995     varVariant:
 996     varUnknown:
 997     varShortInt:
 998     varSmallint:
 999     varInteger:
1000     varInt64:
1001     varByte:
1002     varWord:
1003     varLongWord:
1004     varQWord:
1005     varError:
1006 }
1007 end.