fs_iinterpreter.pas

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

        if Item.Params[j].IsVarParam then
          Items[i][j].Value := Item.Params[j].Value;

    finally
      { restore proc variables if it was called from itself }
      if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
        RestoreLocalVariables(Item);
    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] := Null else
      Result[i] := Items[i].Value;
end;


{ TfsScript }

constructor TfsScript.Create(AOwner: TComponent);
begin
  inherited;
  FEvaluteRiseError := False;
  FItems := TStringList.Create;
  FItems.Sorted := True;
  FItems.Duplicates := dupAccept;
  FLines := TStringList.Create;
  FMacros := TStringList.Create;
  FIncludePath := TStringList.Create;
  FIncludePath.Add('');
  FStatement := TfsStatement.Create(Self, '', '');
  FSyntaxType := 'PascalScript';
  FUnitLines := TStringList.Create;
  FUseClassLateBinding := False;
end;

destructor TfsScript.Destroy;
begin
  inherited;
  Clear;
  ClearRTTI;
  FItems.Free;
  FLines.Free;
  FMacros.Free;
  FIncludePath.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;
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;

proc