(* ppg.mod master source file of the ebnf parser generator.

Copyright (C) 2003-2023 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Modula-2; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  *)

MODULE ppg ;

FROM PushBackInput IMPORT WarnError, WarnString, GetColumnPosition, GetCurrentLine ;
FROM bnflex IMPORT IsSym, SymIs, TokenType, GetCurrentToken, GetCurrentTokenType, GetChar, PutChar,
                   SkipWhite, SkipUntilEoln, AdvanceToken, IsReserved, OpenSource, CloseSource,
                   PushBackToken, SetDebugging ;
FROM StrLib IMPORT StrCopy, StrEqual, StrLen, StrConCat ;
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM NameKey IMPORT Name, MakeKey, WriteKey, LengthKey, GetKey, KeyToCharStar, NulName ;
FROM NumberIO IMPORT CardToStr, WriteCard ;
FROM SymbolKey IMPORT InitTree, SymbolTree, PutSymKey, GetSymKey, ForeachNodeDo, ContainsSymKey, NulKey ;
FROM Lists IMPORT InitList, IsItemInList, IncludeItemIntoList, RemoveItemFromList, KillList, List ;
FROM DynamicStrings IMPORT String, InitString, KillString, ConCat, Mark, ConCatChar,
                           InitStringCharStar, char, Length ;
FROM ASCII IMPORT nul, lf, tab ;
FROM StrIO IMPORT WriteString, WriteLn ;
FROM StdIO IMPORT Write ;
FROM Debug IMPORT Halt ;
FROM Args IMPORT GetArg, Narg ;
FROM SYSTEM IMPORT WORD ;
FROM libc IMPORT exit ;
IMPORT Output ;


CONST
   MaxCodeHunkLength = 8192 ;
   MaxFileName       = 8192 ;
   MaxString         = 8192 ;
   DefaultRecovery   = TRUE ;   (* default is to generate a parser which will recover from errors.  *)
   MaxElementsInSet  =   32 ;

   (* formatting constants *)
   BaseRightLimit    = 75 ;
   BaseRightMargin   = 50 ;
   BaseNewLine       =  3 ;

TYPE
   ElementType = (idel, tokel, litel) ;

   m2condition = (m2none, m2if, m2elsif, m2while) ;

   TraverseResult = (unknown, true, false) ;

   IdentDesc      = POINTER TO RECORD
                                  definition: ProductionDesc ;   (* where this idents production is defined *)
                                  name      : Name ;
                                  line      : CARDINAL ;
                               END ;

   SetDesc        = POINTER TO RECORD
                                  next          : SetDesc ;
                                  CASE type: ElementType OF

                                  idel  : ident : IdentDesc |
                                  tokel,
                                  litel : string: Name

                                  END
                               END ;

(* note that epsilon refers to whether we can satisfy this component part
   of a sentance without consuming a token. Reachend indicates we can get
   to the end of the sentance without consuming a token.

   For expression, statement, productions, terms: the epsilon value should
   equal the reachend value but for factors the two may differ.
*)

   FollowDesc     = POINTER TO RECORD
                                  calcfollow  : BOOLEAN ;          (* have we solved the follow set yet? *)
                                  follow      : SetDesc ;          (* the follow set *)
                                  reachend    : TraverseResult ;   (* can we see the end of the sentance (due to multiple epsilons) *)
                                  epsilon     : TraverseResult ;   (* potentially no token may be consumed within this component of the sentance *)
                                  line        : CARDINAL ;
                    END ;

   TermDesc       = POINTER TO termdesc ;

   ExpressionDesc = POINTER TO RECORD
                                  term      : TermDesc ;
                                  followinfo: FollowDesc ;
                                  line      : CARDINAL ;
                               END ;

   StatementDesc  = POINTER TO RECORD
                                  ident      : IdentDesc ;
                                  expr       : ExpressionDesc ;
                                  followinfo : FollowDesc ;
                                  line       : CARDINAL ;
                               END ;

   CodeHunk       = POINTER TO RECORD
                                  codetext  : ARRAY [0..MaxCodeHunkLength] OF CHAR ;
                                  next      : CodeHunk ;
                               END ;

   CodeDesc       = POINTER TO RECORD
                                  code      : CodeHunk ;
                                  indent    : CARDINAL ;         (* column of the first % *)
                                  line      : CARDINAL ;
                               END ;

   FactorType     = (id, lit, sub, opt, mult, m2) ;

   FactorDesc     = POINTER TO RECORD
                                  followinfo: FollowDesc ;
                                  next      : FactorDesc ;   (* chain of successive factors *)
                                  line      : CARDINAL ;
                                  pushed    : FactorDesc ;   (* chain of pushed code factors *)
                                  CASE type: FactorType OF

                                  id  : ident : IdentDesc |
                                  lit : string: Name |
                                  sub,
                                  opt,
                                  mult: expr  : ExpressionDesc |
                                  m2  : code  : CodeDesc ;

                                  END
                               END ;

   termdesc       =            RECORD
                                  factor    : FactorDesc ;
                                  next      : TermDesc ;  (* chain of alternative terms *)
                                  followinfo: FollowDesc ;
                                  line      : CARDINAL ;
                               END ;

   ProductionDesc = POINTER TO RECORD
                                  next        : ProductionDesc ;   (* the chain of productions *)
                                  statement   : StatementDesc ;
                                  first       : SetDesc ;          (* the first set *)
                                  firstsolved : BOOLEAN ;
                                  followinfo  : FollowDesc ;
                                  line        : CARDINAL ;
                                  description : Name ;
                               END ;

   DoProcedure    = PROCEDURE (ProductionDesc) ;


VAR
   LastLineNo         : CARDINAL ;
   Finished,
   SuppressFileLineTag,
   KeywordFormatting,
   PrettyPrint,
   EmitCode,
   Texinfo,
   Sphinx,
   FreeDocLicense,
   Debugging,
   WasNoError         : BOOLEAN ;
   LinePrologue,
   LineEpilogue,
   LineDeclaration    : CARDINAL ;
   CodePrologue,
   CodeEpilogue,
   CodeDeclaration    : CodeHunk ;
   CurrentProduction,
   TailProduction,
   HeadProduction     : ProductionDesc ;
   CurrentExpression  : ExpressionDesc ;
   CurrentTerm        : TermDesc ;
   CurrentFactor      : FactorDesc ;
   CurrentIdent       : IdentDesc ;
   CurrentStatement   : StatementDesc ;
   CurrentSetDesc     : SetDesc ;
   ReverseValues,
   Values,                           (* tree of tokens and their ORD value        *)
   ReverseAliases,
   Aliases            : SymbolTree ;
   ModuleName         : Name ;
   LastLiteral        : Name ;
   LastIdent          : Name ;
   SymIsProc,                        (* the name of the SymIs function tests and consumes token *)
   TokenTypeProc,                    (* the name of the function which yields the current token type *)
   ErrorProcArray,
   ErrorProcString    : Name ;       (* the name of the error procedures *)
   ArgName,
   FileName           : ARRAY [0..MaxFileName] OF CHAR ;
   OnLineStart,
   BeginningOfLine    : BOOLEAN ;
   Indent             : CARDINAL ;
   EmittedVar         : BOOLEAN ;    (* have we written VAR yet?                   *)
   ErrorRecovery      : BOOLEAN ;    (* do we want to recover from parsing errors? *)
   LargestValue       : CARDINAL ;   (* the number of tokens we are using.         *)
   InitialElement     : BOOLEAN ;    (* used to determine whether we are writing   *)
                                     (* the first element of a case statement.     *)
   ParametersUsed     : BITSET ;     (* which parameters have been used?           *)


(* % declaration *)

(*
   AddEntry - adds an entry into, t, containing [def:value].
*)

PROCEDURE AddEntry (VAR t: SymbolTree; def, value: Name) ;
BEGIN
   IF ContainsSymKey(t, def)
   THEN
      WarnError1("already seen a definition for token '%s'", def)
   ELSE
      PutSymKey(t, def, value)
   END
END AddEntry ;


(*
   Format1 - converts string, src, into, dest, together with encapsulated
             entity, n. It only formats the first %s or %d with n.
*)

PROCEDURE Format1 (src: ARRAY OF CHAR; n: WORD; VAR dest: ARRAY OF CHAR) ;
VAR
   HighSrc,
   HighDest,
   i, j    : CARDINAL ;
   str     : ARRAY [0..MaxString] OF CHAR ;
BEGIN
   HighSrc := StrLen(src) ;
   HighDest := HIGH(dest) ;
   i := 0 ;
   j := 0 ;
   WHILE (i<HighSrc) AND (src[i]#nul) AND (j<HighDest) AND (src[i]#'%') DO
      dest[j] := src[i] ;
      INC(i) ;
      INC(j)
   END ;
   IF (i+1<HighSrc) AND (src[i]='%') AND (j<HighDest)
   THEN
      IF src[i+1]='s'
      THEN
         dest[j] := nul ;
         GetKey(n, str) ;
         StrConCat(dest, str, dest) ;
         j := StrLen(dest) ;
         INC(i, 2)
      ELSIF src[i+1]='d'
      THEN
         dest[j] := nul ;
         CardToStr(n, 0, str) ;
         StrConCat(dest, str, dest) ;
         j := StrLen(dest) ;
         INC(i, 2)
      ELSE
         dest[j] := src[i] ;
         INC(i) ;
         INC(j)
      END
   END ;
   (* and finish off copying src into dest *)
   WHILE (i<HighSrc) AND (src[i]#nul) AND (j<HighDest) DO
      dest[j] := src[i] ;
      INC(i) ;
      INC(j)
   END ;
   IF j<HighDest
   THEN
      dest[j] := nul
   END ;
END Format1 ;


(*
   WarnError1 -
*)

PROCEDURE WarnError1 (a: ARRAY OF CHAR; n: WORD) ;
VAR
   line: ARRAY [0..MaxString] OF CHAR ;
BEGIN
   Format1(a, n, line) ;
   WarnError(line)
END WarnError1 ;


(*
   PrettyFollow -
*)

PROCEDURE PrettyFollow (start, end: ARRAY OF CHAR; f: FollowDesc) ;
BEGIN
   IF Debugging
   THEN
      Output.WriteString(start) ;
      IF f#NIL
      THEN
         WITH f^ DO
            IF calcfollow
            THEN
               Output.WriteString('followset defined as:') ;
               EmitSet(follow, 0, 0)
            END ;
            CASE reachend OF

            true :   Output.WriteString(' [E]') |
            false:   Output.WriteString(' [C]') |
            unknown: Output.WriteString(' [U]')

            ELSE
            END ;
            CASE epsilon OF

            true   : Output.WriteString(' [e]') |
            false  : |
            unknown: Output.WriteString(' [u]')

            ELSE
            END
         END
      END ;
      Output.WriteString(end)
   END
END PrettyFollow ;


(*
   NewFollow - creates a new follow descriptor and returns the data structure.
*)

PROCEDURE NewFollow () : FollowDesc ;
VAR
   f: FollowDesc ;
BEGIN
   NEW(f) ;
   WITH f^ DO
      follow       := NIL ;
      reachend     := unknown ;
      epsilon      := unknown ;
   END ;
   RETURN( f )
END NewFollow ;


(*
   AssignEpsilon - assigns the epsilon value and sets the epsilon to value,
                   providing condition is TRUE.
*)

PROCEDURE AssignEpsilon (condition: BOOLEAN; f: FollowDesc; value: TraverseResult) ;
BEGIN
   WITH f^ DO
      IF condition AND (value#unknown) AND (epsilon=unknown)
      THEN
         epsilon := value ;
         Finished := FALSE
      END
   END
END AssignEpsilon ;


(*
   GetEpsilon - returns the value of epsilon
*)

PROCEDURE GetEpsilon (f: FollowDesc) : TraverseResult ;
BEGIN
   IF f=NIL
   THEN
      Halt('why is the follow info NIL?',
           __FILE__, __FUNCTION__, __LINE__)
   ELSE
      RETURN( f^.epsilon )
   END
END GetEpsilon ;


(*
   AssignReachEnd - assigns the reachend value providing that, condition, is TRUE.
*)

PROCEDURE AssignReachEnd (condition: BOOLEAN; f: FollowDesc; value: TraverseResult) ;
BEGIN
   IF condition
   THEN
      WITH f^ DO
         IF (reachend=unknown) AND (value#unknown)
         THEN
            reachend := value ;
            Finished := FALSE
         END
      END
   END
END AssignReachEnd ;


(*
   GetReachEnd - returns the value of reachend
*)

PROCEDURE GetReachEnd (f: FollowDesc) : TraverseResult ;
BEGIN
   IF f=NIL
   THEN
      Halt('why is the follow info NIL?',
           __FILE__, __FUNCTION__, __LINE__)
   ELSE
      RETURN( f^.reachend )
   END
END GetReachEnd ;


(*
   AssignFollow - assigns the follow set and sets the calcfollow to TRUE.
*)

PROCEDURE AssignFollow (f: FollowDesc; s: SetDesc) ;
BEGIN
   WITH f^ DO
      IF calcfollow
      THEN
         Halt('why are we reassigning this follow set?',
              __FILE__, __FUNCTION__, __LINE__)
      END ;
      follow     := s ;
      calcfollow := TRUE
   END
END AssignFollow ;


(*
   GetFollow - returns the follow set.
*)

PROCEDURE GetFollow (f: FollowDesc) : SetDesc ;
BEGIN
   IF f=NIL
   THEN
      Halt ('why is the follow info NIL?',
            __FILE__, __FUNCTION__, __LINE__)
   ELSE
      WITH f^ DO
         IF calcfollow
         THEN
            RETURN( follow )
         ELSE
            Halt('not calculated the follow set yet..',
                 __FILE__, __FUNCTION__, __LINE__)
         END
      END
   END
END GetFollow ;


(*
   NewProduction - creates a new production and returns the data structure.
*)

PROCEDURE NewProduction () : ProductionDesc ;
VAR
   p: ProductionDesc ;
BEGIN
   NEW(p) ;
   IF TailProduction#NIL
   THEN
      TailProduction^.next := p
   END ;
   TailProduction := p ;
   IF HeadProduction=NIL
   THEN
      HeadProduction := p
   END ;
   WITH p^ DO
      next         := NIL ;
      statement    := NIL ;
      first        := NIL ;
      firstsolved  := FALSE ;
      followinfo   := NewFollow() ;
      line         := GetCurrentLine() ;
      description  := NulName
   END ;
   RETURN( p )
END NewProduction ;


(*
   NewFactor -
*)

PROCEDURE NewFactor () : FactorDesc ;
VAR
   f: FactorDesc ;
BEGIN
   NEW(f) ;
   WITH f^ DO
      next       := NIL ;
      followinfo := NewFollow() ;
      line       := GetCurrentLine()
   END ;
   RETURN( f )
END NewFactor ;


(*
   NewTerm - returns a new term.
*)

PROCEDURE NewTerm () : TermDesc ;
VAR
   t: TermDesc ;
BEGIN
   NEW(t) ;
   WITH t^ DO
      factor     := NIL ;
      followinfo := NewFollow() ;
      next       := NIL ;
      line       := GetCurrentLine()
   END ;
   RETURN( t )
END NewTerm ;


(*
   NewExpression - returns a new expression.
*)

PROCEDURE NewExpression () : ExpressionDesc ;
VAR
   e: ExpressionDesc ;
BEGIN
   NEW(e) ;
   WITH e^ DO
      term       := NIL ;
      followinfo := NewFollow() ;
      line       := GetCurrentLine()
   END ;
   RETURN( e )
END NewExpression ;


(*
   NewStatement - returns a new statement.
*)

PROCEDURE NewStatement () : StatementDesc ;
VAR
   s: StatementDesc ;
BEGIN
   NEW(s) ;
   WITH s^ DO
      ident      := NIL ;
      expr       := NIL ;
      followinfo := NewFollow() ;
      line       := GetCurrentLine()
   END ;
   RETURN( s )
END NewStatement ;


(*
   NewSetDesc - creates a new set description and returns the data structure.
*)

PROCEDURE NewSetDesc () : SetDesc ;
VAR
   s: SetDesc ;
BEGIN
   NEW(s) ;
   WITH s^ DO
      next := NIL
   END ;
   RETURN( s )
END NewSetDesc ;


(*
   NewCodeDesc - creates a new code descriptor and initializes all fields to zero.
*)

PROCEDURE NewCodeDesc () : CodeDesc ;
VAR
   c: CodeDesc ;
BEGIN
   NEW(c) ;
   WITH c^ DO
      code   := NIL ;
      indent := 0 ;
      line   := GetCurrentLine()
   END ;
   RETURN( c )
END NewCodeDesc ;


(*
   CodeFragmentPrologue - consumes code text up to a "%" after a newline.
*)

PROCEDURE CodeFragmentPrologue ;
BEGIN
   LinePrologue := GetCurrentLine() ;
   GetCodeFragment(CodePrologue)
END CodeFragmentPrologue ;


(*
   CodeFragmentEpilogue - consumes code text up to a "%" after a newline.
*)

PROCEDURE CodeFragmentEpilogue ;
BEGIN
   LineEpilogue := GetCurrentLine() ;
   GetCodeFragment(CodeEpilogue)
END CodeFragmentEpilogue ;


(*
   CodeFragmentDeclaration - consumes code text up to a "%" after a newline.
*)

PROCEDURE CodeFragmentDeclaration ;
BEGIN
   LineDeclaration := GetCurrentLine() ;
   GetCodeFragment(CodeDeclaration)
END CodeFragmentDeclaration ;


(*
   GetCodeFragment - collects the code fragment up until ^ %
*)

PROCEDURE GetCodeFragment (VAR h: CodeHunk) ;
VAR
   i : CARDINAL ;
   ch: CHAR ;
BEGIN
   h := NIL ;
   i := 0 ;
   WHILE (PutChar(GetChar())#'%') AND (PutChar(GetChar())#nul) DO
      REPEAT
         WHILE (PutChar(GetChar())#nul) AND (PutChar(GetChar())#lf) DO
            h := Add(h, GetChar(), i)
         END ;
         IF PutChar(GetChar())=lf
         THEN
            (* consume line feed *)
            h := Add(h, GetChar(), i) ;
            ch := PutChar(lf)
         ELSIF PutChar(GetChar())=nul
         THEN
            ch := PutChar(nul) ;
            ch := PutChar(lf)
         ELSE
            ch := PutChar(PutChar(GetChar()))
         END
      UNTIL GetChar()=lf
   END ;
   IF PutChar(GetChar())='%'
   THEN
      h := Add(h, nul, i) ;
      ch := PutChar(' ') ;  (* to give the following token % a delimiter infront of it *)
      AdvanceToken
   ELSE
      WarnError('expecting % to terminate code fragment, found end of file')
   END
END GetCodeFragment ;


(*
   WriteCodeHunkList - writes the CodeHunk list in the correct order.
*)

PROCEDURE WriteCodeHunkList (l: CodeHunk) ;
BEGIN
   IF l#NIL
   THEN
      OnLineStart := FALSE ;
      (* recursion *)
      WITH l^ DO
         WriteCodeHunkList(next) ;
         Output.WriteString(codetext)
      END
   END
END WriteCodeHunkList ;


(*
   WriteIndent - writes, n, spaces.
*)

PROCEDURE WriteIndent (n: CARDINAL) ;
BEGIN
   WHILE n>0 DO
      Output.Write(' ') ;
      DEC(n)
   END ;
   OnLineStart := FALSE
END WriteIndent ;


(*
   CheckWrite -
*)

PROCEDURE CheckWrite (ch: CHAR; VAR curpos: CARDINAL; left: CARDINAL; VAR seentext: BOOLEAN) ;
BEGIN
   IF ch=lf
   THEN
      NewLine(left) ;
      curpos := 0 ;
      seentext := FALSE
   ELSE
      Output.Write(ch) ;
      INC(curpos)
   END
END CheckWrite ;


(*
   WriteStringIndent - writes a string but it will try and remove upto indent spaces
                       if they exist.
*)

PROCEDURE WriteStringIndent (a: ARRAY OF CHAR; indent: CARDINAL;
                             VAR curpos: CARDINAL;
                             left: CARDINAL; VAR seentext: BOOLEAN) ;
VAR
   l, i: CARDINAL ;
BEGIN
   i := 0 ;
   l := StrLen(a) ;
   WHILE i<l DO
      IF seentext
      THEN
         CheckWrite(a[i], curpos, left, seentext)
      ELSE
         IF a[i]=' '
         THEN
            (* ignore space for now *)
            INC(curpos)
         ELSE
            IF curpos>=indent
            THEN
               WriteIndent(curpos-indent)
            END ;
            seentext := TRUE ;
            CheckWrite(a[i], curpos, left, seentext)
         END
      END ;
      INC(i)
   END
END WriteStringIndent ;


(*
   WriteCodeHunkListIndent - writes the CodeHunk list in the correct order
                             but it removes up to indent spaces if they exist.
*)

PROCEDURE WriteCodeHunkListIndent (l: CodeHunk; indent: CARDINAL;
                                   VAR curpos: CARDINAL;
                                   left: CARDINAL; VAR seentext: BOOLEAN) ;
BEGIN
   IF l#NIL
   THEN
      (* recursion *)
      WITH l^ DO
         WriteCodeHunkListIndent(next, indent, curpos, left, seentext) ;
         WriteStringIndent(codetext, indent, curpos, left, seentext)
      END
   END
END WriteCodeHunkListIndent ;


(*
   Add - adds a character to a code hunk and creates another code hunk if necessary.
*)

PROCEDURE Add (VAR p: CodeHunk; ch: CHAR; VAR i: CARDINAL) : CodeHunk ;
VAR
   q: CodeHunk ;
BEGIN
   IF (p=NIL) OR (i>MaxCodeHunkLength)
   THEN
      NEW(q) ;
      q^.next := p ;
      q^.codetext[0] := ch ;
      i := 1 ;
      RETURN( q )
   ELSE
      p^.codetext[i] := ch ;
      INC(i) ;
      RETURN( p )
   END
END Add ;


(*
   ConsHunk - combine two possible code hunks.
*)

PROCEDURE ConsHunk (VAR p: CodeHunk; q: CodeHunk) ;
VAR
   r: CodeHunk ;
BEGIN
   IF p#NIL
   THEN
      r := q ;
      WHILE r^.next#NIL DO
         r := r^.next
      END ;
      r^.next := p ;
   END ;
   p := q
END ConsHunk ;


(*
   GetName - returns the next symbol which is checked for a legal name.
*)

PROCEDURE GetName () : Name ;
VAR
   name: Name ;
BEGIN
   IF IsReserved(GetCurrentToken())
   THEN
      WarnError('expecting a name and found a reserved word') ;
      AdvanceToken ;  (* move on to another token *)
      RETURN( NulName )
   ELSE
      name := GetCurrentToken() ;
      AdvanceToken ;
      RETURN( name )
   END
END GetName ;


(* % rules *)

(*
    Note that all the code from here down to the end of the module as
    delimited by the comment will all be hidden when the buildpg
    script is invoked. Also be careful not to duplicate or remove these
    critical comments below..
    Check buildpg for sed details.
*)

(* StartNonErrorChecking *)

(* actually these two are not strictly rules but hand built primitives *)


(*
   Ident - non error checking varient of Ident
*)

PROCEDURE Ident () : BOOLEAN ;
BEGIN
   IF GetCurrentTokenType()=identtok
   THEN
      NEW(CurrentIdent) ;
      WITH CurrentIdent^ DO
         definition := NIL ;
         name       := GetName() ;
         line       := GetCurrentLine()
      END ;
      RETURN( TRUE )
   ELSE
      RETURN( FALSE )
   END
END Ident ;


(*
   Modula2Code - non error checking varient of Modula2Code
*)

PROCEDURE Modula2Code () : BOOLEAN ;
VAR
   p       : CodeHunk ;
   i       : CARDINAL ;
   quote   : BOOLEAN ;
   line,
   position: CARDINAL ;
BEGIN
   line := GetCurrentLine() ;
   PushBackToken(GetCurrentToken()) ;
   position := GetColumnPosition() ;
   p := NIL ;
   SkipWhite ;
   WHILE (PutChar(GetChar())#'%') AND (PutChar(GetChar())#nul) DO
      IF PutChar(GetChar())='"'
      THEN
         REPEAT
            p := Add(p, GetChar(), i)
         UNTIL (PutChar(GetChar())='"') OR (PutChar(GetChar())=nul) ;
         p := Add(p, '"', i) ;
         IF (PutChar(GetChar())='"') AND (GetChar()='"')
         THEN
         END
      ELSIF PutChar(GetChar())="'"
      THEN
         REPEAT
            p := Add(p, GetChar(), i)
         UNTIL (PutChar(GetChar())="'") OR (PutChar(GetChar())=nul) ;
         p := Add(p, "'", i) ;
         IF (PutChar(GetChar())="'") AND (GetChar()="'")
         THEN
         END
      ELSIF (PutChar(GetChar())='\') AND (GetChar()='\')
      THEN
         p := Add(p, GetChar(), i)
      ELSIF PutChar(GetChar())#'%'
      THEN
         p := Add(p, GetChar(), i)
      END
   END ;
   p := Add(p, nul, i) ;
   WITH CurrentFactor^ DO
      type := m2 ;
      code := NewCodeDesc() ;
      WITH code^ DO
         code   := p ;
         indent := position
      END
   END ;
   IF PutChar(' ')=' '
   THEN
   END ;
   AdvanceToken ;  (* read the next token ready for the parser *)
   IF NOT WasNoError
   THEN
      WarnError1('error probably occurred before the start of inline code on line %d', line)
   END ;
   RETURN( TRUE )
END Modula2Code ;


(*
   StartModName    := % ModuleName := GetName() ; (* ignore begintok *) CodeFragmentPrologue % =:
*)

PROCEDURE StartModName () : BOOLEAN ;
BEGIN
   ModuleName := GetName() ;
   CodeFragmentPrologue ;
   RETURN( TRUE )
END StartModName ;

(*
   EndModName    :=
*)

PROCEDURE EndModName () : BOOLEAN ;
BEGIN
   IF ModuleName#GetName()
   THEN
      WarnError('expecting same module name at end as beginning')
   END ;
   (* ignore endtok as it consumes the token afterwards *)
   CodeFragmentEpilogue ;
   RETURN( TRUE )
END EndModName ;

(*
   DoDeclaration := % CodeFragmentDeclaration % =:
*)

PROCEDURE DoDeclaration () : BOOLEAN ;
BEGIN
   IF ModuleName#GetName()
   THEN
      WarnError('expecting same module name in declaration as in the beginning')
   END ;
   (* ignore begintok as it consumes the token afterwards *)
   CodeFragmentDeclaration ;
   RETURN( TRUE )
END DoDeclaration ;

(* EndNonErrorChecking  now for the real ebnf rules *)

TYPE
   SetOfStop = SET OF TokenType ;

(* **************************************************************************
    E r r o r    R e c o v e r y    I d e n t    &    M o d u l a 2 C o d e
   **************************************************************************

(* StartErrorChecking *)


(*
   SyntaxError - after a syntax error we skip all tokens up until we reach
                 a stop symbol.
*)

PROCEDURE SyntaxError (stop: SetOfStop) ;
BEGIN
   DescribeError ;
   IF Debugging
   THEN
      WriteLn ;
      WriteString('skipping token *** ')
   END ;
   WHILE NOT (GetCurrentTokenType() IN stop) DO
      AdvanceToken
   END ;
   IF Debugging
   THEN
      WriteString(' ***') ; WriteLn
   END ;
   WasNoError := FALSE
END SyntaxError ;


(*
   SyntaxCheck -
*)

PROCEDURE SyntaxCheck (stop: SetOfStop) ;
BEGIN
   IF NOT (GetCurrentTokenType() IN stop)
   THEN
      SyntaxError(stop)
   END
END SyntaxCheck ;


(*
   Expect -
*)

PROCEDURE Expect (t: TokenType; stop: SetOfStop) ;
BEGIN
   IF GetCurrentTokenType()=t
   THEN
      AdvanceToken
   ELSE
      SyntaxError(stop)
   END ;
   SyntaxCheck(stop)
END Expect ;


(*
   Ident - error checking varient of Ident
*)

PROCEDURE Ident (stop: SetOfStop) ;
BEGIN
   IF GetCurrentTokenType()=identtok
   THEN
      NEW(CurrentIdent) ;
      WITH CurrentIdent^ DO
         definition := NIL ;
         name       := GetName() ;
         line       := GetCurrentLine()
      END ;
   END
END Ident ;


(*
   Modula2Code - error checking varient of Modula2Code
*)

PROCEDURE Modula2Code (stop: SetOfStop) ;
VAR
   p       : CodeHunk ;
   i       : CARDINAL ;
   quote   : BOOLEAN ;
   line,
   position: CARDINAL ;
BEGIN
   line := GetCurrentLine() ;
   PushBackToken(GetCurrentToken()) ;
   position := GetColumnPosition() ;
   p := NIL ;
   SkipWhite ;
   WHILE (PutChar(GetChar())#'%') AND (PutChar(GetChar())#nul) DO
      IF PutChar(GetChar())='"'
      THEN
         REPEAT
            p := Add(p, GetChar(), i)
         UNTIL (PutChar(GetChar())='"') OR (PutChar(GetChar())=nul) ;
         p := Add(p, '"', i) ;
         IF (PutChar(GetChar())='"') AND (GetChar()='"')
         THEN
         END
      ELSIF PutChar(GetChar())="'"
      THEN
         REPEAT
            p := Add(p, GetChar(), i)
         UNTIL (PutChar(GetChar())="'") OR (PutChar(GetChar())=nul) ;
         p := Add(p, "'", i) ;
         IF (PutChar(GetChar())="'") AND (GetChar()="'")
         THEN
         END
      ELSIF (PutChar(GetChar())='\') AND (GetChar()='\')
      THEN
         p := Add(p, GetChar(), i)
      ELSIF PutChar(GetChar())#'%'
      THEN
         p := Add(p, GetChar(), i)
      END
   END ;
   p := Add(p, nul, i) ;
   WITH CurrentFactor^ DO
      type := m2 ;
      code := NewCodeDesc() ;
      WITH code^ DO
         code   := p ;
         indent := position
      END
   END ;
   IF PutChar(' ')=' '
   THEN
   END ;
   AdvanceToken ;  (* read the next token ready for the parser *)
   IF NOT WasNoError
   THEN
      WarnError1('error probably occurred before the start of inline code on line %d', line)
   END
END Modula2Code ;


(*
   StartModName    := % ModuleName := GetName() ; (* ignore begintok *) CodeFragmentPrologue % =:
*)

PROCEDURE StartModName (stop: SetOfStop) ;
BEGIN
   ModuleName := GetName() ;
   CodeFragmentPrologue
END StartModName ;


(*
   EndModName    :=
*)

PROCEDURE EndModName (stop: SetOfStop) ;
BEGIN
   IF ModuleName#GetName()
   THEN
      WarnError('expecting same module name at end as beginning')
   END ;
   (* ignore endtok as it consumes the token afterwards *)
   CodeFragmentEpilogue
END EndModName ;


(*
   DoDeclaration := % CodeFragmentDeclaration % =:
*)

PROCEDURE DoDeclaration (stop: SetOfStop) ;
BEGIN
   IF ModuleName#GetName()
   THEN
      WarnError('expecting same module name in declaration as in the beginning')
   END ;
   (* ignore begintok as it consumes the token afterwards *)
   CodeFragmentDeclaration
END DoDeclaration ;


(* EndErrorChecking  now for the real ebnf rules *)

*****************************************************************
  l e a v e   a b o v e   c o d e   a l o n e   (f o r    S E D)
***************************************************************** *)

(* this code below will be recreated by ppg *)

PROCEDURE DescribeError ;
BEGIN
   WarnError('syntax error')
END DescribeError ;

PROCEDURE Main () : BOOLEAN ;
BEGIN
   IF Header()
   THEN
      IF Decls()
      THEN
         IF Footer()
         THEN
            IF Rules()
            THEN
               RETURN( TRUE )
            END
         END
      END
   END ;
   RETURN( FALSE )
END Main ;

PROCEDURE Header () : BOOLEAN ;
BEGIN
   IF SymIs(codetok)
   THEN
      IF SymIs(moduletok)
      THEN
         ModuleName := GetName() ;
         (* ignore the begintok as we are looking one symbol ahead and we dont want to move over MODULE *)
         CodeFragmentPrologue ;
         RETURN( TRUE )
      ELSE
         WarnError('expecting module')
      END
   END ;
   RETURN( FALSE )
END Header ;

PROCEDURE Footer () : BOOLEAN ;
BEGIN
   IF SymIs(codetok)
   THEN
      IF SymIs(moduletok)
      THEN
         IF ModuleName#GetName()
         THEN
            WarnError('expecting same module name at end as beginning')
         END ;
         (* ignore endtok as it consumes the token afterwards *)
         CodeFragmentEpilogue ;
         RETURN( TRUE )
      ELSE
         WarnError('expecting module')
      END
   END ;
   RETURN( FALSE )
END Footer ;

PROCEDURE Decls () : BOOLEAN ;
BEGIN
   IF SymIs(codetok)
   THEN
      IF SymIs(declarationtok)
      THEN
         RETURN( DoDeclaration() )
      ELSE
         WarnError('expecting declaration')
      END
   END ;
   RETURN( FALSE )
END Decls ;


(*
    Rules      := " % " " rules " { Defs } ExtBNF =:
*)

PROCEDURE Rules () : BOOLEAN ;
BEGIN
   IF SymIs(codetok)
   THEN
      IF SymIs(rulestok)
      THEN
         WHILE Defs() DO
         END ;
         IF ExtBNF()
         THEN
            RETURN( TRUE )
         ELSE
            WarnError('expecting some BNF rules to be present')
         END
      END
   END ;
   RETURN( FALSE )
END Rules ;


(*
   Defs       := " special " Special | " token " Token | " error " ErrorProcedures |
                 "tokenfunc" TokenProcedure =:
*)

PROCEDURE Defs () : BOOLEAN ;
BEGIN
   IF SymIs(specialtok)
   THEN
      IF Special()
      THEN
         RETURN( TRUE )
      END
   ELSIF SymIs(tokentok)
   THEN
      IF Token()
      THEN
         RETURN( TRUE )
      END
   ELSIF SymIs(errortok)
   THEN
      IF ErrorProcedures()
      THEN
         RETURN( TRUE )
      END
   ELSIF SymIs(tfunctok)
   THEN
      IF TokenProcedure()
      THEN
         RETURN( TRUE )
      END
   ELSIF SymIs(symfunctok)
   THEN
      IF SymProcedure()
      THEN
         RETURN( TRUE )
      END
   END ;
   RETURN( FALSE )
END Defs ;


(*
   Special := Name First Follow [ "epsilon" ] =:
*)

PROCEDURE Special () : BOOLEAN ;
VAR
   p: ProductionDesc ;
BEGIN
   IF Ident()
   THEN
      p                           := NewProduction() ;
      p^.statement                := NewStatement() ;
      p^.statement^.followinfo^.calcfollow := TRUE ;
      p^.statement^.followinfo^.epsilon    := false ;
      p^.statement^.followinfo^.reachend   := false ;
      p^.statement^.ident         := CurrentIdent ;
      p^.statement^.expr          := NIL ;
      p^.firstsolved              := TRUE ;
      p^.followinfo^.calcfollow   := TRUE ;
      p^.followinfo^.epsilon      := false ;
      p^.followinfo^.reachend     := false ;
      IF First()
      THEN
         IF Follow()
         THEN
            IF SymIs(epsilontok)
            THEN
               p^.statement^.followinfo^.epsilon  := true ;  (* these are not used - but they are displayed when debugging *)
               p^.statement^.followinfo^.reachend := true ;
               p^.followinfo^.epsilon  := true ;
               p^.followinfo^.reachend := true
            END ;
            IF Literal()
            THEN
               p^.description := LastLiteral
            END ;
            RETURN( TRUE )
         ELSE
            WarnError('Follow - expected') ;
            RETURN( FALSE )
         END ;
      ELSE
         WarnError('First - expected') ;
         RETURN( FALSE )
      END
   ELSE
      RETURN( FALSE )
   END
END Special ;


(*
   First := 'first' '{' { LitOrTokenOrIdent % WITH LastSetDesc^ DO
                                  next := HeadProduction^.first ;
                               END ;
                               TailProduction^.first := LastSetDesc ;
                              %
                           } '}'
*)

PROCEDURE First () : BOOLEAN ;
BEGIN
   IF SymIs(firsttok)
   THEN
      IF SymIs(lcparatok)
      THEN
         WHILE LitOrTokenOrIdent() DO
            WITH CurrentSetDesc^ DO
               next := TailProduction^.first ;
            END ;
            TailProduction^.first := CurrentSetDesc
         END ;  (* while *)
         IF SymIs(rcparatok)
         THEN
            RETURN( TRUE )
         ELSE
            WarnError("'}' - expected") ;
            RETURN( FALSE )
         END ;
      ELSE
         WarnError("'{' - expected") ;
         RETURN( FALSE )
      END ;
   ELSE
      RETURN( FALSE )
   END ;
END First ;


(*
   Follow := 'follow' '{' { LitOrTokenOrIdent  } '}'
*)

PROCEDURE Follow () : BOOLEAN ;
BEGIN
   IF SymIs(followtok)
   THEN
      IF SymIs(lcparatok)
      THEN
         WHILE LitOrTokenOrIdent() DO
            WITH CurrentSetDesc^ DO
               next := TailProduction^.followinfo^.follow ;
            END ;
            TailProduction^.followinfo^.follow := CurrentSetDesc
         END ;  (* while *)
         IF SymIs(rcparatok)
         THEN
            RETURN( TRUE )
         ELSE
            WarnError("'}' - expected") ;
            RETURN( FALSE )
         END ;
      ELSE
         WarnError("'{' - expected") ;
         RETURN( FALSE )
      END ;
   ELSE
      RETURN( FALSE )
   END ;
END Follow ;


(*
   LitOrTokenOrIdent := Literal % CurrentSetDesc := NewSetDesc() ;
                               WITH CurrentSetDesc^ DO
                                  type   := litel ;
                                  string := LastLiteral ;
                               END ;
                              %
                         | '<' % CurrentSetDesc := NewSetDesc() ;
                           WITH CurrentSetDesc^ DO
                              type   := tokel ;
                              string := GetCurrentToken() ;
                           END ;
                           AdvanceToken() ;
                          %
                        '>'  | Ident % CurrentSetDesc := NewSetDesc() ;
                               WITH CurrentSetDesc^ DO
                                  type   := idel ;
                                  ident  := CurrentIdent ;
                               END ;
                              %

*)

PROCEDURE LitOrTokenOrIdent () : BOOLEAN ;
BEGIN
   IF Literal()
   THEN
      CurrentSetDesc := NewSetDesc() ;
      WITH CurrentSetDesc^ DO
         type   := litel ;
         string := LastLiteral
      END ;
      RETURN( TRUE )
   ELSIF SymIs(lesstok)
   THEN
      CurrentSetDesc := NewSetDesc() ;
      WITH CurrentSetDesc^ DO
         type   := tokel ;
         string := GetCurrentToken() ;
      END ;
      IF GetSymKey(Aliases, GetCurrentToken())=NulKey
      THEN
(*
         PutSymKey(Values, GetCurrentToken(), LargestValue) ;
         PutSymKey(Aliases, GetCurrentToken(), GetCurrentToken()) ;
         PutSymKey(ReverseAliases, GetCurrentToken(), GetCurrentToken()) ;
         INC(LargestValue) ;
*)
      END ;
      AdvanceToken() ;
      IF SymIs(gretok)
      THEN
         RETURN( TRUE )
      ELSE
         WarnError("'>' - expected") ;
         RETURN( FALSE )
      END ;
   ELSIF Ident()
   THEN
      CurrentSetDesc := NewSetDesc() ;
      WITH CurrentSetDesc^ DO
         type   := idel ;
         ident  := CurrentIdent ;
      END ;
      RETURN( TRUE )
   ELSE
      RETURN( FALSE )
   END ;  (* elsif *)
END LitOrTokenOrIdent ;


(*
   Literal -
*)

PROCEDURE Literal () : BOOLEAN ;
BEGIN
   IF SymIs(squotetok)
   THEN
      LastLiteral := GetCurrentToken() ;
      AdvanceToken ;
      IF SymIs(squotetok)
      THEN
         RETURN( TRUE )
      END
   ELSIF SymIs(dquotetok)
   THEN
      LastLiteral := GetCurrentToken() ;
      AdvanceToken ;
      IF SymIs(dquotetok)
      THEN
         RETURN( TRUE )
      END
   END ;
   RETURN( FALSE )
END Literal ;


(*
   Token      := Literal % VAR l: CARDINAL ;
                        l := GetCurrentToken() ; %
              Name % PutSymKey(Aliases, l, GetCurrentToken()) ; % =:
*)

PROCEDURE Token () : BOOLEAN ;
BEGIN
   IF Literal()
   THEN
      AddEntry(Aliases, LastLiteral, GetCurrentToken()) ;
      AddEntry(ReverseAliases, GetCurrentToken(), LastLiteral) ;
      AddEntry(Values, GetCurrentToken(), LargestValue) ;
      AddEntry(ReverseValues, Name(LargestValue), GetCurrentToken()) ;
      INC(LargestValue) ;
      AdvanceToken ;
      RETURN( TRUE )
   ELSE
      RETURN( FALSE )
   END
END Token ;


(*
   ErrorProcedures  := Literal % ErrorProcArray := LastLiteral %
                       Literal % ErrorProcString := LastLiteral % =:
*)

PROCEDURE ErrorProcedures () : BOOLEAN ;
BEGIN
   IF Literal()
   THEN
      ErrorProcArray := LastLiteral ;
      IF Literal()
      THEN
         ErrorProcString := LastLiteral ;
         RETURN( TRUE )
      END
   END ;
   RETURN( FALSE )
END ErrorProcedures ;


(*
   TokenProcedure := Literal % TokenTypeProc := LastLiteral % =:
*)

PROCEDURE TokenProcedure () : BOOLEAN ;
BEGIN
   IF Literal()
   THEN
      TokenTypeProc := LastLiteral ;
      RETURN( TRUE )
   ELSE
      RETURN( FALSE )
   END
END TokenProcedure ;


(*
   SymProcedure := Literal % SymIsProc := LastLiteral % =:
*)

PROCEDURE SymProcedure () : BOOLEAN ;
BEGIN
   IF Literal()
   THEN
      SymIsProc := LastLiteral ;
      RETURN( TRUE )
   ELSE
      RETURN( FALSE )
   END
END SymProcedure ;


(*
   ExtBNF     := " BNF " { Production } " FNB " =:
*)

PROCEDURE ExtBNF () : BOOLEAN ;
BEGIN
   IF SymIs(BNFtok)
   THEN
      WHILE Production() DO
      END ;
      IF SymIs(FNBtok)
      THEN
         RETURN( TRUE )
      END
   END ;
   RETURN( FALSE )
END ExtBNF ;


(*
    Production := Statement =:
*)

PROCEDURE Production () : BOOLEAN ;
BEGIN
   IF Statement()
   THEN
      RETURN( TRUE )
   END ;
   RETURN( FALSE )
END Production ;


(*
   Statement  := % VAR i: IdentDesc ; %
                 Ident
                 % i := CurrentIdent ; %
                 " := "
                 % VAR e: ExpressionDesc ;
                   e := NewExpression() ; %
                 Expression
                 % WITH CurrentStatement^ DO
                      ident := i ;
                      expr  := e ;
                      first := NIL ;
                   END ;
                 %
                 " =: " =:
*)

PROCEDURE Statement () : BOOLEAN ;
VAR
   i: IdentDesc ;
   s: StatementDesc ;
   e: ExpressionDesc ;
   p: ProductionDesc ;
BEGIN
   IF Ident()
   THEN
      p := FindDefinition(CurrentIdent^.name) ;
      IF p=NIL
      THEN
         p := NewProduction()
      ELSE
         IF NOT ((p^.statement=NIL) OR (p^.statement^.expr=NIL))
         THEN
            WarnError1('already declared rule %s', CurrentIdent^.name)
         END
      END ;
      i := CurrentIdent ;
      IF SymIs(lbecomestok)
      THEN
         e := NewExpression() ;
         CurrentExpression := e ;
         s := NewStatement() ;
         WITH s^ DO
            ident := i ;
            expr  := e ;
         END ;
         IF Expression()
         THEN
            p^.statement := s ;
            IF SymIs(rbecomestok)
            THEN
               RETURN( TRUE )
            END
         END
      END
   END ;
   RETURN( FALSE )
END Statement ;


(*
    Expression := % CurrentTerm := NIL %
                  Term { " | " % CurrentTerm := NewTerm() % Term } =:
*)

PROCEDURE Expression () : BOOLEAN ;
VAR
   t1, t2: TermDesc ;
   e     : ExpressionDesc ;
BEGIN
   e := CurrentExpression ;
   t1 := NewTerm() ;
   CurrentTerm := t1 ;
   IF Term()
   THEN
      e^.term := t1 ;
      WHILE SymIs(bartok) DO
         t2 := NewTerm() ;
         CurrentTerm := t2 ;
         IF Term()
         THEN
            t1^.next := t2 ;
            t1 := t2
         ELSE
            WarnError('term expected')
         END
      END ;
      RETURN( TRUE )
   ELSE
      (* DISPOSE(t1) ; *)
      RETURN( FALSE )
   END
END Expression ;


(*
   Term       := Factor { Factor } =:
*)

PROCEDURE Term () : BOOLEAN ;
VAR
   t1: TermDesc ;
   f1, f2: FactorDesc ;
BEGIN
   CurrentFactor := NewFactor() ;
   f1 := CurrentFactor ;
   t1 := CurrentTerm ;
   IF Factor()
   THEN
      t1^.factor := f1 ;
      f2 := NewFactor() ;
      CurrentFactor := f2 ;
      WHILE Factor() DO
         f1^.next := f2 ;
         f1 := f2 ;
         f2 := NewFactor() ;
         CurrentFactor := f2 ;
      END ;
      (* DISPOSE(f2) ; *)
      RETURN( TRUE )
   ELSE
      (* DISPOSE(f1) ; *)
      RETURN( FALSE )
   END
END Term ;


(*
   Factor     := " % " Modula2Code " % " % AssignCode ; % |
                  ( Ident | Literal | " { " Expression " } " |
                    " [ " Expression " ] " | " ( " Expression " ) " )  =:
*)

PROCEDURE Factor () : BOOLEAN ;
BEGIN
   IF SymIs(codetok)
   THEN
      IF Modula2Code()
      THEN
         IF SymIs(codetok)
         THEN
            RETURN( TRUE )
         END
      END
   ELSE
      IF Ident()
      THEN
         WITH CurrentFactor^ DO
            type  := id ;
            ident := CurrentIdent
         END ;
         RETURN( TRUE )
      ELSIF Literal()
      THEN
         WITH CurrentFactor^ DO
            type   := lit ;
            string := LastLiteral ;
            IF GetSymKey(Aliases, LastLiteral)=NulKey
            THEN
               WarnError1('no token defined for literal %s', LastLiteral)
            END
         END ;
         RETURN( TRUE )
      ELSIF SymIs(lcparatok)
      THEN
         WITH CurrentFactor^ DO
            type := mult ;
            expr := NewExpression() ;
            CurrentExpression := expr ;
            IF Expression()
            THEN
               IF SymIs(rcparatok)
               THEN
                  RETURN( TRUE )
               ELSE
                  WarnError('} expected')
               END
            END
         END
      ELSIF SymIs(lsparatok)
      THEN
         WITH CurrentFactor^ DO
            type := opt ;
            expr := NewExpression() ;
            CurrentExpression := expr ;
            IF Expression()
            THEN
               IF SymIs(rsparatok)
               THEN
                  RETURN( TRUE )
               ELSE
                  WarnError('] expected')
               END
            END
         END
      ELSIF SymIs(lparatok)
      THEN
         WITH CurrentFactor^ DO
            type := sub ;
            expr := NewExpression() ;
            CurrentExpression := expr ;
            IF Expression()
            THEN
               IF SymIs(rparatok)
               THEN
                  RETURN( TRUE )
               ELSE
                  WarnError(') expected')
               END
            END
         END
      END
   END ;
   RETURN( FALSE )
END Factor ;

(* % module pg end *)


(*
   GetDefinitionName - returns the name of the rule inside, p.
*)

PROCEDURE GetDefinitionName (p: ProductionDesc) : Name ;
BEGIN
   IF p#NIL
   THEN
      WITH p^ DO
         IF (statement#NIL) AND (statement^.ident#NIL)
         THEN
            RETURN( statement^.ident^.name )
         END
      END
   END ;
   RETURN( NulName )
END GetDefinitionName ;


(*
   FindDefinition - searches and returns the rule which defines, n.
*)

PROCEDURE FindDefinition (n: Name) : ProductionDesc ;
VAR
   p, f: ProductionDesc ;
BEGIN
   p := HeadProduction ;
   f := NIL ;
   WHILE p#NIL DO
      IF GetDefinitionName(p)=n
      THEN
         IF f=NIL
         THEN
            f := p
         ELSE
            WriteString('multiple definition for rule: ') ; WriteKey(n) ; WriteLn
         END
      END ;
      p := p^.next
   END ;
   RETURN( f )
END FindDefinition ;


(*
   BackPatchIdent - found an ident, i, we must look for the corresponding rule and
                    set the definition accordingly.
*)

PROCEDURE BackPatchIdent (i: IdentDesc) ;
BEGIN
   IF i#NIL
   THEN
      WITH i^ DO
         definition := FindDefinition(name) ;
         IF definition=NIL
         THEN
            WarnError1('unable to find production %s', name) ;
            WasNoError := FALSE
         END
      END
   END
END BackPatchIdent ;


(*
   BackPatchFactor - runs through the factor looking for an ident
*)

PROCEDURE BackPatchFactor (f: FactorDesc) ;
BEGIN
   WHILE f#NIL DO
      WITH f^ DO
         CASE type OF

         id  :  BackPatchIdent(ident) |
         sub ,
         opt ,
         mult:  BackPatchExpression(expr)

         ELSE
         END
      END ;
      f := f^.next
   END
END BackPatchFactor ;


(*
   BackPatchTerm - runs through all terms to find idents.
*)

PROCEDURE BackPatchTerm (t: TermDesc) ;
BEGIN
   WHILE t#NIL DO
      BackPatchFactor(t^.factor) ;
      t := t^.next
   END
END BackPatchTerm ;


(*
   BackPatchExpression - runs through the term to find any idents.
*)

PROCEDURE BackPatchExpression (e: ExpressionDesc) ;
BEGIN
   IF e#NIL
   THEN
      BackPatchTerm(e^.term)
   END
END BackPatchExpression ;


(*
   BackPatchSet -
*)

PROCEDURE BackPatchSet (s: SetDesc) ;
BEGIN
   WHILE s#NIL DO
      WITH s^ DO
         CASE type OF

         idel:  BackPatchIdent(ident)

         ELSE
         END
      END ;
      s := s^.next
   END
END BackPatchSet ;


(*
   BackPatchIdentToDefinitions - search through all the rules and add a link from any ident
                                 to the definition.
*)

PROCEDURE BackPatchIdentToDefinitions (d: ProductionDesc) ;
BEGIN
   IF (d#NIL) AND (d^.statement#NIL)
   THEN
      BackPatchExpression(d^.statement^.expr)
   END
END BackPatchIdentToDefinitions ;


(*
   CalculateFirstAndFollow -
*)

PROCEDURE CalculateFirstAndFollow (p: ProductionDesc) ;
BEGIN
   IF Debugging
   THEN
      WriteLn ;
      WriteKey(p^.statement^.ident^.name) ; WriteLn ;
      WriteString('  calculating first')
   END ;
   CalcFirstProduction(p, p, p^.first) ;
   BackPatchSet(p^.first) ;
   IF Debugging
   THEN
      WriteString('  calculating follow set')
   END ;
   IF p^.followinfo^.follow=NIL
   THEN
      CalcFollowProduction(p)
   END ;
   BackPatchSet(p^.followinfo^.follow)
END CalculateFirstAndFollow ;


(*
   ForeachRuleDo -
*)

PROCEDURE ForeachRuleDo (p: DoProcedure) ;
BEGIN
   CurrentProduction := HeadProduction ;
   WHILE CurrentProduction#NIL DO
      p(CurrentProduction) ;
      CurrentProduction := CurrentProduction^.next
   END
END ForeachRuleDo ;


(*
   WhileNotCompleteDo -
*)

PROCEDURE WhileNotCompleteDo (p: DoProcedure) ;
BEGIN
   REPEAT
      Finished := TRUE ;
      ForeachRuleDo(p) ;
   UNTIL Finished
END WhileNotCompleteDo ;


(*
   NewLine - generate a newline and indent.
*)

PROCEDURE NewLine (Left: CARDINAL) ;
BEGIN
   Output.WriteLn ;
   BeginningOfLine := TRUE ;
   Indent := 0 ;
   WHILE Indent<Left DO
      Output.Write(' ') ;
      INC(Indent)
   END
END NewLine ;


(*
   CheckNewLine -
*)

PROCEDURE CheckNewLine (Left: CARDINAL) ;
BEGIN
   IF Indent=Left
   THEN
      Left := BaseNewLine
   END ;
   IF Indent>BaseRightMargin
   THEN
      NewLine(Left)
   END
END CheckNewLine ;


(*
   IndentString - writes out a string with a preceeding indent.
*)

PROCEDURE IndentString (a: ARRAY OF CHAR) ;
VAR
   i: CARDINAL ;
BEGIN
   i := 0 ;
   WHILE i<Indent DO
      Output.Write(' ') ;
      INC(i)
   END ;
   Output.WriteString(a) ;
   LastLineNo := 0
END IndentString ;


(*
   KeyWord - writes out a keywork with optional formatting directives.
*)

PROCEDURE KeyWord (n: Name) ;
BEGIN
   IF KeywordFormatting
   THEN
      Output.WriteString('{%K') ;
      IF (n = MakeKey('}')) OR (n = MakeKey('{')) OR (n = MakeKey('%'))
      THEN
         Output.Write('%')   (* escape }, { or % *)
      END ;
      Output.WriteKey(n) ;
      Output.Write('}')
   ELSE
      Output.WriteKey(n)
   END
END KeyWord ;


(*
   PrettyPara -
*)

PROCEDURE PrettyPara (c1, c2: ARRAY OF CHAR; e: ExpressionDesc; Left: CARDINAL) ;
BEGIN
   Output.WriteString(c1) ;
   INC(Indent, StrLen(c1)) ;
   Left := Indent ;
   PrettyCommentExpression(e, Left) ;
   Output.WriteString(c2) ;
   INC(Indent, StrLen(c2))
END PrettyPara ;


(*
   WriteKeyTexinfo -
*)

PROCEDURE WriteKeyTexinfo (s: Name) ;
VAR
   ds  : String ;
   ch  : CHAR ;
   i, l: CARDINAL ;
BEGIN
   IF Texinfo
   THEN
      ds := InitStringCharStar(KeyToCharStar(s)) ;
      l := Length(ds) ;
      i := 0 ;
      WHILE i<l DO
         ch := char(ds, i) ;
         IF (ch='{') OR (ch='}')
         THEN
            Output.Write('@')
         END ;
         Output.Write(ch) ;
         INC(i)
      END
   ELSE
      Output.WriteKey(s)
   END
END WriteKeyTexinfo ;


(*
   PrettyCommentFactor -
*)

PROCEDURE PrettyCommentFactor (f: FactorDesc; Left: CARDINAL) ;
VAR
   curpos  : CARDINAL ;
   seentext: BOOLEAN ;
BEGIN
   WHILE f#NIL DO
      CheckNewLine(Left) ;
      WITH f^ DO
         CASE type OF

         id  :  Output.WriteKey(ident^.name) ; Output.WriteString(' ') ;
                INC(Indent, LengthKey(ident^.name)+1) |
         lit :  IF MakeKey("'")=string
                THEN
                   Output.Write('"') ; WriteKeyTexinfo(string) ; Output.WriteString('" ')
                ELSE
                   Output.Write("'") ; WriteKeyTexinfo(string) ; Output.WriteString("' ")
                END ;
                INC(Indent, LengthKey(string)+3) |
         sub:   PrettyPara('( ', ' ) ', expr, Left) |
         opt:   PrettyPara('[ ', ' ] ', expr, Left) |
         mult:  IF Texinfo
                THEN
                   PrettyPara('@{ ', ' @} ', expr, Left)
                ELSE
                   PrettyPara('{ ', ' } ', expr, Left)
                END |
         m2 :   IF EmitCode
                THEN
                   NewLine(Left) ; Output.WriteString('% ') ;
                   seentext := FALSE ;
                   curpos := 0 ;
                   WriteCodeHunkListIndent(code^.code, code^.indent, curpos, Left+2, seentext) ;
                   Output.WriteString(' %') ;
                   NewLine(Left)
                END

         ELSE
         END ;
         PrettyFollow('<f:', ':f>', followinfo)
      END ;
      f := f^.next
   END
END PrettyCommentFactor ;


(*
   PeepTerm - returns the length of characters in term.
*)

PROCEDURE PeepTerm (t: TermDesc) : CARDINAL ;
VAR
   l: CARDINAL ;
BEGIN
   l := 0 ;
   WHILE t#NIL DO
      INC(l, PeepFactor(t^.factor)) ;
      IF t^.next#NIL
      THEN
         INC(l, 3)
      END ;
      t := t^.next
   END ;
   RETURN( l )
END PeepTerm ;


(*
   PeepExpression - returns the length of the expression.
*)

PROCEDURE PeepExpression (e: ExpressionDesc) : CARDINAL ;
BEGIN
   IF e=NIL
   THEN
      RETURN( 0 )
   ELSE
      RETURN( PeepTerm(e^.term) )
   END
END PeepExpression ;


(*
   PeepFactor - returns the length of character in the factor
*)

PROCEDURE PeepFactor (f: FactorDesc) : CARDINAL ;
VAR
   l: CARDINAL ;
BEGIN
   l := 0 ;
   WHILE f#NIL DO
      WITH f^ DO
         CASE type OF

         id  :  INC(l, LengthKey(ident^.name)+1) |
         lit :  INC(l, LengthKey(string)+3) |
         opt ,
         mult,
         sub :  INC(l, PeepExpression(expr)) |
         m2  :  (* empty *)

         ELSE
         END
      END ;
      f := f^.next
   END ;
   RETURN( l )
END PeepFactor ;


(*
   PrettyCommentTerm -
*)

PROCEDURE PrettyCommentTerm (t: TermDesc; Left: CARDINAL) ;
BEGIN
   WHILE t#NIL DO
      CheckNewLine(Left) ;
      PrettyCommentFactor(t^.factor, Left) ;
      IF t^.next#NIL
      THEN
         Output.WriteString(' | ') ;
         INC(Indent, 3) ;
         IF PeepFactor(t^.factor)+Indent>BaseRightMargin
         THEN
            NewLine(Left)
         END
      END ;
      PrettyFollow('<t:', ':t>', t^.followinfo) ;
      t := t^.next
   END
END PrettyCommentTerm ;


(*
   PrettyCommentExpression -
*)

PROCEDURE PrettyCommentExpression (e: ExpressionDesc; Left: CARDINAL) ;
BEGIN
   IF e#NIL
   THEN
      PrettyCommentTerm(e^.term, Left) ;
      PrettyFollow('<e:', ':e>', e^.followinfo)
   END
END PrettyCommentExpression ;


(*
   PrettyCommentStatement -
*)

PROCEDURE PrettyCommentStatement (s: StatementDesc; Left: CARDINAL) ;
BEGIN
   IF s#NIL
   THEN
      PrettyCommentExpression(s^.expr, Left) ;
      PrettyFollow('<s:', ':s>', s^.followinfo)
   END
END PrettyCommentStatement ;


(*
   PrettyCommentProduction - generates the comment for rule, p.
*)

PROCEDURE PrettyCommentProduction (p: ProductionDesc) ;
VAR
   to: SetDesc ;
BEGIN
   IF p#NIL
   THEN
      BeginningOfLine := TRUE ;
      Indent          := 0 ;
      Output.WriteString('(*') ; NewLine(3) ;
      Output.WriteKey(GetDefinitionName(p)) ;
      Output.WriteString(' := ') ;
      INC(Indent, LengthKey(GetDefinitionName(p))+4) ;
      PrettyCommentStatement(p^.statement, Indent) ;
      NewLine(0) ;
      IF ErrorRecovery
      THEN
         NewLine(3) ;
         Output.WriteString('first  symbols:') ;
         EmitSet(p^.first, 0, 0) ;
         NewLine(3) ;
         PrettyFollow('<p:', ':p>', p^.followinfo) ;
         NewLine(3) ;
         CASE GetReachEnd(p^.followinfo) OF

         true   :  Output.WriteString('reachend') |
         false  :  Output.WriteString('cannot reachend') |
         unknown:  Output.WriteString('unknown...')

         ELSE
         END ;
         NewLine(0)
      END ;
      Output.WriteString('*)') ; NewLine(0) ;
   END
END PrettyCommentProduction ;


(*
   PrettyPrintProduction - pretty prints the ebnf rule, p.
*)

PROCEDURE PrettyPrintProduction (p: ProductionDesc) ;
VAR
   to: SetDesc ;
BEGIN
   IF p#NIL
   THEN
      BeginningOfLine := TRUE ;
      Indent          := 0 ;
      IF Texinfo
      THEN
         Output.WriteString('@example') ; NewLine(0)
      ELSIF Sphinx
      THEN
         Output.WriteString('.. code-block:: ebnf') ; NewLine(0)
      END ;
      Output.WriteKey(GetDefinitionName(p)) ;
      Output.WriteString(' := ') ;
      INC(Indent, LengthKey(GetDefinitionName(p))+4) ;
      PrettyCommentStatement(p^.statement, Indent) ;
      IF p^.description#NulName
      THEN
         Output.WriteKey(p^.description)
      END ;
      NewLine(0) ;
      WriteIndent(LengthKey(GetDefinitionName(p))+1) ;
      Output.WriteString(' =: ') ;
      NewLine(0) ;
      IF Texinfo
      THEN
         Output.WriteString('@findex ') ; Output.WriteKey(GetDefinitionName(p)) ; Output.WriteString(' (ebnf)') ; NewLine(0) ;
         Output.WriteString('@end example') ; NewLine(0)
      ELSIF Sphinx
      THEN
         Output.WriteString('.. index::') ; NewLine(0) ;
         Output.WriteString('  pair: ') ; Output.WriteKey(GetDefinitionName(p)) ; Output.WriteString('; (ebnf)') ; NewLine(0)
      END ;
      NewLine(0)
   END
END PrettyPrintProduction ;


(*
   EmitFileLineTag - emits a line and file tag using the C preprocessor syntax.
*)

PROCEDURE EmitFileLineTag (line: CARDINAL) ;
BEGIN
   IF (NOT SuppressFileLineTag) AND (line#LastLineNo)
   THEN
      LastLineNo := line ;
      IF NOT OnLineStart
      THEN
         Output.WriteLn
      END ;
      Output.WriteString('# ') ; Output.WriteCard(line, 0) ; Output.WriteString(' "') ; Output.WriteString(FileName) ; Output.Write('"') ;
      Output.WriteLn ;
      OnLineStart := TRUE
   END
END EmitFileLineTag ;


(*
   EmitRule - generates a comment and code for rule, p.
*)

PROCEDURE EmitRule (p: ProductionDesc) ;
BEGIN
   IF PrettyPrint
   THEN
      PrettyPrintProduction(p)
   ELSE
      PrettyCommentProduction(p) ;
      IF ErrorRecovery
      THEN
         RecoverProduction(p)
      ELSE
         CodeProduction(p)
      END
   END
END EmitRule ;


(*
   CodeCondition -
*)

PROCEDURE CodeCondition (m: m2condition) ;
BEGIN
   CASE m OF

   m2if,
   m2none :  IndentString('IF ')    |
   m2elsif:  IndentString('ELSIF ') |
   m2while:  IndentString('WHILE ')

   ELSE
      Halt('unrecognised m2condition',
           __FILE__, __FUNCTION__, __LINE__)
   END
END CodeCondition ;


(*
   CodeThenDo - codes a "THEN" or "DO" depending upon, m.
*)

PROCEDURE CodeThenDo (m: m2condition) ;
BEGIN
   CASE m OF

   m2if,
   m2none,
   m2elsif:  IF LastLineNo=0
             THEN
                Output.WriteLn
             END ;
             IndentString('THEN') ;
             Output.WriteLn |
   m2while:  Output.WriteString(' DO') ;
             Output.WriteLn

   ELSE
      Halt('unrecognised m2condition',
           __FILE__, __FUNCTION__, __LINE__)
   END ;
   OnLineStart := TRUE
END CodeThenDo ;


(*
   CodeElseEnd - builds an ELSE END statement using string, end.
*)

PROCEDURE CodeElseEnd (end: ARRAY OF CHAR; consumed: BOOLEAN; f: FactorDesc; inopt: BOOLEAN) ;
BEGIN
   Output.WriteLn ;
   OnLineStart := TRUE ;
   EmitFileLineTag(f^.line) ;
   IF NOT inopt
   THEN
      IndentString('ELSE') ; WriteLn ;
      INC(Indent, 3) ;
      IF consumed
      THEN
         IndentString('') ;
         Output.WriteKey(ErrorProcArray) ;
         Output.Write('(') ;
         WITH f^ DO
            CASE type OF

            id  :  Output.Write("'") ; Output.WriteKey(ident^.name) ; Output.WriteString(' - expected') ; Output.WriteString("') ;") |
            lit :  IF MakeKey("'")=string
                   THEN
                      Output.Write('"') ;
                      KeyWord(string) ;
                      Output.WriteString(' - expected') ; Output.WriteString('") ;')
                   ELSIF MakeKey('"')=string
                   THEN
                      Output.Write("'") ; KeyWord(string) ;
                      Output.WriteString(' - expected') ; Output.WriteString("') ;")
                   ELSE
                      Output.Write('"') ; Output.Write("'") ; KeyWord(string) ; Output.WriteString("' - expected") ;
                      Output.WriteString('") ;')
                   END

            ELSE
            END
         END ;
         Output.WriteLn
      END ;
      IndentString('RETURN( FALSE )') ;
      DEC(Indent, 3) ;
      Output.WriteLn
   END ;
   IndentString(end) ;
   Output.WriteLn ;
   OnLineStart := TRUE
END CodeElseEnd ;


(*
   CodeEnd - codes a "END" depending upon, m.
*)

PROCEDURE CodeEnd (m: m2condition; t: TermDesc; consumed: BOOLEAN; f: FactorDesc; inopt: BOOLEAN) ;
BEGIN
   DEC(Indent, 3) ;
   Output.WriteLn ;
   OnLineStart := TRUE ;
   CASE m OF

   m2none :  IF t=NIL
             THEN
                CodeElseEnd('END ;', consumed, f, inopt)
             END |
   m2if   :  IF t=NIL
             THEN
                CodeElseEnd('END ;  (* if *)', consumed, f, inopt)
             END |
   m2elsif:  IF t=NIL
             THEN
                CodeElseEnd('END ;  (* elsif *)', consumed, f, inopt)
             END |
   m2while:  IndentString('END ;  (* while *)')

   ELSE
      Halt('unrecognised m2condition',
           __FILE__, __FUNCTION__, __LINE__)
   END ;
   OnLineStart := FALSE
END CodeEnd ;


(*
   EmitNonVarCode - writes out, code, providing it is not a variable declaration.
*)

PROCEDURE EmitNonVarCode (code: CodeDesc; curpos, left: CARDINAL) ;
VAR
   i       : CARDINAL ;
   t       : CodeHunk ;
   seentext: BOOLEAN ;
BEGIN
   t := code^.code ;
   IF (NOT FindStr(t, i, 'VAR')) AND EmitCode
   THEN
      seentext := FALSE ;
      curpos := 0 ;
      EmitFileLineTag(code^.line) ;
      IndentString('') ;
      WriteCodeHunkListIndent(code^.code, code^.indent, curpos, left, seentext) ;
      Output.WriteString(' ;') ;
      Output.WriteLn ;
      OnLineStart := TRUE
   END
END EmitNonVarCode ;


(*
   ChainOn -
*)

PROCEDURE ChainOn (codeStack, f: FactorDesc) : FactorDesc ;
VAR
   s: FactorDesc ;
BEGIN
   f^.pushed := NIL ;
   IF codeStack=NIL
   THEN
      RETURN( f )
   ELSE
      s := codeStack ;
      WHILE s^.pushed#NIL DO
         s := s^.pushed
      END ;
      s^.pushed := f ;
      RETURN( codeStack )
   END
END ChainOn ;


(*
   FlushCode -
*)

PROCEDURE FlushCode (VAR codeStack: FactorDesc) ;
BEGIN
   IF codeStack#NIL
   THEN
      NewLine(Indent) ; Output.WriteString('(* begin flushing code *)') ;
      OnLineStart := FALSE ;
      WHILE codeStack#NIL DO
         NewLine(Indent) ; EmitNonVarCode(codeStack^.code, 0, Indent) ; NewLine(Indent) ;
         codeStack := codeStack^.pushed ;
         IF codeStack#NIL
         THEN
            Output.WriteString(' (* again flushing code *)') ; Output.WriteLn ;
            OnLineStart := TRUE
         END
      END ;
      NewLine(Indent) ;
      Output.WriteString('(* end flushing code *)') ;
      OnLineStart := FALSE
   END
END FlushCode ;


(*
   CodeFactor -
*)

PROCEDURE CodeFactor (f: FactorDesc; t: TermDesc; l, n: m2condition; inopt, inwhile, consumed: BOOLEAN; codeStack: FactorDesc) ;
BEGIN
   IF f=NIL
   THEN
      IF (* ((l=m2elsif) OR (l=m2if) OR (l=m2none)) AND *) (NOT inwhile) AND (NOT inopt)
      THEN
         Output.WriteLn ;
         IndentString('RETURN( TRUE )') ;
         OnLineStart := FALSE
      END
   ELSE
      WITH f^ DO
         EmitFileLineTag(line) ;
         CASE type OF

         id  :  FlushCode(codeStack) ;
                CodeCondition(n) ;
                Output.WriteKey(ident^.name) ; Output.WriteString('()') ;
                CodeThenDo(n) ;
                INC(Indent, 3) ;
                CodeFactor(f^.next, NIL, n, m2none, inopt, inwhile, TRUE, NIL) ;
                CodeEnd(n, t, consumed, f, inopt) |
         lit :  FlushCode(codeStack) ;
                CodeCondition(n) ;
                Output.WriteKey(SymIsProc) ; Output.Write('(') ;
                Output.WriteKey(GetSymKey(Aliases, string)) ; Output.Write(')') ;
                CodeThenDo(n) ;
                INC(Indent, 3) ;
                CodeFactor(f^.next, NIL, n, m2none, inopt, inwhile, TRUE, NIL) ;
                CodeEnd(n, t, consumed, f, inopt) |
         sub:   FlushCode(codeStack) ;
                CodeExpression(expr, m2none, inopt, inwhile, consumed, NIL) ;
                IF f^.next#NIL
                THEN
                   (*
                    *  the test above makes sure that we don't emit a RETURN( TRUE )
                    *  after a subexpression. Remember sub expressions are not conditional
                    *)
                   CodeFactor(f^.next, t, n, m2none, inopt, inwhile, TRUE, NIL)
                END |
         opt:   FlushCode(codeStack) ;
                CodeExpression(expr, m2if, TRUE, inwhile, FALSE, NIL) ;
                CodeFactor(f^.next, t, n, m2none, inopt, inwhile, consumed, NIL) |
         mult:  FlushCode(codeStack) ;
                CodeExpression(expr, m2while, FALSE, TRUE, consumed, NIL) ;
                CodeFactor(f^.next, t, n, m2none, inopt, inwhile, consumed, NIL) |
         m2 :   codeStack := ChainOn(codeStack, f) ;
                IF consumed OR (f^.next=NIL)
                THEN
                   FlushCode(codeStack)
                END ;
                CodeFactor(f^.next, t, n, m2none, inopt, inwhile, consumed, codeStack)

         ELSE
         END
      END
   END
END CodeFactor ;


(*
   CodeTerm -
*)

PROCEDURE CodeTerm (t: TermDesc; m: m2condition; inopt, inwhile, consumed: BOOLEAN; codeStack: FactorDesc) ;
VAR
   l: m2condition ;
BEGIN
   l := m ;
   WHILE t#NIL DO
      EmitFileLineTag(t^.line) ;
      IF (t^.factor^.type=m2) AND (m=m2elsif)
      THEN
         m := m2if ;
         IndentString('ELSE') ; Output.WriteLn ;
         OnLineStart := TRUE ;
         INC(Indent, 3) ;
         CodeFactor(t^.factor, t^.next, m2none, m2none, inopt, inwhile, consumed, codeStack) ;
         DEC(Indent, 3) ;
         IndentString('END ;') ; Output.WriteLn ;
         OnLineStart := TRUE
      ELSE
         CodeFactor(t^.factor, t^.next, m2none, m, inopt, inwhile, consumed, codeStack)
      END ;
      l := m ;
      IF t^.next#NIL
      THEN
         m := m2elsif
      END ;
      t := t^.next
   END
END CodeTerm ;


(*
   CodeExpression -
*)

PROCEDURE CodeExpression (e: ExpressionDesc; m: m2condition; inopt, inwhile, consumed: BOOLEAN; codeStack: FactorDesc) ;
BEGIN
   IF e#NIL
   THEN
      EmitFileLineTag(e^.line) ;
      CodeTerm(e^.term, m, inopt, inwhile, consumed, codeStack)
   END
END CodeExpression ;


(*
   CodeStatement -
*)

PROCEDURE CodeStatement (s: StatementDesc; m: m2condition) ;
BEGIN
   IF s#NIL
   THEN
      EmitFileLineTag(s^.line) ;
      CodeExpression(s^.expr, m, FALSE, FALSE, FALSE, NIL)
   END
END CodeStatement ;


(*
   CodeProduction - only encode grammer rules which are not special.
*)

PROCEDURE CodeProduction (p: ProductionDesc) ;
BEGIN
   IF (p#NIL) AND ((NOT p^.firstsolved) OR ((p^.statement#NIL) AND (p^.statement^.expr#NIL)))
   THEN
      BeginningOfLine := TRUE ;
      Indent          := 0 ;
      Output.WriteLn ;
      EmitFileLineTag(p^.line) ;
      IndentString('PROCEDURE ') ;
      Output.WriteKey(GetDefinitionName(p)) ;
      Output.WriteString(' () : BOOLEAN ;') ;
      VarProduction(p) ;
      Output.WriteLn ;
      OnLineStart := TRUE ;
      EmitFileLineTag(p^.line) ;
      IndentString('BEGIN') ; WriteLn ;
      OnLineStart := FALSE ;
      EmitFileLineTag(p^.line) ;
      Indent := 3 ;
      CodeStatement(p^.statement, m2none) ;
      Output.WriteLn ;
      Indent := 0 ;
      IndentString('END ') ; WriteKey(GetDefinitionName(p)) ; Output.WriteString(' ;') ;
      Output.WriteLn ;
      Output.WriteLn ;
      Output.WriteLn
   END
END CodeProduction ;


(* and now for the production of code which will recover from syntax errors *)


(*
   RecoverCondition -
*)

PROCEDURE RecoverCondition (m: m2condition) ;
BEGIN
   CASE m OF

   m2if   :  IndentString('IF ')    |
   m2none :  IndentString('IF ')    |
   m2elsif:  IndentString('ELSIF ') |
   m2while:  IndentString('WHILE ')

   ELSE
      Halt('unrecognised m2condition',
           __FILE__, __FUNCTION__, __LINE__)
   END
END RecoverCondition ;


(*
   ConditionIndent - returns the number of spaces indentation created via, m.
*)

PROCEDURE ConditionIndent (m: m2condition) : CARDINAL ;
BEGIN
   CASE m OF

   m2if   :  RETURN( 3 ) |
   m2none :  RETURN( 3 ) |
   m2elsif:  RETURN( 6 ) |
   m2while:  RETURN( 6 )

   ELSE
      Halt('unrecognised m2condition',
           __FILE__, __FUNCTION__, __LINE__)
   END
END ConditionIndent ;


(*
   WriteGetTokenType - writes out the method of determining the token type.
*)

PROCEDURE WriteGetTokenType ;
BEGIN
   Output.WriteKey(TokenTypeProc)
END WriteGetTokenType ;


(*
   NumberOfElements - returns the number of elements in set, to, which lie between low..high
*)

PROCEDURE NumberOfElements (to: SetDesc; low, high: WORD) : CARDINAL ;
VAR
   n: CARDINAL ;
BEGIN
   n := 0 ;
   WHILE to#NIL DO
      WITH to^ DO
         CASE type OF

         tokel:  IF (high=0) OR IsBetween(string, low, high)
                 THEN
                    INC(n)
                 END |
         litel:  IF (high=0) OR IsBetween(GetSymKey(Aliases, string), low, high)
                 THEN
                    INC(n)
                 END |
         idel :  WarnError('not expecting ident in first symbol list') ;
                 WasNoError := FALSE

         ELSE
            WarnError('unknown enuneration element') ;
            WasNoError := FALSE
         END
      END ;
      to := to^.next ;
   END ;
   RETURN( n )
END NumberOfElements ;


(*
   WriteElement - writes the literal name for element, e.
*)

PROCEDURE WriteElement (e: WORD) ;
BEGIN
   Output.WriteKey(GetSymKey(ReverseValues, e))
END WriteElement ;


(*
   EmitIsInSet - writes out the equivalent of GetTokenType() IN { toset }
*)

PROCEDURE EmitIsInSet (to: SetDesc; low, high: Name) ;
BEGIN
   IF NumberOfElements(to, low, high)=1
   THEN
      WriteGetTokenType ; Output.Write('=') ; EmitSet(to, low, high)
   ELSE
      WriteGetTokenType ;
      Output.WriteString(' IN SetOfStop') ;
      IF LargestValue > MaxElementsInSet
      THEN
         Output.WriteCard(CARDINAL(low) DIV MaxElementsInSet, 0)
      END ;
      Output.WriteString(' {') ; EmitSet(to, low, high) ; Output.WriteString('}')
   END
END EmitIsInSet ;


(*
   EmitIsInSubSet - writes out a test to see whether GetTokenype() is in { subset }
*)

PROCEDURE EmitIsInSubSet (to: SetDesc; low, high: WORD) ;
BEGIN
   IF NumberOfElements(to, low, high)=1
   THEN
      Output.Write('(') ; EmitIsInSet(to, low, high) ; Output.Write(')')
   ELSIF low=0
   THEN
      (* no need to check whether GetTokenType > low *)
      Output.WriteString('((') ; WriteGetTokenType ; Output.Write('<') ; WriteElement(INTEGER(high)+1) ;
      Output.WriteString(') AND (') ; EmitIsInSet(to, low, high) ; Output.WriteString('))')
   ELSIF CARDINAL(high)>LargestValue
   THEN
      (* no need to check whether GetTokenType < high *)
      Output.WriteString('((') ; WriteGetTokenType ; Output.WriteString('>=') ; WriteElement(low) ;
      Output.WriteString(') AND (') ; EmitIsInSet(to, low, high) ; Output.WriteString('))')
   ELSE
      Output.WriteString('((') ; WriteGetTokenType ; Output.WriteString('>=') ; WriteElement(low) ;
      Output.WriteString(') AND (') ; WriteGetTokenType ; Output.Write('<') ; WriteElement(INTEGER(high)+1) ;
      Output.WriteString(') AND (') ; EmitIsInSet(to, low, high) ;
      Output.WriteString('))')
   END
END EmitIsInSubSet ;


(*
   EmitIsInFirst -
*)

PROCEDURE EmitIsInFirst (to: SetDesc; m: m2condition) ;
VAR
   i    : CARDINAL ;
   first: BOOLEAN ;
BEGIN
   IF NumberOfElements(to, 0, 0)=1
   THEN
      (* only one element *)
      WriteGetTokenType ;
      Output.Write('=') ;
      EmitSet(to, 0, 0)
   ELSE
      IF LargestValue<=MaxElementsInSet
      THEN
         Output.Write('(') ; WriteGetTokenType ; Output.WriteString(' IN ') ; EmitSetAsParameters(to) ; Output.WriteString(')')
      ELSE
         i     := 0 ;
         first := TRUE ;
         REPEAT
            IF NOT IsEmptySet(to, i*MaxElementsInSet, (i+1)*MaxElementsInSet-1)
            THEN
               IF NOT first
               THEN
                  Output.WriteString(' OR') ;
                  NewLine(Indent+ConditionIndent(m)) ;
                  DEC(Indent, ConditionIndent(m))
               END ;
               EmitIsInSubSet(to, i*MaxElementsInSet, (i+1)*MaxElementsInSet-1) ;
               first := FALSE
            END ;
            INC(i) ;
         UNTIL i*MaxElementsInSet>LargestValue
      END
   END
END EmitIsInFirst ;


(*
   FlushCode -
*)

PROCEDURE FlushRecoverCode (VAR codeStack: FactorDesc) ;
BEGIN
   IF codeStack#NIL
   THEN
      WHILE codeStack#NIL DO
         EmitNonVarCode(codeStack^.code, 0, Indent) ;
         codeStack := codeStack^.pushed
      END
   END
END FlushRecoverCode ;


(*
   RecoverFactor -
*)

PROCEDURE RecoverFactor (f: FactorDesc; m: m2condition; codeStack: FactorDesc) ;
VAR
   to: SetDesc ;
BEGIN
   IF f=NIL
   THEN
   ELSE
      EmitFileLineTag(f^.line) ;
      WITH f^ DO
         CASE type OF

         id  :  to := NIL ;
                CalcFirstFactor(f, NIL, to) ;
                IF (to#NIL) AND (m#m2none)
                THEN
                   RecoverCondition(m) ;
                   EmitIsInFirst(to, m) ;
                   CodeThenDo(m) ;
                   INC(Indent, 3)
                END ;
                FlushRecoverCode(codeStack) ;
                IndentString('') ;
                Output.WriteKey(ident^.name) ; Output.Write('(') ;
                EmitStopParametersAndFollow(f, m) ; Output.WriteString(') ;') ; Output.WriteLn ;
                RecoverFactor(f^.next, m2none, codeStack) ;
                IF (to#NIL) AND (m#m2none)
                THEN
                   DEC(Indent, 3)
                END |
         lit :  IF m=m2none
                THEN
                   FlushRecoverCode(codeStack) ;
                   IndentString('Expect(') ;
                   Output.WriteKey(GetSymKey(Aliases, string)) ; Output.WriteString(', ') ;
                   EmitStopParametersAndFollow(f, m) ; Output.WriteString(') ;') ; Output.WriteLn ;
                   RecoverFactor(f^.next, m2none, codeStack)
                ELSE
                   RecoverCondition(m) ;
                   WriteGetTokenType ;
                   Output.Write('=') ;
                   Output.WriteKey(GetSymKey(Aliases, string)) ;
                   CodeThenDo(m) ;
                   INC(Indent, 3) ;
                   IndentString('Expect(') ;
                   Output.WriteKey(GetSymKey(Aliases, string)) ; Output.WriteString(', ') ;
                   EmitStopParametersAndFollow(f, m) ; Output.WriteString(') ;') ;
                   Output.WriteLn ;
                   FlushRecoverCode(codeStack) ;
                   RecoverFactor(f^.next, m2none, codeStack) ;
                   DEC(Indent, 3)
                END |
         sub:   FlushRecoverCode(codeStack) ;
                RecoverExpression(expr, m2none, m) ;
                RecoverFactor(f^.next, m2none, codeStack) |
         opt:   FlushRecoverCode(codeStack) ;
                IF OptExpSeen(f)
                THEN
                   to := NIL ;
                   CalcFirstExpression(expr, NIL, to) ;
                   RecoverCondition(m) ;
                   EmitIsInFirst(to, m) ;
                   CodeThenDo(m) ;
                   INC(Indent, 3) ;
                   IndentString('(* seen optional [ | ] expression *)') ; Output.WriteLn ;
                   stop();
                   RecoverExpression(expr, m2none, m2if) ;
                   IndentString('(* end of optional [ | ] expression *)') ; Output.WriteLn ;
                   DEC(Indent, 3) ;
                   IndentString('END ;') ; Output.WriteLn
                ELSE
                   RecoverExpression(expr, m2if, m)
                END ;
                RecoverFactor(f^.next, m2none, codeStack) |
         mult:  FlushRecoverCode(codeStack) ;
                IF OptExpSeen(f) OR (m=m2if) OR (m=m2elsif)
                THEN
                   to := NIL ;
                   CalcFirstExpression(expr, NIL, to) ;
                   RecoverCondition(m) ;
                   EmitIsInFirst(to, m) ;
                   CodeThenDo(m) ;
                   INC(Indent, 3) ;
                   IndentString('(* seen optional { | } expression *)') ; Output.WriteLn ;
                   RecoverCondition(m2while) ;
                   EmitIsInFirst(to, m2while) ;
                   CodeThenDo(m2while) ;
                   INC(Indent, 3) ;
                   RecoverExpression(expr, m2none, m2while) ;
                   IndentString('(* end of optional { | } expression *)') ; Output.WriteLn ;
                   DEC(Indent, 3) ;
                   IndentString('END ;') ; Output.WriteLn ;
                   DEC(Indent, 3) ;
                   IF m=m2none
                   THEN
                      IndentString('END ;') ; Output.WriteLn ;
                      DEC(Indent, 3)
                   END
                ELSE
                   RecoverExpression(expr, m2while, m)
                END ;
                RecoverFactor(f^.next, m2none, codeStack) |
         m2 :   codeStack := ChainOn(codeStack, f) ;
                IF f^.next=NIL
                THEN
                   FlushRecoverCode(codeStack)
                ELSE
                   RecoverFactor(f^.next, m, codeStack)   (* was m2none *)
                END

         ELSE
         END
      END
   END
END RecoverFactor ;


(*
   OptExpSeen - returns TRUE if we can see an optional expression in the factor.
                This is not the same as epsilon. Example { '+' } matches epsilon as
                well as { '+' | '-' } but OptExpSeen returns TRUE in the second case
                and FALSE in the first.
*)

PROCEDURE OptExpSeen (f: FactorDesc) : BOOLEAN ;
BEGIN
   IF f=NIL
   THEN
      RETURN( FALSE )
   ELSE
      WITH f^ DO
         CASE type OF

         id  ,
         lit :   RETURN( FALSE ) |
         sub :   RETURN( FALSE ) |  (* is this correct? *)
         opt ,
         mult:   RETURN( (expr#NIL) AND (expr^.term#NIL) AND (expr^.term^.next#NIL) ) |
         m2  :   RETURN( TRUE )

         ELSE
         END
      END
   END ;
   WarnError('all cases were not handled') ;
   WasNoError := FALSE
END OptExpSeen ;


(*
   RecoverTerm -
*)

PROCEDURE RecoverTerm (t: TermDesc; new, old: m2condition) ;
VAR
   LastWasM2Only,             (* does the factor only contain inline code? *)
   alternative  : BOOLEAN ;
   to           : SetDesc ;
BEGIN
   LastWasM2Only := (t^.factor^.type = m2) AND (t^.factor^.next = NIL) ;
   to := NIL ;
   CalcFirstTerm(t, NIL, to) ;
   alternative := FALSE ;
   IF t^.next#NIL
   THEN
      new := m2if
   END ;
   WHILE t#NIL DO
      EmitFileLineTag(t^.line) ;
      LastWasM2Only := (t^.factor^.type = m2) AND (t^.factor^.next = NIL) ;
      IF (t^.factor^.type=m2) AND (new=m2elsif)
      THEN
         new := m2if ;
         IndentString('ELSE') ; Output.WriteLn ;
         INC(Indent, 3) ;
         RecoverFactor(t^.factor, m2none, NIL) ;
         alternative := FALSE
      ELSE
         RecoverFactor(t^.factor, new, NIL)
      END ;
      IF t^.next#NIL
      THEN
         new := m2elsif ;
         alternative := TRUE
      END ;
      t := t^.next
   END ;
   IF (new=m2if) OR (new=m2elsif)
   THEN
      IF alternative AND (old#m2while)
      THEN
         IndentString('ELSE') ; Output.WriteLn ;
         INC(Indent, 3) ;
         IndentString('') ;
         Output.WriteKey(ErrorProcArray) ;
         Output.WriteString("('expecting one of: ") ;
         EmitSetName(to, 0, 0) ;
         Output.WriteString("')") ;
         Output.WriteLn ;
         DEC(Indent, 3)
      ELSIF LastWasM2Only
      THEN
         DEC(Indent, 3)
      END ;
      IndentString('END ;') ; Output.WriteLn
   ELSIF new=m2while
   THEN
      IndentString('END (* while *) ;') ; Output.WriteLn
   ELSIF LastWasM2Only
   THEN
      DEC(Indent, 3)
   END
END RecoverTerm ;


(*
   RecoverExpression -
*)

PROCEDURE RecoverExpression (e: ExpressionDesc; new, old: m2condition) ;
BEGIN
   IF e#NIL
   THEN
      EmitFileLineTag(e^.line) ;
      RecoverTerm(e^.term, new, old)
   END
END RecoverExpression ;


(*
   RecoverStatement -
*)

PROCEDURE RecoverStatement (s: StatementDesc; m: m2condition) ;
BEGIN
   IF s#NIL
   THEN
      EmitFileLineTag(s^.line) ;
      RecoverExpression(s^.expr, m, m2none)
   END
END RecoverStatement ;


(*
   EmitFirstFactor - generate a list of all first tokens between the range: low..high.
*)

PROCEDURE EmitFirstFactor (f: FactorDesc; low, high: CARDINAL) ;
BEGIN

END EmitFirstFactor ;


(*
   EmitUsed -
*)

PROCEDURE EmitUsed (wordno: CARDINAL) ;
BEGIN
   IF NOT (wordno IN ParametersUsed)
   THEN
      Output.WriteString (" (* <* unused *> *) ")
   END
END EmitUsed ;


(*
   EmitStopParameters - generate the stop set.
*)

PROCEDURE EmitStopParameters (FormalParameters: BOOLEAN) ;
VAR
   i: CARDINAL ;
BEGIN
   IF LargestValue<=MaxElementsInSet
   THEN
      Output.WriteString('stopset') ;
      IF FormalParameters
      THEN
         Output.WriteString(': SetOfStop') ;
         EmitUsed (0)
      ELSE
         INCL (ParametersUsed, 0)
      END
   ELSE
      i := 0 ;
      REPEAT
         Output.WriteString('stopset') ; Output.WriteCard(i, 0) ;
         IF FormalParameters
         THEN
            Output.WriteString(': SetOfStop') ; Output.WriteCard(i, 0) ;
            EmitUsed (i)
         ELSE
            INCL (ParametersUsed, i)
         END ;
         INC (i) ;
         IF i*MaxElementsInSet<LargestValue
         THEN
            IF FormalParameters
            THEN
               Output.WriteString('; ')
            ELSE
               Output.WriteString(', ')
            END
         END
      UNTIL i*MaxElementsInSet>=LargestValue ;
   END
END EmitStopParameters ;


(*
   IsBetween - returns TRUE if the value of the token, string, is
               in the range: low..high
*)

PROCEDURE IsBetween (string: Name; low, high: WORD) : BOOLEAN ;
BEGIN
   RETURN( (GetSymKey(Values, string) >= low) AND (GetSymKey(Values, string) <= high) )
END IsBetween ;


(*
   IsEmptySet - returns TRUE if no elements exist in set, to, with values, low..high.
*)

PROCEDURE IsEmptySet (to: SetDesc; low, high: WORD) : BOOLEAN ;
BEGIN
   WHILE to#NIL DO
      WITH to^ DO
         CASE type OF

         tokel:  IF IsBetween(string, low, high)
                 THEN
                    RETURN( FALSE )
                 END |
         litel:  IF IsBetween(GetSymKey(Aliases, string), low, high)
                 THEN
                    RETURN( FALSE )
                 END |
         idel :  WarnError('not expecting ident in first symbol list') ;
                 WasNoError := FALSE

         ELSE
            WarnError('unknown enuneration element') ;
            WasNoError := FALSE
         END
      END ;
      to := to^.next ;
   END ;
   RETURN( TRUE )
END IsEmptySet ;


(*
   EmitSet - emits the tokens in the set, to, which have values low..high
*)

PROCEDURE EmitSet (to: SetDesc; low, high: WORD) ;
VAR
   first: BOOLEAN ;
BEGIN
   first := TRUE ;
   WHILE to#NIL DO
      WITH to^ DO
         CASE type OF

         tokel:  IF (high=0) OR IsBetween(string, low, high)
                 THEN
                    IF NOT first
                    THEN
                       Output.WriteString(', ')
                    END ;
                    Output.WriteKey(string) ;
                    first := FALSE
                 END |
         litel:  IF (high=0) OR IsBetween(GetSymKey(Aliases, string), low, high)
                 THEN
                    IF NOT first
                    THEN
                       Output.WriteString(', ')
                    END ;
                    Output.WriteKey(GetSymKey(Aliases, string)) ;
                    first := FALSE
                 END |
         idel :  WarnError('not expecting ident in first symbol list') ;
                 WasNoError := FALSE

         ELSE
            WarnError('unknown enuneration element') ;
            WasNoError := FALSE
         END
      END ;
      to := to^.next
   END
END EmitSet ;


(*
   EmitSetName - emits the tokens in the set, to, which have values low..high, using
                 their names.
*)

PROCEDURE EmitSetName (to: SetDesc; low, high: WORD) ;
BEGIN
   WHILE to#NIL DO
      WITH to^ DO
         CASE type OF

         tokel:  IF (high=0) OR IsBetween(string, low, high)
                 THEN
                    IF MakeKey("'")=GetSymKey(ReverseAliases, string)
                    THEN
                       Output.WriteString('single quote')
                    ELSE
                       KeyWord(GetSymKey(ReverseAliases, string))
                    END
                 END |
         litel:  IF (high=0) OR IsBetween(GetSymKey(Aliases, string), low, high)
                 THEN
                    Output.WriteKey(string)
                 END |
         idel :  WarnError('not expecting ident in first symbol list') ;
                 WasNoError := FALSE

         ELSE
            WarnError('unknown enuneration element') ;
            WasNoError := FALSE
         END
      END ;
      to := to^.next ;
      IF to#NIL
      THEN
         Output.Write(' ')
      END
   END
END EmitSetName ;


(*
   EmitStopParametersAndSet - generates the stop parameters together with a set
                              inclusion of all the symbols in set, to.
*)

PROCEDURE EmitStopParametersAndSet (to: SetDesc) ;
VAR
   i : CARDINAL ;
BEGIN
   IF LargestValue<=MaxElementsInSet
   THEN
      Output.WriteString('stopset') ;
      INCL (ParametersUsed, 0) ;
      IF (to#NIL) AND (NumberOfElements(to, 0, MaxElementsInSet-1)>0)
      THEN
         Output.WriteString(' + SetOfStop') ;
         Output.Write('{') ;
         EmitSet(to, 0, MaxElementsInSet-1) ;
         Output.Write('}')
      END
   ELSE
      i := 0 ;
      REPEAT
         Output.WriteString('stopset') ; Output.WriteCard(i, 0) ;
         INCL (ParametersUsed, i) ;
         IF (to#NIL) AND (NumberOfElements(to, i*MaxElementsInSet, (i+1)*MaxElementsInSet-1)>0)
         THEN
            Output.WriteString(' + SetOfStop') ; Output.WriteCard(i, 0) ;
            Output.Write('{') ;
            EmitSet(to, i*MaxElementsInSet, (i+1)*MaxElementsInSet-1) ;
            Output.Write('}')
         END ;
         INC(i) ;
         IF i*MaxElementsInSet<LargestValue
         THEN
            Output.WriteString(', ')
         END
      UNTIL i*MaxElementsInSet>=LargestValue
   END
END EmitStopParametersAndSet ;


(*
   EmitSetAsParameters - generates the first symbols as parameters to a set function.
*)

PROCEDURE EmitSetAsParameters (to: SetDesc) ;
VAR
   i : CARDINAL ;
BEGIN
   IF LargestValue<=MaxElementsInSet
   THEN
      Output.Write('{') ;
      EmitSet(to, 0, MaxElementsInSet-1)
   ELSE
      i := 0 ;
      REPEAT
         Output.Write('{') ;
         EmitSet(to, i*MaxElementsInSet, (i+1)*MaxElementsInSet-1) ;
         INC(i) ;
         IF (i+1)*MaxElementsInSet>LargestValue
         THEN
            Output.WriteString('}, ')
         END
      UNTIL (i+1)*MaxElementsInSet>=LargestValue ;
   END ;
   Output.Write('}')
END EmitSetAsParameters ;


(*
   EmitStopParametersAndFollow - generates the stop parameters together with a set
                                 inclusion of all the follow symbols for subsequent
                                 sentances.
*)

PROCEDURE EmitStopParametersAndFollow (f: FactorDesc; m: m2condition) ;
VAR
   to: SetDesc ;
BEGIN
   to := NIL ;
(*
   IF m=m2while
   THEN
      CalcFirstFactor(f, NIL, to)
   END ;
*)
   CollectFollow(to, f^.followinfo) ;
   EmitStopParametersAndSet(to) ;
   IF Debugging
   THEN
      Output.WriteLn ;
      Output.WriteString('factor is: ') ;
      PrettyCommentFactor(f, StrLen('factor is: ')) ;
      Output.WriteLn ;
      Output.WriteString('follow set:') ;
      EmitSet(to, 0, 0) ;
      Output.WriteLn
   END
END EmitStopParametersAndFollow ;


(*
   EmitFirstAsParameters -
*)

PROCEDURE EmitFirstAsParameters (f: FactorDesc) ;
VAR
   to: SetDesc ;
BEGIN
   to := NIL ;
   CalcFirstFactor(f, NIL, to) ;
   EmitSetAsParameters(to)
END EmitFirstAsParameters ;


(*
   RecoverProduction - only encode grammer rules which are not special.
                       Generate error recovery code.
*)

PROCEDURE RecoverProduction (p: ProductionDesc) ;
VAR
   s: String ;
BEGIN
   IF (p#NIL) AND ((NOT p^.firstsolved) OR ((p^.statement#NIL) AND (p^.statement^.expr#NIL)))
   THEN
      BeginningOfLine := TRUE ;
      Indent := 0 ;
      Output.WriteLn ;
      OnLineStart := FALSE ;
      EmitFileLineTag(p^.line) ;
      IndentString('PROCEDURE ') ;
      Output.WriteKey(GetDefinitionName(p)) ;
      Output.WriteString(' (') ;
      ParametersUsed := {} ;
      Output.StartBuffer ;
      Output.WriteString(') ;') ;
      VarProduction(p) ;
      Output.WriteLn ;
      OnLineStart := FALSE ;
      EmitFileLineTag(p^.line) ;
      Indent := 0 ;
      IndentString('BEGIN') ; Output.WriteLn ;
      OnLineStart := FALSE ;
      EmitFileLineTag(p^.line) ;
      Indent := 3 ;
      RecoverStatement(p^.statement, m2none) ;
      Indent := 0 ;
      IndentString('END ') ; Output.WriteKey(GetDefinitionName(p)) ; Output.WriteString(' ;') ;
      Output.WriteLn ;
      Output.WriteLn ;
      Output.WriteLn ;
      s := Output.EndBuffer () ;
      EmitStopParameters (TRUE) ;
      Output.KillWriteS (s)
   END
END RecoverProduction ;


(*
   IsWhite - returns TRUE if, ch, is a space or a tab.
*)

PROCEDURE IsWhite (ch: CHAR) : BOOLEAN ;
BEGIN
   RETURN( (ch=' ') OR (ch=tab) OR (ch=lf) )
END IsWhite ;


(*
   FindStr - returns TRUE if, str, was seen inside the code hunk
*)

PROCEDURE FindStr (VAR code: CodeHunk; VAR i: CARDINAL; str: ARRAY OF CHAR) : BOOLEAN ;
VAR
   j, k: CARDINAL ;
   t   : CodeHunk ;
BEGIN
   t := code ;
   k := StrLen(code^.codetext)+1 ;
   WHILE t#NIL DO
      REPEAT
         WHILE (k>0) AND IsWhite(t^.codetext[k-1]) DO
            DEC(k)
         END ;
         IF k=0
         THEN
            t := t^.next ;
            k := MaxCodeHunkLength+1
         END
      UNTIL (t=NIL) OR (NOT IsWhite(t^.codetext[k-1])) ;

      (* found another word check it *)

      IF t#NIL
      THEN
         j := StrLen(str) ;
         i := k ;
         WHILE (t#NIL) AND (j>0) AND ((str[j-1]=t^.codetext[k-1]) OR
                                      (IsWhite(str[j-1]) AND IsWhite(t^.codetext[k-1]))) DO
            DEC(j) ;
            DEC(k) ;
            IF j=0
            THEN
               (* found word remember position *)
               code := t
            END ;
            IF k=0
            THEN
               t := t^.next ;
               k := MaxCodeHunkLength+1
            END
         END ;
         IF k>0
         THEN
            DEC(k)
         ELSE
            t := t^.next
         END
      END ;
   END ;
   RETURN( (t=NIL) AND (j=0) )
END FindStr ;


(*
   WriteUpto -
*)

PROCEDURE WriteUpto (code, upto: CodeHunk; limit: CARDINAL) ;
BEGIN
   IF code#upto
   THEN
      WriteUpto(code^.next, upto, limit) ;
      Output.WriteString(code^.codetext)
   ELSE
      WHILE (limit<=MaxCodeHunkLength) AND (code^.codetext[limit]#nul) DO
         Output.Write(code^.codetext[limit]) ;
         INC(limit)
      END
   END
END WriteUpto ;


(*
   CheckForVar - checks for any local variables which need to be emitted during
                 this production.
*)

PROCEDURE CheckForVar (code: CodeHunk) ;
VAR
   i: CARDINAL ;
   t: CodeHunk ;
BEGIN
   t := code ;
   IF FindStr(t, i, 'VAR') AND EmitCode
   THEN
      IF NOT EmittedVar
      THEN
         Output.WriteLn ;
         Indent := 0 ;
         IndentString('VAR') ;
         INC(Indent, 3) ;
         Output.WriteLn ;
         EmittedVar := TRUE ;
      END ;
      WriteUpto(code, t, i)
   END
END CheckForVar ;


(*
   VarFactor -
*)

PROCEDURE VarFactor (f: FactorDesc) ;
BEGIN
   WHILE f#NIL DO
      WITH f^ DO
         CASE type OF

         id  :  |
         lit :  |
         sub ,
         opt ,
         mult:  VarExpression(expr) |
         m2  :  CheckForVar(code^.code)

         ELSE
         END
      END ;
      f := f^.next
   END
END VarFactor ;


(*
   VarTerm -
*)

PROCEDURE VarTerm (t: TermDesc) ;
BEGIN
   WHILE t#NIL DO
      VarFactor(t^.factor) ;
      t := t^.next
   END
END VarTerm ;


(*
   VarExpression -
*)

PROCEDURE VarExpression (e: ExpressionDesc) ;
BEGIN
   IF e#NIL
   THEN
      VarTerm(e^.term)
   END
END VarExpression ;


(*
   VarStatement -
*)

PROCEDURE VarStatement (s: StatementDesc) ;
BEGIN
   IF s#NIL
   THEN
      VarExpression(s^.expr)
   END
END VarStatement ;


(*
   VarProduction - writes out all variable declarations.
*)

PROCEDURE VarProduction (p: ProductionDesc) ;
BEGIN
   EmittedVar := FALSE ;
   IF p#NIL
   THEN
      VarStatement(p^.statement)
   END
END VarProduction ;


(*
   In - returns TRUE if token, s, is already in the set, to.
*)

PROCEDURE In (to: SetDesc; s: Name) : BOOLEAN ;
BEGIN
   WHILE to#NIL DO
      WITH to^ DO
         CASE type OF

         idel  :  IF s=ident^.name
                  THEN
                     RETURN( TRUE )
                  END |
         tokel,
         litel :  IF s=string
                  THEN
                     RETURN( TRUE )
                  END

         ELSE
            WarnError('internal error CASE type not known') ;
            WasNoError := FALSE
         END
      END ;
      to := to^.next
   END ;
   RETURN( FALSE )
END In ;


(*
   IntersectionIsNil - given two set lists, s1, s2, return TRUE if the
                       s1 * s2 = {}
*)

PROCEDURE IntersectionIsNil (s1, s2: SetDesc) : BOOLEAN ;
BEGIN
   WHILE s1#NIL DO
      WITH s1^ DO
         CASE type OF

         idel :  IF In(s2, ident^.name)
                 THEN
                    RETURN( FALSE )
                 END |
         tokel,
         litel:  IF In(s2, string)
                 THEN
                    RETURN( FALSE )
                 END

         ELSE
            WarnError('internal error CASE type not known') ;
            WasNoError := FALSE
         END
      END ;
      s1 := s1^.next
   END ;
   RETURN( TRUE )
END IntersectionIsNil ;


(*
   AddSet - adds a first symbol to a production.
*)

PROCEDURE AddSet (VAR to: SetDesc; s: Name) ;
VAR
   d: SetDesc ;
BEGIN
   IF NOT In(to, s)
   THEN
      d := NewSetDesc() ;
      WITH d^ DO
         type   := tokel ;
         string := s ;
         next   := to ;
      END ;
      to := d ;
      Finished := FALSE
   END
END AddSet ;


(*
   OrSet -
*)

PROCEDURE OrSet (VAR to: SetDesc; from: SetDesc) ;
BEGIN
   WHILE from#NIL DO
      WITH from^ DO
         CASE type OF

         tokel:  AddSet(to, string) |
         litel:  AddSet(to, GetSymKey(Aliases, string)) |
         idel :  WarnError('not expecting ident in first symbol list') ;
                 WasNoError := FALSE

         ELSE
            Halt('unknown element in enumeration type',
                 __FILE__, __FUNCTION__, __LINE__)
         END
      END ;
      from := from^.next
   END
END OrSet ;


(*
   CalcFirstFactor -
*)

PROCEDURE CalcFirstFactor (f: FactorDesc; from: ProductionDesc; VAR to: SetDesc) ;
BEGIN
   WHILE f#NIL DO
      WITH f^ DO
         CASE type OF

         id  :  IF ident^.definition=NIL
                THEN
                   WarnError1("no rule found for an 'ident' called '%s'", ident^.name) ;
                   HALT
                END ;
                OrSet(to, ident^.definition^.first) ;
                IF GetReachEnd(ident^.definition^.followinfo)=false
                THEN
                   RETURN
                END |
         lit :  IF GetSymKey(Aliases, string)=NulKey
                THEN
                   WarnError1("unknown token for '%s'", string) ;
                   WasNoError := FALSE
                ELSE
                   AddSet(to, GetSymKey(Aliases, string))
                END ;
                RETURN |
         sub ,
         opt ,
         mult:  CalcFirstExpression(expr, from, to) |
         m2  :

         ELSE
         END
      END ;
      f := f^.next
   END
END CalcFirstFactor ;


(*
   CalcFirstTerm -
*)

PROCEDURE CalcFirstTerm (t: TermDesc; from: ProductionDesc; VAR to: SetDesc) ;
BEGIN
   WHILE t#NIL DO
      CalcFirstFactor(t^.factor, from, to) ;
      t := t^.next
   END
END CalcFirstTerm ;


(*
   CalcFirstExpression -
*)

PROCEDURE CalcFirstExpression (e: ExpressionDesc; from: ProductionDesc; VAR to: SetDesc) ;
BEGIN
   IF e#NIL
   THEN
      CalcFirstTerm(e^.term, from, to)
   END
END CalcFirstExpression ;


(*
   CalcFirstStatement -
*)

PROCEDURE CalcFirstStatement (s: StatementDesc; from: ProductionDesc; VAR to: SetDesc) ;
BEGIN
   IF s#NIL
   THEN
      CalcFirstExpression(s^.expr, from, to)
   END
END CalcFirstStatement ;


(*
   CalcFirstProduction - calculates all of the first symbols for the grammer
*)

PROCEDURE CalcFirstProduction (p: ProductionDesc; from: ProductionDesc; VAR to: SetDesc) ;
VAR
   s: SetDesc ;
BEGIN
   IF p#NIL
   THEN
      IF p^.firstsolved
      THEN
         s := p^.first ;
         WHILE s#NIL DO
            CASE s^.type OF

            idel :  CalcFirstProduction(s^.ident^.definition, from, to) |
            tokel,
            litel:  AddSet(to, s^.string)

            ELSE
            END ;
            s := s^.next
         END
      ELSE
         CalcFirstStatement(p^.statement, from, to)
      END
   END
END CalcFirstProduction ;


(*
   WorkOutFollow -
*)

PROCEDURE WorkOutFollowFactor (f: FactorDesc; VAR followset: SetDesc; after: SetDesc) ;
VAR
   foundepsilon,
   canreachend : TraverseResult ;
BEGIN
   foundepsilon := true ;
   canreachend  := true ;
   WHILE (f#NIL) AND (foundepsilon=true) DO
      WITH f^ DO
         CASE type OF

         id  :  IF ident^.definition=NIL
                THEN
                   WarnError1("no rule found for an 'ident' called '%s'", ident^.name) ;
                   HALT
                END ;
                OrSet(followset, ident^.definition^.first) |
         lit :  AddSet(followset, GetSymKey(Aliases, string)) |
         sub :  WorkOutFollowExpression(expr, followset, NIL) |
         opt :  WorkOutFollowExpression(expr, followset, NIL) |
         mult:  WorkOutFollowExpression(expr, followset, NIL) |
         m2  :

         ELSE
         END
      END ;
      IF GetEpsilon(f^.followinfo)=unknown
      THEN
         WarnError('internal error: epsilon unknown') ;
         PrettyCommentFactor(f, 3) ;
         WasNoError := FALSE
      END ;
      foundepsilon := GetEpsilon(f^.followinfo) ;
      canreachend := GetReachEnd(f^.followinfo) ;  (* only goes from FALSE -> TRUE *)
      f := f^.next
   END ;
   IF canreachend=true
   THEN
      OrSet(followset, after)
   END
END WorkOutFollowFactor ;


(*
   WorkOutFollowTerm -
*)

PROCEDURE WorkOutFollowTerm (t: TermDesc; VAR followset: SetDesc; after: SetDesc) ;
BEGIN
   IF t#NIL
   THEN
      WHILE t#NIL DO
         WITH t^ DO
            WorkOutFollowFactor(factor, followset, after) ;   (*  { '|' Term } *)
         END ;
         t := t^.next
      END
   END
END WorkOutFollowTerm ;


(*
   WorkOutFollowExpression -
*)

PROCEDURE WorkOutFollowExpression (e: ExpressionDesc; VAR followset: SetDesc; after: SetDesc) ;
BEGIN
   IF e#NIL
   THEN
      WITH e^ DO
         WorkOutFollowTerm(term, followset, after)
      END
   END
END WorkOutFollowExpression ;


(*
   CollectFollow - collects the follow set from, f, into, to.
*)

PROCEDURE CollectFollow (VAR to: SetDesc; f: FollowDesc) ;
BEGIN
   OrSet(to, f^.follow)
END CollectFollow ;


(*
   CalcFollowFactor -
*)

PROCEDURE CalcFollowFactor (f: FactorDesc; after: SetDesc) ;
BEGIN
   WHILE f#NIL DO
      WITH f^ DO
         CASE type OF

         id  :  WorkOutFollowFactor(next, followinfo^.follow, after) |
         lit :  WorkOutFollowFactor(next, followinfo^.follow, after) |
         opt ,
         sub :  CalcFirstFactor(next, NIL, followinfo^.follow) ;
                IF (next=NIL) OR (GetReachEnd(next^.followinfo)=true)
                THEN
                   OrSet(followinfo^.follow, after) ;
                   CalcFollowExpression(expr, followinfo^.follow)
                ELSE
                   CalcFollowExpression(expr, followinfo^.follow)
                END |
         mult:  CalcFirstFactor(f, NIL, followinfo^.follow) ;
                (* include first as we may repeat this sentance *)
                IF Debugging
                THEN
                   WriteLn ;
                   WriteString('found mult: and first is: ') ; EmitSet(followinfo^.follow, 0, 0) ; WriteLn
                END ;
                IF (next=NIL) OR (GetReachEnd(next^.followinfo)=true)
                THEN
                   OrSet(followinfo^.follow, after) ;
                   CalcFollowExpression(expr, followinfo^.follow)
                ELSE
                   CalcFollowExpression(expr, followinfo^.follow)
                END

         ELSE
         END
      END ;
      f := f^.next
   END
END CalcFollowFactor ;


(*
   CalcFollowTerm -
*)

PROCEDURE CalcFollowTerm (t: TermDesc; after: SetDesc) ;
BEGIN
   IF t#NIL
   THEN
      WHILE t#NIL DO
         WITH t^ DO
            CalcFollowFactor(factor, after) ;   (*  { '|' Term } *)
         END ;
         t := t^.next
      END
   END
END CalcFollowTerm ;


(*
   CalcFollowExpression -
*)

PROCEDURE CalcFollowExpression (e: ExpressionDesc; after: SetDesc) ;
BEGIN
   IF e#NIL
   THEN
      WITH e^ DO
         CalcFollowTerm(term, after)
      END
   END
END CalcFollowExpression ;


(*
   CalcFollowStatement - given a bnf statement generate the follow set.
*)

PROCEDURE CalcFollowStatement (s: StatementDesc) ;
BEGIN
   IF s#NIL
   THEN
      WITH s^ DO
         CalcFollowExpression(expr, NIL)
      END
   END
END CalcFollowStatement ;


(*
   CalcFollowProduction -
*)

PROCEDURE CalcFollowProduction (p: ProductionDesc) ;
BEGIN
   IF p#NIL
   THEN
      WITH p^ DO
         CalcFollowStatement(statement)
      END
   END
END CalcFollowProduction ;


(*
   CalcEpsilonFactor -
*)

PROCEDURE CalcEpsilonFactor (f: FactorDesc) ;
BEGIN
   WHILE f#NIL DO
      WITH f^ DO
         CASE type OF

         id  :  AssignEpsilon(GetEpsilon(ident^.definition^.followinfo)#unknown,
                              followinfo, GetEpsilon(ident^.definition^.followinfo)) |
         lit :  AssignEpsilon(TRUE, followinfo, false) |
         sub :  CalcEpsilonExpression(expr) ;
                AssignEpsilon(GetEpsilon(expr^.followinfo)#unknown,
                              followinfo, GetEpsilon(expr^.followinfo)) |
         m2  :  AssignEpsilon(TRUE, followinfo, true) |
         opt ,
         mult:  CalcEpsilonExpression(expr) ;
                AssignEpsilon(TRUE, followinfo, true)

         ELSE
         END
      END ;
      f := f^.next
   END
END CalcEpsilonFactor ;


(*
   CalcEpsilonTerm -
*)

PROCEDURE CalcEpsilonTerm (t: TermDesc) ;
BEGIN
   IF t#NIL
   THEN
      WHILE t#NIL DO
         WITH t^ DO
            IF factor#NIL
            THEN
               CASE GetReachEnd(factor^.followinfo) OF

               true :  AssignEpsilon(TRUE, followinfo, true) |
               false:  AssignEpsilon(TRUE, followinfo, false) |
               unknown:

               ELSE
               END
            END ;
            CalcEpsilonFactor(factor)    (*  { '|' Term } *)
         END ;
         t := t^.next
      END
   END
END CalcEpsilonTerm ;


(*
   CalcEpsilonExpression -
*)

PROCEDURE CalcEpsilonExpression (e: ExpressionDesc) ;
VAR
   t     : TermDesc ;
   result: TraverseResult ;
BEGIN
   IF e#NIL
   THEN
      CalcEpsilonTerm(e^.term) ;
      IF GetEpsilon(e^.followinfo)=unknown
      THEN
         result := unknown ;
         WITH e^ DO
            t := term ;
            WHILE t#NIL DO
               IF GetEpsilon(t^.followinfo)#unknown
               THEN
                  stop
               END ;
               CASE GetEpsilon(t^.followinfo) OF

               unknown: |
               true   : result := true |
               false  : IF result#true
                        THEN
                           result := false
                        END

               ELSE
               END ;
               t := t^.next
            END
         END ;
         AssignEpsilon(result#unknown, e^.followinfo, result)
      END
   END
END CalcEpsilonExpression ;


(*
   CalcEpsilonStatement - given a bnf statement generate the follow set.
*)

PROCEDURE CalcEpsilonStatement (s: StatementDesc) ;
BEGIN
   IF s#NIL
   THEN
      WITH s^ DO
         IF expr#NIL
         THEN
            AssignEpsilon(GetEpsilon(expr^.followinfo)#unknown,
                          followinfo, GetEpsilon(expr^.followinfo))
         END ;
         CalcEpsilonExpression(expr)
      END
   END
END CalcEpsilonStatement ;


(*
   CalcEpsilonProduction -
*)

PROCEDURE CalcEpsilonProduction (p: ProductionDesc) ;
BEGIN
   IF p#NIL
   THEN
(*
      IF p^.statement^.ident^.name=MakeKey('DefinitionModule')
      THEN
         stop
      END ;
*)

      IF Debugging
      THEN
         WriteKey(p^.statement^.ident^.name) ;
         WriteString('  calculating epsilon') ;
         WriteLn
      END ;

      WITH p^ DO
         AssignEpsilon(GetEpsilon(statement^.followinfo)#unknown,
                       followinfo, GetEpsilon(statement^.followinfo)) ;
         CalcEpsilonStatement(statement)
      END
   END
END CalcEpsilonProduction ;


(*
   CalcReachEndFactor -
*)

PROCEDURE CalcReachEndFactor (f: FactorDesc) : TraverseResult ;
VAR
   canreachend,
   result     : TraverseResult ;
BEGIN
   IF f=NIL
   THEN
      RETURN( true )   (* we have reached the end of this factor list *)
   ELSE
      WITH f^ DO
         (* we need to traverse all factors even if we can short cut the answer to this list of factors *)
         result := CalcReachEndFactor(next) ;
         CASE type OF

         id  :  IF ident^.definition=NIL
                THEN
                   WarnError1('definition for %s is absent (assuming epsilon is false for this production)', ident^.name) ;
                   result := false
                ELSIF result#false
                THEN
                   CASE GetReachEnd(ident^.definition^.followinfo) OF

                   false  :  result := false |
                   true   :  |
                   unknown:  result := unknown

                   ELSE
                   END
                END |
         lit :  result := false |
         sub :  CalcReachEndExpression(expr) ;
                IF (expr#NIL) AND (result=true)
                THEN
                   result := GetReachEnd(expr^.followinfo)
                END |
         mult,
         opt :  IF expr#NIL
                THEN
                   (* not interested in the result as expression is optional *)
                   CalcReachEndExpression(expr)
                END |
         m2  :

         ELSE
         END ;
         AssignReachEnd(result#unknown, followinfo, result)
      END ;
      RETURN( result )
   END
END CalcReachEndFactor ;


(*
   CalcReachEndTerm -
*)

PROCEDURE CalcReachEndTerm (t: TermDesc) : TraverseResult ;
VAR
   canreachend,
   result     : TraverseResult ;
BEGIN
   IF t#NIL
   THEN
      canreachend := false ;
      WHILE t#NIL DO
         WITH t^ DO
            result := CalcReachEndFactor(factor) ;
            AssignReachEnd(result#unknown, followinfo, result) ;
            CASE result OF

            true   :  canreachend := true |
            false  :  |
            unknown:  IF canreachend=false
                      THEN
                         canreachend := unknown
                      END

            ELSE
            END
         END ;
         t := t^.next    (*  { '|' Term } *)
      END ;
      RETURN( canreachend )
   END
END CalcReachEndTerm ;


(*
   CalcReachEndExpression -
*)

PROCEDURE CalcReachEndExpression (e: ExpressionDesc) ;
VAR
   result: TraverseResult ;
BEGIN
   IF e=NIL
   THEN
      (* no expression, thus reached the end of this sentance *)
   ELSE
      WITH e^ DO
         result := CalcReachEndTerm(term) ;
         AssignReachEnd(result#unknown, followinfo, result)
      END
   END
END CalcReachEndExpression ;


(*
   CalcReachEndStatement -
*)

PROCEDURE CalcReachEndStatement (s: StatementDesc) ;
BEGIN
   IF s#NIL
   THEN
      WITH s^ DO
         IF expr#NIL
         THEN
            CalcReachEndExpression(expr) ;
            AssignReachEnd(GetReachEnd(expr^.followinfo)#unknown,
                           followinfo, GetReachEnd(expr^.followinfo))
         END
      END
   END
END CalcReachEndStatement ;


PROCEDURE stop ; BEGIN END stop ;

(*
   CalcReachEndProduction -
*)

PROCEDURE CalcReachEndProduction (p: ProductionDesc) ;
BEGIN
   IF p#NIL
   THEN
      WITH p^ DO
         CalcReachEndStatement(statement) ;
         IF GetReachEnd(followinfo)#unknown
         THEN
            IF Debugging
            THEN
               WriteString('already calculated reach end for: ') ;
               WriteKey(p^.statement^.ident^.name) ; WriteString(' its value is ') ;
               IF GetReachEnd(followinfo)=true
               THEN
                  WriteString('reachable')
               ELSE
                  WriteString('non reachable')
               END ;
               WriteLn
            END
         END ;
         AssignReachEnd(GetReachEnd(statement^.followinfo)#unknown, followinfo, GetReachEnd(statement^.followinfo)) ;
      END
   END
END CalcReachEndProduction ;


(*
   EmptyFactor -
*)

PROCEDURE EmptyFactor (f: FactorDesc) : BOOLEAN ;
BEGIN
   WHILE f#NIL DO
      WITH f^ DO
         CASE type OF

         id  :  IF NOT EmptyProduction(ident^.definition)
                THEN
                   RETURN( FALSE )
                END |
         lit :  RETURN( FALSE ) |
         sub :  IF NOT EmptyExpression(expr)
                THEN
                   RETURN( FALSE )
                END |
         opt ,
         mult:  RETURN( TRUE ) |
         m2  :

         ELSE
         END
      END ;
      f := f^.next
   END ;
   RETURN( TRUE )
END EmptyFactor ;


(*
   EmptyTerm - returns TRUE if the term maybe empty.
*)

PROCEDURE EmptyTerm (t: TermDesc) : BOOLEAN ;
BEGIN
   WHILE t#NIL DO
      IF EmptyFactor(t^.factor)
      THEN
         RETURN( TRUE )
      ELSE
         t := t^.next
      END
   END ;
   RETURN( FALSE )
END EmptyTerm ;


(*
   EmptyExpression -
*)

PROCEDURE EmptyExpression (e: ExpressionDesc) : BOOLEAN ;
BEGIN
   IF e=NIL
   THEN
      RETURN( TRUE )
   ELSE
      RETURN( EmptyTerm(e^.term) )
   END
END EmptyExpression ;


(*
   EmptyStatement - returns TRUE if statement, s, is empty.
*)

PROCEDURE EmptyStatement (s: StatementDesc) : BOOLEAN ;
BEGIN
   IF s=NIL
   THEN
      RETURN( TRUE )
   ELSE
      RETURN( EmptyExpression(s^.expr) )
   END
END EmptyStatement ;


(*
   EmptyProduction - returns if production, p, maybe empty.
*)

PROCEDURE EmptyProduction (p: ProductionDesc) : BOOLEAN ;
BEGIN
   IF p=NIL
   THEN
      WarnError('unknown production') ;
      RETURN( TRUE )
   ELSIF (p^.firstsolved) AND (p^.first#NIL)
   THEN
      (* predefined but first set to something - thus not empty *)
      RETURN( FALSE )
   ELSE
      RETURN( EmptyStatement(p^.statement) )
   END
END EmptyProduction ;


(*
   EmitFDLNotice -
*)

PROCEDURE EmitFDLNotice ;
BEGIN
   Output.WriteString('@c Copyright (C) 2000-2023 Free Software Foundation, Inc.') ; Output.WriteLn ;
   Output.WriteLn ;
   Output.WriteString('@c This file is part of GCC.') ; Output.WriteLn ;
   Output.WriteString('@c Permission is granted to copy, distribute and/or modify this document') ; Output.WriteLn ;
   Output.WriteString('@c under the terms of the GNU Free Documentation License, Version 1.2 or') ; Output.WriteLn ;
   Output.WriteString('@c any later version published by the Free Software Foundation.') ; Output.WriteLn
END EmitFDLNotice ;


(*
   EmitRules - generates the BNF rules.
*)

PROCEDURE EmitRules ;
BEGIN
   IF Texinfo AND FreeDocLicense
   THEN
      EmitFDLNotice
   END ;
   ForeachRuleDo(EmitRule)
END EmitRules ;


(*
   DescribeElement -
*)

PROCEDURE DescribeElement (name: WORD) ;
VAR
   lit: Name ;
BEGIN
   IF InitialElement
   THEN
      InitialElement := FALSE
   ELSE
      Output.WriteString(' |')
   END ;
   Output.WriteLn ;
   Indent := 3 ;
   IndentString('') ;
   Output.WriteKey(name) ;
   Output.WriteString(': ') ;
   lit := GetSymKey(ReverseAliases, name) ;
   IF MakeKey('"')=lit
   THEN
      Output.WriteString('str := ConCat(ConCatChar(ConCatChar(InitString("syntax error, found ') ;
      Output.Write("'") ; Output.WriteString('"), ') ;
      Output.Write("'") ; Output.Write('"') ; Output.Write("'") ; Output.WriteString("), ") ;
      Output.Write('"') ; Output.Write("'") ; Output.Write('"') ; Output.WriteString("), Mark(str))")
   ELSIF MakeKey("'")=lit
   THEN
     Output.WriteString("str := ConCat(ConCatChar(ConCatChar(InitString('syntax error, found ") ;
     Output.Write('"') ; Output.WriteString("'), ") ;
     Output.Write('"') ; Output.Write("'") ; Output.Write('"') ; Output.WriteString('), ') ;
     Output.Write("'") ; Output.Write('"') ; Output.Write("'") ; Output.WriteString('), Mark(str))')
   ELSE
     Output.WriteString("str := ConCat(InitString(") ; Output.Write('"') ;
     Output.WriteString("syntax error, found ") ; KeyWord(lit) ; Output.WriteString('"), Mark(str))')
   END
END DescribeElement ;


(*
   EmitInTestStop - construct a test for stop element, name.
*)

PROCEDURE EmitInTestStop (name: Name) ;
VAR
   i, value: CARDINAL ;
BEGIN
   IF LargestValue<=MaxElementsInSet
   THEN
      Output.WriteKey(name) ; Output.WriteString(' IN stopset') ;
      INCL (ParametersUsed, 0)
   ELSE
      value := GetSymKey(Values, name) ;
      i := value DIV MaxElementsInSet ;
      Output.WriteKey(name) ; Output.WriteString(' IN stopset') ; Output.WriteCard(i, 0) ;
      INCL (ParametersUsed, i)
   END
END EmitInTestStop ;


(*
   DescribeStopElement -
*)

PROCEDURE DescribeStopElement (name: WORD) ;
VAR
   lit: Name ;
BEGIN
   Indent := 3 ;
   IndentString('IF ') ; EmitInTestStop(name) ; Output.WriteLn ;
   IndentString('THEN') ; Output.WriteLn ;
   Indent := 6 ;
   lit := GetSymKey(ReverseAliases, name) ;
   IF (lit=NulName) OR (lit=MakeKey(''))
   THEN
      IndentString('(* ') ;
      Output.WriteKey(name) ;
      Output.WriteString(' has no token name (needed to generate error messages) *)')
   ELSIF MakeKey("'")=lit
   THEN
      IndentString('message := ConCatChar(ConCatChar(ConCatChar(ConCatChar(ConCatChar(message, ') ;
      Output.WriteString("' '), ") ;
      Output.Write("'") ; Output.Write('"') ; Output.WriteString("'), ") ;
      Output.Write('"') ; Output.Write("'") ; Output.WriteString('"), ') ;
      Output.Write("'") ; Output.Write('"') ; Output.WriteString("'), ',') ; INC(n) ; ")
   ELSIF MakeKey('"')=lit
   THEN
      IndentString("message := ConCatChar(ConCatChar(ConCatChar(ConCatChar(ConCatChar(message, ") ;
      Output.WriteString('" "), ') ;
      Output.Write('"') ; Output.Write("`") ; Output.WriteString('"), ') ;
      Output.Write("'") ; Output.Write('"') ; Output.WriteString("'), ") ;
      Output.Write('"') ; Output.Write("'") ; Output.WriteString('"), ",") ; INC(n) ; ')
   ELSE
      IndentString("message := ConCat(ConCatChar(message, ' ") ; Output.WriteString("'), ") ;
      Output.WriteString('Mark(InitString("') ; KeyWord(lit) ; Output.Write('"') ;
      Output.WriteString('))) ; INC(n)')
   END ;
   Output.WriteLn ;
   Indent := 3 ;
   IndentString('END ;') ; Output.WriteLn
END DescribeStopElement ;


(*
   EmitDescribeStop -
*)

PROCEDURE EmitDescribeStop ;
VAR
   s: String ;
BEGIN
   Output.WriteLn ;
   Indent := 0 ;
   IndentString('(*') ;
   Indent := 3 ;
   Output.WriteLn ;
   IndentString('DescribeStop - issues a message explaining what tokens were expected') ;
   Output.WriteLn ;
   Output.WriteString('*)') ;
   Output.WriteLn ;
   Output.WriteLn ;
   Indent := 0 ;
   IndentString('PROCEDURE DescribeStop (') ;
   ParametersUsed := {} ;
   Output.StartBuffer ;
   Output.WriteString(') : String ;') ;
   Output.WriteLn ;
   IndentString('VAR') ; Output.WriteLn ;
   Indent := 3 ;
   IndentString('n      : CARDINAL ;') ; Output.WriteLn ;
   IndentString('str,') ; Output.WriteLn ;
   IndentString('message: String ;') ; Output.WriteLn ;
   Indent := 0 ;
   IndentString('BEGIN') ; Output.WriteLn ;
   Indent := 3 ;
   IndentString('n := 0 ;') ; Output.WriteLn ;
   IndentString("message := InitString('') ;") ;
   Output.WriteLn ;
   ForeachNodeDo(Aliases, DescribeStopElement) ; Output.WriteLn ;
   Indent := 3 ;
   IndentString('IF n=0') ; Output.WriteLn ;
   IndentString('THEN') ; Output.WriteLn ;
   Indent := 6 ;
   IndentString("str := InitString(' syntax error') ; ") ; Output.WriteLn ;
   IndentString('message := KillString(message) ; ') ; Output.WriteLn ;
   Indent := 3 ;
   IndentString('ELSIF n=1') ; Output.WriteLn ;
   IndentString('THEN') ; Output.WriteLn ;
   Indent := 6 ;
   IndentString("str := ConCat(message, Mark(InitString(' missing '))) ;") ; Output.WriteLn ;
   Indent := 3 ;
   IndentString('ELSE') ; Output.WriteLn ;
   Indent := 6 ;
   IndentString("str := ConCat(InitString(' expecting one of'), message) ;") ; Output.WriteLn ;
   IndentString("message := KillString(message) ;") ; Output.WriteLn ;
   Indent := 3 ;
   IndentString('END ;') ; Output.WriteLn ;
   IndentString('RETURN( str )') ; Output.WriteLn ;
   Indent := 0 ;
   IndentString('END DescribeStop ;') ; Output.WriteLn ;
   Output.WriteLn ;
   s := Output.EndBuffer () ;
   EmitStopParameters(TRUE) ;
   Output.KillWriteS (s)
END EmitDescribeStop ;


(*
   EmitDescribeError -
*)

PROCEDURE EmitDescribeError ;
BEGIN
   Output.WriteLn ;
   Indent := 0 ;
   IndentString('(*') ; Output.WriteLn ;
   Indent := 3 ;
   IndentString('DescribeError - issues a message explaining what tokens were expected') ; Output.WriteLn ;
   Indent := 0 ;
   IndentString('*)') ;
   Output.WriteLn ;
   Output.WriteLn ;
   IndentString('PROCEDURE DescribeError ;') ;
   Output.WriteLn ;
   IndentString('VAR') ; Output.WriteLn ;
   Indent := 3 ;
   IndentString('str: String ;') ; Output.WriteLn ;
   Indent := 0 ;
   IndentString('BEGIN') ; Output.WriteLn ;
   Indent := 3 ;
   IndentString("str := InitString('') ;") ; Output.WriteLn ;
   (* was
   IndentString('str := DescribeStop(') ; EmitStopParameters(FALSE) ; Output.WriteString(') ;') ; Output.WriteLn ;
   *)
   IndentString('CASE ') ; WriteGetTokenType ; Output.WriteString(' OF') ; NewLine(3) ;
   InitialElement := TRUE ;
   ForeachNodeDo(Aliases, DescribeElement) ;
   Output.WriteLn ;
   Indent := 3 ;
   IndentString('ELSE') ; Output.WriteLn ;
   IndentString('END ;') ; Output.WriteLn ;
   IndentString('') ;
   Output.WriteKey(ErrorProcString) ; Output.WriteString('(str) ;') ; Output.WriteLn ;
   Indent := 0 ;
   IndentString('END DescribeError ;') ; Output.WriteLn
END EmitDescribeError ;


(*
   EmitSetTypes - write out the set types used during error recovery
*)

PROCEDURE EmitSetTypes ;
VAR
   i, j, m, n: CARDINAL ;
BEGIN
   Output.WriteString('(*') ; NewLine(3) ;
   Output.WriteString('expecting token set defined as an enumerated type') ; NewLine(3) ;
   Output.WriteString('(') ;
   i := 0 ;
   WHILE i<LargestValue DO
      Output.WriteKey(GetSymKey(ReverseValues, WORD(i))) ;
      INC(i) ;
      IF i<LargestValue
      THEN
         Output.WriteString(', ')
      END
   END ;
   Output.WriteString(') ;') ; NewLine(0) ;
   Output.WriteString('*)') ; NewLine(0) ;
   Output.WriteString('TYPE') ; NewLine(3) ;
   IF LargestValue>MaxElementsInSet
   THEN
      i := 0 ;
      n := LargestValue DIV MaxElementsInSet ;
      WHILE i<=n DO
         j := (i*MaxElementsInSet) ;
         IF LargestValue<(i+1)*MaxElementsInSet-1
         THEN
            m := LargestValue-1
         ELSE
            m := (i+1)*MaxElementsInSet-1
         END ;
         Output.WriteString('stop') ; Output.WriteCard(i, 0) ;
         Output.WriteString(' = [') ;
         Output.WriteKey(GetSymKey(ReverseValues, WORD(j))) ;
         Output.WriteString('..') ;
         Output.WriteKey(GetSymKey(ReverseValues, WORD(m))) ;
         Output.WriteString('] ;') ;
         NewLine(3) ;
         Output.WriteString('SetOfStop') ; Output.WriteCard(i, 0) ;
         Output.WriteString(' = SET OF stop') ; Output.WriteCard(i, 0) ;
         Output.WriteString(' ;') ;
         NewLine(3) ;
         INC(i)
      END
   ELSE
      Output.WriteString('SetOfStop') ;
      Output.WriteString(' = SET OF [') ;
      Output.WriteKey(GetSymKey(ReverseValues, WORD(0))) ;
      Output.WriteString('..') ;
      Output.WriteKey(GetSymKey(ReverseValues, WORD(LargestValue-1))) ;
      Output.WriteString('] ;')
   END ;
   NewLine(0)
END EmitSetTypes ;


(*
   EmitSupport - generates the support routines.
*)

PROCEDURE EmitSupport ;
BEGIN
   IF ErrorRecovery
   THEN
      EmitSetTypes ;
      EmitDescribeStop ;
      EmitDescribeError
   END
END EmitSupport ;


(*
   DisposeSetDesc - dispose of the set list, s.
*)

PROCEDURE DisposeSetDesc (VAR s: SetDesc) ;
VAR
   h, n: SetDesc ;
BEGIN
   IF s#NIL
   THEN
      h := s ;
      n := s^.next ;
      REPEAT
         DISPOSE(h) ;
         h := n ;
         IF n#NIL
         THEN
            n := n^.next
         END
      UNTIL h=NIL ;
      s := NIL
   END
END DisposeSetDesc ;


(*
   OptionalFactor -
*)

PROCEDURE OptionalFactor (f: FactorDesc) : BOOLEAN ;
BEGIN
   WHILE f#NIL DO
      WITH f^ DO
         CASE type OF

         id  :  |
         lit :  |
         sub ,
         opt ,
         mult:  IF OptionalExpression(expr)
                THEN
                   RETURN( TRUE )
                END |
         m2  :

         ELSE
         END
      END ;
      f := f^.next
   END ;
   RETURN( FALSE )
END OptionalFactor ;


(*
   OptionalTerm - returns TRUE if the term maybe empty.
*)

PROCEDURE OptionalTerm (t: TermDesc) : BOOLEAN ;
VAR
   u, v    : TermDesc ;
   tov, tou: SetDesc ;
BEGIN
   u := t ;
   WHILE u#NIL DO
      IF OptionalFactor(u^.factor)
      THEN
         RETURN( TRUE )
      END ;
      v := t ;
      tou := NIL ;
      CalcFirstFactor(u^.factor, NIL, tou) ;
      WHILE v#NIL DO
         IF v#u
         THEN
            tov := NIL ;
            CalcFirstFactor(v^.factor, NIL, tov) ;
            IF IntersectionIsNil(tov, tou)
            THEN
               DisposeSetDesc(tov) ;
            ELSE
               WriteString('problem with two first sets. Set 1: ') ;
               EmitSet(tou, 0, 0) ; WriteLn ;
               WriteString('                             Set 2: ') ;
               EmitSet(tov, 0, 0) ; WriteLn ;
               DisposeSetDesc(tou) ;
               DisposeSetDesc(tov) ;
               RETURN( TRUE )
            END
         END ;
         v := v^.next
      END ;
      DisposeSetDesc(tou) ;
      u := u^.next
   END ;
   RETURN( FALSE )
END OptionalTerm ;


(*
   OptionalExpression -
*)

PROCEDURE OptionalExpression (e: ExpressionDesc) : BOOLEAN ;
BEGIN
   IF e=NIL
   THEN
      RETURN( FALSE )
   ELSE
      RETURN( OptionalTerm(e^.term) )
   END
END OptionalExpression ;


(*
   OptionalStatement - returns FALSE if statement, s, does not have a optional ambiguity.
*)

PROCEDURE OptionalStatement (s: StatementDesc) : BOOLEAN ;
BEGIN
   IF s=NIL
   THEN
      RETURN( FALSE )
   ELSE
      RETURN( OptionalExpression(s^.expr) )
   END
END OptionalStatement ;


(*
   OptionalProduction -
*)

PROCEDURE OptionalProduction (p: ProductionDesc) : BOOLEAN ;
BEGIN
   IF p=NIL
   THEN
      RETURN( FALSE )
   ELSE
      RETURN( OptionalStatement(p^.statement) )
   END
END OptionalProduction ;


(*
   CheckFirstFollow -
*)

PROCEDURE CheckFirstFollow (f: FactorDesc; after: FactorDesc) : BOOLEAN ;
VAR
   first, follow: SetDesc ;
BEGIN
   first := NIL ;
   CalcFirstFactor(f, NIL, first) ;
   follow := NIL ;
   follow := GetFollow(f^.followinfo) ;
   IF IntersectionIsNil(first, follow)
   THEN
      DisposeSetDesc(first) ;
      DisposeSetDesc(follow) ;
      RETURN( FALSE )
   ELSE
      PrettyCommentFactor(f, 3) ;
      NewLine(3) ;
      WriteString('first: ') ;
      EmitSet(first, 0, 0) ;
      NewLine(3) ;
      WriteString('follow: ') ;
      EmitSet(follow, 0, 0) ;
      NewLine(3) ;
      DisposeSetDesc(first) ;
      DisposeSetDesc(follow) ;
      RETURN( TRUE )
   END
END CheckFirstFollow ;


(*
   ConstrainedEmptyFactor -
*)

PROCEDURE ConstrainedEmptyFactor (f: FactorDesc) : BOOLEAN ;
BEGIN
   WHILE f#NIL DO
      WITH f^ DO
         CASE type OF

         id  :  |
         lit :  |
         sub ,
         opt ,
         mult:  IF ConstrainedEmptyExpression(expr)
                THEN
                   RETURN( TRUE )
                END |
         m2  :

         ELSE
         END
      END ;
      IF (f^.type#m2) AND EmptyFactor(f) AND CheckFirstFollow(f, f^.next)
      THEN
         RETURN( TRUE )
      END ;
      f := f^.next
   END ;
   RETURN( FALSE )
END ConstrainedEmptyFactor ;


(*
   ConstrainedEmptyTerm - returns TRUE if the term maybe empty.
*)

PROCEDURE ConstrainedEmptyTerm (t: TermDesc) : BOOLEAN ;
VAR
   first, follow: SetDesc ;
BEGIN
   WHILE t#NIL DO
      IF ConstrainedEmptyFactor(t^.factor)
      THEN
         RETURN( TRUE )
      ELSIF (t^.factor^.type#m2) AND EmptyFactor(t^.factor) AND CheckFirstFollow(t^.factor, t^.factor^.next)
      THEN
         RETURN( TRUE )
      END ;
      t := t^.next
   END ;
   RETURN( FALSE )
END ConstrainedEmptyTerm ;


(*
   ConstrainedEmptyExpression -
*)

PROCEDURE ConstrainedEmptyExpression (e: ExpressionDesc) : BOOLEAN ;
BEGIN
   IF e=NIL
   THEN
      RETURN( FALSE )
   ELSE
      RETURN( ConstrainedEmptyTerm(e^.term) )
   END
END ConstrainedEmptyExpression ;


(*
   ConstrainedEmptyStatement - returns FALSE if statement, s, does not have a optional ambiguity.
*)

PROCEDURE ConstrainedEmptyStatement (s: StatementDesc) : BOOLEAN ;
BEGIN
   IF s=NIL
   THEN
      RETURN( FALSE )
   ELSE
      RETURN( ConstrainedEmptyExpression(s^.expr) )
   END
END ConstrainedEmptyStatement ;


(*
   ConstrainedEmptyProduction - returns TRUE if a problem exists with, p.
*)

PROCEDURE ConstrainedEmptyProduction (p: ProductionDesc) : BOOLEAN ;
BEGIN
   IF p=NIL
   THEN
      RETURN( FALSE )
   ELSE
      RETURN( ConstrainedEmptyStatement(p^.statement) )
   END
END ConstrainedEmptyProduction ;


(*
   TestForLALR1 -
*)

PROCEDURE TestForLALR1 (p: ProductionDesc) ;
BEGIN
   IF OptionalProduction(p)
   THEN
      WarnError1('production %s has two optional sentances using | which both have the same start symbols',
                 p^.statement^.ident^.name) ;
      WasNoError := FALSE ;
      PrettyCommentProduction(p)
   END ;
(*
   IF ConstrainedEmptyProduction(p)
   THEN
      WarnError1('production %s has an empty sentance and the first and follow symbols intersect',
                 p^.statement^.ident^.name) ;
      WasNoError := FALSE
   END
*)
END TestForLALR1 ;


(*
   DoEpsilon - runs the epsilon interrelated rules
*)

PROCEDURE DoEpsilon (p: ProductionDesc) ;
BEGIN
   CalcEpsilonProduction(p) ;
   CalcReachEndProduction(p)
END DoEpsilon ;


(*
   CheckComplete - checks that production, p, is complete.
*)

PROCEDURE CheckComplete (p: ProductionDesc) ;
BEGIN
   IF GetReachEnd(p^.followinfo)=unknown
   THEN
      PrettyCommentProduction(p) ;
      WarnError1('cannot determine epsilon, probably a left recursive rule in %s and associated rules (hint rewrite using ebnf and eliminate left recursion)',
                 p^.statement^.ident^.name) ;
      WasNoError := FALSE
   END
END CheckComplete ;


(*
   PostProcessRules - backpatch the ident to rule definitions and emit comments and code.
*)

PROCEDURE PostProcessRules ;
BEGIN
   ForeachRuleDo(BackPatchIdentToDefinitions) ;
   IF NOT WasNoError
   THEN
      HALT
   END ;
   WhileNotCompleteDo(DoEpsilon) ;
   IF NOT WasNoError
   THEN
      HALT
   END ;
   ForeachRuleDo(CheckComplete) ;
   IF NOT WasNoError
   THEN
      HALT
   END ;
   WhileNotCompleteDo(CalculateFirstAndFollow) ;
   IF NOT WasNoError
   THEN
      HALT
   END ;
   ForeachRuleDo(TestForLALR1) ;
   IF NOT WasNoError
   THEN
      ForeachRuleDo(PrettyCommentProduction)
   END
END PostProcessRules ;


(*
   DisplayHelp - display a summary help and then exit (0).
*)

PROCEDURE DisplayHelp ;
BEGIN
   WriteString('Usage: ppg [-l] [-c] [-d] [-e] [-k] [-t] [-k] [-p] [-x] [-f] [-o outputfile] filename') ; WriteLn ;
   WriteString('   -l             suppress file and line source information') ; WriteLn ;
   WriteString('   -c             do not generate any Modula-2 code within the parser rules') ; WriteLn ;
   WriteString('   -h or --help   generate this help message') ; WriteLn ;
   WriteString('   -e             do not generate a parser with error recovery') ; WriteLn ;
   WriteString('   -k             generate keyword errors with GCC formatting directives') ; WriteLn ;
   WriteString('   -d             generate internal debugging information') ; WriteLn ;
   WriteString('   -p             only display the ebnf rules') ; WriteLn ;
   WriteString('   -t             generate texinfo formating for pretty printing (-p)') ; WriteLn ;
   WriteString('   -x             generate sphinx formating for pretty printing (-p)') ; WriteLn ;
   WriteString('   -f             generate GNU Free Documentation header before pretty printing in texinfo') ; WriteLn ;
   WriteString('   -o             write output to filename') ; WriteLn ;
   exit (0)
END DisplayHelp ;


(*
   ParseArgs -
*)

PROCEDURE ParseArgs ;
VAR
   n, i: CARDINAL ;
BEGIN
   ErrorRecovery     := TRUE ;  (* DefaultRecovery ; *)
   Debugging         := FALSE ;
   PrettyPrint       := FALSE ;
   KeywordFormatting := FALSE ;
   i := 1 ;
   n := Narg() ;
   WHILE i<n DO
      IF GetArg(ArgName, i)
      THEN
         IF StrEqual(ArgName, '-e')
         THEN
            ErrorRecovery := FALSE
         ELSIF StrEqual(ArgName, '-d')
         THEN
            Debugging := TRUE ;
            SetDebugging(TRUE)
         ELSIF StrEqual(ArgName, '-c')
         THEN
            EmitCode := FALSE
         ELSIF StrEqual(ArgName, '-k')
         THEN
            KeywordFormatting := TRUE
         ELSIF StrEqual(ArgName, '-l')
         THEN
            SuppressFileLineTag := TRUE
         ELSIF StrEqual(ArgName, '-h') OR StrEqual(ArgName, '--help')
         THEN
            DisplayHelp
         ELSIF StrEqual(ArgName, '-p')
         THEN
            PrettyPrint := TRUE
         ELSIF StrEqual(ArgName, '-t')
         THEN
            Texinfo := TRUE
         ELSIF StrEqual(ArgName, '-x')
         THEN
            Sphinx := TRUE
         ELSIF StrEqual(ArgName, '-f')
         THEN
            FreeDocLicense := TRUE
         ELSIF StrEqual(ArgName, '-o')
         THEN
            INC (i) ;
            IF GetArg(ArgName, i)
            THEN
               IF NOT Output.Open (ArgName)
               THEN
                  WriteString('cannot open ') ; WriteString(ArgName) ;
                  WriteString(' for writing') ; WriteLn ;
                  exit (1)
               END
            END
         ELSIF OpenSource(ArgName)
         THEN
            StrCopy (ArgName, FileName) ;
            AdvanceToken
         ELSE
            WriteString('cannot open ') ; WriteString(ArgName) ;
            WriteString(' for reading') ; WriteLn ;
            exit (1)
         END
      END ;
      INC (i)
   END ;
   IF n=1
   THEN
      DisplayHelp
   END
END ParseArgs ;


(*
   Init - initialize the modules data structures
*)

PROCEDURE Init ;
BEGIN
   WasNoError        := TRUE ;
   Texinfo           := FALSE ;
   Sphinx            := FALSE ;
   FreeDocLicense    := FALSE ;
   EmitCode          := TRUE ;
   LargestValue      := 0 ;
   HeadProduction    := NIL ;
   CurrentProduction := NIL ;
   InitTree(Aliases) ;
   InitTree(ReverseAliases) ;
   InitTree(Values) ;
   InitTree(ReverseValues) ;
   LastLineNo        := 0 ;
   CodePrologue      := NIL ;
   CodeEpilogue      := NIL ;
   CodeDeclaration   := NIL ;
   ErrorProcArray    := MakeKey('Error') ;
   ErrorProcString   := MakeKey('ErrorS') ;
   TokenTypeProc     := MakeKey('GetCurrentTokenType()') ;
   SymIsProc         := MakeKey('SymIs') ;
   OnLineStart       := TRUE ;
   ParseArgs ;
   WasNoError := Main() ;             (* this line will be manipulated by sed in buildpg *)
   IF WasNoError
   THEN
      PostProcessRules ;
      IF WasNoError
      THEN
         IF Debugging
         THEN
            EmitRules
         ELSIF PrettyPrint
         THEN
            EmitRules
         ELSE
            Output.WriteString('(* it is advisable not to edit this file as it was automatically generated from the grammer file ') ;
            Output.WriteString(FileName) ; Output.WriteString(' *)') ; Output.WriteLn ;
            OnLineStart := FALSE ;
            EmitFileLineTag(LinePrologue) ;
            BeginningOfLine := TRUE ;
            WriteCodeHunkList(CodePrologue) ;
            EmitSupport ;
            EmitFileLineTag(LineDeclaration) ;
            WriteCodeHunkList(CodeDeclaration) ;
            EmitRules ;
            (* code rules *)
            EmitFileLineTag(LineEpilogue) ;
            WriteCodeHunkList(CodeEpilogue)
         END
      END
   END ;
   Output.Close
END Init ;


BEGIN
   Init
END ppg.
(*
 * Local variables:
 *  compile-command: "gm2 -I../gm2-libs:. -fbounds -freturn -c -g ppg.mod"
 * End:
 *)