fr_intrp.pas

FASTREPORT报表工具,可以迅速制作报表.

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

unit FR_Intrp;

interface

{$I FR.inc}

uses Classes, SysUtils, FR_Pars
{$IFDEF 1CScript}
, interp_tp, sint_tr, interp_ex, memmngr{, debugW}
{$ENDIF};

type

// This is a simple Pascal-like interpreter. Input code can contain
// if-then-else, while-do, repeat-until, for, goto operators, begin-end blocks.
// Code can also contain expressions, variables, functions and methods.
// There is three events for handling variables and functions(methods):
// GetValue, SetValue and DoFunction.
// To execute code, call PrepareScript and then DoScript.

  TfrInterpretator = class(TObject)
  protected
    FParser: TfrParser;
{$IFDEF 1CScript}
    FInterpreter : TInterpreter;
  private
    FOnGetValue: TGetPValueEvent;
    procedure GetVariable(Sender : TObject; mIndex : Integer; VarName : String; var Ok : Boolean; var Result : TVariant);
    procedure SetVariable(Sender : TObject; mIndex : Integer; VarName : String; var Ok : Boolean; var Result : TVariant);
    procedure FOnSetValue(Value : TGetPValueEvent);
{$ENDIF}
  public
    Global : Boolean;
    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: Variant); virtual;
    procedure PrepareScript(MemoFrom, MemoTo, MemoErr: TStrings); virtual;
    procedure DoScript(Memo: TStrings); virtual;
    {$IFDEF 1CScript}
    function QueryValue(Name : String) : Variant;  
    property OnGetValue: TGetPValueEvent read FOnGetValue write FOnSetValue;
    {$ENDIF}
    procedure SplitExpressions(Memo, MatchFuncs, SplitTo: TStrings;
      Variables: TfrVariables);
  end;


implementation

{$IFNDEF 1CScript}
type
  TCharArray = Array[0..31999] of Char;
  PCharArray = ^TCharArray;
  lrec = record
    name: String[16];
    n: Integer;
  end;
{$ENDIF}

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

{$IFNDEF 1CScript}
var
  labels: Array[0..100] of lrec;
  labc: Integer;
{$ENDIF}

function Remain(const S: String; From: Integer): String;
begin
  Result := Copy(s, From, MaxInt);
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;


{ TfrInterpretator }
{$IFNDEF 1CScript}
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: TStrings);
var
  i, j, cur, lastp: Integer;
  s, bs: String;
  len: Integer;
  buf: PCharArray;
  Error: Boolean;
  CutList: TStringList;

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
    n, j: Integer;
  label 1;
  begin
1:  SkipSpace;
    j := cur;
    while (buf^[cur] > ' ') and (cur < len) do
    begin
      if (buf^[cur] = '{') and (buf^[j] <> #$27) then
      begin
        n := cur;
        while (buf^[cur] <> '}') and (cur < len) do
          Inc(cur);
        CutList.Add(IntToStr(n) + ' ' + IntToStr(cur - n + 1));
        Move(buf^[cur + 1], buf^[n], len - cur);
        Dec(len, cur - n + 1);
        cur := n;
        goto 1;
      end
      else if (buf^[cur] = '/') and (buf^[cur + 1] = '/') and (buf^[j] <> #$27) then
      begin
        n := cur;
        while (buf^[cur] <> #13) and (cur < len) do
          Inc(cur);
        CutList.Add(IntToStr(n) + ' ' + IntToStr(cur - n + 1));
        Move(buf^[cur + 1], buf^[n], len - cur);
        Dec(len, cur - n + 1);
        cur := n;
        goto 1;
      end;
      Inc(cur);
    end;
    Result := AnsiUpperCase(CopyArr(j, cur - j));
    if Result = '' then
      Result := ' ';
  end;

  procedure AddError(s: String);
  var
    i, j, c: Integer;
    s1: String;
  begin
    Error := True;
    cur := lastp;
    SkipSpace;
    for i := 0 to CutList.Count - 1 do
    begin
      s1 := CutList[i];
      j := StrToInt(Copy(s1, 1, Pos(' ', s1) - 1));
      c := StrToInt(Copy(s1, Pos(' ', s1) + 1, 255));
      if lastp >= j then
        Inc(cur, c);
    end;

    Inc(cur);
    i := 0;
    c := 0;
    j := 0;
    while i < MemoFrom.Count do
    begin
      s1 := MemoFrom[i];
      if c + Length(s1) + 1 < cur then
        c := c + Length(s1) + 1 else
      begin
        j := cur - c;
        break;
      end;
      Inc(i);
    end;
    MemoErr.Add('Line ' + IntToStr(i + 1) + '/' + IntToStr(j) + ': ' + s);
    cur := lastp;
  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 (bs = 'END') or (bs = 'END;') then cur := cur - Length(bs) + 3
    else AddError('Need ";" or "end" here');
  end;

  procedure DoIf;
  var
    nsm, nl, nl1: Integer;
  begin
    nsm := cur;
    DoExpression;
    if Error then Exit;
    bs := ttIf + '  ' + CopyArr(nsm, cur - nsm);
    nl := last;
    MemoTo.Add(bs);
    lastp := cur;
    if GetToken = 'THEN' then
    begin
      DoCommand;
      if Error then Exit;
      nsm := cur;
      if GetToken = 'ELSE' then
      begin
        nl1 := last;
        MemoTo.Add(ttGoto + '  ');
        bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
        DoCommand;
        bs := MemoTo[nl1]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl1] := bs;
      end
      else
      begin
        bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
        cur := nsm;
      end;
    end
    else AddError('Need "then" here');
  end;

  procedure DoRepeat;
  label 1;
  var
    nl, nsm: Integer;
  begin
    nl := last;
  1:DoCommand;
    if Error then Exit;
    lastp := cur;
    bs := GetToken;
    if bs = 'UNTIL' then
    begin
      nsm := cur;
      DoExpression;
      MemoTo.Add(ttIf + Chr(nl) + Chr(nl div 256) + CopyArr(nsm, cur - nsm));
    end
    else if bs[1] = ';' then
    begin
      cur := cur - Length(bs) + 1;
      goto 1;
    end
    else AddError('Need ";" or "until" here');
  end;

  procedure DoWhile;
  var
    nl, nsm: Integer;
  begin
    nl := last;
    nsm := cur;
    DoExpression;
    if Error then Exit;
    MemoTo.Add(ttIf + '  ' + CopyArr(nsm, cur - nsm));
    lastp := cur;
    if GetToken = 'DO' then
    begin
      DoCommand;
      MemoTo.Add(ttGoto + Chr(nl) + Chr(nl div 256));
      bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
    end
    else AddError('Need "do" here');
  end;

  procedure DoFor;
  var
    nsm, nl: Integer;
    loopvar: String;
  begin
    nsm := cur;
    DoEqual;
    if Error then Exit;
    bs := Trim(CopyArr(nsm, cur - nsm));
    loopvar := Copy(bs, 1, Pos(':=', bs) - 1);
    lastp := cur;
    if GetToken = 'TO' then
    begin
      nsm := cur;
      DoExpression;
      if Error then Exit;
      nl := last;
      MemoTo.Add(ttIf + '  ' + loopvar + '<=' + CopyArr(nsm, cur - nsm));

      lastp := cur;
      if GetToken = 'DO' then
      begin
        DoCommand;
        if Error then Exit;
        MemoTo.Add(loopvar + ' ' + loopvar + '+1');
        MemoTo.Add(ttGoto + Chr(nl) + Chr(nl div 256));
        bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
      end
      else AddError('Need "do" here');
    end
    else AddError('Need "to" here');
  end;

  procedure DoGoto;