fs_iilparser.pas

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

          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
      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 LINUX}
        while (i <= Length(Text)) and (Text[i] <> #10) do
{$ELSE}
        while (i <= Length(Text)) and (Text[i] <> #13) 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);
        FStream.Position := 0;
        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 := '';
  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, '');
      Prog.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'];
  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;

  procedure DoArray(xi: TfsXMLItem);
  var
    i, n: Integer;
    v: array of Integer;
    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);
    Expr := DoExpression(xi[0], Prog);
    InitValue := Expr.Value;
    try
      CheckTypeCompatibility(Temp, Expr);
    finally
      Temp.Free;
      Expr.Free;
    end;
  end;

begin
  RefItem := nil;
  InitItem := nil;
  TypeName := 'Variant';
  IsPascal := False;

(*
  <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, 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);
  Result.Value := InitValue;
  Result.RefItem := RefItem;

  { create init statement }
  if (InitItem <> nil) and (Statement <> nil) then
  begin
    AssignStmt := TfsAssignmentStmt.Create(Prog, FUnitName, PropPos(xi));
    AssignStmt.Designator := TfsVariableDesignator.Create(Prog);
    AssignStmt.Designator.RefItem := Result;
    AssignStmt.Expression := DoExpression(InitItem[0], Prog);
    CheckTypeCompatibility(Result, AssignStmt.Expression);
    AssignStmt.Optimize;
    Statement.Add(AssignStmt);
  end;
end;

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;

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

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