pax_pascal.pas

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

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

{$I PaxScript.def}
unit PAX_PASCAL;

interface

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

const
  SP_INTERVAL = -1001;
  SP_ADDRESS = -1002;
  errForward = 'Unsatisfied forward declaration';
type
  TPAXPascalScanner = class(TPAXScanner)
  public
    procedure ReadToken; override;
  end;

  TPAXPascalParser = class(TPAXParser)
  private
    ForwardIds, ForwardPos, EnumIds,

    OperCompare, OperAdditive, OperMult, ConstIds

    : TPAXIds;

    IsInterfaceSection: Boolean;

    function IsUnitId: boolean;
    function IsTypeID: boolean;
  public
    function IsConstant: boolean; override;
    constructor Create; override;
    destructor Destroy; override;
    procedure Reset; override;
    procedure Call_SCANNER; override;
    function IsBaseType(const S: String): Boolean; override;
    function Parse_OverloadableOperator: Integer; override;

/// expressions

    function Parse_EvalExpression: Integer; override;
    function Parse_ArgumentExpression: Integer; override;
    function Parse_ConstExpr: Integer;
    function Parse_Expression: Integer;
    function Parse_SimpleExpression: Integer;
    function Parse_Term: Integer;
    function Parse_Factor: Integer;
    function Parse_Designator(ResID: Integer = 0): Integer;
    function Parse_QualID: Integer;
    function Parse_UnitID: Integer;
    function Parse_TypeID: Integer;
    function Parse_SetConstructor: Integer;
    function Parse_SetElement: Integer;

// Statements
    procedure Parse_Statement;
    procedure Parse_StmtList; override;
    procedure Parse_SimpleStatement;

    procedure Parse_CompoundStmt;
    procedure Parse_IfStmt;
    procedure Parse_CaseStmt;
    procedure Parse_RepeatStmt;
    procedure Parse_WhileStmt;
    procedure Parse_ForStmt;
    procedure Parse_BreakStmt;
    procedure Parse_ContinueStmt;
    procedure Parse_ExitStmt;
    procedure Parse_LabelStmt;
    procedure Parse_HaltStmt;
    procedure Parse_WithStmt;
    procedure Parse_TryStmt;
    procedure Parse_RaiseStmt;
    procedure Parse_ProgramStmt;
    procedure Parse_UnitStmt;

    function Parse_FunctionStmt(ts: TPAXTypeSub; ml: TPAXModifierList): Integer;
    procedure Parse_VarStmt(IsField: Boolean; ml: TPAXModifierList; IsConst: Boolean);
    function Parse_VariableDeclaration(IsField: Boolean; ml: TPAXModifierList;
                                       Ids: TPAXIds; IsConst: Boolean): Integer;
    function Parse_ClassStmt(ClassML: TPAXModifierList; ck: TPAXClassKind; _ClassID: Integer = -1): Integer;
    function Parse_EnumStmt(_ClassID: Integer = -1): Integer;
    procedure Parse_NamespaceStmt(ml: TPAXModifierList);
    procedure Parse_TypeStmt;
    procedure Parse_ArrayStmt(ClassID: Integer);
    procedure Parse_DynamicArrayType(ClassID: Integer);

    procedure Parse_Program; override;
  end;


implementation

procedure TPAXPascalScanner.ReadToken;

procedure ScanChrs;
var
  S: String;
  I: Integer;
begin
  S := '';
  repeat
    GetNextChar;
    ScanHexDigits;
    I := StrToInt(Token.Text);
    S := S + Chr(I);

    if LA(1) = '#' then
      GetNextChar
    else
      Break;
  until false;

  Token.Text := S;
  Token.TokenClass := tcStringConst;

  if LA(1) = '''' then
  begin
    GetNextChar;
    ScanString('''');
    Token.Text := S + Token.Text;
  end;
end;

var
  S: String;
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, 'div') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_INT_DIV;
        end
        else if StrEql(Token.Text, 'and') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_AND;
        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, 'shl') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_LEFT_SHIFT;
        end
        else if StrEql(Token.Text, 'shr') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_RIGHT_SHIFT;
        end
        else if StrEql(Token.Text, 'in') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_IN_SET;
        end
        else if StrEql(Token.Text, 'as') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_TYPE_CAST;
        end
        else if StrEql(Token.Text, 'is') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_IS;
        end
        else if StrEql(Token.Text, 'not') then
        begin
          Token.TokenClass := tcSpecial;
          Token.ID := OP_NOT;
        end;
      end;
      '+': ScanPlus;
      '-': ScanMinus;
      '*': ScanMult;
      '/':
      begin
        if LA(1) = '/' then
        begin
          repeat
            GetNextChar;
          until LA(1) in [#13, #10];
          Continue;
        end;
        ScanDiv;
      end;
      '{':
      begin
        if (LA(1) = '$') and (not LookForward) then
          ScanCondDir('{', ['$'])
        else
        begin
          repeat
            GetNextChar;

            if c in [#10,#13] then
            begin
              IncLineNumber;
              PosNumber := -1;

              if c = #13 then
                GetNextChar;
            end;

          until LA(1) in ['}', #255];
          GetNextChar;
        end;
        Continue;
      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
          ScannerState := scanText;
          GetNextChar;
          ScanHtmlString('');
        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
        ScanColon;
        if LA(1) = '=' then
        begin
          GetNextChar;
          Token.Text := ':=';
          Token.ID := OP_ASSIGN;
        end;
      end;
      '@':
      begin
        Token.Text := '@';
        Token.ID := SP_ADDRESS;
        Token.TokenClass := tcSpecial;
      end;
      '^':
      begin
        Token.Text := '^';
        Token.ID := OP_GET_TERMINAL;
        Token.TokenClass := tcSpecial;
      end;
      ';': ScanSemiColon;
      '(': ScanLeftRoundBracket;
      ')': ScanRightRoundBracket;
      '[': ScanLeftBracket;
      ']': ScanRightBracket;
      ',': ScanComma;
      '.':
      begin
        ScanPoint;
        if LA(1) = '.' then
        begin
          GetNextChar;
          Token.Text := '..';
          Token.ID := SP_INTERVAL;
        end;
      end;
      '''':
      begin
        ScanString('''');
        if LA(1) = '#' then
        begin
          S := Token.Text;
          GetNextChar;
          ScanChrs;
          Token.Text := S + Token.Text;
        end;
      end;
      '"': ScanString('"');
      '#':
      begin
        if LA(1) = '!' then
        begin
          repeat
            GetNextChar;
          until LA(1) in [#13, #10];
          Continue;
        end;
        ScanChrs;
      end;
    else
      raise TPAXScriptFailure.Create(errIllegalCharacter);
    end;

    if not (Token.TokenClass in [tcNone]) then
      Break;

  until false;
end;

constructor TPAXPascalParser.Create;
begin
  ConstIds := TPaxIds.Create(false);

  inherited;

  Scanner := TPAXPascalScanner.Create(Self);

  Upcase := true;
  IsArrayInitialization := true;

  IsInterfaceSection := false;
  IsImplementationSection := false;

  with Keywords do
  begin
    Add('AND');
    Add('ARRAY');
    Add('AS');
    Add('BEGIN');
    Add('BREAK');
    Add('CASE');
    Add('CLASS');
    Add('CONST');
    Add('CONSTRUCTOR');
    Add('CONTINUE');
    Add('DESTRUCTOR');
    Add('DIV');
    Add('DO');
    Add('ELSE');
    Add('END');
    Add('ENUM');
    Add('EXCEPT');
    Add('EXIT');
    Add('EXTERNAL');
    Add('HALT');
    Add('FINALLY');
    Add('FOR');
    Add('FORWARD');
    Add('FUNCTION');
    Add('GOTO');
    Add('IF');
    Add('IN');
    Add('INHERITED');
    Add('LABEL');
    Add('INHERITED');
    Add('NAMESPACE');
    Add('NEW');
    Add('NOT');
    Add('MOD');
    Add('ON');
    Add('OF');
    Add('OPERATOR');
    Add('OR');
    Add('OUT');
    Add('OVERRIDE');
    Add('PROCEDURE');
    Add('PROGRAM');
    Add('PRIVATE');
    Add('PRINT');
    Add('PRINTLN');
    Add('PUBLIC');
    Add('PROPERTY');
    Add('RAISE');
    Add('RECORD');
    Add('REDUCED');
    Add('STATIC');
//    Add('DELETE');
    Add('REPEAT');
    Add('SHL');
    Add('SHR');
    Add('THEN');
    Add('TO');
    Add('TRY');
    Add('TYPE');
    Add('VAR');
    Add('UNTIL');
    Add('USES');
    Add('VIRTUAL');
    Add('WHILE');
    Add('WITH');
    Add('XOR');

    Add('IS');

    Add('UNIT');
    Add('INTERFACE');
    Add('IMPLEMENTATION');
    Add('INITIALIZATION');
    Add('FINALIZATION');
    Add('OVERLOAD');
  end;

  ForwardIds := TPaxIds.Create(false);
  ForwardPos := TPaxIds.Create(false);
  EnumIds := TPaxIds.Create(false);

  OperCompare := TPaxIds.Create(false);
  with OperCompare do
  begin
    Add(OP_EQ);
    Add(OP_NE);
    Add(OP_GT);
    Add(OP_LT);
    Add(OP_GE);
    Add(OP_LE);
    Add(OP_IS);
    Add(OP_IN_SET);
    Add(OP_TYPE_CAST);
  end;

  OperAdditive := TPaxIds.Create(false);
  with OperAdditive do
  begin
    Add(OP_PLUS);
    Add(OP_MINUS);
    Add(OP_OR);
    Add(OP_XOR);
  end;

  OperMult := TPaxIds.Create(false);
  with OperMult do
  begin
    Add(OP_MULT);
    Add(OP_DIV);
    Add(OP_INT_DIV);
    Add(OP_MOD);
    Add(OP_AND);
    Add(OP_RIGHT_SHIFT);
    Add(OP_LEFT_SHIFT)
  end;

end;

procedure TPAXPascalParser.Call_SCANNER;
var
  S: String;
  TempID: Integer;
begin
  inherited;

  if CurrToken.TokenClass in [tcId, tcKeyword] then
  begin
    if IsCurrText('TDateTime') or IsCurrText('Real') then
    begin
      CurrToken.ID := typeDOUBLE;
      CurrToken.TokenClass := tcId;
    end
    else if IsCurrText('OleVariant') then
    begin
      CurrToken.ID := typeVARIANT;
      CurrToken.TokenClass := tcId;
    end
    else if IsCurrText('static') then
    begin
      CurrToken.Text := 'class';
    end
    else if IsCurrText('nil') then
      CurrToken.ID := UndefinedID
    else
    begin
      S := FindTypeAlias(CurrToken.Text, UpCase);
      if S <> '' then
      begin
        CurrToken.Text := S;
        TempID := SymbolTable.LookUpID(S, 0, UpCase);
        if TempID > 0 then
          CurrToken.ID := TempID
        else