pax_basic.pas

来自「Delphi脚本控件」· PAS 代码 · 共 2,916 行 · 第 1/5 页

////////////////////////////////////////////////////////////////////////////
// PAXScript Interpreter
// Author: Alexander Baranovsky ([e-mail])
// ========================================================================
// Copyright (c) Alexander Baranovsky, 2003-2005. All rights reserved.
// Code Version: 3.0
// ========================================================================
// Unit: PAX_BASIC.pas
// ========================================================================
////////////////////////////////////////////////////////////////////////////

{$I PaxScript.def}
unit PAX_BASIC;

interface

uses
  SysUtils, Classes,
  BASE_CONSTS,
  BASE_SYS, BASE_SCANNER, BASE_PARSER, BASE_SCRIPTER, BASE_CLASS, BASE_EXTERN;

const
  SP_INC = -1001;
  SP_DEC = -1002;

  SP_PLUS_ASSIGN = -1003;
  SP_MINUS_ASSIGN = -1004;
  SP_MULT_ASSIGN = -1005;
  SP_DIV_ASSIGN = -1006;
  SP_POWER_ASSIGN = -1007;
  SP_INT_DIV_ASSIGN = -1008;
  SP_CONCAT_ASSIGN = -1009;

  SP_LOGICAL_IMP = -1018;

  SP_CONCAT = -1019;
type
  TPAXBasicScanner = class(TPAXScanner)
  public
    procedure ReadToken; override;
  end;

  TPAXForLoopStack = class;

  TPAXBasicParser = class(TPAXParser)
  public
    SeparatorIDs: TList;
    EntryStackDO: TPAXEntryStack;
    EntryStackFOR: TPAXEntryStack;
    ForLoopStack: TPAXForLoopStack;

    constructor Create; override;
    destructor Destroy; override;
    procedure Reset; override;
    function IsBaseType(const S: String): Boolean; override;
    function Parse_OverloadableOperator: Integer; override;

    function Parse_TypeID: Integer;
    function Parse_EvalExpression: Integer; override;
    function Parse_ArgumentExpression: Integer; override;
    procedure _Call_SCANNER;
    procedure Call_SCANNER; override;
    procedure SkipColons;
    procedure Match(const S: String); override;
    function Parse_PrimaryExpression: Integer;
    function Parse_ObjectLiteral: Integer;
    function Parse_MemberExpression(ID: Integer): Integer;
    function Parse_NewExpression: Integer;
    function Parse_PowerExpression: Integer;
    function Parse_UnaryMinusExpression: Integer;
    function Parse_MultiplicativeExpression: Integer;
    function Parse_ModExpression: Integer;
    function Parse_AdditiveExpression: Integer;
    function Parse_ConcatenationExpression: Integer;
    function Parse_EqualityExpression: Integer;
    function Parse_Expression: Integer;

/// STATEMENTS ////////////////////////////////////////////
    procedure Parse_Statement;
    function Parse_ModifierList: TPAXModifierList;

    function Parse_ClassStmt(ClassML: TPAXModifierList; ck: TPAXClassKind): Integer;
    function Parse_EnumStmt: Integer;
    procedure Parse_NamespaceStmt(ml: TPAXModifierList);
    procedure Parse_DimStmt(IsField: Boolean; ml: TPAXModifierList);
    function Parse_VariableDeclaration(IsField: Boolean; ml: TPAXModifierList): Integer;
    procedure Parse_SimpleStatement;
    procedure Parse_FunctionStmt(ts: TPAXTypeSub;
                                 ml: TPAXModifierList;
                                 cc: Integer = _ccStdCall);
    procedure Parse_ReturnStmt;
    procedure Parse_HaltStmt;
    procedure Parse_IfStmt;
    procedure Parse_ThrowStmt;
    procedure Parse_TryStmt;
    procedure Parse_ExitStmt;
    procedure Parse_WhileStmt;
    function Parse_ForStmt: Boolean;
    procedure Parse_DoStmt;
    procedure Parse_SelectCaseStmt;
    procedure Parse_WithStmt;

    procedure Parse_StmtList; override;
    procedure Parse_SourceElements;
    procedure Parse_Program; override;
  end;


  TPAXForLoopRec = class
  public
    ID: Integer;
    StepID: Integer;
    L, LC, LF: Integer;
  end;

  TPAXForLoopStack = class(TList)
  public
    procedure Push(ID, StepID, L, LC, LF: Integer);
    procedure Pop;
    function Top: TPAXForLoopRec;
  end;

implementation

procedure TPAXForLoopStack.Push(ID, StepID, L, LC, LF: Integer);
var
  R: TPAXForLoopRec;
begin
  R := TPAXForLoopRec.Create;
  R.ID := ID;
  R.StepID := StepID;
  R.L := L;
  R.LC := LC;
  R.LF := LF;
  Add(R);
end;

procedure TPAXForLoopStack.Pop;
begin
  TPAXForLoopRec(Items[Count - 1]).Free;
  Delete(Count - 1);
end;

function TPAXForLoopStack.Top: TPAXForLoopRec;
begin
  result := TPAXForLoopRec(Items[Count - 1]);
end;

procedure TPAXBasicScanner.ReadToken;

function ColonWasScanned(): Boolean;
var
  I: Integer;
  ch: Char;
begin
  result := false;
  I := 1;
  repeat
     if P - I <= 1 then
       break;

     Ch := Buff[P - I];
     case Ch of
        ':',#13,#10:
        begin
          result := true;
          Exit;
        end;
        #8, #9, #32: begin end;
        else
          Exit;
     end;
     Dec(I);
  until false;
end;

begin
  inherited;

  repeat

    if BuffToken.Text <> '' then
    begin
      Token := BuffToken;
      BuffToken.Text := '';
      Exit;
    end;

    GetNextChar;

    Token.TokenClass := tcNone;
    Token.ID := 0;

    case c of
      #8, #9, #10, #13, #32: ScanWhiteSpace;
      #255: ScanEOF;
      '0'..'9': ScanDigits;
      '$': ScanHexDigits;
      'A'..'Z', 'a'..'z', '_':
      begin
        ScanIdentifier;
        if StrEql(Token.Text, 'mod') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_MOD;
        end
        else if StrEql(Token.Text, 'and') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_AND;
        end
        else if StrEql(Token.Text, 'in') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_IN_SET;
        end
        else if StrEql(Token.Text, 'or') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_OR;
        end
        else if StrEql(Token.Text, 'xor') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_XOR;
        end
        else if StrEql(Token.Text, 'not') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_NOT;
        end
        else if StrEql(Token.Text, 'imp') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := SP_LOGICAL_IMP;
        end;
      end;
      '+':
      begin
        ScanPlus;
        if LA(1) = '=' then
        begin
          GetNextChar;
          Token.Text := '+=';
          Token.ID := SP_PLUS_ASSIGN;
        end;
      end;
      '-':
      begin
        ScanMinus;
        if LA(1) = '=' then
        begin
          GetNextChar;
          Token.Text := '-=';
          Token.ID := SP_MINUS_ASSIGN;
        end;
      end;
      '*':
      begin
        ScanMult;
        if LA(1) = '=' then
        begin
          GetNextChar;
          Token.Text := '*=';
          Token.ID := SP_MULT_ASSIGN;
        end;
      end;
      '/':
      begin
        ScanDiv;
        if LA(1) = '=' then
        begin
          GetNextChar;
          Token.Text := '/=';
          Token.ID := SP_DIV_ASSIGN;
        end;
      end;
      '\':
      begin
        GetNextChar;
        Token.TokenClass := tcSpecial;
        Token.Text := '\';
        Token.ID := OP_INT_DIV;
        if c = '=' then
        begin
          GetNextChar;
          Token.Text := '\=';
          Token.ID := SP_INT_DIV_ASSIGN;
        end;
      end;
      '=': ScanEQ;
      '>':
      begin
        ScanGT;
        if LA(1) = '=' then
        begin
          GetNextChar;
          Token.Text := '>=';
          Token.ID := OP_GE;
        end;
      end;
      '?', '%':
      case ScannerState of
        ScanText:
          raise TPAXScriptFailure.Create(errIllegalCharacter);
        ScanProg:
        if LA(1) = '>' then
        begin
          if ColonWasScanned then
          begin
            ScannerState := scanText;
            GetNextChar;
            ScanHtmlString('');
          end
          else
          begin
            Token.Text := ':';
            Token.TokenClass := tcSpecial;
            Token.ID := SP_COLON;
            Insert(':', Buff, P);
          end;
        end
      end;
      '<':
      case ScannerState of
        scanText:
        begin
          if LA(1) = '?' then
          begin
            GetNextChar;
            GetNextChar;
            ScanIdentifier;

            if not StrEql('pax', Trim(Token.Text)) then
              raise TPAXScriptFailure.Create(errIllegalCharacter);

            ScannerState := scanProg;
            Continue;
          end
          else if LA(1) = '%' then
          begin
            GetNextChar;
            ScannerState := scanProg;

            if LA(1) = '=' then
            begin
              GetNextChar;
              BuffToken.Text := 'print';
            end;

            Continue;
          end
          else if LA(1) in ['a'..'z','A'..'Z'] then
            ScanHtmlString(c)
          else
            raise TPAXScriptFailure.Create(errIllegalCharacter);
        end;
        scanProg:
        begin
          ScanLT;
          if LA(1) = '=' then
          begin
            GetNextChar;
            Token.Text := '<=';
            Token.ID := OP_LE;
          end
          else if LA(1) = '>' then
          begin
            GetNextChar;
            Token.Text := '<>';
            Token.ID := OP_NE;
          end;
        end;
      end;
      '&':
      begin
        GetNextChar;
        Token.TokenClass := tcSpecial;
        Token.Text := '&';
        Token.ID := SP_CONCAT;
        if LA(1) = '=' then
        begin
          GetNextChar;
          Token.Text := '&=';
          Token.ID := SP_CONCAT_ASSIGN;
        end;
      end;
      '#':
      if LookForward then
      begin
        repeat
          GetNextChar;
        until LA(1) in [#13, #10];
        continue;
      end
      else
      begin
        ScanCondDir('#', ['a'..'z','A'..'Z','_','0'..'9']);
        continue;
      end;
      '^':
      begin
        GetNextChar;
        Token.TokenClass := tcSpecial;
        Token.Text := '^';
        Token.ID := OP_POWER;
        if c = '=' then
        begin
          GetNextChar;
          Token.Text := '^=';
          Token.ID := SP_POWER_ASSIGN;
        end;
      end;
      ':':
      begin
        ScanColon;
      end;
      '(': ScanLeftRoundBracket;
      ')': ScanRightRoundBracket;
      '[': ScanLeftBracket;
      ']': ScanRightBracket;
      ',': ScanComma;
      '.': ScanPoint;
     '''':
     begin
       repeat
          GetNextChar;
       until LA(1) in [#13, #10];
       Continue;
     end;
      '"': ScanString('"');
    else
      raise TPAXScriptFailure.Create(errIllegalCharacter);
    end;

    if Token.TokenClass <> tcNone then
      Exit;

  until false;
end;

constructor TPAXBasicParser.Create;
begin
  inherited;

  Scanner := TPAXBasicScanner.Create(Self);

  Upcase := true;

  SeparatorIds := TList.Create;
  EntryStackDO := TPAXEntryStack.Create;
  EntryStackFOR := TPAXEntryStack.Create;
  ForLoopStack := TPAXForLoopStack.Create;

  with Keywords do
  begin
    Add('ALIAS');
    Add('ADDRESSOF');
    Add('AND');
    Add('AS');
    Add('BYVAL');
    Add('BYREF');
    Add('BYTE');
    Add('CASE');
    Add('CATCH');
    Add('CDECL');
    Add('CLASS');
    Add('DECLARE');
    Add('DEFAULT');
    Add('DELETE');
    Add('DIM');
    Add('DO');
    Add('ELSE');
    Add('ELSEIF');
    Add('END');
    Add('ENUM');
    Add('FINALLY');
    Add('FOR');
    Add('FUNCTION');
    Add('IN');
    Add('INHERITS');
    Add('GET');
    Add('GOTO');
    Add('IF');
    Add('IMPORTS');
    Add('INHERITS');
    Add('LIB');
    Add('LONG');
    Add('LOOP');
    Add('MYBASE');
    Add('MYCLASS');
    Add('NAMESPACE');
    Add('NEXT');
    Add('NEW');
    Add('NOT');
    Add('OPERATOR');
    Add('OR');
    Add('OVERRIDE');
    Add('PASCAL');
    Add('PRIVATE');
    Add('PUBLIC');
    Add('PROPERTY');
    Add('PROTECTED');
    Add('REDUCED');
    Add('REGISTER');
    Add('RETURN');
    Add('SAFECALL');
    Add('SBYTE');
    Add('SET');
    Add('SELECT');
    Add('SHARED');
    Add('SHORT');
    Add('STDCALL');
    Add('STEP');
    Add('STRUCTURE');
    Add('SUB');
    Add('TERMINALOF');
    Add('THEN');
    Add('THROW');
    Add('TO');
    Add('TRY');
    Add('UINT');
    Add('UNTIL');
    Add('USHORT');
    Add('VIRTUAL');
    Add('WHILE');
    Add('WITH');
    Add('XOR');

    Add('PRINT');
    Add('PRINTLN');
  end;
end;

procedure TPAXBasicParser.Reset;
begin
  inherited;

  if Assigned(SeparatorIDs) then
    SeparatorIDs.Clear;
  if Assigned(EntryStackDO) then
    EntryStackDO.Clear;
  if Assigned(EntryStackFOR) then
    EntryStackFOR.Clear;
  if Assigned(ForLoopStack) then
    ForLoopStack.Clear;
end;

function TPAXBasicParser.Parse_TypeID: Integer;
var
  S: String;
begin
  if StrEql(CurrToken.Text, 'set') then
  begin
    result := typeSET;
    Call_SCANNER;
  end
  else
    result := Parse_Ident;
  S := Name[result];
  if (result > PAXTypes.Count) or (result < 0) then
  begin
//    if Kind[result] <> KindTYPE then
//      raise TPAXScriptFailure.Create(Format(errTypeNotFound, [S]));
  end
  else
    if not (result in SupportedPaxTypes) then
     raise TPAXScriptFailure.Create(Format(errTypeNotFound, [S]));
end;

destructor TPAXBasicParser.Destroy;
begin
  SeparatorIDs.Free;
  EntryStackDO.Free;
  EntryStackFOR.Free;
  ForLoopStack.Free;

  inherited;
end;

function TPAXBasicParser.Parse_EvalExpression: Integer;
begin
  result := Parse_Expression;
end;