bds.mr.dpg/doc/grammars/pascal/wirth/wpPar.pas

unit wpPar;

interface
uses
   SysUtils,
   Generics.Collections,
   wpLex;

type
   TStringMap = TDictionary<AnsiString,AnsiString>;


   TwpPar = class
      private
         fLex  : TwpLex;

         fConstants  : TStringMap;
         fTypes      : TStringMap;

      protected
         function    Match( ttype   : TTokenType;  dispose: boolean=true):TToken;   overload;
         function    Match( ttypes  : TTokenTypes; dispose: boolean=true):TToken;   overload;

      protected
         procedure   block;
         procedure   constant;
         procedure   uconstant;
         procedure   typedef;

      public
         procedure   prg;

      public
         constructor Create( Lexer: TwpLex);
         destructor  Destroy; override;
   end;

   EwpPar = Exception;


implementation

{ TwpPar }



// @@@: Construction / destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
//                                  Construction / destruction
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
// Constructor
// ================================================================================================
constructor TwpPar.Create(Lexer: TwpLex);
begin
   inherited Create;

   fLex        := Lexer;
   fConstants  := TStringMap.Create;
   fTypes      := TStringMap.Create;
end;

// ================================================================================================
// Destructor
// ================================================================================================
destructor TwpPar.Destroy;
begin
   fConstants  .Free;
   fTypes      .Free;

   inherited
end;



// @@@: Internals +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
//                                           Internals
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
//
// ================================================================================================
function TwpPar.Match(ttype: TTokenType; dispose: boolean): TToken;
var
   t: TToken;

begin
   result := nil;
   t      := fLex.NextToken;

   if t.TokenType = ttype then
      if dispose
         then t.Free
         else result := t

   else
      raise EwpPar.Create('Unexpected token')
end;

// ================================================================================================
//
// ================================================================================================
function TwpPar.Match(ttypes: TTokenTypes; dispose: boolean): TToken;
var
   t: TToken;

begin
   result := nil;
   t      := fLex.NextToken;

   if t.TokenType in ttypes then
      if dispose
         then t.Free
         else result := t
   else
      raise EwpPar.Create('Unexpected token')
end;

// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
//                                           Interface
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
// Program
// ================================================================================================
procedure TwpPar.prg;
var
   t  : TToken;

begin
   if Assigned( fLex) then
   begin
      Match(LT_PROGRAM);
      Match(TT_ID);
      Match(TT_LPAREN);

      t := fLex.NextToken;

      // id [, id]*
      if t.TokenType = TT_ID then
      begin
         t.Free;
         t := fLex.NextToken;

         while t.TokenType = TT_COMMA do
         begin
            t.Free;
            Match(TT_ID);
            t := fLex.NextToken;
         end;
      end;

      if t.TokenType <> TT_RPAREN then
         raise EwpPar.Create('")" expected');

      Match(TT_SEMI);
      block;
      Match(TT_DOT)
   end;
end;


// ================================================================================================
// block
// ================================================================================================
procedure TwpPar.block;
var
   token : TToken;
   ttype : TTokenType;
   start : TTokenTypes;
   start2: TTokenTypes;

begin
   start := [LT_LABEL,LT_CONST,LT_TYPE,LT_VAR,LT_PROCEDURE,LT_FUNCTION,LT_BEGIN];
   start2:= [LT_LABEL,LT_CONST,LT_TYPE,LT_VAR,LT_PROCEDURE,LT_FUNCTION];
   token := fLex.NextToken;

   if token.TokenType in start then
   begin
      while token.TokenType in start2 do
      begin
         case token.TokenType of
            // ------------------------------------------------------
            // Label
            // ------------------------------------------------------
            LT_LABEL:
               while true do
               begin
                  Match( TT_UINT);

                  token := fLex.NextToken;
                  ttype := token.TokenType;

                  token.Free;

                  case ttype of
                     TT_COMMA : ;
                     TT_SEMI  : begin token := fLex.NextToken; break end;
                     else raise EwpPar.Create('Expected: ,;');
                  end;
               end;

            // ------------------------------------------------------
            // Const
            // ------------------------------------------------------
            LT_CONST:
               begin
                  token := fLex.NextToken;
                  ttype := token.TokenType;

                  while ttype = TT_ID do
                  begin
                     token.Free;
                     Match(TT_EQ);
                     constant;
                     Match(TT_SEMI);

                     token := flex.NextToken;
                     ttype := token.TokenType;
                  end;
               end;

            // ------------------------------------------------------
            // Type
            // ------------------------------------------------------
            LT_TYPE:
               begin
                  token := fLex.NextToken;
                  ttype := token.TokenType;

                  while ttype = TT_ID do
                  begin
                     token.Free;
                     Match(TT_EQ);
                     typedef;
                     Match(TT_SEMI);

                     token := flex.NextToken;
                     ttype := token.TokenType;
                  end;
               end;

            LT_VAR:
               begin

               end;

            LT_PROCEDURE:
               begin

               end;

            LT_FUNCTION:
               begin

               end;
         end;

//         token := fLex.NextToken
      end;

      if token.TokenType = LT_BEGIN then
      begin

         Match(LT_END)
      end

      else
         raise EwpPar.Create('Expected: Begin');
   end

   else
      raise EwpPar.Create('Expected: label, const, type, var, procedure, function, begin');
end;


// ================================================================================================
// Constant
// ================================================================================================
procedure TwpPar.constant;
var
   token: TToken;
   ttype: TTokenType;

begin
   token := fLex.NextToken;
   ttype := token.TokenType;

   if ttype in [TT_PLUS,TT_MINUS,TT_ID,TT_UINT,TT_UREAL] then
   begin
      if ttype in [TT_PLUS,TT_MINUS] then
      begin
         token.Free;

         token := fLex.NextToken;
         ttype := token.TokenType;
      end;

      token.Free;

      case ttype of
         TT_ID    : ;
         TT_UINT  : ;
         TT_UREAL : ;
         else raise EwpPar.Create('Expected: id,int,real')
      end
   end

   else if ttype in [TT_CHAR, TT_STRING] then
   begin
      token.Free;
   end

   else
      raise EwpPar.Create('Expected: +,-,id,int,real,string');
end;

// ================================================================================================
// Unsigned constant
// ================================================================================================
procedure TwpPar.uconstant;
var
   token: TToken;
   ttype: TTokenType;

begin
   token := fLex.NextToken;
   ttype := token.TokenType;

   token.Free;

   case token.TokenType of
      TT_ID    : ;
      TT_UINT  : ;
      TT_UREAL : ;
      LT_NIL   : ;
      TT_STRING: ;
      else raise EwpPar.Create('Expected: id,int,real,nil,string')
   end;
end;

// ================================================================================================
// Type
// ================================================================================================
procedure TwpPar.typedef;
var
   token: TToken;
   ttype: TTokenType;
   ttext: AnsiString;

   f_const  : TTokenTypes;

begin
   token := fLex.NextToken;
   ttype := token.TokenType;
   ttext := token.TokenText;

   token.Free;

   // ---------------------------------------------------------------
   // TT_ID
   //
   // Identifier can be an existing type identifier, or an existing
   // constant identifier. If it is contant identifier, then it must
   // be a range specification.
   // ---------------------------------------------------------------
   if ttype = TT_ID then
   begin
      // --------------------------------------------------
      // constant .. constant
      // --------------------------------------------------
      if fConstants.ContainsKey(ttext) then
      begin
         Match(TT_RANGE);

         token := fLex.NextToken;
         ttype := token.TokenType;
         ttext := token.TokenText;

         token.Free;
      end

      // --------------------------------------------------
      // type identifier
      // --------------------------------------------------
      else if fTypes.ContainsKey(ttext) then
      begin

      end

      // --------------------------------------------------
      // Not an constant or type identifier
      // --------------------------------------------------
      else
         EwpPar.Create('Expected a type or constant identifier' );
   end;


end;



end.