| (* mcError.mod provides an interface between the string handling modules. |
| |
| Copyright (C) 2015-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 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. |
