rm_intrp.pas

report machine 2.3 功能强大

      DoExpression;
      n := Pos('[', s);
      if n <> 0 then
      begin
        s := ttProc + 'SETARRAY(' + Copy(s, 1, n - 1) + ', ' +
          Copy(s, n + 1, Length(s) - n - 2) + ', ' + CopyArr(nsm, cur - nsm) + ')';
      end
      else
        s := s + CopyArr(nsm, cur - nsm);
      MemoTo.Add(s);
    end
    else
      AddError('Need ":=" here');
  end;

  {-------------------------------------}
  procedure DoExpression;
  var
    nsm: Integer;
  begin
    DoSExpression;
    nsm := cur;
    bs := GetToken;
    if (Pos('>=', bs) = 1) or (Pos('<=', bs) = 1) or (Pos('<>', bs) = 1) then
    begin
      cur := cur - Length(bs) + 2;
      DoSExpression;
    end
    else if (bs[1] = '>') or (bs[1] = '<') or (bs[1] = '=') then
    begin
      cur := cur - Length(bs) + 1;
      DoSExpression;
    end
    else cur := nsm;
  end;

  procedure DoSExpression;
  var
    nsm: Integer;
  begin
    DoTerm;
    nsm := cur;
    bs := GetToken;
    if (bs[1] = '+') or (bs[1] = '-') then
    begin
      cur := cur - Length(bs) + 1;
      DoSExpression;
    end
    else if Pos('OR', bs) = 1 then
    begin
      cur := cur - Length(bs) + 2;
      DoSExpression;
    end
    else cur := nsm;
  end;

  procedure DoTerm;
  var
    nsm: Integer;
  begin
    DoFactor;
    nsm := cur;
    bs := GetToken;
    if (bs[1] = '*') or (bs[1] = '/') then
    begin
      cur := cur - Length(bs) + 1;
      DoTerm;
    end
    else if (Pos('AND', bs) = 1) or (Pos('MOD', bs) = 1) then
    begin
      cur := cur - Length(bs) + 3;
      DoTerm;
    end
    else cur := nsm;
  end;

  procedure DoFactor;
  var
    nsm: Integer;
  begin
    nsm := cur;
    bs := GetToken;
    if bs[1] = '(' then
    begin
      cur := cur - Length(bs) + 1;
      DoExpression;
      SkipSpace;
      lastp := cur;
      if buf^[cur] = ')' then Inc(cur)
      else AddError('Need ")" here');
    end
    else if bs[1] = '[' then
    begin
      cur := cur - Length(bs);
      ProcessBrackets(cur);
      SkipSpace;
      lastp := cur;
      if buf^[cur] = ']' then Inc(cur)
      else AddError('Need "]" here');
    end
    else if (bs[1] = '+') or (bs[1] = '-') then
    begin
      cur := cur - Length(bs) + 1;
      DoExpression;
    end
    else if bs = 'NOT' then
    begin
      cur := cur - Length(bs) + 3;
      DoExpression;
    end
    else
    begin
      cur := nsm;
      DoVariable;
      if Error then
      begin
        Error := False;
        cur := nsm;
        DoConst;
        if Error then
        begin
          Error := False;
          cur := nsm;
          DoFunc;
        end;
      end;
    end;
  end;

  procedure DoVariable;
  begin
    SkipSpace;
    if (buf^[cur] in ['a'..'z', 'A'..'Z']) then
    begin
      Inc(cur);
      while buf^[cur] in ['0'..'9', '_', '.', 'A'..'Z', 'a'..'z'] do
      	Inc(cur);

      if buf^[cur] = '(' then
        Error := True
      else if buf^[cur] = '[' then
      begin
        Inc(cur);
        DoExpression;
        if buf^[cur] <> ']' then
          Error := True
        else
          Inc(cur);
      end;
    end
    else Error := True;
  end;

  procedure DoConst;
  label 1;
  begin
    SkipSpace;
    if buf^[cur] = #$27 then
    begin
      1: Inc(cur);
      while (buf^[cur] <> #$27) and (cur < len) do Inc(cur);
      if (cur < len) and (buf^[cur + 1] = #$27) then
      begin
        Inc(cur);
        goto 1;
      end;
      if cur = len then Error := True
      else Inc(cur);
    end
    else
    begin
      DoDigit;
      if buf^[cur] = '.' then
      begin
        Inc(cur);
        DoDigit;
      end;
    end;
  end;

  procedure DoLabel;
  begin
    DoDigit;
    if buf^[cur] = ':' then Inc(cur)
    else Error := True;
  end;

  procedure DoFunc;
  label 1;
  begin
    DoFuncId;
    if buf^[cur] = '(' then
    begin
      Inc(cur);
      SkipSpace;
      if buf^[cur] = ')' then
      begin
        Inc(cur);
        exit;
      end;
      1: DoExpression;
      lastp := cur;
      SkipSpace;
      if buf^[cur] = ',' then
      begin
        Inc(cur);
        goto 1;
      end
      else if buf^[cur] = ')' then Inc(cur)
      else AddError('Need "," or ")" here');
    end;
  end;

  procedure DoFuncId;
  begin
    SkipSpace;
    if buf^[cur] in ['A'..'Z', 'a'..'z'] then
    begin
      while buf^[cur] in ['0'..'9', '_', '.', 'A'..'Z', 'a'..'z'] do Inc(cur);
    end  
    else Error := True;
  end;

  procedure DoCommand;
  label 1;
  var
    nsm: Integer;
  begin
  1:Error := False;
    nsm := cur;
    lastp := cur;
    bs := GetToken;
    if bs = 'BEGIN' then DoBegin
    else if bs = 'IF' then DoIf
    else if bs = 'REPEAT' then DoRepeat
    else if bs = 'WHILE' then DoWhile
    else if bs = 'FOR' then DoFor
    else if bs = 'GOTO' then DoGoto
    else if (bs = 'END') or (bs = 'END;') then
    begin
      cur := nsm;
      Error := False;
    end
    else if bs = 'UNTIL' then
    begin
      cur := nsm;
      Error := False;
    end
    else
    begin
      cur := nsm;
      DoLabel;
      if Error then
      begin
        Error := False;
        cur := nsm;
        DoVariable;
        if not Error then
        begin
          cur := nsm;
          DoEqual;
        end
        else
        begin
          cur := nsm;
          Error := False;
          DoExpression;
          MemoTo.Add(ttProc + Trim(CopyArr(nsm, cur - nsm)));
        end;
      end
      else
      begin
        AddLabel(Trim(CopyArr(nsm, cur - nsm)), last);
        goto 1;
      end;
    end;
  end;

begin
	CutList := TStringList.Create;
  Error := False;
  GetMem(buf, 32000);
  FillChar(buf^, 32000, 0);
  len := 0;
  for i := 0 to MemoFrom.Count - 1 do
  begin
    s := MemoFrom[i] + #13;
    while Pos(#9, s) <> 0 do
      s[Pos(#9, s)] := ' ';
    Move(s[1], buf^[len], Length(s));
    Inc(len, Length(s));
  end;

  cur := 0; labc := 0;
  MemoTo.Clear;
  MemoErr.Clear;
  if len > 0 then
    DoCommand;
  FreeMem(buf, 32000);
  CutList.Free;

  for i := 0 to MemoTo.Count - 1 do
  begin
    if MemoTo[i][1] = ttGoto then
    begin
      s := Remain(MemoTo[i], 2) + ':';
      for j := 0 to labc do
      begin
        if labels[j].name = s then
        begin
          s := MemoTo[i]; s[2] := Chr(labels[j].n);
          s[3] := Chr(labels[j].n div 256); MemoTo[i] := s;
          break;
        end;
      end;
    end
    else if MemoTo[i][1] = ttIf then
    begin
      s := FParser.Str2OPZ(Remain(MemoTo[i], 4));
      MemoTo[i] := Copy(MemoTo[i], 1, 3) + s;
    end
    else if MemoTo[i][1] = ttProc then
    begin
      s := FParser.Str2OPZ(Remain(MemoTo[i], 2));
      MemoTo[i] := Copy(MemoTo[i], 1, 1) + s;
    end
    else
    begin
      j := 1;
      GetIdentify(MemoTo[i], j);
      len := j;
      s := FParser.Str2OPZ(Remain(MemoTo[i], j));
      MemoTo[i] := Copy(MemoTo[i], 1, len) + s;
    end;
  end;
end;

procedure TRMInterpretator.DoScript(Memo: TStrings);
var
  i, j: Integer;
  s, s1: string;
begin
  i := 0;
  while i < Memo.Count do
  begin
    s := Memo[i];
    j := 1;
    if s[1] = ttIf then
    begin
      if FParser.CalcOPZ(Remain(s, 4)) = 0 then
      begin
        i := Ord(s[2]) + Ord(s[3]) * 256;
        Continue;
      end;
    end
    else if s[1] = ttGoto then
    begin
      i := Ord(s[2]) + Ord(s[3]) * 256;
      Continue;
    end
    else if s[1] = ttProc then
    begin
      s1 := Remain(s, 2);
      if AnsiCompareText(s1, 'EXIT(0)') = 0 then
        Exit;
      FParser.CalcOPZ(s1);
    end
    else
    begin
      s1 := GetIdentify(s, j);
      SetValue(s1, FParser.CalcOPZ(Remain(s, j)));
    end;
    Inc(i);
  end;
end;

procedure TRMInterpretator.SplitExpressions(Memo, MatchFuncs, SplitTo: TStrings;
  Variables: TRMVariables);
var
  i, j: Integer;
  s: String;
  FuncSplitter: TRMFunctionSplitter;
begin
  FuncSplitter := TRMFunctionSplitter.Create(MatchFuncs, SplitTo, Variables);
  i := 0;
  while i < Memo.Count do
  begin
    s := Memo[i];
    j := 1;
    if s[1] = ttIf then
      FuncSplitter.Split(Remain(s, 4))
    else if s[1] = ttProc then
      FuncSplitter.Split(Remain(s, 2))
    else
    begin
      GetIdentify(s, j);
      FuncSplitter.Split(Remain(s, j));
    end;
    Inc(i);
  end;
  FuncSplitter.Free;
end;

procedure TRMInterpretator.GetValue(const Name: string; var Value: Variant);
begin
// abstract method
end;

procedure TRMInterpretator.SetValue(const Name: string; Value: Variant);
begin
// abstract method
end;

procedure TRMInterpretator.DoFunction(const Name: string; p1, p2, p3: Variant;
  var val: Variant);
begin
// abstract method
end;

end.