dbgexpressions.pas

一个不出名的GBA模拟器

//////////////////////////////////////////////////////////////////////
//                                                                  //
// dbgExpressions.pas: Expression management                        //
//   Bog-standard expression parser.                                //
//                                                                  //
// The contents of this file are subject to the Bottled Light       //
// Public License Version 1.0 (the "License"); you may not use this //
// file except in compliance with the License. You may obtain a     //
// copy of the License at http://www.bottledlight.com/BLPL/         //
//                                                                  //
// Software distributed under the License is distributed on an      //
// "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or   //
// implied. See the License for the specific language governing     //
// rights and limitations under the License.                        //
//                                                                  //
// The Original Code is the Mappy VM User Interface, released       //
// April 1st, 2003. The Initial Developer of the Original Code is   //
// Bottled Light, Inc. Portions created by Bottled Light, Inc. are  //
// Copyright (C) 2001-2003 Bottled Light, Inc. All Rights Reserved. //
//                                                                  //
// Author(s):                                                       //
//   Michael Noland (joat), [e-mail]                //
//                                                                  //
// Changelog:                                                       //
//   1.0: First public release (April 1st, 2003)                    //
//                                                                  //
// Notes:                                                           //
//   Can you feel the dust?  This is positivly ancient code, it     //
//   came in large part from one of my first interpreters written   //
//   in TP7.0, pre MappyScript even.                                //
//                                                                  //
//////////////////////////////////////////////////////////////////////

//////////////////////////////////////////////////////////////////////
unit dbgExpressions; /////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////

//////////////////////////////////////////////////////////////////////
interface ////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////

uses
  SysUtils, nexus, console, dwarfUtils;

//////////////////////////////////////////////////////////////////////

type
  TExpression = string;

//////////////////////////////////////////////////////////////////////

function EvaluateExpression(expr: TExpression): integer;

//////////////////////////////////////////////////////////////////////
implementation ///////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////

function RExpression: integer; forward;
procedure SkipWhite; forward;

//////////////////////////////////////////////////////////////////////

var
  Look: char;
  scriptBuffer: string;
  ScriptLen, ScriptPos: integer;

//////////////////////////////////////////////////////////////////////

// Report what was expected and what was found
procedure Expected(this, that: string);
begin
  raise Exception.Create(this + ' was expected, but ' + that + ' was found');
end;

//////////////////////////////////////////////////////////////////////

// Read a new character from the input stream
procedure GetChar;
begin
  if (ScriptPos < ScriptLen) then begin
    Inc(ScriptPos);
    Look := scriptBuffer[ScriptPos];
  end else
    raise Exception.Create('Expression expected but end of file found');
end;

//////////////////////////////////////////////////////////////////////

// Match a specific input character versus what was found
procedure Match(what: char);
begin
  if Look = what then GetChar else Expected(''''+what+'''', ''''+look+'''');
  SkipWhite;
end;

//////////////////////////////////////////////////////////////////////

function IsAlpha(c: char): boolean;
begin
  IsAlpha := UpCase(c) in ['A'..'Z', '_', '?'];
end;

//////////////////////////////////////////////////////////////////////

function IsDigit(c: char): boolean;
begin
  IsDigit := c in ['0'..'9'];
end;

//////////////////////////////////////////////////////////////////////

function IsAddOp(c: char): boolean;
begin
  IsAddOp := c in ['+', '-', '|', '^'];
end;

//////////////////////////////////////////////////////////////////////

function IsMulOp(c: char): boolean;
begin
  IsMulOp := c in ['*', '/', '&', '%'];
end;

//////////////////////////////////////////////////////////////////////

function IsRelop(c: char): boolean;
begin
  IsRelop := c in ['=', '<', '>'];
end;

//////////////////////////////////////////////////////////////////////

function IsWhite(c: char): boolean;
begin
  IsWhite := c in [#0..#32];
end;

//////////////////////////////////////////////////////////////////////

procedure SkipWhite;
begin
  while IsWhite(Look) do GetChar;
end;

//////////////////////////////////////////////////////////////////////

function GetName: string;
begin
  // Reset the string and check for a alpha start
  Result := '';
  if not IsAlpha(Look) then Expected('A name', Look);

  // Read in the string
  while (IsAlpha(Look) or IsDigit(Look)) do begin
    Result := Result + Look;
    GetChar;
  end;

  // Skip white space in the input sequence
  SkipWhite;
end;

//////////////////////////////////////////////////////////////////////

// Read in a number
function GetNum: integer;
var
  st: string;
begin
  { Make sure there is a digit at the front }
  if not (Look in ['$', '0'..'9']) then Expected('Number', Look);

  st := '';
  while Look in ['$', 'x', '0'..'9'] do begin
    st := st + Look;
    GetChar;
  end;
  if Copy(st, 1, 2) = '0x' then begin
    Delete(st, 1, 2);
    st := '$' + st;
  end;

  Result := StrToInt(st);

  SkipWhite;
end;

//////////////////////////////////////////////////////////////////////

procedure SetScript(script: string);
begin
  scriptBuffer := script;
  scriptLen := Length(script);
  scriptPos := 0;
  GetChar;
end;

//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////

function GetIdentifier(token: string): integer;
begin
  if (token <> '') and (token[1] in ['r', 'R']) then begin
    Delete(token, 1, 1);
    Result := vmGetRegister(StrToIntDef(token, 0));
  end else
    Result := ExamineVariable(token);
end;

//////////////////////////////////////////////////////////////////////

// Parse and interpret a factor
function Factor: integer;
begin
  if Look = '[' then begin
    Match('[');
    Result := RExpression;
    Match(']');
    if Look = ':' then begin
      Match(':');
      if Look = '8' then begin
        Match('8');
        Result := vmReadByte(Result);
      end else if Look = '1' then begin
        Match('1');
        Match('6');
        Result := vmReadHalfword(Result);
      end else if Look = '3' then begin
        Match('3');
        Match('2');
        Result := vmReadWord(Result);
      end;
    end else
      Result := vmReadWord(Result);
  end else if Look = '(' then begin
    Match('(');
    Result := RExpression;
    Match(')');
  end else if IsAlpha(Look) then begin
    ;
{    if Look = '(' then
      Result := ParseSubroutineCall
    else}
    Result := GetIdentifier(GetName);
  end else
    Result := GetNum;
end;

//////////////////////////////////////////////////////////////////////

// Parse and interpret a term
function Term: integer;
begin
  Result := Factor;
  while IsMulOp(Look) do begin
    case Look of
      '*': begin
        Match('*');
        Result := Result * Factor;
      end;
      '/': begin
        Match('/');
        Result := Result div Factor;
      end;
      '&': begin
        Match('&');
        if Look = '&' then begin
          Match('&');
          if Result <> 0 then Result := 1;
          if Factor = 0 then Result := 0;
        end else
          Result := Result and Factor;
      end;
      '%': begin
        Match('%');
        Result := Result mod Factor;
      end;
    end;
  end;
end;

//////////////////////////////////////////////////////////////////////

// Parse and interpret an expression
function RExpression: integer;
begin
  if IsAddop(Look) then Result := 0 else Result := Term;
  while IsAddop(Look) do begin
    case Look of
      '+': begin
        Match('+');
        Result := Result + Term;
      end;
      '-': begin
        Match('-');
        Result := Result - Term;
      end;
      '|': begin
        Match('|');
        if Look = '|' then Match('|');
        Result := Result or Term;
      end;
      '^': begin
        Match('^');
        Result := Result xor Term;
      end;
    end;
  end;
end;

//////////////////////////////////////////////////////////////////////

function Equal(left: integer): integer;
begin
  Match('=');

  // Compare the left and right hand sides
  if left = RExpression then Equal := 1 else Equal := 0;
end;

//////////////////////////////////////////////////////////////////////

function LessOrEqual(left: integer): integer;
begin
  Match('=');

  // Compare the left and right hand sides }
  if left <= RExpression then LessOrEqual := 1 else LessOrEqual := 0;
end;

//////////////////////////////////////////////////////////////////////

function NotEqual(left: integer): integer;
begin
  Match('>');

  // Compare the left and right hand sides
  if left <> RExpression then NotEqual := 1 else NotEqual := 0;
end;

//////////////////////////////////////////////////////////////////////

function Less(left: integer): integer;
var
  Right: integer;
begin
  Match('<');

  // Perform a <=, <>, or a < test
  case Look of
    '=': Result := LessOrEqual(left);
    '>': Result := NotEqual(left);
  else
    Right := RExpression;
    if left < right then Result := 1 else Result := 0;
  end;
end;

//////////////////////////////////////////////////////////////////////

// Recognize and interpret a relational greater than
function Greater(left: integer): integer;
var
  Right: integer;
begin
  Match('>');

  // Perform either a >= or a > test
  if Look = '=' then begin
    Match('=');
    Right := RExpression;
    if left >= right then Greater := 1 else Greater := 0;
  end else begin
    Right := RExpression;
    if left > right then Greater := 1 else Greater := 0;
  end;
end;

//////////////////////////////////////////////////////////////////////

{ Parse and interpret a relation }
function Relation: integer;
var
  Value: integer;
begin
  Value := RExpression;
  if IsRelOp(Look) then begin
    case Look of
      '=': Value := Equal(Value);
      '<': Value := Less(Value);
      '>': Value := Greater(Value);
    end;
  end;
  Relation := Value;
end;

//////////////////////////////////////////////////////////////////////

{ Parse and interpret a boolean factor with a leading not }
function Expression: integer;
begin
  if Look = '!' then begin
    Match('!');
    Expression := not Relation;
  end else
    Expression := Relation;
end;

//////////////////////////////////////////////////////////////////////

function EvaluateExpression(expr: TExpression): integer;
begin
  Result := 1;
  if expr <> '' then begin
    try
      SetScript(expr + '.');
      Result := Expression;
    except
      on e: Exception do logWriteLn(e.Message);
    end;
  end;
end;

//////////////////////////////////////////////////////////////////////

end.

//////////////////////////////////////////////////////////////////////