PROGRAM PARSER (INPUT,OUTPUT);
{.PL66}
{.HE   LR(1) Parser         Version 1.00}
{.FO                                    -#-            (C) 1986 Diomidis Spinellis}
{

This program will parse a language according to a BNF grammar file that
will be read from the disk. Errors will be reported and the parse tree
will be made available.
The parsing algorithm is as follows :
For each new symbol added in the parse tree the program will search the
UPPER FRONTIER of the tree for a sequence of terminal and/or nonterminal
symbols that will match a R.H.S (Right hand side) of the BNF grammar file
read. This will happen for all production rules of the grammar. In case
of failure the program will repeat the same sequence but by eliminating the
left most symbol of the upper frontier of the parsing tree. This will continue
until only one item is left on the upper frontier. After that the parser will
proceed to read another item.

(C) Copyright 1986 Diomidis D. Spinellis

Version  1.00

}

CONST

  GRAMMARWIDTH = 10 ;
  MAXGRAMMARLENGTH = 150 ;
  SYMBOLLENGTH = 30;

TYPE

  SYMBOLSTRING = STRING[SYMBOLLENGTH];

  SYMBOL = RECORD
    ISTERMINAL : BOOLEAN;
    NAME : SYMBOLSTRING;
  END;

  RHSTYPE = ARRAY [1..GRAMMARWIDTH] OF SYMBOL ;

  GRAMMARENTRY = RECORD
    LHS : SYMBOLSTRING ; {Is always a non terminal symbol }
    RHS : RHSTYPE ;
    RHSLEN : INTEGER;
  END;

  PARSEENTRYPOINT = ^PARSEENTRY;

  PARSEENTRY = RECORD
    NAME : SYMBOL ;
    RIGHT , LEFT : PARSEENTRYPOINT ;
    DESCENDANT : ARRAY [1..GRAMMARWIDTH] OF PARSEENTRYPOINT ;
  END;

VAR

  GRAMMAR : ARRAY [1..MAXGRAMMARLENGTH] OF GRAMMARENTRY ;

  FIRST,LAST : PARSEENTRYPOINT ;
  GRAMMARLENGTH,I,J : INTEGER;

{.PA}
PROCEDURE REPORTERROR;
{
When the error is reported I do not follow the grammar convention to enclose
the terminal symbols within square brackets. Rather the nonterminal symbols
are enclosed within angle brackets < > . This is used for clarity from the
users point of view .
}
VAR
  I : INTEGER;
  TEMPPOINT : PARSEENTRYPOINT;
BEGIN
  WRITELN('Unable to parse the following chain :');
  TEMPPOINT:=FIRST;
  WHILE TEMPPOINT<>NIL DO
  BEGIN
    IF TEMPPOINT^.NAME.ISTERMINAL THEN
      WRITE(TEMPPOINT^.NAME.NAME)
    ELSE
      WRITE('<',TEMPPOINT^.NAME.NAME,'>');
    TEMPPOINT:=TEMPPOINT^.RIGHT;
  END;
END;


{.PA}
PROCEDURE LIST;
{
List the parsing tree after a successfull parsing operation.
This procedure is only used as a shell for the recursively called procedure
LISTTREE and for the variable TABINCREMENT which is used staticly to define
the offset on the screen of each branch.
}
CONST
  TABINCREMENT = 3 ;

VAR
  TABSPACE : INTEGER;

PROCEDURE LISTTREE(NODE : PARSEENTRYPOINT );
  VAR I : INTEGER;
  BEGIN
    I:=1;
    TABSPACE:=TABSPACE+TABINCREMENT;

    WHILE (NODE^.DESCENDANT[I]<>NIL) AND (I<=GRAMMARWIDTH) DO
    BEGIN
      LISTTREE(NODE^.DESCENDANT[I]);
      I:=I+1;
    END;

    FOR I:=1 TO TABSPACE DO
      WRITE(' ');

    IF NODE^.NAME.ISTERMINAL THEN
      WRITELN('''',NODE^.NAME.NAME,'''')
    ELSE
      WRITELN(NODE^.NAME.NAME);

    TABSPACE:=TABSPACE-TABINCREMENT;
  END;

BEGIN
  TABSPACE:=1;
  LISTTREE(FIRST);
END;

{.PA}
FUNCTION READGRAMMAR:INTEGER ; {Reaturns the number of sentences read}

VAR
  GRAMMARFILENAME : STRING[65];
  BUFFER : STRING[255];
  GRAMMARFILE : TEXT;
  GRAMMARINDEX,RHSINDEX,SENTENCEINDEX,SYMBOLBEGIN : INTEGER;
  INSYMBOL : BOOLEAN;

BEGIN
{
Read the grammar file . The grammar is assumed to be syntacticaly correct !
The syntax of the grammar is as follows :

grammar ::= sentecial_form_list
sentencial_form_list ::= sentence ',' sentential_form_list
sentencial_form_list ::= sentence
sentence ::= nonterminal_symbol ':' ':' '=' symbol_list
symbol_list ::= symbol ' ' symbol_list
symbol_list ::= symbol
symbol ::= terminal_symbol
symbol ::= nonterminal_symbol
terminal_symbol ::= '''' ascii_character ''''
nonterminal_symbol ::= ' ' ascii_sequence ' '
ascii_sequence ::= ascii_character ascii_sequence
ascii_sequence ::= ascii_character
ascii_character ::= ' '
ascii_character ::= '!'
ascii_character ::= '"'
.......................
.......................
ascii_character ::= '~'
}

WRITELN('Grammar file name :');
READLN(GRAMMARFILENAME);
ASSIGN(GRAMMARFILE,GRAMMARFILENAME);
RESET(GRAMMARFILE);
GRAMMARINDEX:=1;
WHILE NOT EOF(GRAMMARFILE) DO
BEGIN
  READLN(GRAMMARFILE,BUFFER);
  BUFFER:=CONCAT(BUFFER,' ');
  GRAMMAR[GRAMMARINDEX].LHS:=COPY(BUFFER,1,POS('::=',BUFFER)-2);
  RHSINDEX:=1;
  INSYMBOL:=FALSE;

  SENTENCEINDEX:=POS('::=',BUFFER)+3;
  WHILE SENTENCEINDEX <= LENGTH(BUFFER) DO
  BEGIN
    IF BUFFER[SENTENCEINDEX]=' ' THEN {Read out white space}
      SENTENCEINDEX:=SENTENCEINDEX+1

    ELSE
    BEGIN
      IF BUFFER[SENTENCEINDEX]='''' THEN
      { Although it is not allowed by the grammar the parser will accept also
      symbols with length more than one }
      BEGIN
        GRAMMAR[GRAMMARINDEX].RHS[RHSINDEX].ISTERMINAL:=TRUE;
        IF (BUFFER[SENTENCEINDEX+1]='''') AND (BUFFER[SENTENCEINDEX+2]='''') THEN
        {Special case '''' means the terminal ' }
        BEGIN
          GRAMMAR[GRAMMARINDEX].RHS[RHSINDEX].NAME:='''';
          SENTENCEINDEX:=SENTENCEINDEX+3;
          END
        ELSE
        BEGIN  { Normal terminal symbol }
          GRAMMAR[GRAMMARINDEX].RHS[RHSINDEX].NAME:=
          COPY(BUFFER,SENTENCEINDEX+1,
          POS('''',COPY(BUFFER,SENTENCEINDEX+1,LENGTH(BUFFER)))-1);
          SENTENCEINDEX:=SENTENCEINDEX+2; {Adjust for the last symbol}
        END;
      END
      ELSE    { Nonterminal symbol }
      BEGIN
        GRAMMAR[GRAMMARINDEX].RHS[RHSINDEX].ISTERMINAL:=FALSE;
        GRAMMAR[GRAMMARINDEX].RHS[RHSINDEX].NAME:=
        COPY(BUFFER,SENTENCEINDEX,
        POS(' ',COPY(BUFFER,SENTENCEINDEX,LENGTH(BUFFER)))-1);
      END;
      RHSINDEX:=RHSINDEX+1;
      SENTENCEINDEX:=
      SENTENCEINDEX+LENGTH(GRAMMAR[GRAMMARINDEX].RHS[RHSINDEX-1].NAME);
    END;
  END;
  GRAMMAR[GRAMMARINDEX].RHSLEN:=RHSINDEX-1;
  GRAMMARINDEX:=GRAMMARINDEX+1;

END; {The while loop}

READGRAMMAR:=GRAMMARINDEX-1;

END; {The function}

{.PA}
FUNCTION READLANG:BOOLEAN;
VAR
  LANGFILENAME : STRING[65];
  LCHAR : CHAR;
  LANGFILE : TEXT;

  PROCEDURE PUTTREE(LCHAR:CHAR);
  {Ammend the LCHAR terminal symbol in the parsing tree . All actions are
  beeing thought of. One should remember that the top of the parsing tree
  or the upper frontier as it is called also forms a linked list.}
  VAR
    TEMPPOINT : PARSEENTRYPOINT;
    I : INTEGER;

  BEGIN

    NEW(TEMPPOINT); { Allocate space }
    TEMPPOINT^.NAME.NAME:=LCHAR; {Add entry to linked list }
    TEMPPOINT^.NAME.ISTERMINAL:=TRUE; {The language contains only terminal symbols }
    TEMPPOINT^.RIGHT:=NIL;
    TEMPPOINT^.LEFT:=LAST;
    FOR I:=1 TO GRAMMARWIDTH DO
      TEMPPOINT^.DESCENDANT[I]:=NIL;
    IF LAST<>NIL THEN
      LAST^.RIGHT:=TEMPPOINT
    ELSE
      FIRST:=TEMPPOINT;
    LAST:=TEMPPOINT;

  END;

  PROCEDURE CHECKREDUCE;
  {This procedure will make all reduce operations that are possible .}
  VAR
    FRONTIERSTART : PARSEENTRYPOINT;
    I : INTEGER;

    PROCEDURE REDUCE(PARSEELEMENT:PARSEENTRYPOINT;SENTENCE:GRAMMARENTRY);
    {Here the sequence of symbols starting on the linked list from
    PARSEELEMENT is reduced acording to the rule of SENTENCE .}
      VAR
        TEMPPOINT,PARSECHAINPOINT : PARSEENTRYPOINT ;
        I : INTEGER ;
      BEGIN
        NEW(TEMPPOINT);
        WRITELN('Reducing ',PARSEELEMENT^.NAME.NAME,' to ',SENTENCE.LHS);
        PARSECHAINPOINT:=PARSEELEMENT;
        FOR I:=1 TO SENTENCE.RHSLEN DO
        BEGIN
          TEMPPOINT^.DESCENDANT[I]:=PARSECHAINPOINT;
          PARSECHAINPOINT:=PARSECHAINPOINT^.RIGHT;
        END;
        TEMPPOINT^.LEFT:=PARSEELEMENT^.LEFT;
        IF PARSEELEMENT^.LEFT=NIL THEN {Check if it starts from FIRST }
          FIRST:=TEMPPOINT
        ELSE
          PARSEELEMENT^.LEFT^.RIGHT:=TEMPPOINT;
        TEMPPOINT^.RIGHT:=PARSECHAINPOINT;
        IF PARSECHAINPOINT=NIL THEN {Check if it ends in LAST }
          LAST:=TEMPPOINT
        ELSE
          PARSECHAINPOINT^.LEFT:=TEMPPOINT;
        TEMPPOINT^.NAME.NAME:=SENTENCE.LHS;
        TEMPPOINT^.NAME.ISTERMINAL:=FALSE; {All LHSs are nonterminals}

      END;

    FUNCTION COMPARE(FRONTIER : PARSEENTRYPOINT ; SENTENCE : GRAMMARENTRY):BOOLEAN;
    {A frontier starting at parseentrypoint is compared to the RHS of a SENTENCE}
      VAR
        I : INTEGER ;
        UP2NOWOK : BOOLEAN ;

      FUNCTION SYMCOMP(A,B : SYMBOL ) : BOOLEAN;
      {Two symbols are compared}
        BEGIN
        IF (A.ISTERMINAL=B.ISTERMINAL) AND (A.NAME=B.NAME) THEN
          SYMCOMP:=TRUE
        ELSE
          SYMCOMP:=FALSE;
        END;

      BEGIN
      IF FRONTIER=NIL THEN
        UP2NOWOK:=FALSE
      ELSE
        UP2NOWOK:=TRUE;

      FOR I:=1 TO SENTENCE.RHSLEN DO
        IF FRONTIER<>NIL THEN          {Check for end of frontier }
          IF SYMCOMP(FRONTIER^.NAME , SENTENCE.RHS[I]) AND UP2NOWOK THEN
            FRONTIER:=FRONTIER^.RIGHT   {Move to next froniter item }
          ELSE
            UP2NOWOK:=FALSE
        ELSE
          UP2NOWOK:=FALSE; {End of frontier encountered before all were read }
      COMPARE:=UP2NOWOK;
      END;

  BEGIN

    FOR I:=1 TO GRAMMARLENGTH DO
    BEGIN
      FRONTIERSTART:=FIRST;
      WHILE FRONTIERSTART<>NIL DO
      BEGIN
        IF COMPARE(FRONTIERSTART,GRAMMAR[I]) THEN
        BEGIN
          REDUCE(FRONTIERSTART,GRAMMAR[I]);
          CHECKREDUCE; { Called recursively for any new possibilities }
        END;
        FRONTIERSTART:=FRONTIERSTART^.RIGHT;
      END; {While}
    END; {For}
  END;  {Check reduce }

BEGIN
WRITELN('Language file name :');
READLN(LANGFILENAME);
ASSIGN(LANGFILE,LANGFILENAME);
RESET(LANGFILE);
FIRST:=NIL;
LAST:=NIL;

WHILE NOT EOF(LANGFILE) DO
BEGIN
  READ(LANGFILE,LCHAR);
  PUTTREE(LCHAR);
  CHECKREDUCE;
END;

IF FIRST=LAST THEN
  READLANG:=TRUE
ELSE
  READLANG:=FALSE;

END;


{.PA}
BEGIN
  GRAMMARLENGTH:=READGRAMMAR;
  IF READLANG THEN
  BEGIN
    WRITELN('Language successfully parsed');
    LIST;
  END
  ELSE
  BEGIN
    WRITELN(' * Error *    -- Unable to parse ');
    REPORTERROR;
  END;

END.