fs_iinterpreter.pas

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

  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 TfsCustomHelper then
    begin
// commented out until we find the better solution
//      if Item.FLockedBy <> FMainProg then
//        while Item.FLocked do;
      Item.FLocked := True;
      Item.FLockedBy := FMainProg;
    end;

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

      { 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
        Item.Value := AValue
      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
        if Item.Params[j].IsVarParam then
          Items[i][j].Value := Item.Params[j].Value;

      { restore proc variables if it was called from itself }
      if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
        RestoreLocalVariables(Item);

    finally
      Item.FLocked := False;
      Item.FLockedBy := nil;
    end;
  end;

  Result := Val;
end;

procedure TfsDesignator.CheckLateBinding;
var
  NewDesignator: TfsDesignator;
  Parser: TfsILParser;
begin
  if FLateBindingXMLSource <> nil then
  begin
    Parser := TfsILParser.Create(FProgram);
    try
      NewDesignator := Parser.DoDesignator(FLateBindingXMLSource, FProgram);
      Borrow(NewDesignator);
      NewDesignator.Free;
    finally
      Parser.Free;
      FLateBindingXMLSource.Free;
      FLateBindingXMLSource := nil;
    end;
  end;
end;

function TfsDesignator.GetValue: Variant;
begin
  CheckLateBinding;
  Result := DoCalc(Null, False);
end;

procedure TfsDesignator.SetValue(const Value: Variant);
begin
  CheckLateBinding;
  DoCalc(Value, True);
end;


{ TfsVariableDesignator }

function TfsVariableDesignator.GetValue: Variant;
begin
  Result := RefItem.Value;
end;

procedure TfsVariableDesignator.SetValue(const Value: Variant);
begin
  RefItem.Value := Value;
end;


{ TfsStringDesignator }

function TfsStringDesignator.GetValue: Variant;
begin
  Result := TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)];
end;

procedure TfsStringDesignator.SetValue(const Value: Variant);
begin
  TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)] := VarToStr(Value)[1];
end;


{ TfsArrayDesignator }

function TfsArrayDesignator.GetValue: Variant;
var
  i: Integer;
begin
  TfsCustomHelper(FRef1).ParentRef := RefItem;
  for i := 0 to FRef2.Count - 1 do
    FRef1.Params[i].Value := FRef2[i].Value;
  Result := FRef1.Value;
end;

procedure TfsArrayDesignator.SetValue(const Value: Variant);
var
  i: Integer;
begin
  TfsCustomHelper(FRef1).ParentRef := RefItem;
  for i := 0 to FRef2.Count - 1 do
    FRef1.Params[i].Value := FRef2[i].Value;
  FRef1.Value := Value;
end;


{ TfsSetExpression }

function TfsSetExpression.Check(const Value: Variant): Boolean;
var
  i: Integer;
  Expr: TfsCustomExpression;
begin
  Result := False;

 (* TfsSetExpression encapsulates the set like [1,2,3..10]
    In the example above we'll have the following Items:
    TfsExpression {1}
    TfsExpression {2}
    TfsExpression {3}
    nil (indicates the range )
    TfsExpression {10} *)

  i := 0;
  while i < Count do
  begin
    Expr := Items[i];

    if (i < Count - 1) and (Items[i + 1] = nil) then { subrange }
    begin
      Result := (Value >= Expr.Value) and (Value <= Items[i + 2].Value);
      Inc(i, 2);
    end
    else
      Result := Value = Expr.Value;

    if Result then break;
    Inc(i);
  end;
end;

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

function TfsSetExpression.GetValue: Variant;
var
  i: Integer;
begin
  Result := VarArrayCreate([0, Count - 1], varVariant);

  for i := 0 to Count - 1 do
    if Items[i] = nil then
      Result[i] := 0 else
      Result[i] := Items[i].Value;
end;


{ TfsScript }

constructor TfsScript.Create(AOwner: TComponent);
begin
  inherited;
  FItems := TStringList.Create;
  FItems.Sorted := True;
  FLines := TStringList.Create;
  FMacros := TStringList.Create;
  FStatement := TfsStatement.Create(Self, '', '');
  FSyntaxType := 'PascalScript';
  FUnitLines := TStringList.Create;
  Add('__StringHelper', TfsStringHelper.Create);
  Add('__ArrayHelper', TfsArrayHelper.Create('__ArrayHelper', -1, fvtVariant, ''));
end;

destructor TfsScript.Destroy;
begin
  inherited;
  Clear;
  FItems.Free;
  FLines.Free;
  FMacros.Free;
  FStatement.Free;
  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;
begin
  while FItems.Count > 0 do
  begin
    FItems.Objects[0].Free;
    FItems.Delete(0);
  end;
  FStatement.Clear;
  FUnitLines.Clear;
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 then
{  for i := 0 to Count - 1 do
    if AnsiCompareText(Name, TfsCustomVariable(FItems.Objects[i]).Name) = 0 then}
    begin
      Result := TfsCustomVariable(FItems.Objects[i]);
      Exit;
    end;
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
{$IFDEF TRIAL}
  ShowMessage('Unregistered version of FastScript.');
{$ENDIF}
  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);