fs_iinterpreter.pas

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

end;

destructor TfsClassVariable.Destroy;
begin
  FMembers.Free;
  inherited;
end;

function TfsClassVariable.GetMembers(Index: Integer): TfsCustomHelper;
begin
  Result := FMembers.FItems[Index];
end;

function TfsClassVariable.GetMembersCount: Integer;
begin
  Result := FMembers.Count;
end;

procedure TfsClassVariable.AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent);
var
  i: Integer;
begin
  i := Pos(' ', Syntax);
  Delete(Syntax, 1, i - 1);
  Syntax := 'function' + Syntax + ': ' + 'Constructor';
  AddMethod(Syntax, CallEvent);
end;

procedure TfsClassVariable.AddConstructor(Syntax: String;
  CallEvent: TfsCallMethodNewEvent);
var
  i: Integer;
begin
  i := Pos(' ', Syntax);
  Delete(Syntax, 1, i - 1);
  Syntax := 'function' + Syntax + ': ' + 'Constructor';
  AddMethod(Syntax, CallEvent);
end;

procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent);
var
  m: TfsMethodHelper;
begin
  m := TfsMethodHelper.Create(Syntax, FProgram);
  m.FOnCall := CallEvent;
  m.FClassRef := FClassRef;
  FMembers.Add(m);
end;

procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent);
var
  m: TfsMethodHelper;
begin
  m := TfsMethodHelper.Create(Syntax, FProgram);
  m.FOnCallNew := CallEvent;
  m.FClassRef := FClassRef;
  FMembers.Add(m);
end;

procedure TfsClassVariable.AddEvent(const Name: String; AEvent: TfsEventClass);
var
  e: TfsEventHelper;
begin
  e := TfsEventHelper.Create(Name, AEvent);
  e.FClassRef := FClassRef;
  FMembers.Add(e);
end;

procedure TfsClassVariable.AddProperty(const Name, Typ: String;
  GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent);
var
  p: TfsPropertyHelper;
begin
  p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ);
  p.FClassRef := FClassRef;
  p.FOnGetValue := GetEvent;
  p.FOnSetValue := SetEvent;
  p.IsReadOnly := not Assigned(SetEvent);
  FMembers.Add(p);
end;

procedure TfsClassVariable.AddPropertyEx(const Name, Typ: String;
  GetEvent: TfsGetValueNewEvent; SetEvent: TfsSetValueNewEvent);
var
  p: TfsPropertyHelper;
begin
  p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ);
  p.FClassRef := FClassRef;
  p.FOnGetValueNew := GetEvent;
  p.FOnSetValueNew := SetEvent;
  p.IsReadOnly := not Assigned(SetEvent);
  FMembers.Add(p);
end;

procedure TfsClassVariable.AddDefaultProperty(const Name, Params, Typ: String;
  CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
begin
  AddIndexProperty(Name, Params, Typ, CallEvent, AReadOnly);
  FDefProperty := Members[FMembers.Count - 1];
end;

procedure TfsClassVariable.AddDefaultProperty(const Name, Params,
  Typ: String; CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean);
begin
  AddIndexProperty(Name, Params, Typ, CallEvent, AReadOnly);
  FDefProperty := Members[FMembers.Count - 1];
end;

procedure TfsClassVariable.AddIndexProperty(const Name, Params,
  Typ: String; CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
var
  i: Integer;
  sl: TStringList;
  s: String;
begin
  sl := TStringList.Create;
  sl.CommaText := Params;

  s := '';
  for i := 0 to sl.Count - 1 do
    s := s + 'p' + IntToStr(i) + ': ' + sl[i] + '; ';

  SetLength(s, Length(s) - 2);
  try
    AddMethod('function ' + Name + '(' + s + '): ' + Typ, CallEvent);
    with TfsMethodHelper(Members[FMembers.Count - 1]) do
    begin
      IsReadOnly := AReadOnly;
      FIndexMethod := True;
    end;
  finally
    sl.Free;
  end;
end;

procedure TfsClassVariable.AddIndexProperty(const Name, Params,
  Typ: String; CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean);
var
  i: Integer;
  sl: TStringList;
  s: String;
begin
  sl := TStringList.Create;
  sl.CommaText := Params;

  s := '';
  for i := 0 to sl.Count - 1 do
    s := s + 'p' + IntToStr(i) + ': ' + sl[i] + '; ';

  SetLength(s, Length(s) - 2);
  try
    AddMethod('function ' + Name + '(' + s + '): ' + Typ, CallEvent);
    with TfsMethodHelper(Members[FMembers.Count - 1]) do
    begin
      IsReadOnly := AReadOnly;
      FIndexMethod := True;
    end;
  finally
    sl.Free;
  end;
end;

procedure TfsClassVariable.AddComponent(c: TComponent);
begin
  FMembers.Add(TfsComponentHelper.Create(c));
end;

procedure TfsClassVariable.AddPublishedProperties(AClass: TClass);
var
  TypeInfo: PTypeInfo;
  PropCount: Integer;
  PropList: PPropList;
  i: Integer;
  cl: String;
  t: TfsVarType;
  FClass: TClass;
  p: TfsPropertyHelper;
begin
  TypeInfo := AClass.ClassInfo;
  if TypeInfo = nil then Exit;

  PropCount := GetPropList(TypeInfo, tkProperties, nil);
  GetMem(PropList, PropCount * SizeOf(PPropInfo));
  GetPropList(TypeInfo, tkProperties, PropList);

  try
    for i := 0 to PropCount - 1 do
    begin
      t := fvtInt;
      cl := '';

      case PropList[i].PropType^.Kind of
        tkInteger:
          t := fvtInt;
        tkSet:
          begin
            t := fvtEnum;
            cl := String(PropList[i].PropType^.Name);
          end;
        tkEnumeration:
          begin
            t := fvtEnum;
            cl := String(PropList[i].PropType^.Name);
            if (CompareText(cl, 'Boolean') = 0) or (CompareText(cl, 'bool') = 0) then
              t := fvtBool;
          end;
        tkFloat:
          t := fvtFloat;
        tkChar, tkWChar:
          t := fvtChar;
        tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}:
          t := fvtString;
        tkVariant:
          t := fvtVariant;
        tkClass:
          begin
            t := fvtClass;
          {$IFNDEF FPC}
            FClass := GetTypeData(PropList[i].PropType^).ClassType;
          {$ELSE}
            FClass := GetTypeData(PropList[i].PropType).ClassType;
          {$ENDIF}
            cl := FClass.ClassName;
          end;
      end;

      p := TfsPropertyHelper.Create(String(PropList[i].Name), t, cl);
      p.FClassRef := FClassRef;
      p.FIsPublished := True;
      FMembers.Add(p);
    end;

  finally
    FreeMem(PropList, PropCount * SizeOf(PPropInfo));
  end;
end;

function TfsClassVariable.Find(const Name: String): TfsCustomHelper;
var
  cl: TfsClassVariable;

  function DoFind(const Name: String): TfsCustomHelper;
  var
    i: Integer;
  begin
    Result := nil;
    for i := 0 to FMembers.Count - 1 do
      if CompareText(Name, Members[i].Name) = 0 then
      begin
        Result := Members[i];
        Exit;
      end;
  end;

begin
  Result := DoFind(Name);
  if Result = nil then
  begin
    cl := FProgram.FindClass(FAncestor);
    if cl <> nil then
      Result := cl.Find(Name);
  end;
end;

function TfsClassVariable.GetValue: Variant;
begin
  if Params[0].Value = Null then
    Result := Integer(FClassRef.NewInstance) else        { constructor call }
    Result := Params[0].Value;                           { typecast }
  Params[0].Value := Null;
end;


{ TfsDesignatorItem }

function TfsDesignatorItem.GetItem(Index: Integer): TfsCustomExpression;
begin
  Result := FItems[Index];
end;


{ TfsDesignator }

constructor TfsDesignator.Create(AProgram: TfsScript);
var
  ParentProg: TfsScript;
begin
  inherited Create('', fvtInt, '');
  FProgram := AProgram;
  FMainProg := FProgram;
  ParentProg := FProgram;
  while ParentProg <> nil do
    if ParentProg.FMainProg then
    begin
      FMainProg := ParentProg;
      break;
    end
    else
      ParentProg := ParentProg.FParent;
end;

destructor TfsDesignator.Destroy;
begin
  if FLateBindingXMLSource <> nil then
    FLateBindingXMLSource.Free;
  inherited;
end;

procedure TfsDesignator.Borrow(ADesignator: TfsDesignator);
var
  SaveItems: TList;
begin
  SaveItems := FItems;
  FItems := ADesignator.FItems;
  ADesignator.FItems := SaveItems;
  FKind := ADesignator.FKind;
  FRef1 := ADesignator.FRef1;
  FRef2 := ADesignator.FRef2;
  FTyp := ADesignator.Typ;
  FTypeName := ADesignator.TypeName;
  FIsReadOnly := ADesignator.IsReadOnly;
  RefItem := ADesignator.RefItem;
end;

procedure TfsDesignator.Finalize;
var
  Item: TfsDesignatorItem;
begin
  Item := Items[Count - 1];
  FTyp := Item.Ref.Typ;
  FTypeName := Item.Ref.TypeName;
  if FTyp = fvtConstructor then
  begin
    FTyp := fvtClass;
    FTypeName := Items[Count - 2].Ref.TypeName;
  end;

  FIsReadOnly := Item.Ref.IsReadOnly;

  { speed optimization for access to single variable, string element or array }
  if (Count = 1) and (Items[0].Ref is TfsVariable) then
  begin
    RefItem := Items[0].Ref;
    FKind := dkVariable;
  end
  else if (Count = 2) and (Items[0].Ref is TfsStringVariable) then
  begin
    RefItem := Items[0].Ref;
    FRef1 := Items[1][0];
    FKind := dkStringArray;
  end
  else if (Count = 2) and (Items[0].Ref is TfsVariable) and (Items[0].Ref.Typ = fvtArray) then
  begin
    RefItem := Items[0].Ref;
    FRef1 := RefItem.RefItem;
    FRef2 := Items[1];
    FKind := dkArray;
  end
  else
    FKind := dkOther;
end;

function TfsDesignator.GetItem(Index: Integer): TfsDesignatorItem;
begin
  Result := FItems[Index];
end;

function TfsDesignator.DoCalc(const AValue: Variant; Flag: Boolean): Variant;
var
  i, j: Integer;
  Item: TfsCustomVariable;
  Val: Variant;
  Ref: TfsCustomVariable;
  Temp, Temp1: array of Variant;

  { copy local variables to Temp }
  procedure SaveLocalVariables(Item: TfsCustomVariable);
  var
    i: Integer;
  begin
    with TfsProcVariable(Item) do
    begin
      SetLength(Temp, Prog.Count);

      for i := 0 to Prog.Count - 1 do
        if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then
          Temp[i] := Prog.Items[i].Value;
    end;
  end;

  { restore local variables from Temp}
  procedure RestoreLocalVariables(Item: TfsCustomVariable);
  var
    i: Integer;
  begin
    with TfsProcVariable(Item) do
      for i := 0 to Prog.Count - 1 do
        if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then
          Prog.Items[i].Value := Temp[i];

    Temp := nil;
  end;

begin
  Ref := nil;
  Val := Null;

  for i := 0 to Count - 1 do
  begin
    Item := Items[i].Ref;

    if Item is TfsDesignator then { it is true for "WITH" statements }
    begin
      Ref := Item;
      Val := Item.Value;
      continue;
    end;

    try
      { we're trying to call the local procedure that is already executing -
        i.e. we have a recursion }
      if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
        SaveLocalVariables(Item);

      if Item.Count > 0 then
      begin
        SetLength(Temp1, Item.Count);
        try
          { calculate params and copy param values to the temp1 array }
          for j := 0 to Item.Count - 1 do
            if Item.IsMacro then
              Temp1[j] := TfsExpression(Items[i][j]).Source
            else
              Temp1[j] := Items[i][j].Value;
          { copy calculated values to the item params }
          for j := 0 to Item.Count - 1 do
            Item.Params[j].Value := Temp1[j];
        finally
          Temp1 := nil;
        end;
      end;

      { copy value and var reference to the helper object }
      if Item is TfsCustomHelper then
      begin
        TfsCustomHelper(Item).ParentRef := Ref;
        TfsCustomHelper(Item).ParentValue := Val;
        TfsCustomHelper(Item).Prog := FProgram;
      end;

      Ref := Item;
      { assign a value to the last designator node if called from SetValue }
      if Flag and (i = Count - 1) then
      begin
        Item.Value := AValue
      end
      else
      begin
        Item.NeedResult := (i <> Count - 1) or NeedResult;
        Val := Item.Value;
      end;

      { copy back var params }
      for j := 0 to Item.Count - 1 do