path: root/gcc/m2/gm2-compiler/M2MetaError.mod

(* M2MetaError.mod provides a set of high level error routines.

Copyright (C) 2008-2025 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/>.  *)

IMPLEMENTATION MODULE M2MetaError ;


FROM M2Base IMPORT ZType, RType, IsPseudoBaseFunction, IsPseudoBaseProcedure ;
FROM NameKey IMPORT Name, KeyToCharStar, NulName ;
FROM StrLib IMPORT StrLen ;
FROM M2LexBuf IMPORT GetTokenNo, UnknownTokenNo ;
FROM M2Error IMPORT Error, NewError, NewWarning, NewNote, ErrorString, InternalError, ChainError, SetColor, FlushErrors, FlushWarnings ;
FROM FIO IMPORT StdOut, WriteLine ;
FROM SFIO IMPORT WriteS ;
FROM StringConvert IMPORT ctos ;
FROM M2Printf IMPORT printf1, printf0 ;
FROM M2Options IMPORT LowerCaseKeywords ;
FROM StrCase IMPORT Lower ;
FROM libc IMPORT printf ;
FROM SYSTEM IMPORT ADDRESS ;
FROM M2Error IMPORT MoveError ;
FROM M2Debug IMPORT Assert ;
FROM Storage IMPORT ALLOCATE ;

FROM Indexing IMPORT Index, InitIndex, KillIndex, GetIndice, PutIndice,
                     DeleteIndice, HighIndice ;

FROM DynamicStrings IMPORT String, InitString, InitStringCharStar,
                           ConCat, ConCatChar, Mark, string, KillString,
                           Dup, char, Length, Mult, EqualArray, Equal ;

FROM SymbolTable IMPORT NulSym,
                        IsDefImp, IsModule, IsInnerModule,
                        IsUnknown, IsType, IsProcedure, IsParameter,
                        IsParameterUnbounded, IsParameterVar, IsVarParam,
                        IsUnboundedParamAny, IsPointer, IsRecord, IsVarient,
                        IsFieldVarient, IsEnumeration, IsFieldEnumeration,
                        IsUnbounded, IsArray, IsRecordField, IsProcType,
                        IsVar, IsConst, IsConstString, IsConstLit, IsConstSet,
                        IsConstructor, IsDummy, IsTemporary, IsVarAParam,
                        IsSubscript, IsSubrange, IsSet, IsHiddenType,
                        IsError, GetSymName, GetScope, IsExported,
                        GetType, SkipType, GetDeclaredDef, GetDeclaredMod,
                        GetDeclaredFor, GetDeclaredModule,
                        GetDeclaredDefinition, GetScope,
                        GetFirstUsed, IsNameAnonymous, GetErrorScope,
                        GetVarDeclTok, GetVarDeclTypeTok, GetVarDeclFullTok ;

IMPORT M2ColorString ;
IMPORT M2Error ;


CONST
   MaxStack   = 10 ;
   Debugging  = FALSE ;
   ColorDebug = FALSE ;

TYPE
   GetTokProcedure = PROCEDURE (CARDINAL) : CARDINAL ;

   errorType = (none, error, warning, note, chained, aborta) ;
   colorType = (unsetColor, noColor, quoteColor, filenameColor, errorColor,
                warningColor, noteColor, keywordColor, locusColor,
                insertColor, deleteColor, typeColor, range1Color, range2Color) ;

   errorBlock = RECORD
                   useError  : BOOLEAN ;
                   e         : Error ;
                   type      : errorType ;
                   out, in   : String ;
                   highplus1 : CARDINAL ;
                   len,
                   ini       : INTEGER ;
                   glyph,
                   chain,
                   root,
                   quotes,
                   positive  : BOOLEAN ;
                   currentCol,
                   beginCol,                (* the color at the start of the string.          *)
                   endCol    : colorType ;  (* the color at the end of the text before.       *)
                   colorStack: ARRAY [0..MaxStack] OF colorType ;
                   stackPtr  : CARDINAL ;
                END ;


    dictionaryEntry = POINTER TO RECORD
                                    key,
                                    value: String ;
                                    next : dictionaryEntry ;
                                 END ;


VAR
   lastRoot  : Error ;
   lastColor : colorType ;
   seenAbort : BOOLEAN ;
   dictionary : Index ;
   outputStack: Index ;
   freeEntry  : dictionaryEntry ;


(*
   pushOutput -
*)

PROCEDURE pushOutput (VAR eb: errorBlock) ;
BEGIN
   PutIndice (outputStack, HighIndice (outputStack)+1, eb.out) ;
   eb.out := InitString ('') ;
   eb.glyph := FALSE
END pushOutput ;


(*
   readWord - reads and returns a word delimited by '}' it uses '%' as
              the escape character.
*)

PROCEDURE readWord (VAR eb: errorBlock) : String ;
VAR
   word: String ;
BEGIN
   word := InitString ('') ;
   WHILE (eb.ini < eb.len) AND (char (eb.in, eb.ini) # "}") DO
      IF char (eb.in, eb.ini) = "%"
      THEN
         INC (eb.ini)
      END ;
      word := ConCatChar (word, char (eb.in, eb.ini)) ;
      INC (eb.ini)
   END ;
   RETURN word
END readWord ;


(*
   addEntry -
*)

PROCEDURE addEntry (key, value: String) ;
VAR
   e: dictionaryEntry ;
   s: String ;
   i: CARDINAL ;
BEGIN
   s := lookupString (key) ;
   IF s = NIL
   THEN
      e := newEntry () ;
      e^.key := key ;
      e^.value := value ;
      PutIndice (dictionary, HighIndice (dictionary)+1, e)
   ELSE
      i := 1 ;
      WHILE i <= HighIndice (dictionary) DO
         e := GetIndice (dictionary, i) ;
         IF Equal (e^.key, key)
         THEN
            e^.value := KillString (e^.value) ;
            e^.value := value ;
            RETURN
         END ;
         INC (i)
      END
   END
END addEntry ;


(*
   popOutput -
*)

PROCEDURE popOutput (VAR eb: errorBlock) ;
VAR
   key,
   previous: String ;
BEGIN
   IF HighIndice (outputStack) >= 1
   THEN
      previous := GetIndice (outputStack, HighIndice (outputStack)) ;
      DeleteIndice (outputStack, HighIndice (outputStack)) ;
      key := readWord (eb) ;
      addEntry (key, eb.out) ;
      eb.out := previous
   END
END popOutput ;


(*
   newEntry -
*)

PROCEDURE newEntry () : dictionaryEntry ;
VAR
   e: dictionaryEntry ;
BEGIN
   IF freeEntry = NIL
   THEN
      NEW (e)
   ELSE
      e := freeEntry ;
      freeEntry := freeEntry^.next
   END ;
   WITH e^ DO
      key := NIL ;
      value := NIL ;
      next := NIL
   END ;
   RETURN e
END newEntry ;


(*
   killEntry - dispose e and delete any strings.
*)

PROCEDURE killEntry (e: dictionaryEntry) ;
BEGIN
   e^.next := freeEntry ;
   freeEntry := e ;
   IF e^.key # NIL
   THEN
      e^.key := KillString (e^.key)
   END ;
   IF e^.value # NIL
   THEN
      e^.value := KillString (e^.value)
   END
END killEntry ;


(*
   resetDictionary - remove all entries in the dictionary.
*)

PROCEDURE resetDictionary ;
VAR
   i: CARDINAL ;
   e: dictionaryEntry ;
BEGIN
   i := 1 ;
   WHILE i <= HighIndice (dictionary) DO
      e := GetIndice (dictionary, i) ;
      killEntry (e) ;
      INC (i)
   END ;
   dictionary := KillIndex (dictionary) ;
   dictionary := InitIndex (1)
END resetDictionary ;


(*
   lookupString - lookup and return a duplicate of the string value for key s.
                  NIL is returned if the key s is unknown.
*)

PROCEDURE lookupString (s: String) : String ;
VAR
   i: CARDINAL ;
   e: dictionaryEntry ;
BEGIN
   i := 1 ;
   WHILE i <= HighIndice (dictionary) DO
      e := GetIndice (dictionary, i) ;
      IF Equal (e^.key, s)
      THEN
         RETURN Dup (e^.value)
      END ;
      INC (i)
   END ;
   RETURN NIL
END lookupString ;


(*
   lookupDefine - looks up the word in the input string (ending with '}').
                  It uses this word as a key into the dictionary and returns
                  the entry.
*)

PROCEDURE lookupDefine (VAR eb: errorBlock) : String ;
VAR
   s: String ;
BEGIN
   s := InitString ('') ;
   WHILE (eb.ini < eb.len) AND (char (eb.in, eb.ini) # "}") DO
      IF char (eb.in, eb.ini) = "%"
      THEN
         INC (eb.ini)
      END ;
      s := ConCatChar (s, char (eb.in, eb.ini)) ;
      INC (eb.ini)
   END ;
   s := lookupString (s) ;
   IF s = NIL
   THEN
      s := InitString ('')
   END ;
   RETURN s
END lookupDefine ;


(*
   processDefine - place contents of dictionary entry name onto the output string.
*)

PROCEDURE processDefine (VAR eb: errorBlock) ;
BEGIN
   eb.out := ConCat (eb.out, lookupDefine (eb))
END processDefine ;


(*
   lookupColor - looks up the color enum from the string.
*)

PROCEDURE lookupColor (s: String) : colorType ;
BEGIN
   IF EqualArray (s, "filename")
   THEN
      RETURN filenameColor
   ELSIF EqualArray (s, "quote")
   THEN
      RETURN quoteColor
   ELSIF EqualArray (s, "error")
   THEN
      RETURN errorColor
   ELSIF EqualArray (s, "warning")
   THEN
      RETURN warningColor ;
   ELSIF EqualArray (s, "note")
   THEN
      RETURN warningColor ;
   ELSIF EqualArray (s, "locus")
   THEN
      RETURN locusColor
   ELSIF EqualArray (s, "insert")
   THEN
      RETURN insertColor
   ELSIF EqualArray (s, "delete")
   THEN
      RETURN deleteColor
   ELSIF EqualArray (s, "type")
   THEN
      RETURN typeColor
   ELSIF EqualArray (s, "range1")
   THEN
      RETURN range1Color
   ELSIF EqualArray (s, "range2")
   THEN
      RETURN range2Color
   END ;
   RETURN noColor
END lookupColor ;


(*
   readColor -
*)

PROCEDURE readColor (VAR eb: errorBlock) : colorType ;
VAR
   s: String ;
   c: colorType ;
BEGIN
   s := InitString ('') ;
   WHILE (eb.ini < eb.len) AND (char (eb.in, eb.ini) # "}") DO
      IF char (eb.in, eb.ini) = "%"
      THEN
         INC (eb.ini)
      END ;
      s := ConCatChar (s, char (eb.in, eb.ini)) ;
      INC (eb.ini)
   END ;
   c := lookupColor (s) ;
   s := KillString (s) ;
   RETURN c
END readColor ;


(*
   keyword - copy characters until the '}' in the input string and convert them to
             the keyword color/font.
*)

PROCEDURE keyword (VAR eb: errorBlock) ;
BEGIN
   IF CAP (char (eb.in, eb.ini)) = 'K'
   THEN
      INC (eb.ini) ;
      pushColor (eb) ;
      changeColor (eb, keywordColor) ;
      WHILE (eb.ini < eb.len) AND (char (eb.in, eb.ini) # "}") DO
         IF Debugging
         THEN
            dump (eb)
         END ;
         IF char (eb.in, eb.ini) = "%"
         THEN
            INC (eb.ini)
         END ;
         copyKeywordChar (eb) ;
         INC (eb.ini)
      END ;
      popColor (eb)
   ELSE
      InternalError ('expecting index to be on the K for keyword')
   END
END keyword ;


(*
   filename - copy characters until the '}' in the input string and convert them to
              the filename color/font.
*)

PROCEDURE filename (VAR eb: errorBlock) ;
BEGIN
   IF CAP (char (eb.in, eb.ini)) = 'F'
   THEN
      INC (eb.ini) ;
      pushColor (eb) ;
      changeColor (eb, filenameColor) ;
      WHILE (eb.ini < eb.len) AND (char (eb.in, eb.ini) # "}") DO
         IF Debugging
         THEN
            dump (eb)
         END ;
         IF char (eb.in, eb.ini) = "%"
         THEN
            INC (eb.ini)
         END ;
         copyChar (eb) ;
         INC (eb.ini)
      END ;
      popColor (eb)
   ELSE
      InternalError ('expecting index to be on the F for filename')
   END
END filename ;


(*
   pushColor -
*)

PROCEDURE pushColor (VAR eb: errorBlock) ;
BEGIN
   WITH eb DO
      IF stackPtr > MaxStack
      THEN
         HALT
      ELSE
         colorStack[stackPtr] := currentCol ;
         INC (stackPtr)
      END
   END
END pushColor ;


(*
   popColor -
*)

PROCEDURE popColor (VAR eb: errorBlock) ;
BEGIN
   WITH eb DO
      IF stackPtr > 0
      THEN
         DEC (stackPtr)
      ELSE
         HALT
      END ;
      currentCol := colorStack[stackPtr] ;
      IF currentCol = unsetColor
      THEN
         currentCol := noColor
      END
   END
END popColor ;


(*
   initErrorBlock - initialise an error block with the, input, string.
*)

PROCEDURE initErrorBlock (VAR eb: errorBlock; input: String; sym: ARRAY OF CARDINAL) ;
BEGIN
   WITH eb DO
      useError   := TRUE ;
      e          := NIL ;
      type       := error ;  (* default to the error color.  *)
      out        := InitString ('') ;
      in         := input ;
      highplus1  := HIGH (sym) + 1 ;
      len        := Length (input) ;
      ini        := 0 ;
      glyph      := FALSE ;  (* nothing to output yet.  *)
      quotes     := TRUE ;
      positive   := TRUE ;
      root       := FALSE ;
      chain      := FALSE ;
      currentCol := findColorType (input) ;
      beginCol   := unsetColor ;
      endCol     := unsetColor ;
      stackPtr   := 0
   END
END initErrorBlock ;


(*
   push - performs a push from the oldblock to the newblock.
          It copies all fields except the output string.
*)

PROCEDURE push (VAR newblock: errorBlock; oldblock: errorBlock) ;
BEGIN
   pushColor (oldblock) ;  (* save the current color.  *)
   newblock := oldblock ;  (* copy all the fields.  *)
   newblock.out := NIL ;  (* must do this before a clear as we have copied the address.  *)
   clear (newblock) ;
   newblock.quotes := TRUE
END push ;


(*
   pop - copies contents of oldblock into newblock.  It only copies the error
         handle if the toblock.e is NIL.
*)

PROCEDURE pop (VAR toblock, fromblock: errorBlock) ;
VAR
   c: colorType ;
BEGIN
   IF empty (fromblock)
   THEN
      toblock.stackPtr := fromblock.stackPtr ;
      toblock.colorStack := fromblock.colorStack ;
      popColor (toblock)   (* and restore the color from the push start.  *)
   ELSE
      IF fromblock.quotes
      THEN
         (* string needs to be quoted.  *)
         IF toblock.currentCol = unsetColor
         THEN
            (* caller has not yet assigned a color, so use the callee color at the end.  *)
            OutOpenQuote (toblock) ;
            OutGlyphS (toblock, fromblock.out) ;
            OutCloseQuote (toblock) ;
            changeColor (toblock, fromblock.currentCol)
         ELSE
            shutdownColor (fromblock) ;
            (* caller has assigned a color, so use it after the new string.  *)
            c := toblock.currentCol ;
            OutOpenQuote (toblock) ;
            OutGlyphS (toblock, fromblock.out) ;
            OutCloseQuote (toblock) ;
            toblock.currentCol := c
         END
      ELSE
         IF toblock.currentCol = unsetColor
         THEN
            OutGlyphS (toblock, fromblock.out) ;
            toblock.endCol := fromblock.endCol ;
            changeColor (toblock, fromblock.endCol)
         ELSE
            pushColor (toblock) ;
            OutGlyphS (toblock, fromblock.out) ;
            toblock.endCol := fromblock.endCol ;
            popColor (toblock)
         END
      END
   END ;
   IF toblock.e = NIL
   THEN
      toblock.e := fromblock.e
   END ;
   toblock.chain := fromblock.chain ;
   toblock.root := fromblock.root ;
   toblock.ini := fromblock.ini ;
   toblock.type := fromblock.type   (* might have been changed by the callee.  *)
END pop ;


(*
   OutOpenQuote -
*)

PROCEDURE OutOpenQuote (VAR eb: errorBlock) ;
BEGIN
   eb.currentCol := noColor ;
   flushColor (eb) ;
   eb.out := ConCat (eb.out, openQuote (InitString ('')))
END OutOpenQuote ;


(*
   OutCloseQuote -
*)

PROCEDURE OutCloseQuote (VAR eb: errorBlock) ;
BEGIN
   eb.out := ConCat (eb.out, closeQuote (InitString (''))) ;
   eb.currentCol := noColor ;
   eb.endCol := noColor
END OutCloseQuote ;


(*
   findColorType - return the color of the string.  This is determined by the first
                   occurrance of an error, warning or note marker.  An error message
                   is assumed to either be: a keyword category, error category, note
                   category, warning category or to be chained from a previous error.
*)

PROCEDURE findColorType (s: String) : colorType ;
VAR
   i: CARDINAL ;
BEGIN
   i := 0 ;
   WHILE i < Length (s) DO
      IF char (s, i) = "{"
      THEN
         INC (i) ;
         IF char (s, i) = "%"
         THEN
            INC (i) ;
            WHILE (i < Length (s)) AND (char (s, i) # "}") DO
               IF char (s, i) = "%"
               THEN
                  INC (i)
               END ;
               CASE char (s, i) OF

               "K":  RETURN errorColor |   (* keyword errors start with the fatal error color.  *)
               "E":  RETURN errorColor |
               "A":  RETURN errorColor |
               "O":  RETURN noteColor |
               "W":  RETURN warningColor |
               "C":  RETURN lastColor

               ELSE
               END ;
               INC (i)
            END
         END
      END ;
      INC (i)
   END ;
   RETURN errorColor  (* default to the error color.  *)
END findColorType ;


(*
   killErrorBlock - deallocates the dynamic strings associated with the error block.
*)

PROCEDURE killErrorBlock (VAR eb: errorBlock) ;
BEGIN
   WITH eb DO
      out := KillString (out) ;
      in := KillString (in)
   END
END killErrorBlock ;


(*
   ebnf := { percent
             | lbra
             | any                  % copy ch %
           }
         =:

   percent := '%' ( "<" |           % open quote
                    ">" |           % close quote
                    anych )         % copy anych %
            =:

   lbra := '{' [ '!' ] percenttoken '}' =:

   percenttoken := '%' (
                         '1'        % doOperand(1) %
                             op
                       | '2'        % doOperand(2) %
                             op
                       | '3'        % doOperand(3) %
                             op
                       | '4'        % doOperand(4) %
                             op
                       )
                 =:

   op := {'a'|'q'|'t'|'d'|'n'|'s'|'B'|'D'|'F'|'G'|'H'|'M'|'U'|'E'|'V'|'W'|'A'} then =:

   then := [ ':' ebnf ] =:
*)

(*
    {%1V}     set the error message location to the name of the symbol declared.
              For example foo: bar
                          ^^^  some error message.
    {%1H}     set the error message location to the whole declaration of the symbol.
              For example foo: bar
                          ^^^^^^^^ some error message.
    {%1B}     set the error message location to the type declaration of the symbol.
              For example foo: bar
                               ^^^ some error message.
*)


(*
   InternalFormat - produces an informative internal error.
*)

PROCEDURE InternalFormat (eb: errorBlock; m: ARRAY OF CHAR; line: CARDINAL) ;
BEGIN
   printf1 ("M2MetaError.mod:%d:internalformat error detected\n", line) ;
   dump (eb) ;
   InternalError (m)
END InternalFormat ;


(*
   x - checks to see that a=b.
*)

PROCEDURE x (a, b: String) : String ;
BEGIN
   IF a # b
   THEN
      InternalError ('different string returned')
   END ;
   RETURN a
END x ;


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

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


(*
   skip - skips over this level input until the next '}'.
*)

PROCEDURE skip (VAR sb: errorBlock) ;
VAR
   level: INTEGER ;
BEGIN
   level := 0 ;
   WHILE sb.ini < sb.len DO
      IF (level = 0) AND (char (sb.in, sb.ini) = "}")
      THEN
         RETURN
      END ;
      IF char (sb.in, sb.ini) = "}"
      THEN
         DEC (level)
      ELSIF char (sb.in, sb.ini) = "{"
      THEN
         INC (level)
      END ;
      INC (sb.ini)
   END
END skip ;


(*
   ifNonNulThen := [ ':' ebnf ] =:
*)

PROCEDURE ifNonNulThen (VAR eb: errorBlock;
                        sym: ARRAY OF CARDINAL) ;
BEGIN
   IF char (eb.in, eb.ini) = ':'
   THEN
      INC (eb.ini) ;
      IF eb.positive
      THEN
         IF empty (eb) AND (Length (eb.out) # 0)
         THEN
            printf0 ("inconsistency found\n") ;
            dump (eb)
         END ;
         IF empty (eb)
         THEN
            IF Debugging
            THEN
               printf0 ("empty expression, skip\n")
            END ;
            clear (eb) ;
            (* skip over this level of input text.  *)
            skip (eb)
         ELSE
            IF Debugging
            THEN
               dump (eb) ;
               printf0 ("non empty expression, clear and continue\n") ;
            END ;
            clear (eb) ;
            IF Debugging
            THEN
               dump (eb) ;
               printf0 ("cleared, continue\n") ;
               dump (eb)
            END ;
            (* carry on processing input text.  *)
            ebnf (eb, sym) ;
            IF Debugging
            THEN
               printf0 ("evaluated\n") ;
               dump (eb)
            END
         END
      ELSE
         IF empty (eb)
         THEN
            clear (eb) ;
            (* carry on processing input text.  *)
            ebnf (eb, sym)
         ELSE
            clear (eb) ;
            (* skip over this level of input text.  *)
            skip (eb)
         END
      END ;
      IF (eb.ini < eb.len) AND (char (eb.in, eb.ini) # '}')
      THEN
         InternalFormat (eb, 'expecting to see }', __LINE__)
      END
   END
END ifNonNulThen ;


(*
   doNumber -
*)

PROCEDURE doNumber (VAR eb: errorBlock;
                    sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF empty (eb)
   THEN
      eb.quotes := FALSE ;
      OutGlyphS (eb, ctos (sym[bol], 0, ' '))
   END
END doNumber ;


(*
   doCount -
*)

PROCEDURE doCount (VAR eb: errorBlock;
                   sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF empty (eb)
   THEN
      eb.quotes := FALSE ;
      OutGlyphS (eb, ctos(sym[bol], 0, ' ')) ;
      CASE sym[bol] MOD 100 OF

      11..13:  OutGlyphS (eb, Mark (InitString ('th')))

      ELSE
         CASE sym[bol] MOD 10 OF

         1:  OutGlyphS (eb, Mark (InitString ('st'))) |
         2:  OutGlyphS (eb, Mark (InitString ('nd'))) |
         3:  OutGlyphS (eb, Mark (InitString ('rd')))

         ELSE
            OutGlyphS (eb, Mark (InitString ('th')))
         END
      END
   END
END doCount ;


PROCEDURE doAscii (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF (sym[bol] = NulSym) OR (NOT empty (eb)) OR IsTemporary (sym[bol]) OR IsNameAnonymous (sym[bol])
   THEN
      RETURN
   ELSE
      OutGlyphS (eb, InitStringCharStar (KeyToCharStar (GetSymName (sym[bol]))))
   END
END doAscii ;


(*
   unquotedKeyword -
*)

PROCEDURE unquotedKeyword (VAR eb: errorBlock) ;
BEGIN
   eb.quotes := FALSE ;
   keyword (eb)
END unquotedKeyword ;


(*
   OutArray -
*)

PROCEDURE OutArray (VAR eb: errorBlock; a: ARRAY OF CHAR) ;
BEGIN
   OutGlyphS (eb, Mark (InitString (a)))
END OutArray ;


(*
   OutGlyphS - outputs a string of glyphs.
*)

PROCEDURE OutGlyphS (VAR eb: errorBlock; s: String) ;
BEGIN
   IF Length (s) > 0
   THEN
      flushColor (eb) ;
      checkMe ;
      eb.glyph := TRUE ;
      eb.out := ConCat (eb.out, s)
   END
END OutGlyphS ;


(*
   OutColorS - outputs a string of color requests.
*)

(*
PROCEDURE OutColorS (VAR eb: errorBlock; s: String) ;
BEGIN
   flushColor (eb) ;
   eb.out := ConCat (eb.out, s)
END OutColorS ;
*)


(*
   empty - returns TRUE if the output string is empty.
           It ignores color changes.
*)

PROCEDURE empty (VAR eb: errorBlock) : BOOLEAN ;
BEGIN
   RETURN NOT eb.glyph
END empty ;


(*
   clear - remove the output string.
*)

PROCEDURE clear (VAR eb: errorBlock) ;
BEGIN
   eb.out := KillString (eb.out) ;
   eb.out := InitString ('') ;
   eb.glyph := FALSE ;
   eb.beginCol := unsetColor ;
   eb.quotes := FALSE
END clear ;


PROCEDURE doName (VAR eb: errorBlock;
                  sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF (NOT empty (eb)) OR (sym[bol] = NulSym) OR IsTemporary (sym[bol]) OR IsNameAnonymous (sym[bol])
   THEN
      RETURN
   ELSE
      IF sym[bol] = ZType
      THEN
         eb.quotes := FALSE ;
         OutArray (eb, 'the ZType')
      ELSIF sym[bol] = RType
      THEN
         eb.quotes := FALSE ;
         OutArray (eb, 'the RType')
      ELSE
         doAscii (eb, sym, bol)
      END
   END
END doName ;


PROCEDURE doQualified (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
VAR
   mod: ARRAY [0..1] OF CARDINAL ;
BEGIN
   IF (NOT empty (eb)) OR (sym[bol] = NulSym) OR IsTemporary (sym[bol]) OR IsNameAnonymous (sym[bol])
   THEN
      RETURN
   ELSE
      mod[0] := GetScope (sym[bol]) ;
      IF IsDefImp (mod[0]) AND IsExported (mod[0], sym[bol])
      THEN
         doAscii (eb, mod, 0) ;
         OutArray (eb, '.') ;
         OutGlyphS (eb, Mark (InitStringCharStar (KeyToCharStar (GetSymName (sym[bol])))))
      ELSE
         doAscii (eb, sym, bol)
      END
   END
END doQualified ;


(*
   doType - returns a string containing the type name of
            sym.
*)

PROCEDURE doType (VAR eb: errorBlock;
                  sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF (NOT empty (eb)) OR (sym[bol] = NulSym)
   THEN
      RETURN
   ELSE
      sym[bol] := GetType (sym[bol]) ;
      doAscii (eb, sym, bol)
   END
END doType ;


(*
   doSkipType - will skip all pseudonym types.  It also
                returns the type symbol found and name.
*)

PROCEDURE doSkipType (eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF (NOT empty (eb)) OR (sym[bol] = NulSym)
   THEN
      RETURN
   ELSE
      sym[bol] := SkipType(sym[bol]) ;
      WHILE IsType(sym[bol]) AND ((GetSymName (sym[bol]) = NulName) OR
                                  IsNameAnonymous (sym[bol])) DO
         sym[bol] := GetType (sym[bol])
      END ;
      doAscii (eb, sym, bol)
   END
END doSkipType ;


(*
   doGetType - attempts to get the type of sym[bol].
*)

PROCEDURE doGetType (VAR eb: errorBlock;
                     VAR sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF (bol > HIGH (sym)) OR (NOT empty (eb)) OR (sym[bol] = NulSym)
   THEN
      RETURN
   ELSE
      sym[bol] := GetType (sym[bol])
   END
END doGetType ;


(*
   doGetSkipType - will skip all pseudonym types.  It also
                   returns the type symbol found and name.
*)

PROCEDURE doGetSkipType (VAR eb: errorBlock; VAR sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
VAR
   prev: CARDINAL ;
BEGIN
   IF (bol > HIGH (sym)) OR (NOT empty (eb)) OR (sym[bol] = NulSym)
   THEN
      RETURN
   ELSE
      REPEAT
         prev := sym[bol] ;
         sym[bol] := SkipType (sym[bol]) ;
         IF IsType(sym[bol]) AND ((GetSymName (sym[bol]) = NulName) OR
                                  IsNameAnonymous (sym[bol])) AND
            (GetType(sym[bol]) # NulSym)
         THEN
            sym[bol] := GetType (sym[bol])
         END
      UNTIL sym[bol] = prev
   END
END doGetSkipType ;


(*
   doChain -
*)

PROCEDURE doChain (VAR eb: errorBlock; tok: CARDINAL) ;
BEGIN
   IF lastRoot=NIL
   THEN
      InternalError ('should not be chaining an error onto an empty error note')
   ELSE
      eb.e := ChainError (tok, lastRoot)
   END
END doChain ;


(*
   doError - creates and returns an error note.
*)

PROCEDURE doError (VAR eb: errorBlock; tok: CARDINAL) ;
BEGIN
   IF eb.useError
   THEN
      chooseError (eb, tok)
   END
END doError ;


(*
   defaultError - adds the default error location to, tok, if one has not already been
                  assigned.
*)

PROCEDURE defaultError (VAR eb: errorBlock; tok: CARDINAL) ;
BEGIN
   IF eb.e = NIL
   THEN
      doError (eb, tok)
   END
END defaultError ;


(*
   chooseError - choose the error kind dependant upon type.
                 Either an error, warning or note will be generated.
*)

PROCEDURE chooseError (VAR eb: errorBlock; tok: CARDINAL) ;
BEGIN
   IF eb.chain
   THEN
      doChain (eb, tok)
   ELSE
      CASE eb.type OF

      chained:  doChain (eb, tok) |
      none,
      aborta,
      error  :  IF eb.e=NIL
                THEN
                   eb.e := NewError (tok)
                ELSE
                   eb.e := MoveError (eb.e, tok)
                END |
      warning:  IF eb.e=NIL
                THEN
                   eb.e := NewWarning (tok)
                ELSE
                   eb.e := MoveError (eb.e, tok)
                END |
      note   :  IF eb.e=NIL
                THEN
                   eb.e := NewNote (tok)
                ELSE
                   eb.e := MoveError (eb.e, tok)
                END

      ELSE
         InternalError ('unexpected enumeration value')
      END
   END ;
   IF eb.root
   THEN
      lastRoot := eb.e ;
      lastColor := findColorType (eb.in)
   END ;
   eb.e := SetColor (eb.e)
END chooseError ;


(*
   doErrorScopeModule -
*)

PROCEDURE doErrorScopeModule (VAR eb: errorBlock; sym: CARDINAL) ;
VAR
   scope: CARDINAL ;
BEGIN
   scope := GetScope (sym) ;
   IF IsModule (scope)
   THEN
      IF IsInnerModule (scope)
      THEN
         doError (eb, GetDeclaredMod (sym))
      ELSE
         doError (eb, GetDeclaredMod (sym))
      END
   ELSE
      Assert (IsDefImp (scope)) ;
      (* if this fails then we need to skip to the outer scope.
         REPEAT
            OuterModule := GetScope(OuterModule)
         UNTIL GetScope(OuterModule)=NulSym.  *)
      IF GetDeclaredModule (sym) = UnknownTokenNo
      THEN
         doError (eb, GetDeclaredDef (sym))
      ELSE
         doError (eb, GetDeclaredMod (sym))
      END
   END
END doErrorScopeModule ;


(*
   doErrorScopeForward -
*)

PROCEDURE doErrorScopeForward (VAR eb: errorBlock; sym: CARDINAL) ;
VAR
   scope: CARDINAL ;
BEGIN
   scope := GetScope (sym) ;
   IF IsModule (scope)
   THEN
      IF IsInnerModule (scope)
      THEN
         doError (eb, GetDeclaredFor (sym))
      ELSE
         doError (eb, GetDeclaredFor (sym))
      END
   ELSE
      Assert (IsDefImp (scope)) ;
      (* if this fails then we need to skip to the outer scope.
         REPEAT
            OuterModule := GetScope(OuterModule)
         UNTIL GetScope(OuterModule)=NulSym.  *)
      IF GetDeclaredModule (sym) = UnknownTokenNo
      THEN
         doError (eb, GetDeclaredDef (sym))
      ELSE
         doError (eb, GetDeclaredFor (sym))
      END
   END
END doErrorScopeForward ;


(*
   doErrorScopeMod - potentially create an error referring to the definition
                     module, fall back to the implementation or program module if
                     there is no declaration in the definition module.
*)

PROCEDURE doErrorScopeMod (VAR eb: errorBlock; sym: CARDINAL) ;
VAR
   scope: CARDINAL ;
BEGIN
   scope := GetScope (sym) ;
   IF scope = NulSym
   THEN
      M2Error.EnterErrorScope (NIL) ;
      doError (eb, GetDeclaredMod (sym))
   ELSE
      M2Error.EnterErrorScope (GetErrorScope (scope)) ;
      IF IsProcedure (scope)
      THEN
         doError (eb, GetDeclaredMod (sym))
      ELSE
         doErrorScopeModule (eb, sym)
      END
   END ;
   M2Error.LeaveErrorScope
END doErrorScopeMod ;


(*
   doErrorScopeFor - potentially create an error referring to the
                     forward declaration, definition module, fall back
                     to the implementation or program module if
                     there is no declaration in the definition module.
*)

PROCEDURE doErrorScopeFor (VAR eb: errorBlock; sym: CARDINAL) ;
VAR
   scope: CARDINAL ;
BEGIN
   scope := GetScope (sym) ;
   IF scope = NulSym
   THEN
      M2Error.EnterErrorScope (NIL) ;
      doError (eb, GetDeclaredFor (sym))
   ELSE
      M2Error.EnterErrorScope (GetErrorScope (scope)) ;
      IF IsProcedure (scope)
      THEN
         doError (eb, GetDeclaredFor (sym))
      ELSE
         doErrorScopeForward (eb, sym)
      END
   END ;
   M2Error.LeaveErrorScope
END doErrorScopeFor ;


(*
   doDeclaredMod - creates an error note where sym[bol] was declared.
*)

PROCEDURE declaredMod (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF bol <= HIGH (sym)
   THEN
      doErrorScopeMod (eb, sym[bol])
   END
END declaredMod ;


(*
   doErrorScopeDefinition - use the declaration in the definitio module if one is available.
*)

PROCEDURE doErrorScopeDefinition (VAR eb: errorBlock; sym: CARDINAL) ;
VAR
   scope: CARDINAL ;
BEGIN
   scope := GetScope (sym) ;
   IF IsModule (scope)
   THEN
      (* No definition module for a program module.  *)
      doError (eb, GetDeclaredMod (sym))
   ELSE
      Assert (IsDefImp (scope)) ;
      IF GetDeclaredDefinition (sym) = UnknownTokenNo
      THEN
         (* Fall back to the implementation module if no declaration exists
            in the definition module.  *)
         doError (eb, GetDeclaredMod (sym))
      ELSE
         doError (eb, GetDeclaredDef (sym))
      END
   END
END doErrorScopeDefinition ;


(*
   doErrorScopeDef - potentially create an error referring to the definition
                     module, fall back to the implementation or program module if
                     there is no declaration in the definition module.
*)

PROCEDURE doErrorScopeDef (VAR eb: errorBlock; sym: CARDINAL) ;
VAR
   scope: CARDINAL ;
BEGIN
   scope := GetScope (sym) ;
   IF scope = NulSym
   THEN
      M2Error.EnterErrorScope (NIL) ;
      doError (eb, GetDeclaredFor (sym))
   ELSE
      M2Error.EnterErrorScope (GetErrorScope (scope)) ;
      IF IsProcedure (scope)
      THEN
         doError (eb, GetDeclaredDef (sym))
      ELSE
         doErrorScopeDefinition (eb, sym)
      END
   END ;
   M2Error.LeaveErrorScope
END doErrorScopeDef ;


(*
   doDeclaredDef - creates an error note where sym[bol] was declared.
*)

PROCEDURE declaredDef (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF bol <= HIGH (sym)
   THEN
      doErrorScopeDef (eb, sym[bol])
   END
END declaredDef ;


(*
   doDeclaredFor - creates an error note where sym[bol] was declared.
*)

PROCEDURE declaredFor (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF bol <= HIGH (sym)
   THEN
      doErrorScopeFor (eb, sym[bol])
   END
END declaredFor ;


(*
   doErrorScopeProc - determine the location for the error or warning from
                      the default declaration.  For example parameters can be
                      declared in definition, forward or in modules (proper procedure).
                      Use GetVarParamTok to obtain a variable or parameter location.
*)

PROCEDURE doErrorScopeProc (VAR eb: errorBlock; sym: CARDINAL;
                            GetVarParamTok: GetTokProcedure) ;
VAR
   scope: CARDINAL ;
BEGIN
   scope := GetScope (sym) ;
   IF scope = NulSym
   THEN
      M2Error.EnterErrorScope (NIL) ;
      doError (eb, GetDeclaredDef (sym))
   ELSE
      M2Error.EnterErrorScope (GetErrorScope (scope)) ;
      IF IsProcedure (scope)
      THEN
         IF IsVar (sym) OR IsParameter (sym)
         THEN
            doError (eb, GetVarParamTok (sym))
         ELSE
            doError (eb, GetDeclaredDef (sym))
         END
      ELSE
         IF IsModule (scope)
         THEN
            IF IsInnerModule (scope)
            THEN
               doError (eb, GetDeclaredDef (sym))
            ELSE
               doError (eb, GetDeclaredDef (sym))
            END
         ELSE
            Assert (IsDefImp (scope)) ;
            (* if this fails then we need to skip to the outer scope.
            REPEAT
             OuterModule := GetScope(OuterModule)
            UNTIL GetScope(OuterModule)=NulSym ;  *)
            IF GetDeclaredDefinition (sym) = UnknownTokenNo
            THEN
               doError (eb, GetDeclaredMod (sym))
            ELSE
               doError (eb, GetDeclaredDef (sym))
            END
         END
      END
   END ;
   M2Error.LeaveErrorScope
END doErrorScopeProc ;


(*
   doDeclaredVar - creates an error note where sym[bol] was declared.
*)

PROCEDURE declaredVar (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF bol <= HIGH (sym)
   THEN
      doErrorScopeProc (eb, sym[bol], GetVarDeclTok)
   END
END declaredVar ;


(*
   doDeclaredType - creates an error note where sym[bol] was declared.
*)

PROCEDURE declaredType (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF bol <= HIGH (sym)
   THEN
      doErrorScopeProc (eb, sym[bol], GetVarDeclTypeTok)
   END
END declaredType ;


(*
   doDeclaredFull - creates an error note where sym[bol] was declared.
*)

PROCEDURE declaredFull (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF bol <= HIGH (sym)
   THEN
      doErrorScopeProc (eb, sym[bol], GetVarDeclFullTok)
   END
END declaredFull ;


(*
   used - creates an error note where sym[bol] was first used.
*)

PROCEDURE used (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF bol <= HIGH (sym)
   THEN
      doError (eb, GetFirstUsed (sym[bol]))
   END
END used ;


(*
   ConCatWord - joins sentances, a, b, together.
*)

(*
PROCEDURE ConCatWord (a, b: String) : String ;
BEGIN
   IF (Length (a) = 1) AND (char(a, 0) = 'a')
   THEN
      a := x (a, ConCatChar (a, 'n'))
   ELSIF (Length (a) > 1) AND (char (a, -1) = 'a') AND IsWhite (char(a, -2))
   THEN
      a := x (a, ConCatChar (a, 'n'))
   END ;
   IF (Length (a) > 0) AND (NOT IsWhite (char (a, -1)))
   THEN
      a := x (a, ConCatChar (a, ' '))
   END ;
   RETURN x (a, ConCat(a, b))
END ConCatWord ;
*)


(*
   symDesc -
*)

PROCEDURE symDesc (sym: CARDINAL) : String ;
BEGIN
   IF IsConstLit (sym)
   THEN
      RETURN InitString ('constant literal')
   ELSIF IsConstSet (sym)
   THEN
      RETURN InitString ('constant set')
   ELSIF IsConstructor (sym)
   THEN
      RETURN InitString ('constructor')
   ELSIF IsConst(sym)
   THEN
      RETURN InitString('constant')
   ELSIF IsArray(sym)
   THEN
      RETURN InitString('array')
   ELSIF IsVar(sym)
   THEN
      IF IsTemporary (sym)
      THEN
         RETURN InitString('expression')
      ELSE
         RETURN InitString('variable')
      END
   ELSIF IsEnumeration(sym)
   THEN
      RETURN InitString('enumeration type')
   ELSIF IsFieldEnumeration(sym)
   THEN
      RETURN InitString('enumeration field')
   ELSIF IsUnbounded(sym)
   THEN
      RETURN InitString('unbounded parameter')
   ELSIF IsProcType(sym)
   THEN
      RETURN InitString('procedure type')
   ELSIF IsPseudoBaseFunction (sym)
   THEN
      RETURN InitString('standard function procedure')
   ELSIF IsPseudoBaseProcedure (sym)
   THEN
      RETURN InitString('standard procedure')
   ELSIF IsProcedure(sym)
   THEN
      RETURN InitString('procedure')
   ELSIF IsPointer(sym)
   THEN
      RETURN InitString('pointer')
   ELSIF IsParameter(sym)
   THEN
      IF IsParameterVar(sym)
      THEN
         RETURN InitString('var parameter')
      ELSE
         RETURN InitString('parameter')
      END
   ELSIF IsType(sym)
   THEN
      IF IsHiddenType (sym)
      THEN
         RETURN InitString('opaque type')
      ELSE
         RETURN InitString('type')
      END
   ELSIF IsRecord(sym)
   THEN
      RETURN InitString('record')
   ELSIF IsRecordField(sym)
   THEN
      RETURN InitString('record field')
   ELSIF IsVarient(sym)
   THEN
      RETURN InitString('varient record')
   ELSIF IsModule(sym)
   THEN
      RETURN InitString('module')
   ELSIF IsDefImp(sym)
   THEN
      RETURN InitString('definition or implementation module')
   ELSIF IsSet(sym)
   THEN
      RETURN InitString('set')
   ELSIF IsUnknown(sym)
   THEN
      RETURN InitString('an unknown')
   ELSIF IsSubrange(sym)
   THEN
      RETURN InitString('subrange')
   ELSE
      RETURN InitString ('')
   END
END symDesc ;


(*
   doDesc -
*)

PROCEDURE doDesc (VAR eb: errorBlock;
                  sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   IF empty (eb)
   THEN
      OutGlyphS (eb, symDesc (sym[bol])) ;
      IF NOT empty (eb)
      THEN
         eb.quotes := FALSE
      END
   END
END doDesc ;


(*
   copySym - copies, n+1, symbols, from, ->, to.
*)

(*
PROCEDURE copySym (from: ARRAY OF CARDINAL; VAR to: ARRAY OF CARDINAL; n: CARDINAL) ;
VAR
   i: CARDINAL ;
BEGIN
   IF n>HIGH(to)
   THEN
      InternalError ('not enough room in the destination array')
   ELSE
      i := 0 ;
      WHILE i<=n DO
         to[i] := from[i] ;
         INC(i)
      END
   END
END copySym ;
*)


(*
   op := {'!'|'a'|'c'|'d'|'k'|'n'|'p'|'q'|'s'|'t'|'u'|
          'A'|'B'|'C'|'D'|'E'|'F'|'G'|'H'|'K'|'M'|'N'|
          'O'|'P'|'Q'|'R'|'S'|'T'|'U'|'V'|'W'|'X'|'Y'|'Z'} then =:
*)

PROCEDURE op (VAR eb: errorBlock;
              sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
   WHILE (eb.ini < eb.len) AND (char (eb.in, eb.ini) # '}') DO
      IF Debugging
      THEN
         printf0 ("while loop in op\n") ;
         dump (eb)
      END ;
      CASE char (eb.in, eb.ini) OF

      '!':  eb.positive := NOT eb.positive |
      'a':  doName (eb, sym, bol) |
      'c':  eb.currentCol := readColor (eb) ;
            DEC (eb.ini) |
      'd':  doDesc (eb, sym, bol) |
      'k':  unquotedKeyword (eb) ;
            DEC (eb.ini) |
      'n':  doNumber (eb, sym, bol) |
      'p':  popColor (eb) |
      'q':  doQualified (eb, sym, bol) |
      's':  doSkipType (eb, sym, bol) |
      't':  doType (eb, sym, bol) |
      'u':  eb.quotes := FALSE |
      'A':  eb.type := aborta ;
            seenAbort := TRUE |
      'B':  declaredType (eb, sym, bol) |
      'C':  eb.chain := TRUE |
      'D':  declaredDef (eb, sym, bol) |
      'E':  eb.type := error |
      'F':  filename (eb) ;
            DEC (eb.ini) |
      'G':  declaredFor (eb, sym, bol) |
      'H':  declaredFull (eb, sym, bol) |
      'K':  keyword (eb) ;
            DEC (eb.ini) |
      'M':  declaredMod (eb, sym, bol) |
      'N':  doCount (eb, sym, bol) |
      'O':  eb.type := note |
      'P':  pushColor (eb) |
      'Q':  resetDictionary |
      'R':  eb.root := TRUE |
      'S':  doGetSkipType (eb, sym, bol) |
      'T':  doGetType (eb, sym, bol) |
      'U':  used (eb, sym, bol) |
      'V':  declaredVar (eb, sym, bol) |
      'W':  eb.type := warning |
      'X':  pushOutput (eb) |
      'Y':  processDefine (eb) |
      'Z':  popOutput (eb) |
      ':':  ifNonNulThen (eb, sym) ;
            DEC (eb.ini) |
      '1':  InternalError ('incorrect format spec, expecting %1 rather than % spec 1') |
      '2':  InternalError ('incorrect format spec, expecting %2 rather than % spec 2') |
      '3':  InternalError ('incorrect format spec, expecting %3 rather than % spec 3') |
      '4':  InternalError ('incorrect format spec, expecting %4 rather than % spec 4')

      ELSE
         InternalFormat (eb, 'expecting one of [akqtdnpsuCDEFGKNOPQRSTUWXYZ:<>%]', __LINE__)
      END ;
      INC (eb.ini)
   END ;
   IF Debugging
   THEN
      printf0 ("finishing op\n") ;
      dump (eb)
   END
END op ;


(*
   percenttoken := '%' (
                         '1'        % doOperand(1) %
                             op
                       | '2'        % doOperand(2) %
                             op
                       | '3'        % doOperand(3) %
                             op
                       | '4'        % doOperand(4) %
                             op
                       )
                       } =:
*)

PROCEDURE percenttoken (VAR eb: errorBlock; sym: ARRAY OF CARDINAL) ;
BEGIN
   IF char (eb.in, eb.ini) = '%'
   THEN
      INC (eb.ini) ;
      CASE char (eb.in, eb.ini) OF

      '1':  INC (eb.ini) ;
            op (eb, sym, 0) |
      '2':  INC (eb.ini) ;
            op (eb, sym, 1) |
      '3':  INC (eb.ini) ;
            op (eb, sym, 2) |
      '4':  INC (eb.ini) ;
            op (eb, sym, 3)

      ELSE
         op (eb, sym, 0)
      END ;
      IF (eb.ini < eb.len) AND (char (eb.in, eb.ini) # '}')
      THEN
         InternalFormat (eb, 'expecting to see }', __LINE__)
      END
   END
END percenttoken ;


(*
   changeColor - changes to color, c.
*)

PROCEDURE changeColor (VAR eb: errorBlock; c: colorType) ;
BEGIN
   eb.currentCol := c
END changeColor ;


(*
   shutdownColor - shutdown existing color if it exists.
*)

PROCEDURE shutdownColor (VAR eb: errorBlock) ;
BEGIN
   IF (eb.endCol # unsetColor) AND (eb.endCol # noColor)
   THEN
      eb.out := colorEnd (eb.out) ;
      eb.endCol := noColor
   END
END shutdownColor ;


(*
   flushColor - flushes any outstanding color change.
*)

PROCEDURE flushColor (VAR eb: errorBlock) ;
BEGIN
   IF eb.endCol # eb.currentCol
   THEN
      shutdownColor (eb) ;
      IF eb.endCol # eb.currentCol
      THEN
         emitColor (eb, eb.currentCol) ;
         eb.endCol := eb.currentCol
      END ;
      IF eb.beginCol = unsetColor
      THEN
         eb.beginCol := eb.currentCol
      END
   END
END flushColor ;


(*
   emitColorGCC -
*)

PROCEDURE emitColorGCC (VAR eb: errorBlock; c: colorType) ;
BEGIN
   CASE c OF

   unsetColor   :  |
   noColor      :  eb.out := M2ColorString.endColor (eb.out) |
   quoteColor   :  eb.out := M2ColorString.quoteColor (eb.out) |
   filenameColor:  eb.out := M2ColorString.filenameColor (eb.out) |
   errorColor   :  eb.out := M2ColorString.errorColor (eb.out) |
   warningColor :  eb.out := M2ColorString.warningColor (eb.out) |
   noteColor    :  eb.out := M2ColorString.noteColor (eb.out) |
   keywordColor :  eb.out := M2ColorString.locusColor (eb.out) |
   locusColor   :  eb.out := M2ColorString.locusColor (eb.out) |
   insertColor  :  eb.out := M2ColorString.insertColor (eb.out) |
   deleteColor  :  eb.out := M2ColorString.deleteColor (eb.out) |
   typeColor    :  eb.out := M2ColorString.typeColor (eb.out) |
   range1Color  :  eb.out := M2ColorString.range1Color (eb.out) |
   range2Color  :  eb.out := M2ColorString.range2Color (eb.out)

   END
END emitColorGCC ;


(*
   emitColorTag -
*)

PROCEDURE emitColorTag (VAR eb: errorBlock; c: colorType) ;
VAR
   s: String ;
BEGIN
   CASE c OF

   unsetColor   :  s := InitString ('<unset>') |
   noColor      :  s := InitString ('<nocol>') ; stop |
   quoteColor   :  s := InitString ('<quote>') |
   filenameColor:  s := InitString ('<filename>') |
   errorColor   :  s := InitString ('<error>') |
   warningColor :  s := InitString ('<warn>') |
   noteColor    :  s := InitString ('<note>') |
   keywordColor :  s := InitString ('<key>') |
   locusColor   :  s := InitString ('<locus>') |
   insertColor  :  s := InitString ('<insert>') |
   deleteColor  :  s := InitString ('<delete>') |
   typeColor    :  s := InitString ('<type>') |
   range1Color  :  s := InitString ('<range1>') |
   range2Color  :  s := InitString ('<range2>')

   END ;
   eb.out := ConCat (eb.out, Mark (s))
END emitColorTag ;


(*
   emitColor - adds the appropriate color string to the output string.
*)

PROCEDURE emitColor (VAR eb: errorBlock; c: colorType) ;
BEGIN
   IF ColorDebug
   THEN
      emitColorTag (eb, c)
   ELSE
      emitColorGCC (eb, c)
   END
END emitColor ;


(*
   openQuote -
*)

PROCEDURE openQuote (s: String) : String ;
BEGIN
   IF ColorDebug
   THEN
      RETURN ConCat (s, Mark (InitString ('<openquote>')))
   ELSE
      RETURN M2ColorString.quoteOpen (s)
   END
END openQuote ;


(*
   closeQuote -
*)

PROCEDURE closeQuote (s: String) : String ;
BEGIN
   IF ColorDebug
   THEN
      RETURN ConCat (s, Mark (InitString ('<closequote>')))
   ELSE
      RETURN M2ColorString.quoteClose (s)
   END
END closeQuote ;


(*
   colorEnd -
*)

PROCEDURE colorEnd (s: String) : String ;
BEGIN
   stop ;
   IF ColorDebug
   THEN
      RETURN ConCat (s, Mark (InitString ('<nocol>')))
   ELSE
      RETURN M2ColorString.endColor (s)
   END
END colorEnd ;


(*
   copyChar - copies a character from in string to out string.
*)

PROCEDURE copyChar (VAR eb: errorBlock) ;
BEGIN
   IF eb.ini < eb.len
   THEN
      flushColor (eb) ;
      checkMe ;
      eb.glyph := TRUE ;
      eb.out := x (eb.out, ConCatChar (eb.out, char (eb.in, eb.ini)))
   END
END copyChar ;


(*
   copyKeywordChar - copies a character from in string to out string
                     it will convert the character to lower case if the
                     -fm2-lower-case option was specified.
*)

PROCEDURE copyKeywordChar (VAR eb: errorBlock) ;
VAR
   ch: CHAR ;
BEGIN
   IF eb.ini < eb.len
   THEN
      flushColor (eb) ;
      ch := char (eb.in, eb.ini) ;
      IF LowerCaseKeywords
      THEN
         ch := Lower (ch)
      END ;
      eb.glyph := TRUE ;
      eb.out := x (eb.out, ConCatChar (eb.out, ch))
   END
END copyKeywordChar ;


(*
   percent := '%' anych           % copy anych %
            =:
*)

PROCEDURE percent (VAR eb: errorBlock; sym: ARRAY OF CARDINAL) ;
BEGIN
   IF char (eb.in, eb.ini)='%'
   THEN
      INC (eb.ini) ;
      IF eb.ini < eb.len
      THEN
         IF char (eb.in, eb.ini) = '<'
         THEN
            (* %< is a quotation symbol.  *)
            pushColor (eb) ;
            eb.currentCol := noColor ;
            flushColor (eb) ;
            changeColor (eb, quoteColor) ;
            eb.endCol := quoteColor ;  (* the openQuote will change the color.  *)
            (* OutGlyphS performs a flush and we are emitting the open quote glyph.  *)
            OutGlyphS (eb, openQuote (InitString ('')))
         ELSIF char (eb.in, eb.ini) = '>'
         THEN
            OutGlyphS (eb, closeQuote (InitString (''))) ;
            eb.endCol := noColor ;  (* closeQuote also turns off color.  *)
            popColor (eb)
         ELSE
            copyChar (eb)
         END
      END
   END
END percent ;


(*
   lbra := '{' [ '!' ] percenttoken '}' =:
*)

PROCEDURE lbra (VAR eb: errorBlock; sym: ARRAY OF CARDINAL) ;
BEGIN
   IF char (eb.in, eb.ini) = '{'
   THEN
      eb.positive := TRUE ;
      INC (eb.ini) ;
      IF char (eb.in, eb.ini) = '!'
      THEN
         eb.positive := FALSE ;
         INC (eb.ini)
      END ;
      IF char (eb.in, eb.ini) # '%'
      THEN
         InternalFormat (eb, 'expecting to see %', __LINE__)
      END ;
      percenttoken (eb, sym) ;
      IF (eb.ini < eb.len) AND (char (eb.in, eb.ini) # '}')
      THEN
         InternalFormat (eb, 'expecting to see }', __LINE__)
      END
   END
END lbra ;


PROCEDURE stop ; BEGIN END stop ;

PROCEDURE checkMe ; BEGIN END checkMe ;


(*
   dumpErrorType -
*)

PROCEDURE dumpErrorType (e: errorType) ;
BEGIN
   CASE e OF

   none   :  printf0 ("none") |
   error  :  printf0 ("error") |
   warning:  printf0 ("warning") |
   note   :  printf0 ("note") |
   chained:  printf0 ("chained") |
   aborta :  printf0 ("abort")

   END
END dumpErrorType ;


(*
   dumpColorType -
*)

PROCEDURE dumpColorType (c: colorType) ;
BEGIN
   CASE c OF

   unsetColor   :  printf0 ("unsetColor") |
   noColor      :  printf0 ("noColor") |
   quoteColor   :  printf0 ("quoteColor") |
   filenameColor:  printf0 ("filenameColor") |
   errorColor   :  printf0 ("errorColor") |
   warningColor :  printf0 ("warningColor") |
   noteColor    :  printf0 ("noteColor") |
   keywordColor :  printf0 ("keywordColor") |
   locusColor   :  printf0 ("locusColor") |
   insertColor  :  printf0 ("insertColor") |
   deleteColor  :  printf0 ("deleteColor") |
   typeColor    :  printf0 ("typeColor") |
   range1Color  :  printf0 ("range1Color") |
   range2Color  :  printf0 ("range2Color")

   END
END dumpColorType ;


(*
   dump -

*)

PROCEDURE dump (eb: errorBlock) ;
VAR
   ch: CHAR ;
   l : CARDINAL ;
   i : INTEGER ;
BEGIN
   l := Length (eb.out) ;
   printf0 ("\n\nerrorBlock\n") ;
   printf0 ("\ntype      = ") ; dumpErrorType (eb.type) ;
   printf1 ("\nout       = |%s|", eb.out) ;
   printf1 ("\nin        = |%s|", eb.in) ;
   printf1 ("\nLength (out) = %d", l) ;
   printf1 ("\nlen       = %d", eb.len) ;
   printf1 ("\nhighplus1 = %d", eb.highplus1) ;
   printf1 ("\nglyph     = %d", eb.glyph) ;
   printf1 ("\nquotes    = %d", eb.quotes) ;
   printf1 ("\npositive  = %d", eb.positive) ;
   printf0 ("\nbeginCol  = ") ; dumpColorType (eb.beginCol) ;
   printf0 ("\nendCol    = ") ; dumpColorType (eb.endCol) ;
   printf0 ("\ncurrentCol = ") ; dumpColorType (eb.currentCol) ;
   printf1 ("\nini        = %d", eb.ini) ;
   IF eb.ini < eb.len
   THEN
      ch := char (eb.in, eb.ini) ;
      printf1 ("\ncurrent char = %c", ch) ;
      printf1 ("\n%s\n", eb.in) ;
      i := 0 ;
      WHILE i<eb.ini DO
         printf0 (" ") ;
         INC (i)
      END ;
      printf0 ("^\n")
   END ;
   printf0 ("\n")
END dump ;


(*
   ebnf := { percent
             | lbra
             | any                    % copy ch %
           }
         =:
*)

PROCEDURE ebnf (VAR eb: errorBlock; sym: ARRAY OF CARDINAL) ;
VAR
   nb: errorBlock ;
BEGIN
   IF Debugging
   THEN
      printf0 ("top of ebnf\n") ;
      dump (eb)
   END ;
   WHILE eb.ini < eb.len DO
      IF Debugging
      THEN
         printf0 ("while loop ebnf\n") ;
         dump (eb)
      END ;
      CASE char (eb.in, eb.ini) OF

      '!':  eb.positive := NOT eb.positive |
      '%':  percent (eb, sym) |
      '{':  push (nb, eb) ;
            lbra (nb, sym) ;
            pop (eb, nb) ;
            IF (eb.ini < eb.len) AND (char (eb.in, eb.ini) # '}')
            THEN
               InternalFormat (eb, 'expecting to see }', __LINE__)
            END |
      '}':  RETURN

      ELSE
         IF ((IsWhite (char (eb.in, eb.ini)) AND (Length (eb.out) > 0) AND
              (NOT IsWhite (char (eb.out, -1)))) OR
            (NOT IsWhite (char (eb.in, eb.ini)))) AND (eb.highplus1 > 0)
         THEN
            eb.quotes := FALSE ;  (* copying a normal character, don't quote the result.  *)
            copyChar (eb)
         END
      END ;
      INC (eb.ini)
   END ;
   eb.currentCol := noColor ;
   flushColor (eb) ;
   IF Debugging
   THEN
      printf0 ("finishing ebnf\n") ;
      dump (eb)
   END
END ebnf ;


PROCEDURE MetaErrorStringT0 (tok: CARDINAL; m: String) ;
VAR
   eb : errorBlock ;
   sym: ARRAY [0..0] OF CARDINAL ;
BEGIN
   sym[0] := NulSym ;
   initErrorBlock (eb, m, sym) ;
   ebnf (eb, sym) ;
   flushColor (eb) ;
   defaultError (eb, tok) ;
   ErrorString (eb.e, Dup (eb.out)) ;
   killErrorBlock (eb) ;
   checkAbort
END MetaErrorStringT0 ;


PROCEDURE MetaErrorT0 (tok: CARDINAL; m: ARRAY OF CHAR) ;
BEGIN
   MetaErrorStringT0 (tok, InitString(m))
END MetaErrorT0 ;


PROCEDURE MetaErrorStringT1 (tok: CARDINAL; m: String; s: CARDINAL) ;
VAR
   eb : errorBlock ;
   sym: ARRAY [0..0] OF CARDINAL ;
BEGIN
   sym[0] := s ;
   initErrorBlock (eb, m, sym) ;
   ebnf (eb, sym) ;
   flushColor (eb) ;
   defaultError (eb, tok) ;
   ErrorString (eb.e, Dup (eb.out)) ;
   killErrorBlock (eb) ;
   checkAbort
END MetaErrorStringT1 ;


PROCEDURE MetaErrorT1 (tok: CARDINAL; m: ARRAY OF CHAR; s: CARDINAL) ;
BEGIN
   MetaErrorStringT1 (tok, InitString (m), s)
END MetaErrorT1 ;


PROCEDURE MetaErrorStringT2 (tok: CARDINAL; m: String; s1, s2: CARDINAL) ;
VAR
   eb : errorBlock ;
   sym: ARRAY [0..1] OF CARDINAL ;
BEGIN
   sym[0] := s1 ;
   sym[1] := s2 ;
   initErrorBlock (eb, m, sym) ;
   ebnf (eb, sym) ;
   flushColor (eb) ;
   defaultError (eb, tok) ;
   ErrorString (eb.e, Dup (eb.out)) ;
   killErrorBlock (eb) ;
   checkAbort
END MetaErrorStringT2 ;


PROCEDURE MetaErrorT2 (tok: CARDINAL; m: ARRAY OF CHAR; s1, s2: CARDINAL) ;
BEGIN
   MetaErrorStringT2 (tok, InitString (m), s1, s2)
END MetaErrorT2 ;


PROCEDURE MetaErrorStringT3 (tok: CARDINAL; m: String; s1, s2, s3: CARDINAL) ;
VAR
   eb : errorBlock ;
   sym: ARRAY [0..2] OF CARDINAL ;
BEGIN
   sym[0] := s1 ;
   sym[1] := s2 ;
   sym[2] := s3 ;
   initErrorBlock (eb, m, sym) ;
   eb.highplus1 := HIGH (sym) + 1 ;
   ebnf (eb, sym) ;
   flushColor (eb) ;
   defaultError (eb, tok) ;
   ErrorString (eb.e, Dup (eb.out)) ;
   killErrorBlock (eb) ;
   checkAbort
END MetaErrorStringT3 ;


PROCEDURE MetaErrorT3 (tok: CARDINAL; m: ARRAY OF CHAR; s1, s2, s3: CARDINAL) ;
BEGIN
   MetaErrorStringT3 (tok, InitString (m), s1, s2, s3) ;
END MetaErrorT3 ;


PROCEDURE MetaErrorStringT4 (tok: CARDINAL; m: String; s1, s2, s3, s4: CARDINAL) ;
VAR
   eb : errorBlock ;
   sym: ARRAY [0..3] OF CARDINAL ;
BEGIN
   sym[0] := s1 ;
   sym[1] := s2 ;
   sym[2] := s3 ;
   sym[3] := s4 ;
   initErrorBlock (eb, m, sym) ;
   ebnf (eb, sym) ;
   flushColor (eb) ;
   defaultError (eb, tok) ;
   ErrorString (eb.e, Dup (eb.out)) ;
   killErrorBlock (eb) ;
   checkAbort
END MetaErrorStringT4 ;


PROCEDURE MetaErrorT4 (tok: CARDINAL; m: ARRAY OF CHAR; s1, s2, s3, s4: CARDINAL) ;
BEGIN
   MetaErrorStringT4 (tok, InitString (m), s1, s2, s3, s4) ;
END MetaErrorT4 ;


PROCEDURE MetaError0 (m: ARRAY OF CHAR) ;
BEGIN
   MetaErrorT0 (GetTokenNo (), m)
END MetaError0 ;


PROCEDURE MetaError1 (m: ARRAY OF CHAR; s: CARDINAL) ;
BEGIN
   MetaErrorT1 (GetTokenNo (), m, s)
END MetaError1 ;


PROCEDURE MetaError2 (m: ARRAY OF CHAR; s1, s2: CARDINAL) ;
BEGIN
   MetaErrorT2 (GetTokenNo (), m, s1, s2)
END MetaError2 ;


PROCEDURE MetaError3 (m: ARRAY OF CHAR; s1, s2, s3: CARDINAL) ;
BEGIN
   MetaErrorT3 (GetTokenNo (), m, s1, s2, s3)
END MetaError3 ;


PROCEDURE MetaError4 (m: ARRAY OF CHAR; s1, s2, s3, s4: CARDINAL) ;
BEGIN
   MetaErrorT4 (GetTokenNo (), m, s1, s2, s3, s4)
END MetaError4 ;


(*
   wrapErrors -
*)

PROCEDURE wrapErrors (tok: CARDINAL;
                      m1, m2: ARRAY OF CHAR;
                      sym: ARRAY OF CARDINAL) ;
VAR
   eb: errorBlock ;
BEGIN
   initErrorBlock (eb, InitString (m1), sym) ;
   ebnf (eb, sym) ;
   flushColor (eb) ;
   defaultError (eb, tok) ;
   lastRoot := eb.e ;
   ErrorString (eb.e, Dup (eb.out)) ;
   killErrorBlock (eb) ;
   initErrorBlock (eb, InitString (m2), sym) ;
   eb.type := chained ;
   ebnf (eb, sym) ;
   flushColor (eb) ;
   defaultError (eb, tok) ;
   ErrorString (eb.e, Dup (eb.out)) ;
   killErrorBlock (eb)
END wrapErrors ;


PROCEDURE MetaErrorsT1 (tok: CARDINAL; m1, m2: ARRAY OF CHAR; s: CARDINAL) ;
VAR
   sym: ARRAY [0..0] OF CARDINAL ;
BEGIN
   sym[0] := s ;
   wrapErrors (tok, m1, m2, sym)
END MetaErrorsT1 ;


PROCEDURE MetaErrorsT2 (tok: CARDINAL; m1, m2: ARRAY OF CHAR; s1, s2: CARDINAL) ;
VAR
   sym: ARRAY [0..1] OF CARDINAL ;
BEGIN
   sym[0] := s1 ;
   sym[1] := s2 ;
   wrapErrors (tok, m1, m2, sym)
END MetaErrorsT2 ;


PROCEDURE MetaErrorsT3 (tok: CARDINAL; m1, m2: ARRAY OF CHAR; s1, s2, s3: CARDINAL) ;
VAR
   sym : ARRAY [0..2] OF CARDINAL ;
BEGIN
   sym[0] := s1 ;
   sym[1] := s2 ;
   sym[2] := s3 ;
   wrapErrors (tok, m1, m2, sym)
END MetaErrorsT3 ;


PROCEDURE MetaErrorsT4 (tok: CARDINAL; m1, m2: ARRAY OF CHAR; s1, s2, s3, s4: CARDINAL) ;
VAR
   sym : ARRAY [0..3] OF CARDINAL ;
BEGIN
   sym[0] := s1 ;
   sym[1] := s2 ;
   sym[2] := s3 ;
   sym[3] := s4 ;
   wrapErrors (tok, m1, m2, sym)
END MetaErrorsT4 ;


PROCEDURE MetaErrors1 (m1, m2: ARRAY OF CHAR; s: CARDINAL) ;
BEGIN
   MetaErrorsT1 (GetTokenNo (), m1, m2, s)
END MetaErrors1 ;


PROCEDURE MetaErrors2 (m1, m2: ARRAY OF CHAR; s1, s2: CARDINAL) ;
BEGIN
   MetaErrorsT2 (GetTokenNo (), m1, m2, s1, s2)
END MetaErrors2 ;


PROCEDURE MetaErrors3 (m1, m2: ARRAY OF CHAR; s1, s2, s3: CARDINAL) ;
BEGIN
   MetaErrorsT3 (GetTokenNo (), m1, m2, s1, s2, s3)
END MetaErrors3 ;


PROCEDURE MetaErrors4 (m1, m2: ARRAY OF CHAR; s1, s2, s3, s4: CARDINAL) ;
BEGIN
   MetaErrorsT4 (GetTokenNo (), m1, m2, s1, s2, s3, s4)
END MetaErrors4 ;


PROCEDURE MetaErrorString0 (m: String) ;
BEGIN
   MetaErrorStringT0 (GetTokenNo (), m)
END MetaErrorString0 ;


PROCEDURE MetaErrorString1 (m: String; s: CARDINAL) ;
BEGIN
   MetaErrorStringT1 (GetTokenNo (), m, s)
END MetaErrorString1 ;


PROCEDURE MetaErrorString2 (m: String; s1, s2: CARDINAL) ;
BEGIN
   MetaErrorStringT2 (GetTokenNo (), m, s1, s2)
END MetaErrorString2 ;


PROCEDURE MetaErrorString3 (m: String; s1, s2, s3: CARDINAL) ;
BEGIN
   MetaErrorStringT3 (GetTokenNo (), m, s1, s2, s3)
END MetaErrorString3 ;


PROCEDURE MetaErrorString4 (m: String; s1, s2, s3, s4: CARDINAL) ;
BEGIN
   MetaErrorStringT4 (GetTokenNo (), m, s1, s2, s3, s4)
END MetaErrorString4 ;


(*
   checkAbort - checks to see if the boolean flag seenAbort has been set,
                if so it flushes all existing errors and terminates.
*)

PROCEDURE checkAbort ;
BEGIN
   IF seenAbort
   THEN
      FlushWarnings ;
      FlushErrors
   END
END checkAbort ;


(*
   translate -
*)

PROCEDURE translate (m, s: String; VAR i: INTEGER; name: Name) : String ;
VAR
   l : INTEGER ;
   ch: CHAR ;
BEGIN
   l := Length (m) ;
   WHILE (i >= 0) AND (i < l) DO
      ch := char (m, i) ;
      IF (ch = '%') AND (i < l)
      THEN
         INC (i) ;
         ch := char (m, i) ;
         INC (i) ;
         IF ch = 'a'
         THEN
            s := ConCat (s, Mark (InitString ('%<'))) ;
            s := ConCat (s, Mark (InitStringCharStar (KeyToCharStar (name)))) ;
            s := ConCat (s, Mark (InitString ('%>'))) ;
            RETURN s
         END ;
         s := ConCatChar (s, '%')
      END ;
      s := ConCatChar (s, ch) ;
      INC (i)
   END ;
   RETURN s
END translate ;


(*
   MetaErrorNT0 - generate an error message at tok using format.
*)

PROCEDURE MetaErrorNT0 (tok: CARDINAL; format: ARRAY OF CHAR) ;
BEGIN
   MetaErrorStringT0 (tok, InitString (format))
END MetaErrorNT0 ;


(*
   MetaErrorNT1 - generate an error message at tok using format and name.
                  The format should contain %a for name substitution.
*)

PROCEDURE MetaErrorNT1 (tok: CARDINAL; format: ARRAY OF CHAR; name: Name) ;
VAR
   i  : INTEGER ;
   s,
   fmt: String ;
BEGIN
   i := 0 ;
   fmt := InitString (format) ;
   s := InitString ('') ;
   s := translate (fmt, s, i, name) ;
   MetaErrorStringT0 (tok, s) ;
   fmt := KillString (fmt) ;
END MetaErrorNT1 ;


(*
   MetaErrorN1 -
*)

PROCEDURE MetaErrorN1 (m: ARRAY OF CHAR; n: Name) ;
BEGIN
   MetaErrorNT1 (GetTokenNo (), m, n)
END MetaErrorN1 ;


(*
   MetaErrorNT1 - generate an error message at tok using format, name1
                  and name2.  The format should contain two occurances of %a
                  for name substitution.
*)

PROCEDURE MetaErrorNT2 (tok: CARDINAL; format: ARRAY OF CHAR; name1, name2: Name) ;
VAR
   i  : INTEGER ;
   s,
   fmt: String ;
BEGIN
   i := 0 ;
   fmt := InitString (format) ;
   s := InitString ('') ;
   s := translate (fmt, s, i, name1) ;
   s := translate (fmt, s, i, name2) ;
   MetaErrorStringT0 (tok, s) ;
   fmt := KillString (fmt) ;
END MetaErrorNT2 ;


(*
   MetaErrorN2 -
*)

PROCEDURE MetaErrorN2 (m: ARRAY OF CHAR; n1, n2: Name) ;
BEGIN
   MetaErrorNT2 (GetTokenNo (), m, n1, n2)
END MetaErrorN2 ;


(*
   wrapString - return a string which has been formatted with the specifier codes.
                Color is disabled.  The result string is returned.
*)

PROCEDURE wrapString (m: String;
                      sym: ARRAY OF CARDINAL) : String ;
VAR
   eb : errorBlock ;
   s  : String ;
   old: BOOLEAN ;
BEGIN
   old := M2ColorString.SetEnableColor (FALSE) ;
   initErrorBlock (eb, Dup (m), sym) ;
   eb.useError := FALSE ;
   ebnf (eb, sym) ;
   flushColor (eb) ;
   s := Dup (eb.out) ;
   killErrorBlock (eb) ;
   old := M2ColorString.SetEnableColor (old) ;
   RETURN s
END wrapString ;


PROCEDURE MetaString0 (m: String) : String ;
VAR
   sym: ARRAY [0..0] OF CARDINAL ;
BEGIN
   sym[0] := NulSym ;
   RETURN wrapString (m, sym)
END MetaString0 ;


PROCEDURE MetaString1 (m: String; s: CARDINAL) : String ;
VAR
   sym: ARRAY [0..0] OF CARDINAL ;
BEGIN
   sym[0] := s ;
   RETURN wrapString (m, sym)
END MetaString1 ;


PROCEDURE MetaString2 (m: String; s1, s2: CARDINAL) : String ;
VAR
   sym: ARRAY [0..1] OF CARDINAL ;
BEGIN
   sym[0] := s1 ;
   sym[1] := s2 ;
   RETURN wrapString (m, sym)
END MetaString2 ;


PROCEDURE MetaString3 (m: String; s1, s2, s3: CARDINAL) : String ;
VAR
   sym: ARRAY [0..2] OF CARDINAL ;
BEGIN
   sym[0] := s1 ;
   sym[1] := s2 ;
   sym[2] := s3 ;
   RETURN wrapString (m, sym)
END MetaString3 ;


PROCEDURE MetaString4 (m: String; s1, s2, s3, s4: CARDINAL) : String ;
VAR
   sym: ARRAY [0..3] OF CARDINAL ;
BEGIN
   sym[0] := s1 ;
   sym[1] := s2 ;
   sym[2] := s3 ;
   sym[3] := s4 ;
   RETURN wrapString (m, sym)
END MetaString4 ;


(*
   MetaErrorDecl - if sym is a variable or parameter then generate a
                   declaration error or warning message.  If error is
                   FALSE then a warning is issued.
*)

PROCEDURE MetaErrorDecl (sym: CARDINAL; error: BOOLEAN) ;
BEGIN
   IF (sym # NulSym) AND IsVar (sym)
   THEN
      IF error
      THEN
         IF IsVarAParam (sym)
         THEN
            MetaErrorT1 (GetVarDeclFullTok (sym), 'parameter declaration for {%1ad}', sym)
         ELSE
            MetaErrorT1 (GetVarDeclFullTok (sym), 'variable declaration for {%1ad}', sym)
         END
      ELSE
         IF IsVarAParam (sym)
         THEN
            MetaErrorT1 (GetVarDeclFullTok (sym), 'parameter declaration for {%1Wad}', sym)
         ELSE
            MetaErrorT1 (GetVarDeclFullTok (sym), 'variable declaration for {%1Wad}', sym)
         END
      END
   END
END MetaErrorDecl ;


BEGIN
   lastRoot := NIL ;
   lastColor := noColor ;
   seenAbort := FALSE ;
   outputStack := InitIndex (1) ;
   dictionary := InitIndex (1) ;
   freeEntry := NIL
END M2MetaError.