fs_iinterpreter.pas

报表控件。FastReport 是非常强大的报表控件

  FUnitLines.Free;
end;

procedure TfsScript.Add(const Name: String; Item: TObject);
begin
  FItems.AddObject(Name, Item);
  if Item is TfsCustomVariable then
    TfsCustomVariable(Item).AddedBy := FAddedBy;
end;

function TfsScript.Count: Integer;
begin
  Result := FItems.Count;
end;

procedure TfsScript.Remove(Item: TObject);
begin
  FItems.Delete(FItems.IndexOfObject(Item));
end;

procedure TfsScript.Clear;
var
  i: Integer;
  item: TObject;
begin
  i := 0;
  while i < FItems.Count do
  begin
    item := FItems.Objects[i];
    if (item is TfsRTTIModule) or
      ((item is TfsCustomVariable) and
       (TfsCustomVariable(item).AddedBy = TObject(1))) then
      Inc(i)
    else
    begin
      item.Free;
      FItems.Delete(i);
    end;
  end;
  FStatement.Clear;
  FUnitLines.Clear;
  FErrorPos := '';
  FErrorMsg := '';
  FErrorUnit := '';
end;

procedure TfsScript.ClearItems(Owner: TObject);
begin
  RemoveItems(Owner);
  FStatement.Clear;
  FUnitLines.Clear;
end;

procedure TfsScript.RemoveItems(Owner: TObject);
var
  i: Integer;
begin
  for i := Count - 1 downto 0 do
    if Items[i].AddedBy = Owner then
    begin
      Items[i].Free;
      Remove(Items[i]);
    end;
end;

function TfsScript.GetItem(Index: Integer): TfsCustomVariable;
begin
  Result := TfsCustomVariable(FItems.Objects[Index]);
end;

function TfsScript.Find(const Name: String): TfsCustomVariable;
begin
  Result := FindLocal(Name);

  { trying to find the identifier in all parent programs }
  if (Result = nil) and (FParent <> nil) then
    Result := FParent.Find(Name);
end;

function TfsScript.FindLocal(const Name: String): TfsCustomVariable;
var
  i: Integer;
begin
  Result := nil;
  i := FItems.IndexOf(Name);
  if (i <> -1) and (FItems.Objects[i] is TfsCustomVariable) then
    Result := TfsCustomVariable(FItems.Objects[i]);
end;

function TfsScript.Compile: Boolean;
var
  p: TfsILParser;
begin
  Result := False;
  FErrorMsg := '';

  p := TfsILParser.Create(Self);
  try
    p.SelectLanguage(FSyntaxType);
    if p.MakeILScript(FLines.Text) then
      p.ParseILScript;
  finally
    p.Free;
  end;

  if FErrorMsg = '' then
  begin
    Result := True;
    FErrorPos := '';
  end
end;

procedure TfsScript.Execute;
begin

  FExitCalled := False;
  FTerminated := False;
  FIsRunning := True;
  FMainProg := True;
  try
    FStatement.Execute;
  finally
    FExitCalled := False;
    FTerminated := False;
    FIsRunning := False;
  end;
end;

function TfsScript.Run: Boolean;
begin
  Result := Compile;
  if Result then
    Execute;
end;

function TfsScript.GetILCode(Stream: TStream): Boolean;
var
  p: TfsILParser;
begin
  Result := False;
  FErrorMsg := '';

  p := TfsILParser.Create(Self);
  try
    p.SelectLanguage(FSyntaxType);
    if p.MakeILScript(FLines.Text) then
      p.ILScript.SaveToStream(Stream);
  finally
    p.Free;
  end;

  if FErrorMsg = '' then
  begin
    Result := True;
    FErrorPos := '';
  end;
end;

function TfsScript.SetILCode(Stream: TStream): Boolean;
var
  p: TfsILParser;
begin
  Result := False;
  FErrorMsg := '';

  p := TfsILParser.Create(Self);
  try
    p.ILScript.LoadFromStream(Stream);
    p.ParseILScript;
  finally
    p.Free;
  end;

  if FErrorMsg = '' then
  begin
    Result := True;
    FErrorPos := '';
  end;
end;

procedure TfsScript.AddType(const TypeName: String; ParentType: TfsVarType);
var
  v: TfsTypeVariable;
begin
  if Find(TypeName) <> nil then Exit;
  v := TfsTypeVariable.Create(TypeName, ParentType, '');
  Add(TypeName, v);
end;

function TfsScript.AddClass(AClass: TClass; const Ancestor: String): TfsClassVariable;
var
  cl: TfsClassVariable;
begin
  Result := nil;
  if Find(AClass.ClassName) <> nil then Exit;

  Result := TfsClassVariable.Create(AClass, Ancestor);
  Result.FProgram := Self;
  Add(Result.Name, Result);

  cl := TfsClassVariable(Find(Ancestor));
  if cl <> nil then
    Result.FDefProperty := cl.DefProperty;
end;

procedure TfsScript.AddConst(const Name, Typ: String; const Value: Variant);
var
  v: TfsVariable;
begin
  if Find(Name) <> nil then Exit;

  v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ);
  v.Value := Value;
  v.IsReadOnly := True;
  Add(v.Name, v);
end;

procedure TfsScript.AddEnum(const Typ, Names: String);
var
  i: Integer;
  v: TfsVariable;
  sl: TStringList;
begin
  v := TfsVariable.Create(Typ, fvtEnum, Typ);
  Add(v.Name, v);

  sl := TStringList.Create;
  sl.CommaText := Names;

  try
    for i := 0 to sl.Count - 1 do
    begin
      v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ);
      v.Value := i;
      v.IsReadOnly := True;
      Add(v.Name, v);
    end;
  finally
    sl.Free;
  end;
end;

procedure TfsScript.AddEnumSet(const Typ, Names: String);
var
  i, j: Integer;
  v: TfsVariable;
  sl: TStringList;
begin
  v := TfsVariable.Create(Typ, fvtEnum, Typ);
  Add(v.Name, v);

  sl := TStringList.Create;
  sl.CommaText := Names;

  try
    j := 1;
    for i := 0 to sl.Count - 1 do
    begin
      v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ);
      v.Value := j;
      v.IsReadOnly := True;
      Add(v.Name, v);
      j := j * 2;
    end;
  finally
    sl.Free;
  end;
end;

procedure TfsScript.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent;
  const Category: String = ''; const Description: String = '');
var
  v: TfsMethodHelper;
begin
  v := TfsMethodHelper.Create(Syntax, Self);
  v.FOnCall := CallEvent;
  if Description = '' then
    v.FDescription := v.Name else
    v.FDescription := Description;
  v.FCategory := Category;
  Add(v.Name, v);
end;

procedure TfsScript.AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent;
  const Category: String = ''; const Description: String = '');
var
  v: TfsMethodHelper;
begin
  v := TfsMethodHelper.Create(Syntax, Self);
  v.FOnCallNew := CallEvent;
  if Description = '' then
    v.FDescription := v.Name else
    v.FDescription := Description;
  v.FCategory := Category;
  Add(v.Name, v);
end;

procedure TfsScript.AddObject(const Name: String; Obj: TObject);
begin
  AddVariable(Name, Obj.ClassName, Integer(Obj));
end;

procedure TfsScript.AddVariable(const Name, Typ: String; const Value: Variant);
var
  v: TfsVariable;
begin
  if Find(Name) <> nil then Exit;

  v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ);
  v.Value := Value;
  Add(v.Name, v);
end;

procedure TfsScript.AddForm(Form: TComponent);
begin
  AddComponent(Form);
end;

procedure TfsScript.AddComponent(Form: TComponent);
var
  i: Integer;
  v: TfsClassVariable;
begin
{$IFNDEF NOFORMS}
  v := FindClass(Form.ClassName);
  if v = nil then
  begin
    if Form.InheritsFrom(TForm) then
      AddClass(Form.ClassType, 'TForm')
    else if Form.InheritsFrom(TDataModule) then
      AddClass(Form.ClassType, 'TDataModule')
    else
      Exit;
    v := FindClass(Form.ClassName);
  end;

  for i := 0 to Form.ComponentCount - 1 do
    v.AddComponent(Form.Components[i]);
  AddObject(Form.Name, Form);
{$ENDIF}
end;

procedure TfsScript.AddRTTI;
var
  i: Integer;
  rtti: TfsRTTIModule;
  obj: TClass;
begin
  if FRTTIAdded then Exit;

  AddedBy := TObject(1); // do not clear
  for i := 0 to FRTTIModules.Count - 1 do
  begin
    obj := FRTTIModules[i];
    rtti := TfsRTTIModule(obj.NewInstance);
    rtti.Create(Self);
    Add('', rtti);
  end;
  AddedBy := nil;

  FRTTIAdded := True;
end;

procedure TfsScript.ClearRTTI;
var
  i: Integer;
  item: TObject;
begin
  if not FRTTIAdded then Exit;

  i := 0;
  while i < FItems.Count do
  begin
    item := FItems.Objects[i];
    if (item is TfsRTTIModule) or
      ((item is TfsCustomVariable) and
       (TfsCustomVariable(item).AddedBy = TObject(1))) then
    begin
      item.Free;
      FItems.Delete(i);
    end
    else
      Inc(i);
  end;

  FRTTIAdded := False;
end;

function TfsScript.CallFunction(const Name: String; const Params: Variant): Variant;
var
  i: Integer;
  v: TfsCustomVariable;
  p: TfsProcVariable;
begin
  v := FindLocal(Name);
  if (v <> nil) and (v is TfsProcVariable) then
  begin
    p := TfsProcVariable(v);

    if VarIsArray(Params) then
      for i := 0 to VarArrayHighBound(Params, 1) do
        p.Params[i].Value := Params[i];
    Result := p.Value;
  end
  else
  begin
    Result := Null;
  end
end;

function TfsScript.CallFunction1(const Name: String; var Params: Variant): Variant;
var
  i: Integer;
  v: TfsCustomVariable;
  p: TfsProcVariable;
begin
  v := FindLocal(Name);
  if (v <> nil) and (v is TfsProcVariable) then
  begin
    p := TfsProcVariable(v);

    if VarIsArray(Params) then
      for i := 0 to VarArrayHighBound(Params, 1) do
        p.Params[i].Value := Params[i];
    Result := p.Value;
    if VarIsArray(Params) then
      for i := 0 to VarArrayHighBound(Params, 1) do
        Params[i] := p.Params[i].Value;
  end
  else
    Result := Null;
end;

function TfsScript.Evaluate(const Expression: String): Variant;
var
  p: TfsScript;
  Prog: TfsScript;
  SaveEvent: TfsRunLineEvent;
begin
  Result := Null;
  if FProgRunning = nil then
    p := Self else
    p := FProgRunning;

  Prog := TfsScript.Create(nil);
  Prog.AddRTTI;
  Prog.Parent := p;
  SaveEvent := FOnRunLine;
  FOnRunLine := nil;
  try
    Prog.Lines.Text := 'function __f__: Variant; begin Result := ' + Expression +
      ' end; begin end.';
    if not Prog.Compile then
      Result := Prog.ErrorMsg else
      Result := Prog.FindLocal('__f__').Value;
  finally
    Prog.Free;
    FOnRunLine := SaveEvent;
  end;
end;

function TfsScript.FindClass(const Name: String): TfsClassVariable;
var
  Item: TfsCustomVariable;
begin
  Item := Find(Name);
  if (Item <> nil) and (Item is TfsClassVariable) then
    Result := TfsClassVariable(Item) else
    Result := nil
end;

procedure TfsScript.RunLine(const UnitName, Index: String);
var
  p: TfsScript;
begin