(* M2Error.mod error reporting interface.

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

IMPLEMENTATION MODULE M2Error ;

FROM NameKey IMPORT NulName, Name, KeyToCharStar ;
FROM DynamicStrings IMPORT String, InitString, InitStringCharStar, ConCat, ConCatChar, Mark, string, KillString, Dup ;
FROM FIO IMPORT StdOut, WriteNBytes, Close, FlushBuffer ;
FROM StrLib IMPORT StrLen, StrEqual ;
FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3 ;
FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToColumnNo, GetTokenNo ;
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM M2Printf IMPORT printf0, printf1, printf2, printf3 ;
FROM M2Options IMPORT Xcode ;
FROM M2RTS IMPORT ExitOnHalt ;
FROM SYSTEM IMPORT ADDRESS ;
FROM M2Emit IMPORT EmitError ;
FROM M2LexBuf IMPORT UnknownTokenNo ;
FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, PushAddress, PopAddress, NoOfItemsInStackAddress ;
FROM Indexing IMPORT Index, HighIndice, InitIndex, GetIndice, PutIndice ;
FROM M2Debug IMPORT Assert ;
FROM M2Pass IMPORT IsPass0, IsPass1 ;
FROM SymbolTable IMPORT NulSym ;

FROM M2ColorString IMPORT filenameColor, endColor, errorColor, warningColor, noteColor,
                          range1Color, range2Color, quoteOpen, quoteClose ;

IMPORT M2Emit ;


CONST
   Debugging  =  TRUE ;
   DebugTrace = FALSE ;
   DebugError = FALSE ;

TYPE
   Error = POINTER TO RECORD
                         parent,
                         child,
                         next     : Error ;
                         note,
                         fatal    : BOOLEAN ;
                         s        : String ;
                         (* index of token causing the error *)
                         token    : CARDINAL ;
                         color    : BOOLEAN ;
                         scope    : ErrorScope ;
                      END ;

   KindScope = (noscope, definition, implementation, program, module, procedure) ;

   ErrorScope = POINTER TO RECORD
                              scopeKind: KindScope ;
                              scopeName: Name ;
                              symbol   : CARDINAL ;   (* symbol table entry.  *)
                           END ;


VAR
   head        : Error ;
   InInternal  : BOOLEAN ;
   lastScope   : ErrorScope ;
   scopeIndex  : CARDINAL ;
   scopeArray  : Index ;
   currentScope: ErrorScope ;
   scopeStack  : StackOfAddress ;


(*
   SetColor - informs the error module that this error will have had colors
              assigned to it.  If an error is issued without colors assigned
              then the default colors will be assigned to the legacy error
              messages.
*)

PROCEDURE SetColor (e: Error) : Error ;
BEGIN
   e^.color := TRUE ;
   RETURN e
END SetColor ;


(*
   Cast - casts a := b
*)

PROCEDURE Cast (VAR a: ARRAY OF BYTE; b: ARRAY OF BYTE) ;
VAR
   i: CARDINAL ;
BEGIN
   IF HIGH(a)=HIGH(b)
   THEN
      FOR i := 0 TO HIGH(a) DO
         a[i] := b[i]
      END
   END
END Cast ;


(*
   TranslateNameToString - takes a format specification string, a, and
                           if they consist of of %a then this is translated
                           into a String and %a is replaced by %s.
*)

PROCEDURE TranslateNameToCharStar (VAR a: ARRAY OF CHAR;
                                   n: CARDINAL) : BOOLEAN ;
VAR
   argno,
   i, h : CARDINAL ;
BEGIN
   argno := 1 ;
   i := 0 ;
   h := StrLen(a) ;
   WHILE i<h DO
      IF (a[i]='%') AND (i+1<h)
      THEN
         IF (a[i+1]='a') AND (argno=n)
         THEN
            a[i+1] := 's' ;
            RETURN( TRUE )
         END ;
         INC(argno) ;
         IF argno>n
         THEN
            (* all done *)
            RETURN( FALSE )
         END
      END ;
      INC(i)
   END ;
   RETURN( FALSE )
END TranslateNameToCharStar ;


(*
   InternalError - displays an internal error message together with the compiler source
                   file and line number.
                   This function is not buffered and is used when the compiler is about
                   to give up.
*)

PROCEDURE InternalError (message: ARRAY OF CHAR) <* noreturn *> ;
BEGIN
   IF NOT InInternal
   THEN
      InInternal := TRUE ;
      FlushErrors
   END ;
   M2Emit.InternalError (message) ;
   HALT
END InternalError ;


(* ***************************************************************************
   The following routines are used for normal syntax and semantic error reporting
   *************************************************************************** *)


(*
   WriteFormat0 - displays the source module and line together
                  with the encapsulated format string.
                  Used for simple error messages tied to the current token.
*)

PROCEDURE WriteFormat0 (a: ARRAY OF CHAR) ;
VAR
   e: Error ;
BEGIN
   e := NewError(GetTokenNo()) ;
   WITH e^ DO
      s := Sprintf0(Mark(InitString(a)))
   END
END WriteFormat0 ;


(*
   WarnFormat0 - displays the source module and line together
                 with the encapsulated format string.
                 Used for simple warning messages tied to the current token.
*)

PROCEDURE WarnFormat0 (a: ARRAY OF CHAR) ;
VAR
   e: Error ;
BEGIN
   e := NewWarning(GetTokenNo()) ;
   WITH e^ DO
      s := Sprintf0(Mark(InitString(a)))
   END
END WarnFormat0 ;


(*
   DoFormat1 -
*)

PROCEDURE DoFormat1 (a: ARRAY OF CHAR; w: ARRAY OF BYTE) : String ;
VAR
   s: String ;
   n: Name ;
BEGIN
   n := NulName ;
   IF TranslateNameToCharStar(a, 1)
   THEN
      Cast(n, w) ;
      s := Mark(InitStringCharStar(KeyToCharStar(n))) ;
      s := Sprintf1(Mark(InitString(a)), s)
   ELSE
      s := Sprintf1(Mark(InitString(a)), w)
   END ;
   RETURN( s )
END DoFormat1 ;


(*
   WriteFormat1 - displays the source module and line together
                  with the encapsulated format string.
                  Used for simple error messages tied to the current token.
*)

PROCEDURE WriteFormat1 (a: ARRAY OF CHAR; w: ARRAY OF BYTE) ;
VAR
   e: Error ;
BEGIN
   e := NewError(GetTokenNo()) ;
   e^.s := DoFormat1(a, w)
END WriteFormat1 ;


(*
   WarnFormat1 - displays the source module and line together
                 with the encapsulated format string.
                 Used for simple warning messages tied to the current token.
*)

PROCEDURE WarnFormat1 (a: ARRAY OF CHAR; w: ARRAY OF BYTE) ;
VAR
   e: Error ;
BEGIN
   e := NewWarning(GetTokenNo()) ;
   e^.s := DoFormat1(a, w)
END WarnFormat1 ;


(*
   DoFormat2 -
*)

PROCEDURE DoFormat2 (a: ARRAY OF CHAR; w1, w2: ARRAY OF BYTE) : String ;
VAR
   n     : Name ;
   s,
   s1, s2: String ;
   b     : BITSET ;
BEGIN
   b := {} ;
   n := NulName ;
   IF TranslateNameToCharStar(a, 1)
   THEN
      Cast(n, w1) ;
      s1 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
      INCL(b, 1)
   END ;
   IF TranslateNameToCharStar(a, 2)
   THEN
      Cast(n, w2) ;
      s2 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
      INCL(b, 2)
   END ;
   CASE b OF

   {}   :  s := Sprintf2(Mark(InitString(a)), w1, w2) |
   {1}  :  s := Sprintf2(Mark(InitString(a)), s1, w2) |
   {2}  :  s := Sprintf2(Mark(InitString(a)), w1, s2) |
   {1,2}:  s := Sprintf2(Mark(InitString(a)), s1, s2)

   ELSE
      HALT
   END ;
   RETURN( s )
END DoFormat2 ;


(*
   WriteFormat2 - displays the module and line together with the encapsulated
                  format strings.
                  Used for simple error messages tied to the current token.
*)

PROCEDURE WriteFormat2 (a: ARRAY OF CHAR; w1, w2: ARRAY OF BYTE) ;
VAR
   e: Error ;
BEGIN
   e := NewError(GetTokenNo()) ;
   e^.s := DoFormat2(a, w1, w2)
END WriteFormat2 ;


PROCEDURE DoFormat3 (a: ARRAY OF CHAR; w1, w2, w3: ARRAY OF BYTE) : String ;
VAR
   n            : Name ;
   s, s1, s2, s3: String ;
   b            : BITSET ;
BEGIN
   b := {} ;
   n := NulName ;
   IF TranslateNameToCharStar(a, 1)
   THEN
      Cast(n, w1) ;
      s1 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
      INCL(b, 1)
   END ;
   IF TranslateNameToCharStar(a, 2)
   THEN
      Cast(n, w2) ;
      s2 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
      INCL(b, 2)
   END ;
   IF TranslateNameToCharStar(a, 3)
   THEN
      Cast(n, w3) ;
      s3 := Mark(InitStringCharStar(KeyToCharStar(n))) ;
      INCL(b, 3)
   END ;
   CASE b OF

   {}     :  s := Sprintf3(Mark(InitString(a)), w1, w2, w3) |
   {1}    :  s := Sprintf3(Mark(InitString(a)), s1, w2, w3) |
   {2}    :  s := Sprintf3(Mark(InitString(a)), w1, s2, w3) |
   {1,2}  :  s := Sprintf3(Mark(InitString(a)), s1, s2, w3) |
   {3}    :  s := Sprintf3(Mark(InitString(a)), w1, w2, s3) |
   {1,3}  :  s := Sprintf3(Mark(InitString(a)), s1, w2, s3) |
   {2,3}  :  s := Sprintf3(Mark(InitString(a)), w1, s2, s3) |
   {1,2,3}:  s := Sprintf3(Mark(InitString(a)), s1, s2, s3)

   ELSE
      HALT
   END ;
   RETURN( s )
END DoFormat3 ;


(*
   WriteFormat3 - displays the module and line together with the encapsulated
                  format strings.
                  Used for simple error messages tied to the current token.
*)

PROCEDURE WriteFormat3 (a: ARRAY OF CHAR; w1, w2, w3: ARRAY OF BYTE) ;
VAR
   e: Error ;
BEGIN
   e := NewError(GetTokenNo()) ;
   e^.s := DoFormat3(a, w1, w2, w3)
END WriteFormat3 ;


(*
   MoveError - repositions an error, e, to token, AtTokenNo, and returns, e.
*)

PROCEDURE MoveError (e: Error; AtTokenNo: CARDINAL) : Error ;
BEGIN
   IF e # NIL
   THEN
      e^.token := AtTokenNo
   END ;
   RETURN e
END MoveError ;


(*
   NewError - creates and returns a new error handle.
*)

PROCEDURE NewError (AtTokenNo: CARDINAL) : Error ;
VAR
   e, f: Error ;
BEGIN
   IF AtTokenNo = UnknownTokenNo
   THEN
      (* this could be used as a useful debugging hook as the front end
         has forgotten the token no.  This can occur if a complex record
         structure or array is used for example.  *)
      AtTokenNo := GetTokenNo ()
   END ;
   NEW(e) ;
   WITH e^ DO
      s      := NIL ;
      token  := AtTokenNo ;
      next   := NIL ;
      parent := NIL ;
      child  := NIL ;
      note   := FALSE ;
      fatal  := TRUE ;
      color  := FALSE ;
   END ;
   (* Assert (scopeKind # noscope) ;  *)
   e^.scope := currentScope ;
   IF (head=NIL) OR (head^.token>AtTokenNo)
   THEN
      e^.next := head ;
      head    := e
   ELSE
      f := head ;
      WHILE (f^.next#NIL) AND (f^.next^.token<AtTokenNo) DO
         f := f^.next
      END ;
      e^.next := f^.next ;
      f^.next := e
   END ;
   RETURN( e )
END NewError ;


(*
   NewWarning - creates and returns a new error handle suitable for a warning.
                A warning will not stop compilation.
*)

PROCEDURE NewWarning (AtTokenNo: CARDINAL) : Error ;
VAR
   e: Error ;
BEGIN
   e := NewError(AtTokenNo) ;
   e^.fatal := FALSE ;
   e^.note  := FALSE ;
   RETURN e
END NewWarning ;


(*
   NewNote - creates and returns a new error handle suitable for a note.
             A note will not stop compilation.
*)

PROCEDURE NewNote (AtTokenNo: CARDINAL) : Error ;
VAR
   e: Error ;
BEGIN
   e := NewError(AtTokenNo) ;
   e^.fatal := FALSE ;
   e^.note  := TRUE ;
   RETURN e
END NewNote ;


(*
   ChainError - creates and returns a new error handle, this new error
                is associated with, e, and is chained onto the end of, e.
                If, e, is NIL then the result to NewError is returned.
*)

PROCEDURE ChainError (AtTokenNo: CARDINAL; e: Error) : Error ;
VAR
   f: Error ;
BEGIN
   IF e=NIL
   THEN
      RETURN NewError (AtTokenNo)
   ELSE
      NEW (f) ;
      WITH f^ DO
         s         := NIL ;
         token     := AtTokenNo ;
         next      := e^.child ;
         parent    := e ;
         child     := NIL ;
         fatal     := e^.fatal ;
         scope     := e^.scope
      END ;
      e^.child := f
   END ;
   RETURN f
END ChainError ;


(*
   ErrorFormat routines provide a printf capability for the error handle.
*)

PROCEDURE ErrorFormat0 (e: Error; a: ARRAY OF CHAR) ;
BEGIN
   WITH e^ DO
      IF s=NIL
      THEN
         s := Sprintf0(Mark(InitString(a)))
      ELSE
         s := ConCat(s, Mark(Sprintf0(Mark(InitString(a)))))
      END
   END
END ErrorFormat0 ;


PROCEDURE ErrorFormat1 (e: Error; a: ARRAY OF CHAR; w: ARRAY OF BYTE) ;
VAR
   s1: String ;
BEGIN
   s1 := DoFormat1(a, w) ;
   WITH e^ DO
      IF s=NIL
      THEN
         s := s1
      ELSE
         s := ConCat(s, Mark(s1))
      END
   END
END ErrorFormat1 ;


PROCEDURE ErrorFormat2 (e: Error; a: ARRAY OF CHAR; w1, w2: ARRAY OF BYTE) ;
VAR
   s1: String ;
BEGIN
   s1 := DoFormat2(a, w1, w2) ;
   WITH e^ DO
      IF s=NIL
      THEN
         s := s1
      ELSE
         s := ConCat(s, Mark(s1))
      END
   END
END ErrorFormat2 ;


PROCEDURE ErrorFormat3 (e: Error; a: ARRAY OF CHAR;
                        w1, w2, w3: ARRAY OF BYTE) ;
VAR
   s1: String ;
BEGIN
   s1 := DoFormat3(a, w1, w2, w3) ;
   WITH e^ DO
      IF s=NIL
      THEN
         s := s1
      ELSE
         s := ConCat(s, Mark(s1))
      END
   END
END ErrorFormat3 ;


PROCEDURE ErrorString (e: Error; str: String) ;
BEGIN
   WITH e^ DO
      s := str
   END
END ErrorString ;


(*
   Init - initializes the error list.
*)

PROCEDURE Init ;
BEGIN
   head := NIL ;
   InInternal := FALSE ;
   scopeStack := InitStackAddress () ;
   scopeArray := InitIndex (1) ;
   currentScope := NIL ;
   scopeIndex := 0
END Init ;


(*
   CheckIncludes - generates a sequence of error messages which determine the relevant
                   included file and line number.
                   For example:

                   gcc a.c
                   In file included from b.h:1,
                                    from a.c:1:
                   c.h:1: parse error before `and'

                   where a.c is: #include "b.h"
                         b.h is: #include "c.h"
                         c.h is: and this and that

                   we attempt to follow the error messages that gcc issues.
*)

PROCEDURE CheckIncludes (token: CARDINAL; depth: CARDINAL) ;
VAR
   included: String ;
   lineno  : CARDINAL ;
BEGIN
   included := FindFileNameFromToken(token, depth+1) ;
   IF included#NIL
   THEN
      lineno := TokenToLineNo(token, depth+1) ;
      IF depth=0
      THEN
         printf2('In file included from %s:%d', included, lineno)
      ELSE
         printf2('                 from %s:%d', included, lineno)
      END ;
      IF FindFileNameFromToken(token, depth+2)=NIL
      THEN
         printf0(':\n')
      ELSE
         printf0(',\n')
      END ;
      CheckIncludes(token, depth+1)
   END
END CheckIncludes ;


(*
   FlushAll - flushes all errors in list, e.
*)

PROCEDURE FlushAll (e: Error; FatalStatus: BOOLEAN) : BOOLEAN ;
VAR
   f      : Error ;
   written: BOOLEAN ;
BEGIN
   written := FALSE ;
   IF e#NIL
   THEN
      REPEAT
         WITH e^ DO
            IF (FatalStatus=fatal) AND (s#NIL)
            THEN
               currentScope := scope ;
               CheckIncludes (token, 0) ;
               EmitError (fatal, note, token, AnnounceScope (e, s)) ;
               IF (child#NIL) AND FlushAll (child, FatalStatus)
               THEN
               END ;
               s := NIL ;
               written := TRUE
            END
         END ;
         f := e ;
         e := e^.next ;
         IF NOT Debugging
         THEN
            WITH f^ DO
               s := KillString (s)
            END ;
            DISPOSE (f)
         END ;
      UNTIL e=NIL
   END ;
   RETURN written
END FlushAll ;


(*
   FlushErrors - switches the output channel to the error channel
                 and then writes out all errors.
*)

PROCEDURE FlushErrors ;
BEGIN
   IF DebugTrace
   THEN
      printf0('\nFlushing all errors\n') ;
      printf0('===================\n')
   END ;
   IF FlushAll (head, TRUE)
   THEN
      ExitOnHalt(1) ;
      HALT
   END
END FlushErrors ;


(*
   FlushWarnings - switches the output channel to the error channel
                   and then writes out all warnings.
                   If an error is present the compilation is terminated,
                   if warnings only were emitted then compilation will
                   continue.
*)

PROCEDURE FlushWarnings ;
BEGIN
   IF FlushAll (head, FALSE)
   THEN
   END
END FlushWarnings ;


(*
   ErrorStringsAt2 - given error strings, s1, and, s2, it places these
                     strings at token positions, tok1 and tok2, respectively.
                     Both strings are consumed.
*)

PROCEDURE ErrorStringsAt2 (s1, s2: String; tok1, tok2: CARDINAL) ;
VAR
   e: Error ;
BEGIN
   IF s1=s2
   THEN
      s2 := Dup(s1)
   END ;
   e := NewError(tok1) ;
   ErrorString(e, s1) ;
   ErrorString(ChainError(tok2, e), s2)
END ErrorStringsAt2 ;


(*
   ErrorStringAt2 - given an error string, s, it places this
                    string at token positions, tok1 and tok2, respectively.
                    The string is consumed.
*)

PROCEDURE ErrorStringAt2 (s: String; tok1, tok2: CARDINAL) ;
BEGIN
   ErrorStringsAt2(s, s, tok1, tok2)
END ErrorStringAt2 ;


(*
   ErrorStringAt - given an error string, s, it places this
                   string at token position, tok.
                   The string is consumed.
*)

PROCEDURE ErrorStringAt (s: String; tok: CARDINAL) ;
VAR
   e: Error ;
BEGIN
   e := NewError(tok) ;
   ErrorString(e, s) ;
END ErrorStringAt ;


(*
   WarnStringsAt2 - given warning strings, s1, and, s2, it places these
                    strings at token positions, tok1 and tok2, respectively.
                    Both strings are consumed.
*)

PROCEDURE WarnStringsAt2 (s1, s2: String; tok1, tok2: CARDINAL) ;
VAR
   e: Error ;
BEGIN
   IF s1=s2
   THEN
      s2 := Dup(s1)
   END ;
   e := NewWarning(tok1) ;
   ErrorString(e, s1) ;
   ErrorString(ChainError(tok2, e), s2)
END WarnStringsAt2 ;


(*
   WarnStringAt2 - given an warning string, s, it places this
                   string at token positions, tok1 and tok2, respectively.
                   The string is consumed.
*)

PROCEDURE WarnStringAt2 (s: String; tok1, tok2: CARDINAL) ;
BEGIN
   WarnStringsAt2(s, s, tok1, tok2)
END WarnStringAt2 ;


(*
   WarnStringAt - given an error string, s, it places this
                  string at token position, tok.
                  The string is consumed.
*)

PROCEDURE WarnStringAt (s: String; tok: CARDINAL) ;
VAR
   e: Error ;
BEGIN
   e := NewWarning(tok) ;
   ErrorString(e, s) ;
END WarnStringAt ;


(*
   ErrorAbort0 - aborts compiling, it flushes all warnings and errors before aborting.
*)

PROCEDURE ErrorAbort0 (a: ARRAY OF CHAR) ;
BEGIN
   FlushWarnings ;
   IF NOT StrEqual(a, '')
   THEN
      WriteFormat0(a)
   END ;
   IF NOT FlushAll (head, TRUE)
   THEN
      WriteFormat0('unidentified error') ;
      IF FlushAll (head, TRUE)
      THEN
      END
   END ;
   ExitOnHalt(1) ;
   HALT
END ErrorAbort0 ;


(*
   IsErrorScopeNul - returns TRUE if es is NIL or it has a NulName.
*)

PROCEDURE IsErrorScopeNul (es: ErrorScope) : BOOLEAN ;
BEGIN
   RETURN (es = NIL) OR (es^.scopeName = NulName)
END IsErrorScopeNul ;


(*
   GetAnnounceScope - return message with the error scope attached to message.
                      filename and message are treated as read only by this
                      procedure function.
*)

PROCEDURE GetAnnounceScope (filename, message: String) : String ;
VAR
   pre,
   fmt,
   desc,
   quoted: String ;
BEGIN
   IF filename = NIL
   THEN
      pre := InitString ('')
   ELSE
      pre := Sprintf1 (Mark (InitString ("%s: ")), filename)
   END ;

   IF NOT IsErrorScopeNul (currentScope)
   THEN
      quoted := InitString ('') ;
      quoted := quoteOpen (quoted) ;
      quoted := ConCat (quoted, Mark (InitStringCharStar (KeyToCharStar (currentScope^.scopeName)))) ;
      quoted := quoteClose (quoted)
   END ;

   IF currentScope = NIL
   THEN
      desc := InitString ("no scope active")
   ELSE
      CASE currentScope^.scopeKind OF

      definition    :   desc := InitString ("In definition module") |
      implementation:   desc := InitString ("In implementation module") |
      program       :   desc := InitString ("In program module") |
      module        :   desc := InitString ("In inner module") |
      procedure     :   desc := InitString ("In procedure") |
      noscope       :   desc := InitString ("Unknown scope")

      END
   END ;
   fmt := ConCat (pre, Mark (desc)) ;
   IF IsErrorScopeNul (currentScope)
   THEN
      fmt := ConCat (fmt, Sprintf0 (Mark (InitString (": "))))
   ELSE
      fmt := ConCat (fmt, Sprintf1 (Mark (InitString (" %s: ")), quoted))
   END ;
   RETURN ConCat (fmt, message)
END GetAnnounceScope ;


(*
   IsSameScope - return TRUE if a and b refer to the same scope.
*)

PROCEDURE IsSameScope (a, b: ErrorScope) : BOOLEAN ;
BEGIN
   IF a = b
   THEN
      RETURN TRUE
   ELSIF (a = NIL) OR (b = NIL)
   THEN
      RETURN FALSE
   ELSE
      (* this does not compare the symbol field.  *)
      RETURN (a^.scopeKind = b^.scopeKind) AND (a^.scopeName = b^.scopeName)
   END
END IsSameScope ;


(*
   AnnounceScope - return the error string s with a scope description prepended
                   assuming that scope has changed.
*)

PROCEDURE AnnounceScope (e: Error; message: String) : String ;
BEGIN
   IF NOT IsSameScope (lastScope, e^.scope)
   THEN
      lastScope := e^.scope ;
      IF IsErrorScopeNul (lastScope)
      THEN
         RETURN ConCat (InitString ("no scope active: "), message)
      ELSE
         Assert ((e^.scope # NIL) AND (e^.scope^.scopeKind # noscope)) ;
         (* filename := FindFileNameFromToken (e^.token, 0) ; *)
         message := GetAnnounceScope (NIL, message)
      END
   END ;
   RETURN message
END AnnounceScope ;


(*
   newErrorScope - create an ErrorScope of kindScope and return the object.
                   It is also added the a dynamic array.
*)

PROCEDURE newErrorScope (kind: KindScope) : ErrorScope ;
VAR
   es: ErrorScope ;
   c : CARDINAL ;
BEGIN
   IF IsPass0 ()
   THEN
      NEW (es) ;
      es^.scopeKind := kind ;
      es^.scopeName := NulName ;
      es^.symbol := NulSym ;
      PutIndice (scopeArray, HighIndice (scopeArray) + 1, es) ;
      IF DebugError
      THEN
         c := HighIndice (scopeArray) ;
         printf2 ("pass 0:  %d  %d\n", c, kind)
      END
   ELSE
      INC (scopeIndex) ;
      es := GetIndice (scopeArray, scopeIndex) ;
      IF DebugError
      THEN
         IF IsPass1 ()
         THEN
            printf3 ("pass 1:  %d  %d  %d\n", scopeIndex, es^.scopeKind, kind)
         ELSE
            printf3 ("pass 2:  %d  %d  %d\n", scopeIndex, es^.scopeKind, kind)
         END
      END ;
      Assert (es^.scopeKind = kind)
   END ;
   RETURN es
END newErrorScope ;


(*
   DefaultProgramModule - sets up an unnamed program scope before the Ident is seen.
*)

PROCEDURE DefaultProgramModule ;
BEGIN
   PushAddress (scopeStack, currentScope) ;
   currentScope := newErrorScope (program)
END DefaultProgramModule ;


(*
   DefaultImplementationModule - sets up an unnamed implementation
                                 scope before the Ident is seen.
*)

PROCEDURE DefaultImplementationModule ;
BEGIN
   PushAddress (scopeStack, currentScope) ;
   currentScope := newErrorScope (implementation)
END DefaultImplementationModule ;


(*
   DefaultDefinitionModule - sets up an unnamed definition
                             scope before the Ident is seen.
*)

PROCEDURE DefaultDefinitionModule ;
BEGIN
   PushAddress (scopeStack, currentScope) ;
   currentScope := newErrorScope (definition)
END DefaultDefinitionModule ;


(*
   DefaultInnerModule - sets up an unnamed inner
                        scope before the Ident is seen.
*)

PROCEDURE DefaultInnerModule ;
BEGIN
   PushAddress (scopeStack, currentScope) ;
   currentScope := newErrorScope (module)
END DefaultInnerModule ;


(*
   DefaultProcedure - sets up an unnamed procedure
                      scope before the Ident is seen.
*)

PROCEDURE DefaultProcedure ;
BEGIN
   PushAddress (scopeStack, currentScope) ;
   currentScope := newErrorScope (procedure)
END DefaultProcedure ;


(*
   EnterImplementationScope - signifies to the error routines that the front end
                              has started to compile implementation module scopeName.
*)

PROCEDURE EnterImplementationScope (scopename: Name) ;
BEGIN
   Assert (currentScope # NIL) ;
   Assert (currentScope^.scopeKind = implementation) ;
   IF currentScope^.scopeName = NulName
   THEN
      IF DebugError
      THEN
         printf1 ("seen implementation: %a\n", scopename)
      END ;
      currentScope^.scopeName := scopename
   END
END EnterImplementationScope ;


(*
   EnterProgramScope - signifies to the error routines that the front end
                       has started to compile program module scopeName.
*)

PROCEDURE EnterProgramScope (scopename: Name) ;
BEGIN
   Assert (currentScope # NIL) ;
   Assert (currentScope^.scopeKind = program) ;
   IF currentScope^.scopeName = NulName
   THEN
      IF DebugError
      THEN
         printf1 ("seen program: %a\n", scopename)
      END ;
      currentScope^.scopeName := scopename
   END
END EnterProgramScope ;


(*
   EnterModuleScope - signifies to the error routines that the front end
                      has started to compile an inner module scopeName.
*)

PROCEDURE EnterModuleScope (scopename: Name) ;
BEGIN
   Assert (currentScope # NIL) ;
   Assert (currentScope^.scopeKind = module) ;
   IF currentScope^.scopeName = NulName
   THEN
      IF DebugError
      THEN
         printf1 ("seen module: %a\n", scopename)
      END ;
      currentScope^.scopeName := scopename
   END
END EnterModuleScope ;


(*
   EnterDefinitionScope - signifies to the error routines that the front end
                          has started to compile definition module scopeName.
*)

PROCEDURE EnterDefinitionScope (scopename: Name) ;
BEGIN
   Assert (currentScope # NIL) ;
   Assert (currentScope^.scopeKind = definition) ;
   IF currentScope^.scopeName = NulName
   THEN
      IF DebugError
      THEN
         printf1 ("seen definition: %a\n", scopename)
      END ;
      currentScope^.scopeName := scopename
   END
END EnterDefinitionScope ;


(*
   EnterProcedureScope - signifies to the error routines that the front end
                         has started to compile definition module scopeName.
*)

PROCEDURE EnterProcedureScope (scopename: Name) ;
BEGIN
   Assert (currentScope # NIL) ;
   Assert (currentScope^.scopeKind = procedure) ;
   IF currentScope^.scopeName = NulName
   THEN
      IF DebugError
      THEN
         printf1 ("seen procedure: %a\n", scopename)
      END ;
      currentScope^.scopeName := scopename
   END
END EnterProcedureScope ;


(*
   LeaveErrorScope - leave the current scope and pop into the previous one.
*)

PROCEDURE LeaveErrorScope ;
BEGIN
   currentScope := PopAddress (scopeStack)
END LeaveErrorScope ;


(*
   EnterErrorScope - pushes the currentScope and sets currentScope to scope.
*)

PROCEDURE EnterErrorScope (scope: ErrorScope) ;
BEGIN
   PushAddress (scopeStack, currentScope) ;
   currentScope := scope
END EnterErrorScope ;


(*
   GetCurrentErrorScope - returns currentScope.
*)

PROCEDURE GetCurrentErrorScope () : ErrorScope ;
BEGIN
   RETURN currentScope
END GetCurrentErrorScope ;


(*
   DepthScope - returns the depth of the scope stack.
*)

PROCEDURE DepthScope () : CARDINAL ;
BEGIN
   RETURN NoOfItemsInStackAddress (scopeStack)
END DepthScope ;


(*
   ResetErrorScope - should be called at the start of each pass to
                     reset the error scope index.
*)

PROCEDURE ResetErrorScope ;
BEGIN
   scopeIndex := 0
END ResetErrorScope ;


BEGIN
   Init
END M2Error.