fs_iilparser.pas

这个是功能强大的报表软件

          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(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);
              { 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(Integer(PriorValue)) is TComponent then
                  begin
                    Component := TComponent(Integer(PriorValue)).FindComponent(NodeText);
                    if Component <> nil then
                    begin
                      Item.Ref := TfsCustomVariable.Create('', fvtClass, Component.ClassName);
                      Item.Ref.Value := Integer(Component);
                    end;
                  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.AddConst(Item.Ref[j].DefValue);
          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;

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

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