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}
19 interface
21 uses
25 // ////////////////////////////////////////////////////////////////////////// //
26 type
28 public
34 public
37 public
42 // ////////////////////////////////////////////////////////////////////////// //
43 type
45 private
51 public
60 // ////////////////////////////////////////////////////////////////////////// //
61 type
63 public
69 // ////////////////////////////////////////////////////////////////////////// //
70 type
72 public
82 public
85 public
90 class procedure parseErrorFmt (pr: TTextParser; const afmt: AnsiString; const args: array of const);
92 class function parse (clist: TExprConstList; pr: TTextParser; allowAssign: Boolean=false): TExprBase;
93 class function parse (clist: TExprConstList; const str: AnsiString; allowAssign: Boolean=false): TExprBase;
101 public
108 private
110 public
120 private
122 public
131 private
133 public
145 private
147 public
154 public
160 public
166 private
169 public
178 private
180 private
182 public
188 TBinExprAdd = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
189 TBinExprSub = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
190 TBinExprMul = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
191 TBinExprDiv = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
192 TBinExprMod = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
194 TBinExprLogAnd = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
195 TBinExprLogOr = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
197 TBinExprCmpLess = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
198 TBinExprCmpGreat = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
199 TBinExprCmpLessEqu = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
200 TBinExprCmpGreatEqu = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
201 TBinExprCmpEqu = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
202 TBinExprCmpNotEqu = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
204 TBinAssign = class(TBinExpr) public function value (scope: TExprScope): Variant; override; function toString (): AnsiString; override; end;
207 private
209 public
218 // ////////////////////////////////////////////////////////////////////////// //
222 implementation
224 uses
225 utils;
228 // ////////////////////////////////////////////////////////////////////////// //
230 begin
235 begin
240 // ////////////////////////////////////////////////////////////////////////// //
242 begin
243 if (pr <> nil) then begin tokLine := pr.tokLine; tokCol := pr.tokCol; end else begin tokLine := 0; tokCol := 0; end;
247 constructor TExomaParseException.CreateFmt (pr: TTextParser; const afmt: AnsiString; const args: array of const);
248 begin
249 if (pr <> nil) then begin tokLine := pr.tokLine; tokCol := pr.tokCol; end else begin tokLine := 0; tokCol := 0; end;
254 // ////////////////////////////////////////////////////////////////////////// //
256 begin
293 // ////////////////////////////////////////////////////////////////////////// //
294 (*
295 procedure dumpPublishedProperties (obj: TObject);
296 var
297 pt: PTypeData;
298 pi: PTypeInfo;
299 i, j: Integer;
300 pp: PPropList;
301 begin
302 if (obj = nil) then exit;
303 //e_LogWritefln('Object of type ''%s'':', [obj.ClassName]);
304 pi := obj.ClassInfo;
305 pt := GetTypeData(pi);
306 //e_LogWritefln('property count: %s', [pt.PropCount]);
307 GetMem(pp, pt^.PropCount*sizeof(Pointer));
308 try
309 j := GetPropList(pi, [tkInteger, tkBool, tkSString, tkLString, tkAString, tkSet, tkEnumeration], pp);
310 //e_LogWritefln('ordinal property count: %s', [j]);
311 for i := 0 to j-1 do
312 begin
313 {
314 if (typinfo.PropType(obj, pp^[i].name) in [tkSString, tkLString, tkAString]) then
315 begin
316 e_LogWritefln(' #%s: <%s>; type: %s; value: <%s>', [i+1, pp^[i].name, typeKind2Str(typinfo.PropType(obj, pp^[i].name)), GetStrProp(obj, pp^[i])]);
317 end
318 else if (typinfo.PropType(obj, pp^[i].name) = tkSet) then
319 begin
320 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)]);
321 end
322 else if (typinfo.PropType(obj, pp^[i].name) = tkEnumeration) then
323 begin
324 e_LogWritefln(' #%s: <%s>; type: %s; value: <%s>', [i+1, pp^[i].name, typeKind2Str(typinfo.PropType(obj, pp^[i].name)), GetEnumProp(obj, pp^[i])]);
325 end
326 else
327 begin
328 e_LogWritefln(' #%s: <%s>; type: %s; value: %s', [i+1, pp^[i].name, typeKind2Str(typinfo.PropType(obj, pp^[i].name)), GetOrdProp(obj, pp^[i])]);
329 end;
330 }
331 end;
332 finally
333 FreeMem(pp);
334 end;
335 end;
336 *)
339 // ////////////////////////////////////////////////////////////////////////// //
341 var
346 begin
352 pc := GetPropList(pi, [tkInteger, tkBool, tkSString, tkLString, tkAString, {tkSet,} tkEnumeration], pl);
354 begin
356 begin
362 end
363 else
364 begin
371 begin
381 var
383 begin
386 begin
393 //tkFloat: result := 'Float';
394 //tkClass: result := 'Class';
395 //tkInt64: result := 'Int64';
396 //tkClassRef: result := 'ClassRef';
405 var
407 begin
410 begin
415 tkBool: if TExprBase.coerce2bool(v) then SetOrdProp(obj, pl^[idx], 1) else SetOrdProp(obj, pl^[idx], 0);
417 //tkFloat: result := 'Float';
418 //tkClass: result := 'Class';
419 //tkInt64: result := 'Int64';
420 //tkClassRef: result := 'ClassRef';
428 // ////////////////////////////////////////////////////////////////////////// //
429 class procedure TExprScope.error (const amsg: AnsiString); begin raise TExomaException.Create(amsg); end;
430 class procedure TExprScope.errorfmt (const afmt: AnsiString; const args: array of const); begin raise TExomaException.CreateFmt(afmt, args); end;
432 function TExprScope.getObj (const aname: AnsiString): TObject; begin result := nil; errorfmt('unknown object ''%s''', [aname]); end;
433 function TExprScope.getField (obj: TObject; const afldname: AnsiString): Variant; begin result := Unassigned; errorfmt('unknown field ''%s''', [afldname]); end;
434 procedure TExprScope.setField (obj: TObject; const afldname: AnsiString; var aval: Variant); begin errorfmt('unknown field ''%s''', [afldname]); end;
437 // ////////////////////////////////////////////////////////////////////////// //
438 class procedure TExprBase.error (const amsg: AnsiString); begin raise TExomaException.Create(amsg); end;
439 class procedure TExprBase.errorfmt (const afmt: AnsiString; const args: array of const); begin raise TExomaException.CreateFmt(afmt, args); end;
441 class procedure TExprBase.parseError (pr: TTextParser; const amsg: AnsiString); begin raise TExomaParseException.Create(pr, amsg); end;
442 class procedure TExprBase.parseErrorFmt (pr: TTextParser; const afmt: AnsiString; const args: array of const); begin raise TExomaParseException.CreateFmt(pr, afmt, args); end;
445 begin
453 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := (LongInt(v0) <> 0);
461 begin
469 begin
477 begin
482 begin
487 begin
498 procedure TExprBase.assign (scope: TExprScope; var v: Variant); begin error('not an lvalue'); end;
501 // ////////////////////////////////////////////////////////////////////////// //
503 destructor TExprStatList.Destroy (); var f: Integer; begin for f := 0 to High(mList) do mList[f].Free(); mList := nil; end;
506 begin
508 begin
515 var
517 begin
522 var
524 begin
529 var
532 begin
536 try
538 except
545 // ////////////////////////////////////////////////////////////////////////// //
550 begin
555 function TExprCond.toString (): AnsiString; begin result := '('+mCond.toString()+'?'+mTrue.toString()+':'+mFalse.toString()+')'; end;
558 begin
566 // ////////////////////////////////////////////////////////////////////////// //
568 function TObjExpr.value (scope: TExprScope): Variant; begin result := UInt64(PtrUInt(Pointer(scope.getObj(mName)))); end;
573 // ////////////////////////////////////////////////////////////////////////// //
579 function TLitExpr.toString (): AnsiString; begin result := VarToStr(mValue); if isStr(mValue) then result := quoteStr(result); end;
580 function TLitExpr.clone (): TExprBase; begin result := TLitExpr.Create(0); (result as TLitExpr).mValue := mValue; end;
583 // ////////////////////////////////////////////////////////////////////////// //
586 function TUnExpr.clone (): TExprBase; begin result := (self.ClassType.Create() as TUnExpr); (result as TUnExpr).mOp0 := mOp0.clone(); end;
589 begin
604 begin
612 // ////////////////////////////////////////////////////////////////////////// //
614 begin
620 begin
622 if (varType(result) <> varQWord) then errorfmt('can''t take field ''%s'' value of non-object', [mField]);
627 var
629 begin
631 if (varType(o) <> varQWord) then errorfmt('can''t assign value to field ''%s'' of non-object', [mField]);
640 // ////////////////////////////////////////////////////////////////////////// //
643 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 begin
648 begin
650 begin
661 end
663 begin
670 end
672 begin
681 end
682 else
683 begin
690 // ////////////////////////////////////////////////////////////////////////// //
692 var
694 begin
701 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result)+LongInt(r1);
706 function TBinExprAdd.toString (): AnsiString; begin result := '('+mOp0.toString()+'+'+mOp1.toString+')'; end;
709 var
711 begin
717 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result)-LongInt(r1);
722 function TBinExprSub.toString (): AnsiString; begin result := '('+mOp0.toString()+'-'+mOp1.toString+')'; end;
725 var
727 begin
733 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result)*LongInt(r1);
738 function TBinExprMul.toString (): AnsiString; begin result := '('+mOp0.toString()+'*'+mOp1.toString+')'; end;
741 var
743 begin
749 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result) div LongInt(r1);
754 function TBinExprDiv.toString (): AnsiString; begin result := '('+mOp0.toString()+'/'+mOp1.toString+')'; end;
757 var
759 begin
764 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := LongInt(result) mod LongInt(r1);
769 function TBinExprMod.toString (): AnsiString; begin result := '('+mOp0.toString()+'%'+mOp1.toString+')'; end;
772 begin
778 function TBinExprLogAnd.toString (): AnsiString; begin result := '('+mOp0.toString()+'&&'+mOp1.toString+')'; end;
781 begin
787 function TBinExprLogOr.toString (): AnsiString; begin result := '('+mOp0.toString()+'||'+mOp1.toString+')'; end;
790 var
792 begin
798 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) < LongInt(r1));
804 function TBinExprCmpLess.toString (): AnsiString; begin result := '('+mOp0.toString()+'<'+mOp1.toString+')'; end;
807 var
809 begin
815 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) > LongInt(r1));
821 function TBinExprCmpGreat.toString (): AnsiString; begin result := '('+mOp0.toString()+'>'+mOp1.toString+')'; end;
824 var
826 begin
832 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) <= LongInt(r1));
838 function TBinExprCmpLessEqu.toString (): AnsiString; begin result := '('+mOp0.toString()+'<='+mOp1.toString+')'; end;
841 var
843 begin
849 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) >= LongInt(r1));
855 function TBinExprCmpGreatEqu.toString (): AnsiString; begin result := '('+mOp0.toString()+'>='+mOp1.toString+')'; end;
858 var
860 begin
866 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) = LongInt(r1));
874 function TBinExprCmpEqu.toString (): AnsiString; begin result := '('+mOp0.toString()+'=='+mOp1.toString+')'; end;
877 var
879 begin
885 varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord: result := Boolean(LongInt(result) <> LongInt(r1));
893 function TBinExprCmpNotEqu.toString (): AnsiString; begin result := '('+mOp0.toString()+'<>'+mOp1.toString+')'; end;
896 // ////////////////////////////////////////////////////////////////////////// //
898 begin
903 function TBinAssign.toString (): AnsiString; begin result := mOp0.toString()+'='+mOp1.toString(); end;
906 // ////////////////////////////////////////////////////////////////////////// //
907 class function TExprBase.parse (clist: TExprConstList; const str: AnsiString; allowAssign: Boolean=false): TExprBase;
908 var
910 begin
912 try
914 if (pr.tokType <> pr.TTEOF) then begin result.Free(); parseError(pr, 'extra code in expression'); end;
915 finally
920 class function TExprBase.parseStatList (clist: TExprConstList; const str: AnsiString): TExprBase;
921 var
925 begin
930 try
931 try
933 begin
938 //writeln(': ', e.toString());
941 //writeln('tt=', pr.tokType, ' <', pr.tokStr, '>');
942 //writeln(r.toString());
947 except
952 else
955 finally
962 class function TExprBase.parse (clist: TExprConstList; pr: TTextParser; allowAssign: Boolean=false): TExprBase;
967 var
970 begin
972 try
974 if pr.eatDelim('!') then begin result := doTerm(); result := TUnExprNot.Create(result); exit; end;
976 if pr.eatDelim('-') then begin result := doTerm(); result := TUnExprNeg.Create(result); exit; end;
980 begin
982 if (pr.tokStr = 'false') then begin result := TLitExpr.Create(false); pr.skipToken(); exit; end;
983 if (CompareText(pr.tokStr, 'true') = 0) or (CompareText(pr.tokStr, 'false') = 0) then parseError(pr, '`true` and `false` are case-sensitive');
986 begin
988 begin
990 exit;
996 begin
1000 exit;
1002 except
1010 begin
1012 try
1014 begin
1020 except
1027 begin
1029 try
1031 begin
1036 except
1043 begin
1045 try
1047 begin
1051 else if pr.eatTT(pr.TTGreatEqu) then result := TBinExprCmpGreatEqu.Create(result, doPlusMinus())
1054 except
1061 begin
1063 try
1065 begin
1070 except
1077 begin
1079 try
1081 begin
1084 except
1091 begin
1093 try
1095 begin
1098 except
1104 // funcall, [], dot
1105 // !, ~
1106 // *, /, %
1107 // +, -
1108 // <<, >>
1109 // <, <=, >, >=
1110 // ==, !=
1111 // &
1112 // ^
1113 // |
1114 // &&
1115 // ||
1118 var
1122 begin
1124 try
1126 begin
1134 begin
1136 break;
1138 //assert(false);
1140 begin
1147 except
1154 var
1156 begin
1158 // ternary
1160 begin
1163 try
1168 except
1174 var
1176 begin
1179 try
1181 try
1183 finally
1186 except
1191 else
1197 {
1198 varEmpty:
1199 varNull:
1200 varSingle:
1201 varDouble:
1202 varDecimal:
1203 varCurrency:
1204 varDate:
1205 varOleStr:
1206 varStrArg:
1207 varString:
1208 varDispatch:
1209 varBoolean:
1210 varVariant:
1211 varUnknown:
1212 varShortInt:
1213 varSmallint:
1214 varInteger:
1215 varInt64:
1216 varByte:
1217 varWord:
1218 varLongWord:
1219 varQWord:
1220 varError:
1221 }