2060 lines
54 KiB
ObjectPascal
2060 lines
54 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastScript v1.9 }
|
|
{ Intermediate Language parser }
|
|
{ }
|
|
{ (c) 2003-2007 by Alexander Tzyganenko, }
|
|
{ Fast Reports Inc }
|
|
{ }
|
|
{******************************************}
|
|
|
|
//VCL uses section
|
|
{$IFNDEF FMX}
|
|
unit fs_iilparser;
|
|
|
|
interface
|
|
|
|
{$i fs.inc}
|
|
|
|
uses
|
|
SysUtils, Classes, fs_iinterpreter, fs_iparser, fs_iexpression, fs_xml
|
|
{$IFDEF Delphi6}
|
|
, Variants
|
|
{$ENDIF};
|
|
{$ELSE}
|
|
interface
|
|
|
|
{$i fmx.inc}
|
|
{$i fs.inc}
|
|
|
|
uses
|
|
System.SysUtils, System.Classes, FMX.fs_iinterpreter, FMX.fs_iparser, FMX.fs_iexpression, FMX.fs_xml, System.Variants;
|
|
{$ENDIF}
|
|
|
|
|
|
type
|
|
TfsEmitOp = (emNone, emCreate, emFree);
|
|
|
|
{ TfsILParser performs the syntax analyze of source code. Source code
|
|
can be on ANY language. Grammars are stored in the XML file and
|
|
can be easily changed to support any structured language. Currently
|
|
supported languages are Pascal, C++, Basic and Java subsets.
|
|
|
|
The result of the analyze (function MakeScript) is the output XML script
|
|
(called Intermediate Language). This output processed by the ParseILScript
|
|
method. This method creates the program structure (defined in the
|
|
fs_Interpreter unit) and fills it by the data }
|
|
|
|
TfsILParser = class(TObject)
|
|
private
|
|
FErrorPos: String;
|
|
FGrammar: TfsXMLDocument;
|
|
FILScript: TfsXMLDocument;
|
|
FLangName: String;
|
|
FNeedDeclareVars: Boolean;
|
|
FParser: TfsParser;
|
|
FProgram: TfsScript;
|
|
FProgRoot: TfsXMLItem;
|
|
FRoot: TfsXMLItem;
|
|
FUnitName: String;
|
|
FUsesList: TStrings;
|
|
FWithList: TStringList;
|
|
function PropPos(xi: TfsXMLItem): String;
|
|
procedure ErrorPos(xi: TfsXMLItem);
|
|
procedure CheckIdent(Prog: TfsScript; const Name: String);
|
|
function FindClass(const TypeName: String): TfsClassVariable;
|
|
procedure CheckTypeCompatibility(Var1, Var2: TfsCustomVariable);
|
|
function FindVar(Prog: TfsScript; const Name: String): TfsCustomVariable;
|
|
function FindType(s: String): TfsVarType;
|
|
function CreateVar(xi: TfsXMLItem; Prog: TfsScript; const Name: String;
|
|
Statement: TfsStatement = nil; CreateParam: Boolean = False;
|
|
IsVarParam: Boolean = False): TfsCustomVariable;
|
|
function DoSet(xi: TfsXMLItem; Prog: TfsScript): TfsSetExpression;
|
|
function DoExpression(xi: TfsXMLItem; Prog: TfsScript): TfsExpression;
|
|
procedure DoUses(xi: TfsXMLItem; Prog: TfsScript);
|
|
procedure DoVar(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoConst(xi: TfsXMLItem; Prog: TfsScript);
|
|
procedure DoParameters(xi: TfsXMLItem; v: TfsProcVariable);
|
|
procedure DoProc1(xi: TfsXMLItem; Prog: TfsScript);
|
|
procedure DoProc2(xi: TfsXMLItem; Prog: TfsScript);
|
|
procedure DoFunc1(xi: TfsXMLItem; Prog: TfsScript);
|
|
procedure DoFunc2(xi: TfsXMLItem; Prog: TfsScript);
|
|
procedure DoAssign(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoCall(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoIf(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoVbFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoCppFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoWhile(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoRepeat(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoCase(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoTry(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoBreak(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoContinue(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoExit(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoReturn(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoWith(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoDelete(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoCompoundStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
procedure DoProgram(xi: TfsXMLItem; Prog: TfsScript);
|
|
public
|
|
constructor Create(AProgram: TfsScript);
|
|
destructor Destroy; override;
|
|
|
|
procedure SelectLanguage(const LangName: String);
|
|
{ convert the input script to the Intermediate Language }
|
|
function MakeILScript(const Text: String): Boolean;
|
|
{ parse IL }
|
|
procedure ParseILScript;
|
|
{ this method is needed here to implement late-binding }
|
|
function DoDesignator(xi: TfsXMLItem; Prog: TfsScript;
|
|
EmitOp: TfsEmitOp = emNone): TfsDesignator;
|
|
property ILScript: TfsXMLDocument read FILScript;
|
|
end;
|
|
|
|
|
|
implementation
|
|
//VCL uses section
|
|
{$IFNDEF FMX}
|
|
uses fs_itools, fs_iconst
|
|
{$IFDEF CROSS_COMPILE}
|
|
, Types
|
|
{$ELSE}
|
|
, Windows
|
|
{$ENDIF}
|
|
{$IFDEF OLE}
|
|
, fs_idisp
|
|
{$ENDIF};
|
|
//FMX uses section
|
|
{$ELSE}
|
|
uses FMX.fs_itools, FMX.fs_iconst, System.Types, FMX.Types
|
|
{$IFDEF OLE}
|
|
, fs_idisp
|
|
{$ENDIF};
|
|
{$ENDIF}
|
|
|
|
|
|
{ TfsILParser }
|
|
|
|
constructor TfsILParser.Create(AProgram: TfsScript);
|
|
begin
|
|
FNeedDeclareVars := True;
|
|
FProgram := AProgram;
|
|
FGrammar := TfsXMLDocument.Create;
|
|
FILScript := TfsXMLDocument.Create;
|
|
FParser := TfsParser.Create;
|
|
FUsesList := TStringList.Create;
|
|
FWithList := TStringList.Create;
|
|
end;
|
|
|
|
destructor TfsILParser.Destroy;
|
|
begin
|
|
FGrammar.Free;
|
|
FILScript.Free;
|
|
FParser.Free;
|
|
FUsesList.Free;
|
|
FWithList.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsILParser.SelectLanguage(const LangName: String);
|
|
var
|
|
i: Integer;
|
|
Name, PropText: String;
|
|
xi: TfsXMLItem;
|
|
ParserRoot: TfsXMLItem;
|
|
ss: TStringStream;
|
|
begin
|
|
FParser.Clear;
|
|
FLangName := LangName;
|
|
ss := TStringStream.Create(fsGetLanguage(LangName));
|
|
try
|
|
FGrammar.LoadFromStream(ss);
|
|
finally
|
|
ss.Free;
|
|
end;
|
|
|
|
FRoot := FGrammar.Root;
|
|
ParserRoot := FRoot.FindItem('parser');
|
|
|
|
xi := ParserRoot.FindItem('keywords');
|
|
for i := 0 to xi.Count - 1 do
|
|
FParser.Keywords.Add(xi[i].Name);
|
|
for i := 0 to ParserRoot.Count - 1 do
|
|
begin
|
|
Name := LowerCase(ParserRoot[i].Name);
|
|
PropText := ParserRoot[i].Prop['text'];
|
|
if Name = 'identchars' then
|
|
FParser.ConstructCharset(PropText)
|
|
else if Name = 'commentline1' then
|
|
FParser.CommentLine1 := PropText
|
|
else if Name = 'commentline2' then
|
|
FParser.CommentLine2 := PropText
|
|
else if Name = 'commentblock1' then
|
|
FParser.CommentBlock1 := PropText
|
|
else if Name = 'commentblock2' then
|
|
FParser.CommentBlock2 := PropText
|
|
else if Name = 'stringquotes' then
|
|
FParser.StringQuotes := PropText
|
|
else if Name = 'hexsequence' then
|
|
FParser.HexSequence := PropText
|
|
else if Name = 'specstrchar' then
|
|
begin
|
|
if PropText = '1' then
|
|
FParser.SpecStrChar := true;
|
|
end
|
|
else if Name = 'declarevars' then
|
|
begin
|
|
if PropText = '0' then
|
|
FNeedDeclareVars := False;
|
|
end
|
|
else if Name = 'skipeol' then
|
|
begin
|
|
if PropText = '0' then
|
|
FParser.SkipEOL := False;
|
|
end
|
|
else if Name = 'skipchar' then
|
|
FParser.SkipChar := PropText
|
|
else if Name = 'casesensitive' then
|
|
begin
|
|
if PropText = '1' then
|
|
FParser.CaseSensitive := True;
|
|
end
|
|
end;
|
|
|
|
if FProgram.ExtendedCharset then
|
|
for i := 128 to 255 do
|
|
FParser.IdentifierCharset := FParser.IdentifierCharset + [Chr(i)];
|
|
end;
|
|
|
|
function TfsILParser.MakeILScript(const Text: String): Boolean;
|
|
var
|
|
FList: TStrings;
|
|
FStream: TStream;
|
|
FErrorMsg: String;
|
|
FErrorPos: String;
|
|
FTermError: Boolean;
|
|
i: Integer;
|
|
|
|
function Run(xi: TfsXMLItem): Boolean;
|
|
var
|
|
i, j, ParsPos, ParsPos1, LoopPos, ListPos: Integer;
|
|
s, NodeName, Token, PropText, PropAdd, PropAddText, PropNode: String;
|
|
Completed, TopLevelNode, Flag: Boolean;
|
|
const
|
|
PathD = {$IFDEF MSWINDOWS} '\'; {$ELSE} '/'; {$ENDIF}
|
|
procedure DoInclude(const Name: String);
|
|
var
|
|
sl: TStringList;
|
|
p: TfsILParser;
|
|
ss: TStringStream;
|
|
s, UnitPath: String;
|
|
idx: Integer;
|
|
begin
|
|
if FUsesList.IndexOf(Name) <> -1 then
|
|
Exit;
|
|
FUsesList.Add(Name);
|
|
sl := TStringList.Create;
|
|
try
|
|
if Assigned(FProgram.OnGetUnit) then
|
|
begin
|
|
s := '';
|
|
FProgram.OnGetUnit(FProgram, Name, s);
|
|
sl.Text := s;
|
|
end
|
|
else
|
|
begin
|
|
UnitPath := '';
|
|
for idx := 0 to FProgram.IncludePath.Count - 1 do
|
|
begin
|
|
UnitPath := FProgram.IncludePath[idx];
|
|
if (UnitPath <> '') and (PathD <> UnitPath[Length(UnitPath)]) then
|
|
UnitPath := UnitPath + PathD;
|
|
if FileExists(UnitPath + Name) then
|
|
break;
|
|
end;
|
|
sl.LoadFromFile(UnitPath + Name);
|
|
end;
|
|
|
|
p := TfsILParser.Create(FProgram);
|
|
p.FUnitName := Name;
|
|
ss := TStringStream.Create(''{$IFDEF Delphi12},TEncoding.UTF8{$ENDIF});
|
|
try
|
|
s := '';
|
|
if sl.Count > 0 then
|
|
begin
|
|
p.SelectLanguage(FLangName);
|
|
p.FUsesList.Assign(FUsesList);
|
|
if p.MakeILScript(sl.Text) then
|
|
begin
|
|
FUsesList.Assign(p.FUsesList);
|
|
p.ILScript.SaveToStream(ss);
|
|
s := ss.DataString;
|
|
Delete(s, 1, Pos('?>', s) + 1);
|
|
end
|
|
else
|
|
begin
|
|
FErrorMsg := FProgram.ErrorMsg;
|
|
FErrorPos := FProgram.ErrorPos;
|
|
if FProgram.ErrorUnit = '' then
|
|
FProgram.ErrorUnit := Name;
|
|
end;
|
|
end;
|
|
|
|
FList.Insert(ListPos, '</uses>');
|
|
FList.Insert(ListPos, s);
|
|
FList.Insert(ListPos, '<uses' + ' unit="' + Name + '">');
|
|
Inc(ListPos, 3);
|
|
finally
|
|
p.Free;
|
|
ss.Free;
|
|
end;
|
|
finally
|
|
sl.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure CheckPropNode(Flag: Boolean);
|
|
var
|
|
i, ParsPos1: Integer;
|
|
s: String;
|
|
begin
|
|
if CompareText(PropNode, 'uses') = 0 then
|
|
begin
|
|
while FList.Count > ListPos do
|
|
begin
|
|
s := FList[FList.Count - 1];
|
|
i := Pos('text="', s);
|
|
Delete(s, 1, i + 5);
|
|
i := Pos('" ', s);
|
|
Delete(s, i, 255);
|
|
DoInclude(Copy(s, 2, Length(s) - 2));
|
|
FList.Delete(FList.Count - 1);
|
|
end;
|
|
end
|
|
else if PropNode <> '' then
|
|
if Flag then
|
|
begin
|
|
ParsPos1 := FParser.Position;
|
|
FParser.Position := ParsPos;
|
|
FParser.SkipSpaces;
|
|
|
|
s := '<' + PropNode + ' pos="' + FParser.GetXYPosition + '"';
|
|
FParser.Position := ParsPos1;
|
|
|
|
if PropNode = 'expr' then
|
|
s := s + ' pos1="' + FParser.GetXYPosition + '"';
|
|
s := s + '>';
|
|
|
|
FList.Insert(ListPos, s);
|
|
FList.Add('</' + PropNode + '>');
|
|
end
|
|
else
|
|
begin
|
|
while FList.Count > ListPos do
|
|
FList.Delete(FList.Count - 1);
|
|
end;
|
|
end;
|
|
|
|
procedure AddError(xi: TfsXMLItem);
|
|
var
|
|
PropErr: String;
|
|
xi1: TfsXMLItem;
|
|
begin
|
|
PropErr := xi.Prop['err'];
|
|
if (PropErr <> '') and (FErrorMsg = '') then
|
|
begin
|
|
xi1 := FRoot.FindItem('parser');
|
|
xi1 := xi1.FindItem('errors');
|
|
FErrorMsg := xi1.FindItem(PropErr).Prop['text'];
|
|
FParser.Position := ParsPos;
|
|
FParser.SkipSpaces;
|
|
FErrorPos := FParser.GetXYPosition;
|
|
FTermError := xi.Prop['term'] = '1';
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Result := True;
|
|
ParsPos := FParser.Position;
|
|
ListPos := FList.Count;
|
|
NodeName := AnsiLowerCase(xi.Name);
|
|
PropText := AnsiLowerCase(xi.Prop['text']);
|
|
PropNode := LowerCase(xi.Prop['node']);
|
|
TopLevelNode := xi.Parent = FRoot;
|
|
|
|
Completed := False;
|
|
Flag := False;
|
|
Token := '';
|
|
|
|
if TopLevelNode then
|
|
Completed := True
|
|
else if NodeName = 'char' then
|
|
begin
|
|
if xi.Prop['skip'] <> '0' then
|
|
FParser.SkipSpaces;
|
|
Token := FParser.GetChar;
|
|
Flag := True;
|
|
end
|
|
else if NodeName = 'keyword' then
|
|
begin
|
|
Token := FParser.GetWord;
|
|
Flag := True;
|
|
end
|
|
else if NodeName = 'ident' then
|
|
begin
|
|
Token := FParser.GetIdent;
|
|
Flag := True;
|
|
end
|
|
else if NodeName = 'number' then
|
|
begin
|
|
Token := FParser.GetNumber;
|
|
Flag := True;
|
|
end
|
|
else if NodeName = 'string' then
|
|
begin
|
|
Token := FParser.GetString;
|
|
Flag := True;
|
|
end
|
|
else if NodeName = 'frstring' then
|
|
begin
|
|
Token := FParser.GetFRString;
|
|
s := FParser.GetXYPosition;
|
|
FList.Add('<dsgn pos="' + s + '">');
|
|
FList.Add('<node text="Get" pos="' + s + '"/>');
|
|
FList.Add('<expr pos="' + s + '">');
|
|
FList.Add('<string text="''' + StrToXML(Token) + '''" pos="' + s + '"/>');
|
|
FList.Add('</expr>');
|
|
FList.Add('</dsgn>');
|
|
Flag := True;
|
|
end
|
|
else if NodeName = 'eol' then
|
|
Completed := FParser.GetEOL
|
|
else if NodeName = 'sequence' then
|
|
Completed := True
|
|
else if (NodeName = 'switch') or (NodeName = 'optionalswitch') then
|
|
begin
|
|
Completed := True;
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
Completed := Run(xi[i]);
|
|
if Completed then
|
|
break;
|
|
end;
|
|
|
|
if not Completed then
|
|
if NodeName <> 'optionalswitch' then
|
|
begin
|
|
Result := False;
|
|
AddError(xi);
|
|
end;
|
|
Exit;
|
|
end
|
|
else if (NodeName = 'loop') or (NodeName = 'optionalloop') then
|
|
begin
|
|
j := 0;
|
|
repeat
|
|
Inc(j);
|
|
Flag := False;
|
|
LoopPos := FParser.Position;
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
Result := Run(xi[i]);
|
|
if not Result then
|
|
begin
|
|
Flag := True;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
{ try loop delimiter }
|
|
ParsPos1 := FParser.Position;
|
|
if Result and (PropText <> '') then
|
|
begin
|
|
FParser.SkipSpaces;
|
|
if FParser.GetChar <> PropText then
|
|
begin
|
|
FParser.Position := ParsPos1;
|
|
Flag := True;
|
|
end;
|
|
end;
|
|
|
|
{ avoid infinity loop }
|
|
if FParser.Position = LoopPos then
|
|
Flag := True;
|
|
until Flag;
|
|
|
|
{ at least one loop was succesful }
|
|
if j > 1 then
|
|
begin
|
|
{ special case - now implemented only in "case" statement }
|
|
if (xi.Prop['skip'] = '1') or FTermError then
|
|
FErrorMsg := '';
|
|
FParser.Position := ParsPos1;
|
|
Result := True;
|
|
end;
|
|
|
|
if NodeName = 'optionalloop' then
|
|
begin
|
|
if not Result then
|
|
FParser.Position := ParsPos;
|
|
Result := True;
|
|
end;
|
|
Exit;
|
|
end
|
|
else if NodeName = 'optional' then
|
|
begin
|
|
for i := 0 to xi.Count - 1 do
|
|
if not Run(xi[i]) then
|
|
begin
|
|
FParser.Position := ParsPos;
|
|
break;
|
|
end;
|
|
Exit;
|
|
end
|
|
else
|
|
begin
|
|
j := FRoot.Find(NodeName);
|
|
if j = -1 then
|
|
raise Exception.Create(SInvalidLanguage);
|
|
|
|
Completed := Run(FRoot[j]);
|
|
end;
|
|
|
|
if Flag then
|
|
begin
|
|
if FParser.CaseSensitive then
|
|
Completed := (Token <> '') and
|
|
((PropText = '') or (Token = PropText))
|
|
else
|
|
Completed := (Token <> '') and
|
|
((PropText = '') or (AnsiCompareText(Token, PropText) = 0));
|
|
end;
|
|
|
|
if not Completed then
|
|
begin
|
|
Result := False;
|
|
AddError(xi);
|
|
end
|
|
else
|
|
begin
|
|
if not TopLevelNode then
|
|
CheckPropNode(True);
|
|
|
|
PropAdd := xi.Prop['add'];
|
|
PropAddText := xi.Prop['addtext'];
|
|
if PropAdd <> '' then
|
|
begin
|
|
if PropAddText = '' then
|
|
s := Token else
|
|
s := PropAddText;
|
|
FList.Add('<' + PropAdd + ' text="' + StrToXML(s) + '" pos="' +
|
|
FParser.GetXYPosition + '"/>');
|
|
end;
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
Result := Run(xi[i]);
|
|
if not Result then
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
if not Result then
|
|
FParser.Position := ParsPos;
|
|
if TopLevelNode then
|
|
CheckPropNode(Result);
|
|
end;
|
|
|
|
begin
|
|
FList := TStringList.Create;
|
|
FErrorMsg := '';
|
|
FErrorPos := '';
|
|
Result := False;
|
|
|
|
try
|
|
FParser.Text := Text;
|
|
|
|
i := 1;
|
|
if FParser.GetChar = '#' then
|
|
begin
|
|
if CompareText(FParser.GetIdent, 'language') = 0 then
|
|
begin
|
|
i := FParser.Position;
|
|
{$IFDEF Windows}
|
|
while (i <= Length(Text)) and (Text[i] <> #13) do
|
|
{$ELSE}
|
|
while (i <= Length(Text)) and (Text[i] <> #10) do
|
|
{$ENDIF}
|
|
Inc(i);
|
|
SelectLanguage(Trim(Copy(Text, FParser.Position, i - FParser.Position)));
|
|
Inc(i, 2);
|
|
end;
|
|
end;
|
|
FParser.Position := i;
|
|
|
|
if Run(FRoot.FindItem('program')) and (FErrorMsg = '') then
|
|
begin
|
|
FErrorMsg := '';
|
|
FErrorPos := '';
|
|
FStream := TMemoryStream.Create;
|
|
try
|
|
FList.Insert(0, '<?xml version="1.0"?>');
|
|
FList.Insert(1, '<program>');
|
|
FList.Add('</program>');
|
|
FList.SaveToStream(FStream{$IFDEF Delphi12}, TEncoding.UTF8{$ENDIF});
|
|
{$IFDEF Delphi12}
|
|
FStream.Position := 3;
|
|
{$ELSE}
|
|
FStream.Position := 0;
|
|
{$ENDIF}
|
|
FILScript.LoadFromStream(FStream);
|
|
FILScript.Root.Add.Assign(FRoot.FindItem('types'));
|
|
// uncomment the following lines to see what is IL script
|
|
// FILScript.AutoIndent := True;
|
|
// FILScript.SaveToFile(ExtractFilePath(ParamStr(0)) + 'out.xml');
|
|
Result := True;
|
|
finally
|
|
FStream.Free;
|
|
end;
|
|
end;
|
|
|
|
FProgram.ErrorPos := FErrorPos;
|
|
FProgram.ErrorMsg := FErrorMsg;
|
|
finally
|
|
FList.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsILParser.ParseILScript;
|
|
begin
|
|
FWithList.Clear;
|
|
FProgram.ErrorUnit := '';
|
|
FUnitName := '';
|
|
FUsesList.Clear;
|
|
try
|
|
DoProgram(FILScript.Root, FProgram);
|
|
FProgram.ErrorPos := '';
|
|
except
|
|
on e: Exception do
|
|
begin
|
|
FProgram.ErrorMsg := e.Message;
|
|
FProgram.ErrorPos := FErrorPos;
|
|
FProgram.ErrorUnit := FUnitName;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TfsILParser.PropPos(xi: TfsXMLItem): String;
|
|
begin
|
|
Result := xi.Prop['pos'];
|
|
end;
|
|
|
|
procedure TfsILParser.ErrorPos(xi: TfsXMLItem);
|
|
begin
|
|
FErrorPos := PropPos(xi);
|
|
end;
|
|
|
|
procedure TfsILParser.CheckIdent(Prog: TfsScript; const Name: String);
|
|
begin
|
|
if Prog.FindLocal(Name) <> nil then
|
|
raise Exception.Create(SIdRedeclared + '''' + Name + '''');
|
|
end;
|
|
|
|
function TfsILParser.FindClass(const TypeName: String): TfsClassVariable;
|
|
begin
|
|
Result := FProgram.FindClass(TypeName);
|
|
if Result = nil then
|
|
raise Exception.Create(SUnknownType + '''' + TypeName + '''');
|
|
end;
|
|
|
|
procedure TfsILParser.CheckTypeCompatibility(Var1, Var2: TfsCustomVariable);
|
|
begin
|
|
if not AssignCompatible(Var1, Var2, FProgram) then
|
|
raise Exception.Create(SIncompatibleTypes + ': ''' + Var1.GetFullTypeName +
|
|
''', ''' + Var2.GetFullTypeName + '''');
|
|
end;
|
|
|
|
function TfsILParser.FindVar(Prog: TfsScript; const Name: String): TfsCustomVariable;
|
|
begin
|
|
Result := Prog.Find(Name);
|
|
if Result = nil then
|
|
if not FNeedDeclareVars then
|
|
begin
|
|
Result := TfsVariable.Create(Name, fvtVariant, '');
|
|
FProgram.Add(Name, Result);
|
|
end
|
|
else
|
|
raise Exception.Create(SIdUndeclared + '''' + Name + '''');
|
|
end;
|
|
|
|
function TfsILParser.FindType(s: String): TfsVarType;
|
|
var
|
|
xi: TfsXMLItem;
|
|
begin
|
|
xi := FProgRoot.FindItem('types');
|
|
if xi.Find(s) <> -1 then
|
|
s := xi[xi.Find(s)].Prop['type']
|
|
else
|
|
begin
|
|
xi := FGrammar.Root.FindItem('types');
|
|
if xi.Find(s) <> -1 then
|
|
s := xi[xi.Find(s)].Prop['type']
|
|
end;
|
|
Result := StrToVarType(s, FProgram);
|
|
if Result = fvtClass then
|
|
FindClass(s);
|
|
end;
|
|
|
|
function TfsILParser.CreateVar(xi: TfsXMLItem; Prog: TfsScript; const Name: String;
|
|
Statement: TfsStatement = nil; CreateParam: Boolean = False;
|
|
IsVarParam: Boolean = False): TfsCustomVariable;
|
|
var
|
|
i, j: Integer;
|
|
Typ: TfsVarType;
|
|
TypeName: String;
|
|
RefItem: TfsCustomVariable;
|
|
InitValue: Variant;
|
|
InitItem: TfsXMLItem;
|
|
AssignStmt: TfsAssignmentStmt;
|
|
IsPascal: Boolean;
|
|
SourcePos: String;
|
|
|
|
procedure DoArray(xi: TfsXMLItem);
|
|
var
|
|
i, n: Integer;
|
|
v: array of {$IFDEF FPC}SizeInt{$ELSE}Integer{$ENDIF};
|
|
Expr: TfsExpression;
|
|
begin
|
|
n := xi.Count;
|
|
SetLength(v, n * 2);
|
|
|
|
for i := 0 to n - 1 do
|
|
begin
|
|
Expr := DoExpression(xi[i][0], Prog);
|
|
v[i * 2] := Expr.Value;
|
|
Expr.Free;
|
|
|
|
if xi[i].Count = 2 then
|
|
begin
|
|
Expr := DoExpression(xi[i][1], Prog);
|
|
v[i * 2 + 1] := Expr.Value;
|
|
Expr.Free;
|
|
end
|
|
else
|
|
begin
|
|
v[i * 2 + 1] := v[i * 2] - 1;
|
|
v[i * 2] := 0;
|
|
end;
|
|
end;
|
|
|
|
if n = 0 then
|
|
begin
|
|
SetLength(v, 2);
|
|
v[0] := 0;
|
|
v[1] := 0;
|
|
n := 1;
|
|
end;
|
|
|
|
InitValue := VarArrayCreate(v, varVariant);
|
|
RefItem := TfsArrayHelper.Create('', n, Typ, TypeName);
|
|
Prog.Add('', RefItem);
|
|
v := nil;
|
|
Typ := fvtArray;
|
|
end;
|
|
|
|
procedure DoInit(xi: TfsXMLItem);
|
|
var
|
|
Expr: TfsExpression;
|
|
Temp: TfsVariable;
|
|
begin
|
|
Temp := TfsVariable.Create('', Typ, TypeName);
|
|
try
|
|
Expr := DoExpression(xi[0], Prog);
|
|
InitValue := Expr.Value;
|
|
try
|
|
CheckTypeCompatibility(Temp, Expr);
|
|
finally
|
|
Expr.Free;
|
|
end;
|
|
finally
|
|
Temp.Free;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
RefItem := nil;
|
|
InitItem := nil;
|
|
TypeName := 'Variant';
|
|
IsPascal := False;
|
|
SourcePos := FErrorPos;
|
|
|
|
(*
|
|
<var>
|
|
<ident text="ar"/>
|
|
<array>
|
|
<dim>
|
|
<expr/>
|
|
<expr/>
|
|
</dim>
|
|
...
|
|
</array>
|
|
<type text="String"/>
|
|
<init>
|
|
<expr/>
|
|
</init>
|
|
</var>
|
|
|
|
- type may be first (in C-like languages) or last (in Pascal-like ones)
|
|
- type may be skipped (treated as variant)
|
|
- array and init may be either skipped, or after each <ident>
|
|
- array and init may be after each <ident>
|
|
- do not handle <ident> tags - they are handled in calling part
|
|
*)
|
|
|
|
|
|
{ find the type }
|
|
for i := 0 to xi.Count - 1 do
|
|
if CompareText(xi[i].name, 'type') = 0 then
|
|
begin
|
|
IsPascal := i <> 0;
|
|
TypeName := xi[i].Prop['text'];
|
|
ErrorPos(xi[i]);
|
|
break;
|
|
end;
|
|
|
|
Typ := FindType(TypeName);
|
|
case Typ of
|
|
fvtInt, fvtInt64, fvtFloat, fvtClass:
|
|
InitValue := 0;
|
|
fvtBool:
|
|
InitValue := False;
|
|
fvtChar, fvtString:
|
|
InitValue := '';
|
|
else
|
|
InitValue := Null;
|
|
end;
|
|
|
|
{ fing the <ident> tag corresponding to our variable }
|
|
for i := 0 to xi.Count - 1 do
|
|
if CompareText(xi[i].Prop['text'], Name) = 0 then
|
|
begin
|
|
{ process <array> and <init> tags if any }
|
|
j := i + 1;
|
|
while (j < xi.Count) and (IsPascal or (CompareText(xi[j].Name, 'ident') <> 0)) do
|
|
begin
|
|
if CompareText(xi[j].Name, 'array') = 0 then
|
|
DoArray(xi[j])
|
|
else if CompareText(xi[j].Name, 'init') = 0 then
|
|
begin
|
|
if Statement = nil then
|
|
DoInit(xi[j]);
|
|
InitItem := xi[j];
|
|
end;
|
|
Inc(j);
|
|
end;
|
|
break;
|
|
end;
|
|
|
|
if CreateParam then
|
|
Result := TfsParamItem.Create(Name, Typ, TypeName, InitItem <> nil, IsVarParam)
|
|
else if Typ in [fvtChar, fvtString] then
|
|
Result := TfsStringVariable.Create(Name, Typ, TypeName) else
|
|
Result := TfsVariable.Create(Name, Typ, TypeName);
|
|
|
|
try
|
|
Result.Value := InitValue;
|
|
Result.RefItem := RefItem;
|
|
Result.SourcePos := SourcePos;
|
|
Result.SourceUnit := FUnitName;
|
|
Result.OnGetVarValue := FProgram.OnGetVarValue;
|
|
|
|
{ create init statement }
|
|
if (InitItem <> nil) and (Statement <> nil) then
|
|
begin
|
|
AssignStmt := TfsAssignmentStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(AssignStmt);
|
|
AssignStmt.Designator := TfsVariableDesignator.Create(Prog);
|
|
AssignStmt.Designator.RefItem := Result;
|
|
AssignStmt.Expression := DoExpression(InitItem[0], Prog);
|
|
CheckTypeCompatibility(Result, AssignStmt.Expression);
|
|
AssignStmt.Optimize;
|
|
end;
|
|
|
|
except
|
|
on e: Exception do
|
|
begin
|
|
Result.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
end;
|
|
{$HINTS OFF}
|
|
function TfsILParser.DoDesignator(xi: TfsXMLItem; Prog: TfsScript;
|
|
EmitOp: TfsEmitOp = emNone): TfsDesignator;
|
|
var
|
|
i, j: Integer;
|
|
NodeName, NodeText, TypeName: String;
|
|
Expr: TfsExpression;
|
|
Item, PriorItem: TfsDesignatorItem;
|
|
ClassVar: TfsClassVariable;
|
|
StringVar: TfsStringVariable;
|
|
Typ: TfsVarType;
|
|
LateBinding, PriorIsIndex: Boolean;
|
|
NewDesignator: TfsDesignator;
|
|
PriorValue: Variant;
|
|
Component: TComponent;
|
|
|
|
function FindInWithList(const Name: String; ResultDS: TfsDesignator;
|
|
Item: TfsDesignatorItem): Boolean;
|
|
var
|
|
i: Integer;
|
|
WithStmt: TfsWithStmt;
|
|
WithItem: TfsDesignatorItem;
|
|
ClassVar: TfsClassVariable;
|
|
xi1: TfsXMLItem;
|
|
begin
|
|
Result := False;
|
|
LateBinding := False;
|
|
for i := FWithList.Count - 1 downto 0 do
|
|
begin
|
|
{ prevent checking non-local 'with' }
|
|
if Prog.FindLocal(FWithList[i]) = nil then
|
|
continue;
|
|
WithStmt := TfsWithStmt(FWithList.Objects[i]);
|
|
|
|
if WithStmt.Variable.Typ = fvtVariant then
|
|
begin
|
|
{ first check all known variables }
|
|
if Prog.Find(Name) <> nil then
|
|
Exit;
|
|
{ if nothing found, create late binding information }
|
|
Item.Ref := WithStmt.Variable;
|
|
ResultDS.Finalize;
|
|
ResultDS.LateBindingXMLSource := TfsXMLItem.Create;
|
|
ResultDS.LateBindingXMLSource.Assign(xi);
|
|
xi1 := TfsXMLItem.Create;
|
|
xi1.Name := 'node';
|
|
xi1.Text := 'text="' + FWithList[i] + '"';
|
|
ResultDS.LateBindingXMLSource.InsertItem(0, xi1);
|
|
LateBinding := True;
|
|
Result := True;
|
|
break;
|
|
end
|
|
else
|
|
begin
|
|
ClassVar := FindClass(WithStmt.Variable.TypeName);
|
|
Item.Ref := ClassVar.Find(NodeText);
|
|
end;
|
|
|
|
if Item.Ref <> nil then
|
|
begin
|
|
WithItem := TfsDesignatorItem.Create;
|
|
WithItem.Ref := WithStmt.Variable;
|
|
WithItem.SourcePos := Item.SourcePos;
|
|
|
|
ResultDS.Remove(Item);
|
|
ResultDS.Add(WithItem);
|
|
ResultDS.Add(Item);
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF OLE}
|
|
procedure CreateOLEHelpers(Index: Integer);
|
|
var
|
|
i: Integer;
|
|
OLEHelper: TfsOLEHelper;
|
|
begin
|
|
for i := Index to xi.Count - 1 do
|
|
begin
|
|
ErrorPos(xi[i]);
|
|
NodeName := LowerCase(xi[i].Name);
|
|
NodeText := xi[i].Prop['text'];
|
|
|
|
if (NodeName = 'node') and (NodeText <> '[') then
|
|
begin
|
|
Item := TfsDesignatorItem.Create;
|
|
Result.Add(Item);
|
|
Item.SourcePos := FErrorPos;
|
|
OLEHelper := TfsOLEHelper.Create(NodeText);
|
|
Prog.Add('', OLEHelper);
|
|
Item.Ref := OLEHelper;
|
|
end
|
|
else if NodeName = 'expr' then
|
|
begin
|
|
Expr := DoExpression(xi[i], Prog);
|
|
PriorItem := Result.Items[Result.Count - 1];
|
|
PriorItem.Add(Expr);
|
|
PriorItem.Ref.Add(TfsParamItem.Create('', fvtVariant, '', False, False));
|
|
end
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
begin
|
|
Result := TfsDesignator.Create(Prog);
|
|
try
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
ErrorPos(xi[i]);
|
|
NodeName := LowerCase(xi[i].Name);
|
|
NodeText := xi[i].Prop['text'];
|
|
|
|
if NodeName = 'node' then
|
|
begin
|
|
Item := TfsDesignatorItem.Create;
|
|
Result.Add(Item);
|
|
Item.SourcePos := FErrorPos;
|
|
|
|
if Result.Count = 1 then
|
|
begin
|
|
if not FindInWithList(NodeText, Result, Item) then
|
|
Item.Ref := FindVar(Prog, NodeText);
|
|
|
|
{ LateBinding flag turned on in the FindInWithList }
|
|
if LateBinding then
|
|
Exit;
|
|
{ add .Create for cpp NEW statement, i.e convert o = new TObject
|
|
to o = TObject.Create }
|
|
if EmitOp = emCreate then
|
|
begin
|
|
if not (Item.Ref is TfsClassVariable) then
|
|
raise Exception.Create(SClassRequired);
|
|
ClassVar := TfsClassVariable(Item.Ref);
|
|
Item := TfsDesignatorItem.Create;
|
|
Result.Add(Item);
|
|
Item.Ref := ClassVar.Find('Create');
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
PriorItem := Result.Items[Result.Count - 2];
|
|
PriorIsIndex := (PriorItem.Ref is TfsMethodHelper) and
|
|
TfsMethodHelper(PriorItem.Ref).IndexMethod and not PriorItem.Flag;
|
|
Typ := PriorItem.Ref.Typ;
|
|
{ late binding }
|
|
if (Typ = fvtVariant) and not PriorIsIndex then
|
|
begin
|
|
PriorValue := PriorItem.Ref.Value;
|
|
if VarIsNull(PriorValue) then
|
|
begin
|
|
Result.Remove(Item);
|
|
Item.Free;
|
|
Result.Finalize;
|
|
Result.LateBindingXMLSource := TfsXMLItem.Create;
|
|
Result.LateBindingXMLSource.Assign(xi);
|
|
Exit;
|
|
end
|
|
else
|
|
begin
|
|
if (TVarData(PriorValue).VType = varString) {$IFDEF Delphi12}or (TVarData(PriorValue).VType = varUString){$ENDIF} then
|
|
{ accessing string elements }
|
|
Typ := fvtString
|
|
{$IFDEF OLE}
|
|
else if TVarData(PriorValue).VType = varDispatch then
|
|
begin
|
|
{ calling ole }
|
|
Result.Remove(Item);
|
|
Item.Free;
|
|
CreateOLEHelpers(i);
|
|
Result.Finalize;
|
|
Exit;
|
|
end
|
|
{$ENDIF}
|
|
else if (TVarData(PriorValue).VType and varArray) = varArray then
|
|
begin
|
|
{ accessing array elements }
|
|
if NodeText = '[' then { set ref to arrayhelper }
|
|
Item.Ref := FindVar(Prog, '__ArrayHelper')
|
|
else
|
|
raise Exception.Create(SIndexRequired);
|
|
continue;
|
|
end
|
|
else
|
|
begin
|
|
{ accessing class items }
|
|
Typ := fvtClass;
|
|
PriorItem.Ref.TypeName := TObject(frxInteger(PriorItem.Ref.Value)).ClassName;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
if PriorIsIndex then
|
|
begin
|
|
PriorItem.Flag := True;
|
|
Result.Remove(Item); { previous item is set up already }
|
|
Item.Free;
|
|
FErrorPos := PriorItem.SourcePos;
|
|
if NodeText <> '[' then
|
|
raise Exception.Create(SIndexRequired);
|
|
end
|
|
else if Typ = fvtString then
|
|
begin
|
|
if NodeText = '[' then { set ref to stringhelper }
|
|
Item.Ref := FindVar(Prog, '__StringHelper')
|
|
else
|
|
raise Exception.Create(SStringError);
|
|
end
|
|
else if Typ = fvtClass then
|
|
begin
|
|
TypeName := PriorItem.Ref.TypeName;
|
|
ClassVar := FindClass(TypeName);
|
|
|
|
if NodeText = '[' then { default property }
|
|
begin
|
|
Item.Flag := True;
|
|
Item.Ref := ClassVar.DefProperty;
|
|
if Item.Ref = nil then
|
|
raise Exception.CreateFmt(SClassError, [TypeName]);
|
|
end
|
|
else { property or method }
|
|
begin
|
|
Item.Ref := ClassVar.Find(NodeText, False);
|
|
{ property not found. Probably it's a form element such as button? }
|
|
if Item.Ref = nil then
|
|
begin
|
|
PriorValue := PriorItem.Ref.Value;
|
|
if ((VarIsNull(PriorValue) or (PriorValue = 0)) and not Prog.IsRunning) and Prog.UseClassLateBinding then
|
|
begin
|
|
{ at compile time, we don't know anything about form elements.
|
|
So clear the designator items and use the late binding. }
|
|
Result.Remove(Item);
|
|
Item.Free;
|
|
while Result.Count > 1 do
|
|
begin
|
|
Item := Result.Items[Result.Count - 1];
|
|
Result.Remove(Item);
|
|
Item.Free;
|
|
end;
|
|
Item := Result.Items[0];
|
|
Result.Finalize;
|
|
Result.Typ := fvtVariant;
|
|
Result.LateBindingXMLSource := TfsXMLItem.Create;
|
|
Result.LateBindingXMLSource.Assign(xi);
|
|
Exit;
|
|
end
|
|
else
|
|
begin
|
|
{ we at run time now. Try to search in the form's elements. }
|
|
if TObject(frxInteger(PriorValue)) is TComponent then
|
|
begin
|
|
Component := TComponent(frxInteger(PriorValue)).FindComponent(NodeText);
|
|
if Component <> nil then
|
|
{ creates TfsComponentHelper }
|
|
Item.Ref := ClassVar.AddComponent(Component);
|
|
end;
|
|
if Item.Ref = nil then
|
|
raise Exception.Create(SIdUndeclared + '''' + NodeText + '''');
|
|
end
|
|
end;
|
|
end;
|
|
end
|
|
else if Typ = fvtArray then { set ref to array helper }
|
|
Item.Ref := PriorItem.Ref.RefItem
|
|
else
|
|
raise Exception.Create(SArrayRequired);
|
|
end;
|
|
end
|
|
else if NodeName = 'expr' then
|
|
begin
|
|
Expr := DoExpression(xi[i], Prog);
|
|
Result.Items[Result.Count - 1].Add(Expr);
|
|
end
|
|
else if NodeName = 'addr' then { @ operator }
|
|
begin
|
|
if xi.Count <> 2 then
|
|
raise Exception.Create(SVarRequired);
|
|
|
|
Item := TfsDesignatorItem.Create;
|
|
Result.Add(Item);
|
|
ErrorPos(xi[1]);
|
|
Item.SourcePos := FErrorPos;
|
|
|
|
{ we just return the string containing a referenced item name. For
|
|
example, var s: String; procedure B1; begin end; s := @B1
|
|
will assign 'B1' to the s }
|
|
StringVar := TfsStringVariable.Create('', fvtString, '');
|
|
StringVar.Value := xi[1].Prop['text'];
|
|
Prog.Add('', StringVar);
|
|
Item.Ref := StringVar;
|
|
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
if EmitOp = emFree then
|
|
begin
|
|
PriorItem := Result.Items[Result.Count - 1];
|
|
if (PriorItem.Ref.Typ <> fvtClass) and (PriorItem.Ref.Typ <> fvtVariant) then
|
|
raise Exception.Create(SClassRequired);
|
|
Item := TfsDesignatorItem.Create;
|
|
Result.Add(Item);
|
|
ClassVar := FindClass('TObject');
|
|
Item.Ref := ClassVar.Find('Free');
|
|
end;
|
|
|
|
Result.Finalize;
|
|
if Result.Kind <> dkOther then
|
|
begin
|
|
NewDesignator := nil;
|
|
if Result.Kind = dkVariable then
|
|
NewDesignator := TfsVariableDesignator.Create(Prog)
|
|
else if Result.Kind = dkStringArray then
|
|
NewDesignator := TfsStringDesignator.Create(Prog)
|
|
else if Result.Kind = dkArray then
|
|
NewDesignator := TfsArrayDesignator.Create(Prog);
|
|
|
|
NewDesignator.Borrow(Result);
|
|
Result.Free;
|
|
Result := NewDesignator;
|
|
end;
|
|
|
|
for i := 0 to Result.Count - 1 do
|
|
begin
|
|
Item := Result[i];
|
|
FErrorPos := Item.SourcePos;
|
|
if Item.Ref is TfsDesignator then continue;
|
|
|
|
if Item.Count < Item.Ref.GetNumberOfRequiredParams then
|
|
raise Exception.Create(SNotEnoughParams)
|
|
else if Item.Count > Item.Ref.Count then
|
|
raise Exception.Create(STooManyParams)
|
|
else if Item.Count <> Item.Ref.Count then { construct the default params }
|
|
for j := Item.Count to Item.Ref.Count - 1 do
|
|
begin
|
|
Expr := TfsExpression.Create(FProgram);
|
|
Item.Add(Expr);
|
|
Expr.AddConstWithType(Item.Ref[j].DefValue, Item.Ref[j].Typ);
|
|
Expr.Finalize;
|
|
end;
|
|
|
|
for j := 0 to Item.Count - 1 do
|
|
begin
|
|
FErrorPos := Item[j].SourcePos;
|
|
CheckTypeCompatibility(Item.Ref[j], Item[j]);
|
|
end;
|
|
end;
|
|
|
|
except
|
|
on e: Exception do
|
|
begin
|
|
Result.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
end;
|
|
{$HINTS ON}
|
|
function TfsILParser.DoSet(xi: TfsXMLItem; Prog: TfsScript): TfsSetExpression;
|
|
var
|
|
i: Integer;
|
|
Name: String;
|
|
begin
|
|
Result := TfsSetExpression.Create('', fvtVariant, '');
|
|
try
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
Name := LowerCase(xi[i].Name);
|
|
if Name = 'expr' then
|
|
Result.Add(DoExpression(xi[i], Prog))
|
|
else if Name = 'range' then
|
|
Result.Add(nil);
|
|
end;
|
|
|
|
except
|
|
on e: Exception do
|
|
begin
|
|
Result.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TfsILParser.DoExpression(xi: TfsXMLItem; Prog: TfsScript): TfsExpression;
|
|
var
|
|
ErPos: String;
|
|
SourcePos1, SourcePos2: TPoint;
|
|
|
|
procedure DoExpressionItems(xi: TfsXMLItem; Expression: TfsExpression);
|
|
var
|
|
i: Integer;
|
|
NodeName: String;
|
|
OpName: String;
|
|
begin
|
|
i := 0;
|
|
while i < xi.Count do
|
|
begin
|
|
ErrorPos(xi[i]);
|
|
Expression.SourcePos := FErrorPos;
|
|
NodeName := Lowercase(xi[i].Name);
|
|
OpName := xi[i].Prop['text'];
|
|
|
|
if (NodeName = 'op') then
|
|
begin
|
|
OpName := LowerCase(OpName);
|
|
if (OpName = ')') or (i < xi.Count - 1) then
|
|
Expression.AddOperator(OpName);
|
|
end
|
|
else if (NodeName = 'number') or (NodeName = 'string') then
|
|
Expression.AddConst(ParserStringToVariant(OpName))
|
|
else if NodeName = 'dsgn' then
|
|
Expression.AddDesignator(DoDesignator(xi[i], Prog))
|
|
else if NodeName = 'set' then
|
|
Expression.AddSet(DoSet(xi[i], Prog))
|
|
else if NodeName = 'new' then
|
|
Expression.AddDesignator(DoDesignator(xi[i][0], Prog, emCreate))
|
|
else if NodeName = 'expr' then
|
|
DoExpressionItems(xi[i], Expression);
|
|
|
|
Inc(i);
|
|
end;
|
|
end;
|
|
|
|
function GetSource(pt1, pt2: TPoint): String;
|
|
var
|
|
i1, i2: Integer;
|
|
begin
|
|
i1 := FParser.GetPlainPosition(pt1);
|
|
i2 := FParser.GetPlainPosition(pt2);
|
|
if (i1 = -1) or (i2 = -1) then
|
|
Result := ''
|
|
else
|
|
Result := Copy(FParser.Text, i1, i2 - i1);
|
|
end;
|
|
|
|
begin
|
|
Result := TfsExpression.Create(FProgram);
|
|
try
|
|
DoExpressionItems(xi, Result);
|
|
SourcePos1 := fsPosToPoint(PropPos(xi));
|
|
SourcePos2 := fsPosToPoint(xi.Prop['pos1']);
|
|
Result.Source := GetSource(SourcePos1, SourcePos2);
|
|
|
|
ErPos := Result.Finalize;
|
|
if ErPos <> '' then
|
|
begin
|
|
FErrorPos := ErPos;
|
|
raise Exception.Create(SIncompatibleTypes);
|
|
end;
|
|
|
|
except
|
|
on e: Exception do
|
|
begin
|
|
Result.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsILParser.DoUses(xi: TfsXMLItem; Prog: TfsScript);
|
|
var
|
|
i: Integer;
|
|
SaveUnitName: String;
|
|
s: String;
|
|
sl: TStringList;
|
|
ms: TMemoryStream;
|
|
xd: TfsXMLDocument;
|
|
begin
|
|
SaveUnitName := FUnitName;
|
|
FUnitName := xi.Prop['unit'];
|
|
xd := nil;
|
|
|
|
if FUsesList.IndexOf(FUnitName) <> -1 then
|
|
begin
|
|
FUnitName := SaveUnitName;
|
|
Exit;
|
|
end;
|
|
FUsesList.Add(FUnitName);
|
|
if Assigned(FProgram.OnGetILUnit) then
|
|
begin
|
|
s := '';
|
|
FProgram.OnGetILUnit(FProgram, FUnitName, s);
|
|
if s <> '' then
|
|
begin
|
|
sl := TStringList.Create;
|
|
sl.Text := s;
|
|
|
|
ms := TMemoryStream.Create;
|
|
sl.SaveToStream(ms);
|
|
sl.Free;
|
|
ms.Position := 0;
|
|
|
|
xd := TfsXMLDocument.Create;
|
|
xd.LoadFromStream(ms);
|
|
ms.Free;
|
|
end;
|
|
end;
|
|
|
|
if xd <> nil then
|
|
begin
|
|
try
|
|
DoProgram(xd.Root, Prog);
|
|
finally
|
|
xd.Free;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
for i := 0 to xi.Count - 1 do
|
|
DoProgram(xi[i], Prog);
|
|
end;
|
|
|
|
FUnitName := SaveUnitName;
|
|
end;
|
|
|
|
procedure TfsILParser.DoVar(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
i: Integer;
|
|
Name: String;
|
|
begin
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
ErrorPos(xi[i]);
|
|
if CompareText(xi[i].Name, 'ident') = 0 then
|
|
begin
|
|
Name := xi[i].Prop['text'];
|
|
CheckIdent(Prog, Name);
|
|
Prog.Add(Name, CreateVar(xi, Prog, Name, Statement));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsILParser.DoConst(xi: TfsXMLItem; Prog: TfsScript);
|
|
var
|
|
Name: String;
|
|
Expr: TfsExpression;
|
|
v: TfsVariable;
|
|
begin
|
|
Name := xi[0].Prop['text'];
|
|
ErrorPos(xi[0]);
|
|
CheckIdent(Prog, Name);
|
|
|
|
Expr := DoExpression(xi[1], Prog);
|
|
v := TfsVariable.Create(Name, Expr.Typ, Expr.TypeName);
|
|
v.Value := Expr.Value;
|
|
v.IsReadOnly := True;
|
|
Expr.Free;
|
|
|
|
Prog.Add(Name, v);
|
|
end;
|
|
|
|
procedure TfsILParser.DoParameters(xi: TfsXMLItem; v: TfsProcVariable);
|
|
var
|
|
i: Integer;
|
|
s: String;
|
|
varParams: Boolean;
|
|
|
|
procedure DoParam(xi: TfsXMLItem);
|
|
var
|
|
i: Integer;
|
|
Name: String;
|
|
Param: TfsParamItem;
|
|
varParam: Boolean;
|
|
begin
|
|
varParam := False;
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
ErrorPos(xi[i]);
|
|
if CompareText(xi[i].Name, 'varparam') = 0 then
|
|
varParam := True
|
|
else if CompareText(xi[i].Name, 'ident') = 0 then
|
|
begin
|
|
Name := xi[i].Prop['text'];
|
|
CheckIdent(v.Prog, Name);
|
|
Param := TfsParamItem(CreateVar(xi, v.Prog, Name, nil, True,
|
|
varParams or VarParam));
|
|
Param.DefValue := Param.Value;
|
|
v.Add(Param);
|
|
v.Prog.Add(Name, Param);
|
|
varParam := False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if CompareText(xi.Name, 'parameters') <> 0 then Exit;
|
|
varParams := False;
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
s := LowerCase(xi[i].Name);
|
|
if s = 'varparams' then
|
|
varParams := True
|
|
else if s = 'var' then
|
|
begin
|
|
DoParam(xi[i]);
|
|
varParams := False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsILParser.DoProc1(xi: TfsXMLItem; Prog: TfsScript);
|
|
var
|
|
i: Integer;
|
|
s, Name: String;
|
|
Proc: TfsProcVariable;
|
|
begin
|
|
ErrorPos(xi[0]);
|
|
Name := xi[0].Prop['text'];
|
|
CheckIdent(Prog, Name);
|
|
|
|
{$IFDEF CPUX64}
|
|
Proc := TfsProcVariable.Create(Name, fvtInt64, '', Prog, False);
|
|
{$ELSE}
|
|
Proc := TfsProcVariable.Create(Name, fvtInt, '', Prog, False);
|
|
{$ENDIF}
|
|
Proc.SourcePos := PropPos(xi);
|
|
Proc.SourceUnit := FUnitName;
|
|
Prog.Add(Name, Proc);
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
s := LowerCase(xi[i].Name);
|
|
if s = 'parameters' then
|
|
DoParameters(xi[i], Proc);
|
|
end;
|
|
end;
|
|
|
|
procedure TfsILParser.DoProc2(xi: TfsXMLItem; Prog: TfsScript);
|
|
var
|
|
Name: String;
|
|
Proc: TfsProcVariable;
|
|
begin
|
|
Name := xi[0].Prop['text'];
|
|
Proc := TfsProcVariable(FindVar(Prog, Name));
|
|
DoProgram(xi, Proc.Prog);
|
|
end;
|
|
|
|
procedure TfsILParser.DoFunc1(xi: TfsXMLItem; Prog: TfsScript);
|
|
var
|
|
i: Integer;
|
|
s, Name, TypeName: String;
|
|
Typ: TfsVarType;
|
|
Func: TfsProcVariable;
|
|
begin
|
|
Name := '';
|
|
TypeName := '';
|
|
Typ := fvtVariant;
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
ErrorPos(xi[i]);
|
|
s := LowerCase(xi[i].Name);
|
|
if s = 'type' then
|
|
begin
|
|
TypeName := xi[i].Prop['text'];
|
|
Typ := FindType(TypeName);
|
|
end
|
|
else if s = 'name' then
|
|
begin
|
|
Name := xi[i].Prop['text'];
|
|
CheckIdent(Prog, Name);
|
|
end
|
|
end;
|
|
|
|
|
|
Func := TfsProcVariable.Create(Name, Typ, TypeName, Prog,
|
|
CompareText(TypeName, 'void') <> 0);
|
|
Func.SourcePos := PropPos(xi);
|
|
Func.SourceUnit := FUnitName;
|
|
Prog.Add(Name, Func);
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
s := LowerCase(xi[i].Name);
|
|
if s = 'parameters' then
|
|
DoParameters(xi[i], Func);
|
|
end;
|
|
end;
|
|
|
|
procedure TfsILParser.DoFunc2(xi: TfsXMLItem; Prog: TfsScript);
|
|
var
|
|
i: Integer;
|
|
s, Name: String;
|
|
Func: TfsProcVariable;
|
|
begin
|
|
Name := '';
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
s := LowerCase(xi[i].Name);
|
|
if s = 'name' then
|
|
Name := xi[i].Prop['text'];
|
|
end;
|
|
|
|
Func := TfsProcVariable(FindVar(Prog, Name));
|
|
DoProgram(xi, Func.Prog);
|
|
end;
|
|
|
|
procedure TfsILParser.DoAssign(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
i: Integer;
|
|
Stmt: TfsAssignmentStmt;
|
|
Designator: TfsDesignator;
|
|
Expression: TfsExpression;
|
|
Modificator: String;
|
|
begin
|
|
Designator := nil;
|
|
Expression := nil;
|
|
|
|
try
|
|
Modificator := ' ';
|
|
Designator := DoDesignator(xi[0], Prog);
|
|
|
|
i := 1;
|
|
if CompareText(xi[1].Name, 'modificator') = 0 then
|
|
begin
|
|
Modificator := xi[1].Prop['text'];
|
|
Inc(i);
|
|
end;
|
|
Expression := DoExpression(xi[i], Prog);
|
|
|
|
if Designator.IsReadOnly then
|
|
raise Exception.Create(SLeftCantAssigned);
|
|
|
|
CheckTypeCompatibility(Designator, Expression);
|
|
if Modificator = ' ' then
|
|
Modificator := Expression.Optimize(Designator);
|
|
except
|
|
on e: Exception do
|
|
begin
|
|
if Designator <> nil then
|
|
Designator.Free;
|
|
if Expression <> nil then
|
|
Expression.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
case Modificator[1] of
|
|
'+':
|
|
Stmt := TfsAssignPlusStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
'-':
|
|
Stmt := TfsAssignMinusStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
'*':
|
|
Stmt := TfsAssignMulStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
'/':
|
|
Stmt := TfsAssignDivStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
else
|
|
Stmt := TfsAssignmentStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
Statement.Add(Stmt);
|
|
Stmt.Designator := Designator;
|
|
Stmt.Expression := Expression;
|
|
Stmt.Optimize;
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoCall(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
Stmt: TfsCallStmt;
|
|
begin
|
|
Stmt := TfsCallStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
Stmt.Designator := DoDesignator(xi[0], Prog);
|
|
if xi.Count > 1 then
|
|
begin
|
|
Stmt.Modificator := xi[1].Prop['text'];
|
|
if Stmt.Designator.IsReadOnly then
|
|
raise Exception.Create(SLeftCantAssigned);
|
|
end;
|
|
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoIf(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
i: Integer;
|
|
s: String;
|
|
Stmt: TfsIfStmt;
|
|
begin
|
|
Stmt := TfsIfStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
Stmt.Condition := DoExpression(xi[0], Prog);
|
|
|
|
for i := 1 to xi.Count - 1 do
|
|
begin
|
|
s := Lowercase(xi[i].Name);
|
|
if s = 'thenstmt' then
|
|
DoCompoundStmt(xi[1], Prog, Stmt)
|
|
else if s = 'elsestmt' then
|
|
DoCompoundStmt(xi[2], Prog, Stmt.ElseStmt);
|
|
end;
|
|
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
i: Integer;
|
|
Stmt: TfsForStmt;
|
|
begin
|
|
Stmt := TfsForStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
ErrorPos(xi[0]);
|
|
Stmt.Variable := FindVar(Prog, xi[0].Prop['text']);
|
|
if not ((Stmt.Variable is TfsVariable) and
|
|
(Stmt.Variable.Typ in [fvtInt, fvtInt64, fvtVariant, fvtFloat])) then
|
|
raise Exception.Create(SForError);
|
|
|
|
Stmt.BeginValue := DoExpression(xi[1], Prog);
|
|
CheckTypeCompatibility(Stmt.Variable, Stmt.BeginValue);
|
|
|
|
i := 2;
|
|
if CompareText(xi[2].Name, 'downto') = 0 then
|
|
begin
|
|
Stmt.Down := True;
|
|
Inc(i);
|
|
end;
|
|
|
|
Stmt.EndValue := DoExpression(xi[i], Prog);
|
|
CheckTypeCompatibility(Stmt.Variable, Stmt.EndValue);
|
|
if i + 1 < xi.Count then
|
|
DoStmt(xi[i + 1], Prog, Stmt);
|
|
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoVbFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
i: Integer;
|
|
Stmt: TfsVbForStmt;
|
|
begin
|
|
Stmt := TfsVbForStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
ErrorPos(xi[0]);
|
|
Stmt.Variable := FindVar(Prog, xi[0].Prop['text']);
|
|
if not ((Stmt.Variable is TfsVariable) and
|
|
(Stmt.Variable.Typ in [fvtInt, fvtInt64, fvtVariant, fvtFloat])) then
|
|
raise Exception.Create(SForError);
|
|
|
|
Stmt.BeginValue := DoExpression(xi[1], Prog);
|
|
CheckTypeCompatibility(Stmt.Variable, Stmt.BeginValue);
|
|
|
|
Stmt.EndValue := DoExpression(xi[2], Prog);
|
|
CheckTypeCompatibility(Stmt.Variable, Stmt.EndValue);
|
|
|
|
i := 3;
|
|
if i < xi.Count then
|
|
if CompareText(xi[i].Name, 'expr') = 0 then
|
|
begin
|
|
Stmt.Step := DoExpression(xi[i], Prog);
|
|
CheckTypeCompatibility(Stmt.Variable, Stmt.Step);
|
|
Inc(i);
|
|
end;
|
|
|
|
if i < xi.Count then
|
|
DoStmt(xi[i], Prog, Stmt);
|
|
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoCppFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
Stmt: TfsCppForStmt;
|
|
begin
|
|
Stmt := TfsCppForStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
DoStmt(xi[0], Prog, Stmt.FirstStmt);
|
|
Stmt.Expression := DoExpression(xi[1], Prog);
|
|
DoStmt(xi[2], Prog, Stmt.SecondStmt);
|
|
DoStmt(xi[3], Prog, Stmt);
|
|
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoWhile(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
Stmt: TfsWhileStmt;
|
|
begin
|
|
Stmt := TfsWhileStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
Stmt.Condition := DoExpression(xi[0], Prog);
|
|
if xi.Count > 1 then
|
|
DoStmt(xi[1], Prog, Stmt);
|
|
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoRepeat(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
i, j: Integer;
|
|
Stmt: TfsRepeatStmt;
|
|
begin
|
|
Stmt := TfsRepeatStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
|
|
j := xi.Count - 1;
|
|
if CompareText(xi[j].Name, 'inverse') = 0 then
|
|
begin
|
|
Stmt.InverseCondition := True;
|
|
Dec(j);
|
|
end;
|
|
Stmt.Condition := DoExpression(xi[j], Prog);
|
|
Dec(j);
|
|
|
|
for i := 0 to j do
|
|
DoStmt(xi[i], Prog, Stmt);
|
|
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoCase(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
i: Integer;
|
|
Stmt: TfsCaseStmt;
|
|
|
|
procedure DoCaseSelector(xi: TfsXMLItem);
|
|
var
|
|
Selector: TfsCaseSelector;
|
|
begin
|
|
if (CompareText(xi.Name, 'caseselector') <> 0) or (xi.Count <> 2) then Exit;
|
|
Selector := TfsCaseSelector.Create(Prog, FUnitName, PropPos(xi));
|
|
Stmt.Add(Selector);
|
|
|
|
Selector.SetExpression := DoSet(xi[0], Prog);
|
|
DoStmt(xi[1], Prog, Selector);
|
|
end;
|
|
|
|
begin
|
|
Stmt := TfsCaseStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
Stmt.Condition := DoExpression(xi[0], Prog);
|
|
|
|
for i := 1 to xi.Count - 1 do
|
|
DoCaseSelector(xi[i]);
|
|
if CompareText(xi[xi.Count - 1].Name, 'caseselector') <> 0 then
|
|
DoStmt(xi[xi.Count - 1], Prog, Stmt.ElseStmt);
|
|
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoTry(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
i: Integer;
|
|
Stmt: TfsTryStmt;
|
|
begin
|
|
Stmt := TfsTryStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
|
|
for i := 0 to xi.Count - 1 do
|
|
if CompareText(xi[i].Name, 'exceptstmt') = 0 then
|
|
begin
|
|
Stmt.IsExcept := True;
|
|
DoCompoundStmt(xi[i], Prog, Stmt.ExceptStmt);
|
|
end
|
|
else if CompareText(xi[i].Name, 'finallystmt') = 0 then
|
|
DoCompoundStmt(xi[i], Prog, Stmt.ExceptStmt)
|
|
else
|
|
DoStmt(xi[i], Prog, Stmt);
|
|
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoBreak(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
Stmt: TfsBreakStmt;
|
|
begin
|
|
Stmt := TfsBreakStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoContinue(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
Stmt: TfsContinueStmt;
|
|
begin
|
|
Stmt := TfsContinueStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoExit(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
Stmt: TfsExitStmt;
|
|
begin
|
|
Stmt := TfsExitStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoReturn(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
xi1: TfsXMLItem;
|
|
begin
|
|
if xi.Count = 1 then { "return expr" }
|
|
begin
|
|
xi1 := TfsXMLItem.Create;
|
|
xi1.Name := 'dsgn';
|
|
xi.InsertItem(0, xi1);
|
|
with xi1.Add do
|
|
begin
|
|
Name := 'node';
|
|
Text := 'text="Result" pos="' + xi[1].Prop['pos'] + '"';
|
|
end;
|
|
|
|
DoAssign(xi, Prog, Statement);
|
|
end;
|
|
|
|
DoExit(xi, Prog, Statement);
|
|
end;
|
|
|
|
procedure TfsILParser.DoWith(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
d: TfsDesignator;
|
|
i, n: Integer;
|
|
s: String;
|
|
v: TfsVariable;
|
|
Stmt: TfsWithStmt;
|
|
|
|
function CreateUniqueVariable: String;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := 0;
|
|
while (Prog.FindLocal(IntToStr(i)) <> nil) or
|
|
(FWithList.IndexOf(IntToStr(i)) <> -1) do
|
|
Inc(i);
|
|
Result := '_WithList_' + IntToStr(i);
|
|
end;
|
|
|
|
begin
|
|
n := xi.Count - 1;
|
|
|
|
for i := 0 to n - 1 do
|
|
begin
|
|
d := DoDesignator(xi[i], Prog);
|
|
if not ((d.Typ = fvtClass) or (d.Typ = fvtVariant)) then
|
|
begin
|
|
d.Free;
|
|
raise Exception.Create(SClassRequired);
|
|
end;
|
|
|
|
{ create local variable with unique name }
|
|
s := CreateUniqueVariable;
|
|
v := TfsVariable.Create(s, d.Typ, d.TypeName);
|
|
Prog.Add(s, v);
|
|
|
|
Stmt := TfsWithStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Stmt.Variable := v;
|
|
Stmt.Designator := d;
|
|
Statement.Add(Stmt);
|
|
FWithList.AddObject(s, Stmt);
|
|
end;
|
|
|
|
DoStmt(xi[xi.Count - 1], Prog, Statement);
|
|
|
|
for i := 0 to n - 1 do
|
|
FWithList.Delete(FWithList.Count - 1);
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoDelete(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
Stmt: TfsCallStmt;
|
|
begin
|
|
Stmt := TfsCallStmt.Create(Prog, FUnitName, PropPos(xi));
|
|
Statement.Add(Stmt);
|
|
Stmt.Designator := DoDesignator(xi[0], Prog, emFree);
|
|
FProgram.AddCodeLine(FUnitName, PropPos(xi));
|
|
end;
|
|
|
|
procedure TfsILParser.DoCompoundStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to xi.Count - 1 do
|
|
DoStmt(xi[i], Prog, Statement);
|
|
end;
|
|
|
|
procedure TfsILParser.DoStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
|
|
var
|
|
s: String;
|
|
begin
|
|
s := LowerCase(xi.Name);
|
|
if s = 'assignstmt' then
|
|
DoAssign(xi, Prog, Statement)
|
|
else if s = 'callstmt' then
|
|
DoCall(xi, Prog, Statement)
|
|
else if s = 'ifstmt' then
|
|
DoIf(xi, Prog, Statement)
|
|
else if s = 'casestmt' then
|
|
DoCase(xi, Prog, Statement)
|
|
else if s = 'forstmt' then
|
|
DoFor(xi, Prog, Statement)
|
|
else if s = 'vbforstmt' then
|
|
DoVbFor(xi, Prog, Statement)
|
|
else if s = 'cppforstmt' then
|
|
DoCppFor(xi, Prog, Statement)
|
|
else if s = 'whilestmt' then
|
|
DoWhile(xi, Prog, Statement)
|
|
else if s = 'repeatstmt' then
|
|
DoRepeat(xi, Prog, Statement)
|
|
else if s = 'trystmt' then
|
|
DoTry(xi, Prog, Statement)
|
|
else if s = 'break' then
|
|
DoBreak(xi, Prog, Statement)
|
|
else if s = 'continue' then
|
|
DoContinue(xi, Prog, Statement)
|
|
else if s = 'exit' then
|
|
DoExit(xi, Prog, Statement)
|
|
else if s = 'return' then
|
|
DoReturn(xi, Prog, Statement)
|
|
else if s = 'with' then
|
|
DoWith(xi, Prog, Statement)
|
|
else if s = 'delete' then
|
|
DoDelete(xi, Prog, Statement)
|
|
else if s = 'compoundstmt' then
|
|
DoCompoundStmt(xi, Prog, Statement)
|
|
else if s = 'uses' then
|
|
DoUses(xi, Prog)
|
|
else if s = 'var' then
|
|
DoVar(xi, Prog, Statement)
|
|
else if s = 'const' then
|
|
DoConst(xi, Prog)
|
|
else if s = 'procedure' then
|
|
DoProc2(xi, Prog)
|
|
else if s = 'function' then
|
|
DoFunc2(xi, Prog)
|
|
end;
|
|
|
|
procedure TfsILParser.DoProgram(xi: TfsXMLItem; Prog: TfsScript);
|
|
var
|
|
TempRoot: TfsXMLItem;
|
|
|
|
procedure DoFirstPass(xi: TfsXMLItem);
|
|
var
|
|
i: Integer;
|
|
s: String;
|
|
begin
|
|
for i := 0 to xi.Count - 1 do
|
|
begin
|
|
s := LowerCase(xi[i].Name);
|
|
if s = 'compoundstmt' then
|
|
DoFirstPass(xi[i])
|
|
else if s = 'procedure' then
|
|
DoProc1(xi[i], Prog)
|
|
else if s = 'function' then
|
|
DoFunc1(xi[i], Prog)
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
TempRoot := FProgRoot;
|
|
FProgRoot := xi;
|
|
DoFirstPass(xi);
|
|
DoCompoundStmt(xi, Prog, Prog.Statement);
|
|
FProgRoot := TempRoot;
|
|
end;
|
|
|
|
|
|
end.
|