fs_iilparser.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

    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
  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);

  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;

  Stmt.Designator := Designator;
  Stmt.Expression := Expression;
  Stmt.Optimize;
  Statement.Add(Stmt);
  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));
  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;

  Statement.Add(Stmt);
  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));
  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;

  Statement.Add(Stmt);
  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));
  ErrorPos(xi[0]);
  Stmt.Variable := FindVar(Prog, xi[0].Prop['text']);
  if not ((Stmt.Variable is TfsVariable) and
    (Stmt.Variable.Typ in [fvtInt, 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);

  Statement.Add(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));
  ErrorPos(xi[0]);
  Stmt.Variable := FindVar(Prog, xi[0].Prop['text']);
  if not ((Stmt.Variable is TfsVariable) and
    (Stmt.Variable.Typ in [fvtInt, 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);

  Statement.Add(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));
  DoStmt(xi[0], Prog, Stmt.FirstStmt);
  Stmt.Expression := DoExpression(xi[1], Prog);
  DoStmt(xi[2], Prog, Stmt.SecondStmt);
  DoStmt(xi[3], Prog, Stmt);

  Statement.Add(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));
  Stmt.Condition := DoExpression(xi[0], Prog);
  DoStmt(xi[1], Prog, Stmt);

  Statement.Add(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));

  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);

  Statement.Add(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));
  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);

  Statement.Add(Stmt);
  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));

  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);

  Statement.Add(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 := 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
      raise Exception.Create(SClassRequired);

    { 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));
  Stmt.Designator := DoDesignator(xi[0], Prog, emFree);
  Statement.Add(Stmt);
  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.