pascal_parser.pas

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

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


{$I PaxScript.def}
unit PASCAL_PARSER;

interface

uses
  SysUtils, Classes,
  BASE_CONSTS,
  BASE_SYS,
  BASE_SCANNER,
  BASE_EXTERN;

type
  TPascalScanner = class(TPAXScanner)
  public
    procedure ReadToken; override;
  end;

  TPascalParser = class
  public
    Scanner: TPascalScanner;
    CurrToken: TPAXToken;
    D: TPAXMethodDefinition;
    ResultType: String;
    NP: Integer;
    IsDynamicArrayType: Boolean;
    constructor Create;
    destructor Destroy; override;
    procedure Call_SCANNER;
    function IsCurrText(const S: String): boolean;
    function Parse_Ident: String;
    procedure Match(const S: String);
    function Parse_Type(var TypeID, ExtraTypeID, Size: Integer): ShortString;
    procedure Parse_IdentList;
    procedure Parse_FormalParameter;
    procedure Parse_FormalParameters;
    procedure Parse_Heading;
    function Parse_Property(var ReadName, WriteName: String;
                            var Def: Boolean; DefList: TPAXDefinitionList): String;
    procedure ParseUsesClause(Output: TStrings);
  end;

implementation

procedure TPascalScanner.ReadToken;

procedure ScanChrs;
var
  S: String;
  I: Integer;
begin
  S := '';
  repeat
    GetNextChar;
    ScanDigits;
    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;

begin
  repeat
    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', '_':
        ScanIdentifier;
      '+': ScanPlus;
      '-': ScanMinus;
      '=': ScanEQ;
      ':': ScanColon;
      ';': ScanSemiColon;
      '(': ScanLeftRoundBracket;
      ')': ScanRightRoundBracket;
      '[': ScanLeftBracket;
      ']': ScanRightBracket;
      ',': ScanComma;
      '''': ScanString('''');
      '#': ScanChrs;
      '{':
      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;
    else
      raise TPAXScriptFailure.Create(errIllegalCharacter);
    end;

    if Token.TokenClass <> tcNone then
      Exit;

  until false;
end;

constructor TPascalParser.Create;
begin
  inherited;

  Scanner := TPascalScanner.Create(Self);

  ResultType := '';
  NP := 0;
  IsDynamicArrayType := false;
end;

destructor TPascalParser.Destroy;
begin
  Scanner.Free;
  inherited;
end;

procedure TPascalParser.Call_SCANNER;
begin
  Scanner.ReadToken;
  CurrToken := Scanner.Token;

  if CurrToken.TokenClass = tcSeparator then
    if CurrToken.ID <> SP_EOF then
    begin
      Call_SCANNER;
      Exit;
    end;
end;

function TPascalParser.IsCurrText(const S: String): boolean;
begin
  result := StrEql(CurrToken.Text, S)
end;

procedure TPascalParser.Match(const S: String);
begin
  if not IsCurrText(S) then
    raise TPAXScriptFailure.Create(Format(err_X_expected_but_Y_fond, [S, CurrToken.Text]));
end;

function TPascalParser.Parse_Ident: String;
begin
  if CurrToken.TokenClass <> tcId then
    raise TPAXScriptFailure.Create(errIdentifierExpected);

  result := CurrToken.Text;
  Call_SCANNER;
end;

function TPascalParser.Parse_Type(var TypeID, ExtraTypeID, Size: Integer): ShortString;
var
  I: Integer;
  RTTIDef: TPAXRTTITypeDefinition;
  ClassDef: TPAXClassDefinition;
  S: String;
label
  Again;
begin
  ExtraTypeID := 0;
  IsDynamicArrayType := false;
  Size := -1;

  S := Parse_Ident;
  result := S;

  S := FindTypeAlias(result, true);
  if S <> '' then
    result := S;

  if StrEql(result, 'array') then
  begin
Again:
    ExtraTypeID := typeDYNAMICARRAY;
    Match('of');
    Call_SCANNER;

    result := Parse_Ident;

    if StrEql(result, 'array') then goto Again;

    if StrEql(result, 'const') then
      result := 'TVarRec';
  end
  else if StrEql(result, 'paxarray') then
  begin
    typeID := typeARRAY;
    ExtraTypeID := typeARRAY;
    Exit;
  end;

  for I:=0 to PAXTypes.Count - 1 do
    if StrEql(result, PAXTypes[I]) then
    begin
      typeID := I;
      Exit;
    end;

  typeID := typeCLASS;

  RTTIDef := D.DefList.FindRTTITypeDefByName(result);
  if RTTIDef <> nil then
  begin
    typeID := RTTIDef.FinalType;
    Exit;
  end;

  ClassDef := D.DefList.FindClassDefByName(result);

  if ClassDef <> nil then
  begin
    if ClassDef.classKind = ckEnum then
      typeID := typeINTEGER
    else if ClassDef.classKind = ckDynamicArray then
    begin
      IsDynamicArrayType := true;
      ExtraTypeId := typeDYNAMICARRAY;
      TypeID := ClassDef.ElType;
    end
    else if ClassDef.classKind = ckInterface then
      typeID := typeINTERFACE;
    Size := ClassDef.RecordSize;

    Exit;
  end;

  S := UpperCase(result);
  if UnresolvedTypes.IndexOf(S) = -1 then
    UnresolvedTypes.Add(S);

  if StrEql(result, 'IInterface') then
    typeID := typeINTERFACE;

  if Pos('CLASS', UpperCase(result)) > 0 then
    typeID := typeCLASSREF;
end;

procedure TPascalParser.Parse_IdentList;
var
  S: String;
begin
  Inc(D.NP);
  S := Parse_Ident;
  D.ParamNames[D.NP - 1] := S;
  while IsCurrText(',') do
  begin
    Inc(D.NP);
    Call_SCANNER;
    S := Parse_Ident;
    D.ParamNames[D.NP - 1] := S;
  end;
end;

procedure TPascalParser.Parse_FormalParameter;
var
  I, PrevNP, TypeID, ExtraTypeID, Size: Integer;
  ByRef, IsSelf, IsOut, IsConst: Boolean;
  StrType, S: String;
begin
  ByRef := false;
  IsOut := false;
  IsConst := false;
  if IsCurrText('var') then
  begin
    ByRef := true;
    Call_SCANNER;
  end
  else if IsCurrText('const') then
  begin
    IsConst := true;
    Call_SCANNER;
  end
  else if IsCurrText('out') then
  begin
    ByRef := true;
    IsOut := true;
    Call_SCANNER;
  end;

  PrevNP := D.NP;

  IsSelf := CurrToken.Text = 'Self';

  Parse_IdentList;

  if (D.NP = 1) and (PrevNP = 0) and D.NewFake and IsSelf then
    Dec(D.NP);

  TypeID := TypeVOID;
  if IsCurrText(':') then
  begin
    Call_SCANNER;
    StrType := Parse_Type(TypeID, ExtraTypeID, Size);
  end
  else
    if IsOut then
      TypeID := TypeINTERFACE;

  for I:= PrevNP + 1 to D.NP do
  begin
    D.Types[I - 1] := TypeID;
    D.ExtraTypes[I - 1] := ExtraTypeID;
    D.StrTypes[I - 1] := StrType;
    D.ByRefs[I - 1] := ByRef;
    D.Consts[I - 1] := IsConst;
    D.Sizes[I - 1] := Size;

  end;