mwsimplepaspar.pas

MWDELPAR（解析Pascal语法）

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License Version
1.1 (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.mozilla.org/NPL/NPL-1_1Final.html

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: mwSimplePasPar.pas, released August 25, 1999.

The Initial Developer of the Original Code is Martin Waldenburg
([e-mail]).
Portions created by Martin Waldenburg are Copyright (C) 1998, 1999 Martin
Waldenburg.
All Rights Reserved.
Portions CopyRight by Robert Zierer.

Contributor(s): James Jacobson, Dean Hill______________________________________.

Last Modified: mm/dd/yyyy
Current Version: 0.24

Notes: This program is an early beginning of a Pascal parser.
I'd like to invite the Delphi community to develop it further and to create
a fully featured Object Pascal parser.

Modification history:

Known Issues:
-----------------------------------------------------------------------------}

unit mwSimplePasPar;

interface

uses
  SysUtils, Windows, Messages, Classes, Controls, mwPasLexTypes, mwPasLex,
  mwSimplePasParTypes, Dialogs;

type
  ESyntaxError = class(Exception)
  private //jdj 7/18/1999
    FPosXY: TPoint;
  protected

  public
    constructor Create(const Msg: string);
    constructor CreateFmt(const Msg: string; const Args: array of const);
    constructor CreatePos(const Msg: string; aPosXY: TPoint);
    property PosXY: TPoint read FPosXY write FPosXY;
  end;

type
  TmwSimplePasPar = class(TObject)
  private
    FOnMessage: TMessageEvent;
    fLexer: TmwPasLex;
    fOwnStream: Boolean;
    fStream: TMemoryStream;
    fInterfaceOnly: Boolean;
  protected
    fInRound: Boolean;
    procedure Expected(Sym: TptTokenKind); virtual;
    procedure ExpectedEx(Sym: TptTokenKind); virtual;
    procedure ExpectedFatal(Sym: TptTokenKind); virtual;
    procedure HandlePtCompDirect(Sender: TmwBasePasLex); virtual;
    procedure HandlePtDefineDirect(Sender: TmwBasePasLex); virtual;
    procedure HandlePtElseDirect(Sender: TmwBasePasLex); virtual;
    procedure HandlePtEndIfDirect(Sender: TmwBasePasLex); virtual;
    procedure HandlePtIfDefDirect(Sender: TmwBasePasLex); virtual;
    procedure HandlePtIfNDefDirect(Sender: TmwBasePasLex); virtual;
    procedure HandlePtIfOptDirect(Sender: TmwBasePasLex); virtual;
    procedure HandlePtIncludeDirect(Sender: TmwBasePasLex); virtual;
    procedure HandlePtResourceDirect(Sender: TmwBasePasLex); virtual;
    procedure HandlePtUndefDirect(Sender: TmwBasePasLex); virtual;
    procedure NextToken; virtual;
    procedure SkipJunk; virtual;
    procedure TerminateStream; virtual;
    procedure SEMICOLON; virtual;
    function GetExID: TptTokenKind; virtual;
    function GetTokenID: TptTokenKind; virtual;
    function GetGenID: TptTokenKind; virtual;
    procedure AccessSpecifier; virtual;
    procedure AdditiveOperator; virtual;
    procedure ArrayConstant; virtual;
    procedure ArrayType; virtual;
    procedure AsmStatement; virtual;
    procedure Block; virtual;
    procedure CaseLabel; virtual;
    procedure CaseSelector; virtual;
    procedure CaseStatement; virtual;
    procedure CharString; virtual;
    procedure ClassField; virtual;
    procedure ClassForward; virtual;
    procedure ClassFunctionHeading; virtual;
    procedure ClassHeritage; virtual;
    procedure ClassMemberList; virtual;
    procedure ClassMethodDirective; virtual;
    procedure ClassMethodHeading; virtual;
    procedure ClassMethodOrProperty; virtual;
    procedure ClassMethodResolution; virtual;
    procedure ClassProcedureHeading; virtual;
    procedure ClassProperty; virtual;
    procedure ClassReferenceType; virtual;
    procedure ClassType; virtual;
    procedure ClassVisibility; virtual;
    procedure CompoundStatement; virtual;
    procedure ConstantColon; virtual;
    procedure ConstantDeclaration; virtual;
    procedure ConstantEqual; virtual;
    procedure ConstantExpression; virtual;
    procedure ConstantName; virtual;
    procedure ConstantValue; virtual;
    procedure ConstantValueTyped; virtual;
    procedure ConstParameter; virtual;
    procedure ConstructorHeading; virtual;
    procedure ConstructorName; virtual;
    procedure ConstSection; virtual;
    procedure ContainsClause; virtual;
    procedure ContainsExpression; virtual;
    procedure ContainsIdentifier; virtual;
    procedure ContainsStatement; virtual;
    procedure DeclarationSection; virtual;
    procedure Designator; virtual;
    procedure DestructorHeading; virtual;
    procedure DestructorName; virtual;
    procedure Directive16Bit; virtual;
    procedure DirectiveBinding; virtual;
    procedure DirectiveCalling; virtual;
    procedure DispInterfaceForward; virtual;
    procedure EmptyStatement; virtual;
    procedure EnumeratedType; virtual;
    procedure ExceptBlock; virtual;
    procedure ExceptionBlockElseBranch; virtual;
    procedure ExceptionClassTypeIdentifier; virtual;
    procedure ExceptionHandler; virtual;
    procedure ExceptionHandlerList; virtual;
    procedure ExceptionIdentifier; virtual;
    procedure ExceptionVariable; virtual;
    procedure ExpliciteType; virtual;
    procedure ExportedHeading; virtual;
    procedure ExportsClause; virtual;
    procedure ExportsElement; virtual;
    procedure Expression; virtual;
    procedure ExpressionList; virtual;
    procedure ExternalDirective; virtual;
    procedure ExternalDirectiveThree; virtual;
    procedure ExternalDirectiveTwo; virtual;
    procedure Factor; virtual;
    procedure FieldDeclaration; virtual;
    procedure FieldList; virtual;
    procedure FileType; virtual;
    procedure FormalParameterList; virtual;
    procedure FormalParameterSection; virtual;
    procedure ForStatement; virtual;
    procedure FunctionHeading; virtual;
    procedure FunctionMethodDeclaration; virtual;
    procedure FunctionMethodName; virtual;
    procedure FunctionProcedureBlock; virtual;
    procedure FunctionProcedureName; virtual;
    procedure IdentifierList; virtual;
    procedure IfStatement; virtual;
    procedure ImplementationSection; virtual;
    procedure IncludeFile; virtual;
    procedure InheritedStatement; virtual;
    procedure InitializationSection; virtual;
    procedure InlineStatement; virtual;
    procedure InterfaceDeclaration; virtual;
    procedure InterfaceForward; virtual;
    procedure InterfaceGUID; virtual;
    procedure InterfaceHeritage; virtual;
    procedure InterfaceMemberList; virtual;
    procedure InterfaceSection; virtual;
    procedure InterfaceType; virtual;
    procedure LabelDeclarationSection; virtual;
    procedure LabeledStatement; virtual;
    procedure LabelId; virtual;
    procedure LibraryFile; virtual;
    procedure MainUsedUnitExpression; virtual;
    procedure MainUsedUnitName; virtual;
    procedure MainUsedUnitStatement; virtual;
    procedure MainUsesClause; virtual;
    procedure MultiplicativeOperator; virtual;
    procedure NewFormalParameterType; virtual;
    procedure Number; virtual;
    procedure ObjectConstructorHeading; virtual;
    procedure ObjectDestructorHeading; virtual;
    procedure ObjectField; virtual;
    procedure ObjectForward; virtual;
    procedure ObjectFunctionHeading; virtual;
    procedure ObjectHeritage; virtual;
    procedure ObjectMemberList; virtual;
    procedure ObjectMethodDirective; virtual;
    procedure ObjectMethodHeading; virtual;
    procedure ObjectNameOfMethod; virtual;
    procedure ObjectProcedureHeading; virtual;
    procedure ObjectType; virtual;
    procedure ObjectVisibility; virtual;
    procedure OldFormalParameterType; virtual;
    procedure OrdinalIdentifier; virtual;
    procedure OrdinalType; virtual;
    procedure OutParameter; virtual;
    procedure PackageFile; virtual;
    procedure ParameterFormal; virtual;
    procedure ParameterName; virtual;
    procedure ParameterNameList; virtual;
    procedure ParseFile; virtual;
    procedure PointerType; virtual;
    procedure ProceduralDirective; virtual;
    procedure ProceduralType; virtual;
    procedure ProcedureDeclarationSection; virtual;
    procedure ProcedureHeading; virtual;
    procedure ProcedureMethodDeclaration; virtual;
    procedure ProcedureMethodName; virtual;
    procedure ProgramBlock; virtual;
    procedure ProgramFile; virtual;
    procedure PropertyInterface; virtual;
    procedure PropertyName; virtual;
    procedure PropertyParameterConst; virtual;
    procedure PropertyParameterList; virtual;
    procedure PropertySpecifiers; virtual;
    procedure QualifiedIdentifier; virtual;
    procedure QualifiedIdentifierList; virtual;
    procedure RaiseStatement; virtual;
    procedure ReadAccessIdentifier; virtual;
    procedure RealIdentifier; virtual;
    procedure RealType; virtual;
    procedure RecordConstant; virtual;
    procedure RecordFieldConstant; virtual;
    procedure RecordType; virtual;
    procedure RecordVariant; virtual;
    procedure RelativeOperator; virtual;
    procedure RepeatStatement; virtual;
    procedure RequiresClause; virtual;
    procedure RequiresIdentifier; virtual;
    procedure ResolutionInterfaceName; virtual;
    procedure ResourceDeclaration; virtual;
    procedure ReturnType; virtual;
    procedure SetConstructor; virtual;
    procedure SetElement; virtual;
    procedure SetType; virtual;
    procedure SimpleExpression; virtual;
    procedure SimpleStatement; virtual;
    procedure SimpleType; virtual;
    procedure SkipAnsiComment; virtual;
    procedure SkipBorComment; virtual;
    procedure SkipSlashesComment; virtual;
    procedure Statement; virtual;
    procedure StatementList; virtual;
    procedure StorageExpression; virtual;
    procedure StorageIdentifier; virtual;
    procedure StorageDefault; virtual;
    procedure StorageNoDefault; virtual;
    procedure StorageSpecifier; virtual;
    procedure StorageStored; virtual;
    procedure StringIdentifier; virtual;
    procedure StringStatement; virtual;
    procedure StringType; virtual;
    procedure StructuredType; virtual;
    procedure SubrangeType; virtual;
    procedure TagField; virtual;
    procedure TagFieldName; virtual;
    procedure TagFieldTypeName; virtual;
    procedure Term; virtual;
    procedure TryStatement; virtual;
    procedure TypedConstant; virtual;
    procedure TypeDeclaration; virtual;
    procedure TypeId; virtual;
    procedure TypeKind; virtual;
    procedure TypeName; virtual;
    procedure TypeSection; virtual;
    procedure UnitFile; virtual;
    procedure UnitId; virtual;
    procedure UsedUnitName; virtual;
    procedure UsedUnitsList; virtual;
    procedure UsesClause; virtual;
    procedure VarAbsolute; virtual;
    procedure VarEqual; virtual;
    procedure VarDeclaration; virtual;
    procedure Variable; virtual;
    procedure VariableList; virtual;
    procedure VariableReference; virtual;
    procedure VariableTwo; virtual;
    procedure VariantIdentifier; virtual;
    procedure VariantSection; virtual;
    procedure VarName; virtual;
    procedure VarNameList; virtual;
    procedure VarParameter; virtual;
    procedure VarSection; virtual;
    procedure VisibilityAutomated; virtual;
    procedure VisibilityPrivate; virtual;
    procedure VisibilityProtected; virtual;
    procedure VisibilityPublic; virtual;
    procedure VisibilityPublished; virtual;
    procedure VisibilityUnknown; virtual;
    procedure WhileStatement; virtual;
    procedure WithStatement; virtual;
    procedure WriteAccessIdentifier; virtual;
    procedure SynError(Error: TmwParseError); virtual;
    property ExID: TptTokenKind read GetExID;
    property GenID: TptTokenKind read GetGenID;
    property TokenID: TptTokenKind read GetTokenID;
  public
    constructor Create;
    destructor Destroy; Override;
    procedure Run(UnitName: string; SourceStream: TMemoryStream);
    property InterfaceOnly: Boolean read fInterfaceOnly write fInterfaceOnly;
    property Lexer: TmwPasLex read fLexer;
    property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
  published
  end;

implementation

{ ESyntaxError }

constructor ESyntaxError.Create(const Msg: string);
begin
  FPosXY := Point(-1, -1);
  inherited Create(Msg);
end;

constructor ESyntaxError.CreateFmt(const Msg: string; const Args: array of const);
begin
  FPosXY := Point(-1, -1);
  inherited CreateFmt(Msg, Args);
end;

constructor ESyntaxError.CreatePos(const Msg: string; aPosXY: TPoint);
begin
  Message := Msg;
  FPosXY := aPosXY;
end;

{ TmwSimplePasPar }

const
  cnExpected = 'Expected ''%s'' found ''%s''';
  cnOrExpected = 'Expected ''%s'' or ''%s'' found ''%s''';
  cnEndOfFile = 'end of file'; {jdj 7/22/1999}
  cnIntegerOverflow = 'Integer constant too large'; {jdj 7/22/1999}

{range checks a ptIntegerConst-slightly faster than StrToInt}
function IsValidInteger(const S: string): Boolean; {jdj 7/22/1999}
var
  C: Integer;
  N: Integer;
begin
  Val(S, N, C);
  Result := (C = 0);
end;

procedure TmwSimplePasPar.Run(UnitName: string; SourceStream: TMemoryStream);
begin
  fStream := nil;
  fOwnStream := False;
  if SourceStream = nil then
  begin
    fStream := TMemoryStream.Create;
    fOwnStream := True;
    fStream.LoadFromFile(UnitName);
  end
  else
    fStream := SourceStream;
  TerminateStream;
  fLexer.Origin := fStream.Memory;
  ParseFile;
  if fOwnStream then
    fStream.Free;
end;

constructor TmwSimplePasPar.Create;
begin
  inherited Create;
  fLexer := TmwPasLex.Create;
  fLexer.OnCompDirect := HandlePtCompDirect;
  fLexer.OnDefineDirect := HandlePtDefineDirect;
  fLexer.OnElseDirect := HandlePtElseDirect;
  fLexer.OnEndIfDirect := HandlePtEndIfDirect;
  fLexer.OnIfDefDirect := HandlePtIfDefDirect;
  fLexer.OnIfNDefDirect := HandlePtIfNDefDirect;
  fLexer.OnIfOptDirect := HandlePtIfOptDirect;
  fLexer.OnIncludeDirect := HandlePtIncludeDirect;
  fLexer.OnResourceDirect := HandlePtResourceDirect;
  fLexer.OnUnDefDirect := HandlePtUndefDirect;
end;

destructor TmwSimplePasPar.Destroy;
begin
  fLexer.Free;
  inherited Destroy;
end;

{next two check for ptNull and ExpectedFatal for an EOF Error}
procedure TmwSimplePasPar.Expected(Sym: TptTokenKind);
begin
  if Sym <> Lexer.TokenID then
  begin
    if TokenID = ptNull then
      ExpectedFatal(Sym) {jdj 7/22/1999}
    else
      if Assigned(FOnMessage) then
        FOnMessage(Self, Format(cnExpected, [TokenName(Sym), fLexer.Token]),
          fLexer.PosXY.X, fLexer.PosXY.Y);
  end else NextToken;
end;

procedure TmwSimplePasPar.ExpectedEx(Sym: TptTokenKind);
begin
  if Sym <> Lexer.ExID then
  begin
    if Lexer.TokenID = ptNull then
      ExpectedFatal(Sym) {jdj 7/22/1999}
    else
      if Assigned(FOnMessage) then
        FOnMessage(Self, Format(cnExpected, [TokenName(Sym), fLexer.Token]),
          fLexer.PosXY.X, fLexer.PosXY.Y);
  end else NextToken;
end;

{Replace Token with cnEndOfFile if TokenId = ptnull}
procedure TmwSimplePasPar.ExpectedFatal(Sym: TptTokenKind);
var
  tS: string;
begin
  if Sym <> Lexer.TokenID then
  begin
      {--jdj 7/22/1999--}
    if Lexer.TokenId = ptNull then
      tS := cnEndOfFile
    else
      tS := fLexer.Token;
     {--jdj 7/22/1999--}
    raise ESyntaxError.CreatePos(Format(cnExpected, [TokenName(Sym), tS]), fLexer.PosXY);
  end else NextToken;
end;

procedure TmwSimplePasPar.HandlePtCompDirect(Sender: TmwBasePasLex);
begin
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.HandlePtDefineDirect(Sender: TmwBasePasLex);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Self, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y);
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.HandlePtElseDirect(Sender: TmwBasePasLex);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Self, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y);
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.HandlePtEndIfDirect(Sender: TmwBasePasLex);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Self, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y);
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.HandlePtIfDefDirect(Sender: TmwBasePasLex);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Self, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y);
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.HandlePtIfNDefDirect(Sender: TmwBasePasLex);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Self, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y);
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.HandlePtIfOptDirect(Sender: TmwBasePasLex);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Self, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y);
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.HandlePtIncludeDirect(Sender: TmwBasePasLex);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Self, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y);
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.HandlePtResourceDirect(Sender: TmwBasePasLex);
begin
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.HandlePtUndefDirect(Sender: TmwBasePasLex);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Self, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y);
  Sender.NextNoJunk;
    { ToDo }
end;

procedure TmwSimplePasPar.NextToken;
begin
  fLexer.Next;
  SkipJunk;
end;

procedure TmwSimplePasPar.SkipJunk;
begin
  if Lexer.IsJunk then
  begin
    repeat
      case TokenID of
        ptAnsiComment:
          begin
            SkipAnsiComment;
          end;
        ptBorComment:
          begin
            SkipBorComment;
          end;
        ptSlashesComment:
          begin
            SkipSlashesComment;
          end;
      else
        begin
          Lexer.Next;
        end;
      end;
    until not Lexer.IsJunk;
  end;
end;

procedure TmwSimplePasPar.SkipAnsiComment;
begin
  Expected(ptAnsiComment);
  while TokenID in [ptAnsiComment, ptCRLFCo] do Lexer.Next;
end;

procedure TmwSimplePasPar.SkipBorComment;
begin
  Expected(ptBorComment);
  while TokenID in [ptBorComment, ptCRLFCo] do Lexer.Next;
end;

procedure TmwSimplePasPar.SkipSlashesComment;
begin
  Expected(ptSlashesComment);
end;

procedure TmwSimplePasPar.TerminateStream;
var
  aChar: Char;
begin
  fStream.Position := fStream.Size;
  aChar := #0;
  fStream.Write(aChar, 1);
end;

procedure TmwSimplePasPar.SEMICOLON;
begin
  case Lexer.TokenID of
    ptElse, ptEnd, ptExcept, ptfinally, ptRoundClose, ptUntil: ;
  else
    Expected(ptSemiColon);
  end;
end;

function TmwSimplePasPar.GetExID: TptTokenKind;
begin
  Result := fLexer.ExID;
end;

function TmwSimplePasPar.GetTokenID: TptTokenKind;
begin
  Result := fLexer.TokenID;
end;

function TmwSimplePasPar.GetGenID: TptTokenKind;
begin
  Result := fLexer.GenID;
end;

procedure TmwSimplePasPar.SynError(Error: TmwParseError);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Self, ParserErrorName(Error) + ' found ' + fLexer.Token, fLexer.PosXY.X,
      fLexer.PosXY.Y);

end;



(******************************************************************************
 This part is oriented at the official grammar of Delphi 4
 and parialy based on Robert Zierers Delphi grammar.
 For more information about Delphi grammars take a look at:
 http://www.stud.mw.tu-muenchen.de/~rz1/Grammar.html
******************************************************************************)

procedure TmwSimplePasPar.ParseFile;
begin
  SkipJunk;
  case GenID of