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