fs_iilparser.pas

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

        { 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 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(Integer(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);
            if Item.Ref = nil then
              raise Exception.Create(SIdUndeclared + '''' + NodeText + '''');
          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);
        Expr.AddConst(Item.Ref[j].DefValue);
        Expr.Finalize;
        Item.Add(Expr);
      end;

    for j := 0 to Item.Count - 1 do
    begin
      FErrorPos := Item[j].SourcePos;
      CheckTypeCompatibility(Item.Ref[j], Item[j]);
    end;
  end;
end;

function TfsILParser.DoSet(xi: TfsXMLItem; Prog: TfsScript): TfsSetExpression;
var
  i: Integer;
  Name: String;
begin
  Result := TfsSetExpression.Create('', fvtVariant, '');

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

  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;
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 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
    DoProgram(xd.Root, Prog);
    xd.Free;
  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);

  Proc := TfsProcVariable.Create(Name, fvtInt, '', Prog, False);
  Proc.SourcePos := PropPos(xi);
  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 := fvtInt;

  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);
  Prog.Add(Name, Func);

  for i := 0 to xi.Count - 1 do
  begin
    s := LowerCase(xi[i].Name);