fr_intrp.pas

FreeReport 2.34 consists of the report engine, designer and previewer, with capabilities comparable

{******************************************}
{                                          }
{             FastReport v2.3              }
{               Interpreter                }
{                                          }
{ Copyright (c) 1998-2000 by Tzyganenko A. }
{                                          }
{******************************************}

unit FR_Intrp;

interface

{$I FR.inc}

uses Classes, SysUtils, Graphics, FR_Pars;

type
  TfrInterpretator = class(TObject)
  private
    FParser: TfrParser;
  public
    constructor Create;
    destructor Destroy; override;
    procedure GetValue(const Name: String; var Value: Variant); virtual;
    procedure SetValue(const Name: String; Value: Variant); virtual;
    procedure DoFunction(const name: String; p1, p2, p3: Variant;
                         var val: String); virtual;
    procedure PrepareScript(MemoFrom, MemoTo, MemoErr: TStringList); virtual;
    procedure DoScript(Memo: TStringList); virtual;
  end;

  TfrVariables = class(TObject)
  private
    FList: TList;
    procedure SetVariable(Name: String; Value: Variant);
    function GetVariable(Name: String): Variant;
    procedure SetValue(Index: Integer; Value: Variant);
    function GetValue(Index: Integer): Variant;
    function GetName(Index: Integer): String;
    function GetCount: Integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure Delete(Index: Integer);
    function IndexOf(Name: String): Integer;
    property Variable[Name: String]: Variant
      read GetVariable write SetVariable; default;
    property Value[Index: Integer]: Variant read GetValue write SetValue;
    property Name[Index: Integer]: String read GetName;
    property Count: Integer read GetCount;
  end;


implementation

{$IFDEF Delphi6}
  uses Variants;
{$ENDIF}

type
  TCharArray = Array[0..31999] of Char;
  PCharArray = ^TCharArray;
  lrec = record
    name: String[16];
    n: Integer;
  end;

  PVariable = ^TVariable;
  TVariable = record
    Name: PString;
    Value: Variant;
  end;

const
  ttIf    = #1;
  ttGoto  = #2;
  ttProc  = #3;

var
  labels: Array[0..100] of lrec;
  labc: Integer;

{------------------------------------------------------------------------------}
constructor TfrVariables.Create;
begin
  inherited Create;
  FList := TList.Create;
end;

destructor TfrVariables.Destroy;
begin
  Clear;
  FList.Free;
  inherited Destroy;
end;

procedure TfrVariables.Clear;
begin
  while FList.Count > 0 do
    Delete(0);
end;

procedure TfrVariables.SetVariable(Name: String; Value: Variant);
var
  i: Integer;
  p: PVariable;
begin
  for i := 0 to FList.Count - 1 do
    if AnsiCompareText(PVariable(FList[i]).Name^, Name) = 0 then
    begin
      PVariable(FList[i]).Value := Value;
      Exit;
    end;
  GetMem(p, SizeOf(TVariable));
  FillChar(p^, SizeOf(TVariable), 0);
  p^.Name := NewStr(Name);
  p^.Value := Value;
  FList.Add(p);
end;

function TfrVariables.GetVariable(Name: String): Variant;
var
  i: Integer;
begin
  Result := Null;
  for i := 0 to FList.Count - 1 do
    if AnsiCompareText(PVariable(FList[i]).Name^, Name) = 0 then
    begin
      Result := PVariable(FList[i]).Value;
      break;
    end;
end;

procedure TfrVariables.SetValue(Index: Integer; Value: Variant);
begin
  if (Index < 0) or (Index >= FList.Count) then Exit;
  PVariable(FList[Index])^.Value := Value;
end;

function TfrVariables.GetValue(Index: Integer): Variant;
begin
  Result := 0;
  if (Index < 0) or (Index >= FList.Count) then Exit;
  Result := PVariable(FList[Index])^.Value;
end;

function TfrVariables.IndexOf(Name: String): Integer;
var
  i: Integer;
begin
  Result := -1;
  for i := 0 to FList.Count - 1 do
    if AnsiCompareText(PVariable(FList[i]).Name^, Name) = 0 then
    begin
      Result := i;
      break;
    end;
end;

function TfrVariables.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TfrVariables.GetName(Index: Integer): String;
begin
  Result := '';
  if (Index < 0) or (Index >= FList.Count) then Exit;
  Result := PVariable(FList[Index])^.Name^;
end;

procedure TfrVariables.Delete(Index: Integer);
var
  p: PVariable;
begin
  if (Index < 0) or (Index >= FList.Count) then Exit;
  p := FList[Index];
  DisposeStr(p^.Name);
  p^.Value := 0;
  FreeMem(p, SizeOf(TVariable));
  FList.Delete(Index);
end;

{------------------------------------------------------------------------------}
function Remain(S: String; From: Integer): String;
begin
  Result := Copy(s, From, Length(s) - 1);
end;

function GetIdentify(const s: String; var i: Integer): String;
var
  k: Integer;
begin
  while (i <= Length(s)) and (s[i] = ' ') do
    Inc(i);
  k := i;
  while (i <= Length(s)) and (s[i] <> ' ') do
    Inc(i);
  Result := Copy(s, k, i - k);
end;

{-----------------------------------------------------------------------------}
constructor TfrInterpretator.Create;
begin
  inherited Create;
  FParser := TfrParser.Create;
  FParser.OnGetValue := GetValue;
  FParser.OnFunction := DoFunction;
end;

destructor TfrInterpretator.Destroy;
begin
  FParser.Free;
  inherited Destroy;
end;

procedure TfrInterpretator.PrepareScript(MemoFrom, MemoTo, MemoErr: TStringList);
var
  i, j, cur, lastp: Integer;
  s, bs: String;
  len: Integer;
  buf: PCharArray;
  Error: Boolean;

procedure DoCommand; forward;
procedure DoBegin; forward;
procedure DoIf; forward;
procedure DoRepeat; forward;
procedure DoWhile; forward;
procedure DoGoto; forward;
procedure DoEqual; forward;
procedure DoExpression; forward;
procedure DoSExpression; forward;
procedure DoTerm; forward;
procedure DoFactor; forward;
procedure DoVariable; forward;
procedure DoConst; forward;
procedure DoLabel; forward;
procedure DoFunc; forward;
procedure DoFuncId; forward;

  function last: Integer;
  begin
    Result := MemoTo.Count;
  end;

  function CopyArr(cur, n: Integer): String;
  begin
    SetLength(Result, n);
    Move(buf^[cur], Result[1], n);
  end;

  procedure AddLabel(s: String; n: Integer);
  var
    i: Integer;
    f: Boolean;
  begin
    f := True;
    for i := 0 to labc - 1 do
      if labels[i].name = s then f := False;
    if f then
    begin
      labels[labc].name := s;
      labels[labc].n := n;
      Inc(labc);
    end;
  end;

  procedure SkipSpace;
  begin
    while (buf^[cur] = ' ') and (cur < len) do Inc(cur);
  end;

  function GetToken: String;
  var
    j: Integer;
  begin
    SkipSpace;
    j := cur; Inc(cur);
    while (buf^[cur] > ' ') and (cur < len) do Inc(cur);
    Result := AnsiUpperCase(CopyArr(j, cur - j));
  end;

  procedure AddError(s: String);
  var
    i, j, c: Integer;
    s1: String;
  begin
    Error := True;
    cur := lastp;
    SkipSpace;
    c := 0;
    for i := 0 to cur do
      if buf^[i] > ' ' then Inc(c);
    i := 0;
    j := 1;
    while c > 0 do
    begin
      s1 := MemoFrom[i];
      j := 1;
      while (j <= Length(s1)) and (c > 0) do
      begin
        if s1[j] = '{' then break;
        if s1[j] > ' ' then Dec(c);
        Inc(j);
      end;
      if c = 0 then break;
      Inc(i);
    end;
    MemoErr.Add('羊痤赅 ' + IntToStr(i + 1) + '/' + IntToStr(j - 1) + ': ' + s);
  end;

  procedure ProcessBrackets(var i: Integer);
  var
    c: Integer;
    fl1, fl2: Boolean;
  begin
    fl1 := True; fl2 := True; c := 0;
    Dec(i);
    repeat
      Inc(i);
      if fl1 and fl2 then
        if buf^[i] = '[' then
          Inc(c) else
          if buf^[i] = ']' then Dec(c);
      if fl1 then
        if buf^[i] = '"' then fl2 := not fl2;
      if fl2 then
        if buf^[i] = '''' then fl1 := not fl1;
    until (c = 0) or (i >= len);
  end;

  {----------------------------------------------}
  procedure DoDigit;
  begin
    while (buf^[cur] = ' ') and (cur < len) do Inc(cur);
    if buf^[cur] in ['0'..'9'] then
      while (buf^[cur] in ['0'..'9']) and (cur < len) do Inc(cur)
    else Error := True;
  end;

  procedure DoBegin;
  label 1;
  begin
  1:DoCommand;
    if Error then Exit;
    lastp := cur;
    bs := GetToken;
    if (bs = '') or (bs[1] = ';') then
    begin
      cur := cur - Length(bs) + 1;
      goto 1;
    end
    else if Pos('END', bs) = 1 then cur := cur - Length(bs) + 3
    else AddError('卿羼