Update copyright years.

[thirdparty/gcc.git] / gcc / m2 / mc / mcError.mod

(* mcError.mod provides an interface between the string handling modules.

Copyright (C) 2015-2024 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 mcError ;

FROM ASCII IMPORT nul, nl ;
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 Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM M2RTS IMPORT ExitOnHalt ;
FROM SYSTEM IMPORT ADDRESS ;
IMPORT StdIO ;

FROM nameKey IMPORT Name, keyToCharStar ;
FROM mcLexBuf IMPORT findFileNameFromToken, tokenToLineNo, tokenToColumnNo, getTokenNo ;
FROM mcPrintf IMPORT printf0, printf1, printf2 ;


CONST
   Debugging  =  TRUE ;
   DebugTrace = FALSE ;
   Xcode      =  TRUE ;

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

VAR
   head      : error ;
   inInternal: BOOLEAN ;


(*
   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 ;


(*
   outString - writes the contents of String to stdout.
               The string, s, is destroyed.
*)

PROCEDURE outString (file: String; line, col: CARDINAL; s: String) ;
VAR
   leader : String ;
   p, q   : POINTER TO CHAR ;
   space,
   newline: BOOLEAN ;
BEGIN
   INC (col) ;
   IF Xcode
   THEN
      leader := Sprintf2(Mark(InitString('%s:%d:')), file, line)
   ELSE
      leader := Sprintf3(Mark(InitString('%s:%d:%d:')), file, line, col)
   END ;
   p := string(s) ;
   newline := TRUE ;
   space := FALSE ;
   WHILE (p#NIL) AND (p^#nul) DO
      IF newline
      THEN
         q := string (leader) ;
         WHILE (q#NIL) AND (q^#nul) DO
            StdIO.Write (q^) ;
            INC (q)
         END
      END ;
      newline := (p^=nl) ;
      space := (p^=' ') ;
      IF newline AND Xcode
      THEN
         printf1 ('(pos: %d)', col)
      END ;
      StdIO.Write (p^) ;
      INC (p)
   END ;
   IF NOT newline
   THEN
      IF Xcode
      THEN
         IF NOT space
         THEN
            StdIO.Write (' ')
         END ;
         printf1 ('(pos: %d)', col)
      END ;
      StdIO.Write (nl)
   END ;
   FlushBuffer (StdOut) ;
   IF NOT Debugging
   THEN
      s      := KillString (s) ;
      leader := KillString (leader)
   END
END outString ;


(*
   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 (a: ARRAY OF CHAR; file: ARRAY OF CHAR; line: CARDINAL) ;
BEGIN
   ExitOnHalt (1) ;
   IF NOT inInternal
   THEN
      inInternal := TRUE ;
      flushErrors ;
      outString (findFileNameFromToken (getTokenNo (), 0),
                 tokenToLineNo (getTokenNo (), 0),
                 tokenToColumnNo (getTokenNo (), 0),
                 Mark(InitString ('*** fatal error ***')))
   END ;
   outString (Mark (InitString (file)), line, 0,
              ConCat (Mark (InitString('*** internal error *** ')), Mark (InitString (a)))) ;
   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
   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 := {} ;
   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 := {} ;
   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 ;


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

PROCEDURE newError (atTokenNo: CARDINAL) : error ;
VAR
   e, f: error ;
BEGIN
   NEW (e) ;
   WITH e^ DO
      s      := NIL ;
      token  := atTokenNo ;
      next   := NIL ;
      parent := NIL ;
      child  := NIL ;
      fatal  := TRUE
   END ;
   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 ;
   RETURN e
END newWarning ;


(*
   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
      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
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
               checkIncludes (token, 0) ;
               IF fatal
               THEN
                  s := ConCat (InitString (' error: '), Mark (s))
               ELSE
                  s := ConCat (InitString(' warning: '), Mark (s))
               END ;
               outString (findFileNameFromToken (token, 0),
                          tokenToLineNo (token, 0), tokenToColumnNo (token, 0), 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 ;


BEGIN
   init
END mcError.