DEADSOFTWARE

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