fs_iinterpreter.pas

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

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

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
    Result := Null;
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.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
  p := Self;
  while p <> nil do
    if Assigned(p.FOnRunLine) then
    begin
      p.FOnRunLine(Self, UnitName, Index);
      break;
    end
    else
      p := p.FParent;
end;

function TfsScript.GetVariables(Index: String): Variant;
var
  v: TfsCustomVariable;
begin
  v := Find(Index);
  if v <> nil then
    Result := v.Value else
    Result := Null;
end;

procedure TfsScript.SetVariables(Index: String; const Value: Variant);
var
  v: TfsCustomVariable;
begin
  v := Find(Index);
  if v <> nil then
    v.Value := Value else
    AddVariable(Index, 'Variant', Value);
end;

procedure TfsScript.SetLines(const Value: TStrings);
begin
  FLines.Assign(Value);
end;

procedure TfsScript.Terminate;

  procedure TerminateAll(Script: TfsScript);
  var
    i: Integer;
  begin
    Script.FExitCalled := True;
    Script.FTerminated := True;
    for i := 0 to Script.Count - 1 do
      if Script.Items[i] is TfsProcVariable then
        TerminateAll(TfsProcVariable(Script.Items[i]).Prog);
  end;

begin
  TerminateAll(Self);
end;

procedure TfsScript.AddCodeLine(const UnitName, APos: String);
var
  sl: TStringList;
  LineN: String;
begin
  if FUnitLines.IndexOfName(UnitName) = -1 then
    FUnitLines.Add(UnitName + '=');

  sl := TStringList.Create;
  sl.CommaText := FUnitLines.Values[UnitName];
  LineN := Copy(APos, 1, Pos(':', APos) - 1);
  if sl.IndexOf(LineN) = -1 then
    FUnitLines.Values[UnitName] := FUnitLines.Values[UnitName] + LineN + ',';
  sl.Free;
end;

function TfsScript.IsExecutableLine(LineN: Integer; const UnitName: String = ''): Boolean;
var
  sl: TStringList;
begin
  Result := False;
  if FUnitLines.IndexOfName(UnitName) = -1 then Exit;

  sl := TStringList.Create;
  sl.CommaText := FUnitLines.Values[UnitName];
  if sl.IndexOf(IntToStr(LineN)) <> -1 then
    Result := True;
  sl.Free;
end;


{ TfsStatement }

constructor TfsStatement.Create(AProgram: TfsScript; const UnitName,
  SourcePos: String);
begin
  inherited Create;
  FProgram := AProgram;
  FSourcePos := SourcePos;
  FUnitName := UnitName;
end;

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

procedure TfsStatement.Execute;
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
  begin
    if FProgram.FTerminated then break;
    Items[i].Execute;
    if FProgram.FBreakCalled or FProgram.FContinueCalled or
      FProgram.FExitCalled then break;
  end;
end;

procedure TfsStatement.RunLine;
begin
  FProgram.RunLine(FUnitName, FSourcePos);
end;


{ TfsAssignmentStmt }

destructor TfsAssignmentStmt.Destroy;
begin
  FDesignator.Free;
  FExpression.Free;
  inherited;
end;

procedure TfsAssignmentStmt.Optimize;
begin
  FVar := FDesignator;
  FExpr := FExpression;

  if FDesignator is TfsVariableDesignator then
    FVar := FDesignator.RefItem;
  if TfsExpression(FExpression).SingleItem <> nil then
    FExpr := TfsExpression(FExpression).SingleItem;
end;

procedure TfsAssignmentStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FExpr.Value;
end;

procedure TfsAssignPlusStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FVar.Value + FExpr.Value;
end;

procedure TfsAssignMinusStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FVar.Value - FExpr.Value;
end;

procedure TfsAssignMulStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FVar.Value * FExpr.Value;
end;

procedure TfsAssignDivStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FVar.Value / FExpr.Value;
end;


{ TfsCallStmt }

destructor TfsCallStmt.Destroy;
begin
  FDesignator.Free;
  inherited;
end;

procedure TfsCallStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  if FModificator = '' then
  begin
    FDesignator.NeedResult := False;
    FDesignator.Value;
  end
  else if FModificator = '+' then
    FDesignator.Value := FDesignator.Value + 1
  else if FModificator = '-' then
    FDesignator.Value := FDesignator.Value - 1
end;


{ TfsIfStmt }

constructor TfsIfStmt.Create(AProgram: TfsScript; const UnitName,
  SourcePos: String);
begin
  inherited;
  FElseStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
end;

destructor TfsIfStmt.Destroy;
begin
  FCondition.Free;
  FElseStmt.Free;
  inherited;
end;

procedure TfsIfStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  if Boolean(FCondition.Value) = True then
    inherited Execute else
    FElseStmt.Execute;
end;


{ TfsRepeatStmt }

destructor TfsRepeatStmt.Destroy;
begin
  FCondition.Free;
  inherited;
end;

procedure TfsRepeatStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;

  repeat
    inherited Execute;
    if FProgram.FBreakCalled or FProgram.FExitCalled then break;
    FProgram.FContinueCalled := False;
  until Boolean(FCondition.Value) = not FInverseConditio