rm_intrp.pas

report machine 2.3 功能强大

{*****************************************}
{                                         }
{         Report Machine v2.0             }
{              Interpretator              }
{                                         }
{*****************************************}

unit RM_Intrp;

interface

{$I RM.inc}

uses Classes, SysUtils, Graphics, RM_Pars;

type
// This is a simple Pascal-like interpreter. Input code can contain
// if-then-else, while-do, repeat-until, 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.

 { TRMInterpertator }
  TRMInterpretator = class(TObject)
  protected
    FParser: TRMParser;
  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: Variant); virtual;
    procedure PrepareScript(MemoFrom, MemoTo, MemoErr: TStrings); virtual;
    procedure DoScript(Memo: TStrings); virtual;
    procedure SplitExpressions(Memo, MatchFuncs, SplitTo: TStrings; Variables: TRMVariables);
  end;

implementation

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

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

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

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;

{-----------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMInterpretator}

constructor TRMInterpretator.Create;
begin
  inherited Create;
  FParser := TRMParser.Create;
  FParser.OnGetValue := GetValue;
  FParser.OnFunction := DoFunction;
end;

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

procedure TRMInterpretator.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
    begin
      if labels[i].name = s then f := False;
    end;
    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, 9999));
      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
      begin
        if buf^[i] = '[' then
          Inc(c)
        else if buf^[i] = ']' then Dec(c);
      end;
      if fl1 then
      begin
        if buf^[i] = '"' then fl2 := not fl2;
      end;
      if fl2 then
      begin
        if buf^[i] = '''' then fl1 := not fl1;
      end;
    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
    begin
      while (buf^[cur] in ['0'..'9']) and (cur < len) do Inc(cur)
    end
    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;
  var
    nsm: Integer;
  begin
    SkipSpace;
    nsm := cur;
    lastp := cur;
    DoDigit;
    if Error then AddError('"goto" label must be a number');
    MemoTo.Add(ttGoto + Trim(CopyArr(nsm, cur - nsm)));
  end;

  procedure DoEqual;
  var
    s: string;
    n, nsm: Integer;
  begin
    nsm := cur;
    DoVariable;
    s := Trim(CopyArr(nsm, cur - nsm)) + ' ';
    lastp := cur;
    bs := GetToken;
    if (bs = ';') or (bs = '') or (bs = #0) or (bs = 'END') or (bs = 'ELSE') then
    begin
      s := Trim(CopyArr(nsm, lastp - nsm));
      MemoTo.Add(ttProc + s + '(0)');
      cur := lastp;
    end
    else if Pos(':=', bs) = 1 then
    begin
      cur := cur - Length(bs) + 2;
      nsm := cur;