KJ16609/gcc
1
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2026-02-21 19:35:28 -05:00
Code Issues Packages Projects Releases Wiki Activity

PR modula2/122407: similar error messages are emitted for an unknown symbol

Browse Source 
This followup to PR modula2/122241 reduces error message clutter by
filtering unknown symbol error ensuring that only one error message
is emitted for an unknown symbol at a particular location.
The filter is implemented using two binary trees.  A new generic
(based on the address type) binary dictionary module is added to
the base libraries.

gcc/m2/ChangeLog:

	PR modula2/122407
	* Make-lang.in (GM2-LIBS-BOOT-DEFS): Add BinDict.def.
	(GM2-LIBS-BOOT-MODS): Add BinDict.mod.
	(GM2-COMP-BOOT-DEFS): Add FilterError.def.
	(GM2-COMP-BOOT-MODS): Add FilterError.mod.
	(GM2-LIBS-DEFS): Add BinDict.def.
	(GM2-LIBS-MODS): Add BinDict.mod.
	* gm2-compiler/M2Error.def (KillError): New procedure.
	* gm2-compiler/M2Error.mod (WriteFormat3): Reformat.
	(NewError): Rewrite and call AddToList.
	(AddToList): New procedure.
	(SubFromList): Ditto.
	(WipeReferences): Ditto.
	(KillError): Ditto.
	* gm2-compiler/M2LexBuf.mod (MakeVirtualTok): Return
	caret if all token positions are identical.
	* gm2-compiler/M2MetaError.mod (KillError): Import.
	(FilterError): Import.
	(FilterUnknown): New global.
	(initErrorBlock): Initialize symcause and token.
	(push): Capitalize comments.
	(pop): Copy symcause to toblock if discovered.
	(doError): Add parameter sym.
	(defaultError): Assign token if discovered.
	Pass NulSym to doError.
	(updateTokSym): New procedure.
	(chooseError): Call updateTokSym.
	(doErrorScopeModule): Pass sym to doError.
	(doErrorScopeForward): Ditto.
	(doErrorScopeMod): Ditto.
	(doErrorScopeFor): Ditto.
	(doErrorScopeDefinition): Ditto.
	(doErrorScopeDef): Ditto.
	(doErrorScopeProc): Ditto.
	(used): Pass sym[bol] to doError.
	(op): Assign symcause when encountering
	an error, warning or note.
	(MetaErrorStringT1): Rewrite.
	(MetaErrorStringT2): Ditto.
	(MetaErrorStringT3): Ditto.
	(MetaErrorStringT4): Ditto.
	(isUniqueError): New procedure function.
	(wrapErrors): Rewrite.
	(FilterUnknown): Initialize.
	* gm2-compiler/M2Quads.mod (BuildTSizeFunction): Add spell check
	hint specifier.
	* gm2-compiler/FilterError.def: New file.
	* gm2-compiler/FilterError.mod: New file.
	* gm2-libs/BinDict.def: New file.
	* gm2-libs/BinDict.mod: New file.

libgm2/ChangeLog:

	PR modula2/122407
	* libm2pim/Makefile.am (M2MODS): Add BinDict.mod.
	(M2DEFS): Add BinDict.def.
	* libm2pim/Makefile.in: Regenerate.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
This commit is contained in:
Gaius Mulley
2025-10-24 13:04:10 +01:00
parent 04df8fa9e7
commit cafc877cc1
12 changed files with 938 additions and 89 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/m2/Make-lang.in
View File

@@ -671,6 +671,7 @@ GM2-LIBS-BOOT-DEFS = \
ASCII.def \
Args.def \
Assertion.def \
BinDict.def \
Break.def \
CmdArgs.def \
Debug.def \
@@ -718,6 +719,7 @@ GM2-LIBS-BOOT-MODS = \
ASCII.mod \
Args.mod \
Assertion.mod \
BinDict.mod \
Break.mod \
CmdArgs.mod \
Debug.mod \
@@ -769,6 +771,7 @@ GM2-LIBS-BOOT-CC = \
# Definition modules for the front end found in gm2-compiler.
GM2-COMP-BOOT-DEFS = \
FilterError.def \
FifoQueue.def \
Lists.def \
M2ALU.def \
@@ -845,6 +848,7 @@ GM2-COMP-BOOT-DEFS = \
# Implementation modules for the front end found in gm2-compiler.
GM2-COMP-BOOT-MODS = \
FilterError.mod \
FifoQueue.mod \
Lists.mod \
Lists.mod \
@@ -946,6 +950,7 @@ GM2-LIBS-DEFS = \
ASCII.def \
Args.def \
Assertion.def \
BinDict.def \
Break.def \
Builtins.def \
COROUTINES.def \
@@ -1000,6 +1005,7 @@ GM2-LIBS-MODS = \
ASCII.mod \
Args.mod \
Assertion.mod \
BinDict.mod \
Break.mod \
Builtins.mod \
COROUTINES.mod \
@@ -1062,6 +1068,7 @@ GM2-LIBS-CC = \
# cc1gm2$(exeext) uses these definition modules found in the gm2-compiler directory.
GM2-COMP-DEFS = \
FilterError.def \
FifoQueue.def \
Lists.def \
M2ALU.def \
@@ -1135,6 +1142,7 @@ GM2-COMP-DEFS = \
# cc1gm2$(exeext) uses these implementation modules found in the gm2-compiler directory.
GM2-COMP-MODS = \
FilterError.mod \
FifoQueue.mod \
Lists.mod \
M2ALU.mod \

61
gcc/m2/gm2-compiler/FilterError.def Normal file
View File

@@ -0,0 +1,61 @@
(* FilterError.def provides a filter for token and symbol.
Copyright (C) 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.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. *)
DEFINITION MODULE FilterError ;
TYPE
Filter ;
(*
Init - return a new empty Filter.
*)
PROCEDURE Init () : Filter ;
(*
AddSymError - adds the pair sym token to the filter.
*)
PROCEDURE AddSymError (filter: Filter;
sym: CARDINAL; token: CARDINAL) ;
(*
IsSymError - return TRUE if the pair sym token have been entered in the filter.
*)
PROCEDURE IsSymError (filter: Filter; sym: CARDINAL; token: CARDINAL) : BOOLEAN ;
(*
Kill - deletes the entire filter tree.
*)
PROCEDURE Kill (VAR filter: Filter) ;
END FilterError.

229
gcc/m2/gm2-compiler/FilterError.mod Normal file
View File

@@ -0,0 +1,229 @@
(* FilterError.def implements a filter for token and symbol.
Copyright (C) 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.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. *)
IMPLEMENTATION MODULE FilterError ;
(* The purpose of this module is to be able to filter out multiple error
reports refering to the same symbol and token. This is achieved by
maintaining a dictionary of symbols each pointing to a dictionary of
tokens. *)
FROM SYSTEM IMPORT ADDRESS, ADR ;
FROM Storage IMPORT DEALLOCATE, ALLOCATE ;
FROM BinDict IMPORT Node ;
FROM Assertion IMPORT Assert ;
FROM libc IMPORT printf ;
IMPORT BinDict ;
CONST
Debugging = FALSE ;
TYPE
Filter = POINTER TO RECORD
Sym2Dict: BinDict.Dictionary ;
END ;
PtrToCardinal = POINTER TO CARDINAL ;
PtrToBoolean = POINTER TO BOOLEAN ;
(*
Init - return a new empty Filter.
*)
PROCEDURE Init () : Filter ;
VAR
filter: Filter ;
BEGIN
NEW (filter) ;
WITH filter^ DO
Sym2Dict := BinDict.Init (CompareCardinal, DeleteCardinal, DeleteTree) ;
END ;
RETURN filter
END Init ;
(*
Kill - deletes the entire filter tree and all contents.
*)
PROCEDURE Kill (VAR filter: Filter) ;
BEGIN
BinDict.Kill (filter^.Sym2Dict) ;
DISPOSE (filter)
END Kill ;
(*
CompareCardinal - return an INTEGER representing the comparison
between left and right.
0 if left == right, -1 if left < right,
+1 if left > right.
*)
PROCEDURE CompareCardinal (left, right: PtrToCardinal) : INTEGER ;
BEGIN
IF left^ = right^
THEN
RETURN 0
ELSIF left^ < right^
THEN
RETURN -1
ELSE
RETURN 1
END
END CompareCardinal ;
(*
DeleteCardinal - deallocate the cardinal key.
*)
PROCEDURE DeleteCardinal (card: PtrToCardinal) ;
BEGIN
DISPOSE (card)
END DeleteCardinal ;
(*
DeleteBoolean - deallocate the boolean value.
*)
PROCEDURE DeleteBoolean (boolean: PtrToBoolean) ;
BEGIN
DISPOSE (boolean)
END DeleteBoolean ;
(*
DeleteTree - delete tree and all its contents.
*)
PROCEDURE DeleteTree (ErrorTree: BinDict.Dictionary) ;
BEGIN
BinDict.Kill (ErrorTree)
END DeleteTree ;
(*
AddSymError - adds the pair sym token to the filter.
*)
PROCEDURE AddSymError (filter: Filter;
sym: CARDINAL; token: CARDINAL) ;
BEGIN
IF NOT IsSymError (filter, sym, token)
THEN
AddNewEntry (filter, sym, token, TRUE)
END
END AddSymError ;
(*
AddNewEntry - adds a new value to the sym token pair.
*)
PROCEDURE AddNewEntry (filter: Filter; sym: CARDINAL;
token: CARDINAL; value: BOOLEAN) ;
VAR
TokenTree : BinDict.Dictionary ;
ptrToToken,
ptrToCard : PtrToCardinal ;
ptrToBool : PtrToBoolean ;
BEGIN
TokenTree := BinDict.Get (filter^.Sym2Dict, ADR (sym)) ;
IF TokenTree = NIL
THEN
TokenTree := BinDict.Init (CompareCardinal, DeleteCardinal, DeleteBoolean) ;
NEW (ptrToCard) ;
ptrToCard^ := sym ;
BinDict.Insert (filter^.Sym2Dict, ptrToCard, TokenTree) ;
Assert (BinDict.Get (filter^.Sym2Dict, ptrToCard) = TokenTree)
END ;
NEW (ptrToBool) ;
ptrToBool^ := value ;
NEW (ptrToToken) ;
ptrToToken^ := token ;
IF Debugging
THEN
printf ("adding sym %d: key = 0x%x, value = 0x%x (%d, %d)\n",
sym, ptrToToken, ptrToBool, ptrToToken^, ptrToBool^)
END ;
BinDict.Insert (TokenTree, ptrToToken, ptrToBool) ;
Assert (BinDict.Get (TokenTree, ptrToToken) = ptrToBool) ;
IF Debugging
THEN
BinDict.PostOrder (TokenTree, PrintNode)
END
END AddNewEntry ;
(*
PrintNode -
*)
PROCEDURE PrintNode (node: Node) ;
VAR
ptrToCard : PtrToCardinal ;
ptrToBool : PtrToBoolean ;
BEGIN
ptrToCard := BinDict.Key (node) ;
ptrToBool := BinDict.Value (node) ;
printf ("key = 0x%x, value = 0x%x (%d, %d)\n",
ptrToCard, ptrToBool, ptrToCard^, ptrToBool^)
END PrintNode ;
(*
IsSymError - return TRUE if the pair sym token have been
entered in the filter.
*)
PROCEDURE IsSymError (filter: Filter; sym: CARDINAL; token: CARDINAL) : BOOLEAN ;
VAR
ptb : PtrToBoolean ;
TokenTree: BinDict.Dictionary ;
BEGIN
TokenTree := BinDict.Get (filter^.Sym2Dict, ADR (sym)) ;
(* RETURN (TokenTree # NIL) ; *)
IF TokenTree = NIL
THEN
(* No symbol registered, therefore FALSE. *)
RETURN FALSE
END ;
ptb := BinDict.Get (TokenTree, ADR (token)) ;
IF ptb = NIL
THEN
(* The symbol was registered, but no entry for token, therefore FALSE. *)
RETURN FALSE
END ;
(* Found symbol and token so we return the result. *)
RETURN ptb^
END IsSymError ;
END FilterError.

8
gcc/m2/gm2-compiler/M2Error.def
View File

@@ -129,6 +129,14 @@ PROCEDURE ChainError (AtTokenNo: CARDINAL; e: Error) : Error ;
PROCEDURE MoveError (e: Error; AtTokenNo: CARDINAL) : Error ;
(*
KillError - remove error e from the error list and deallocate
memory associated with e.
*)
PROCEDURE KillError (VAR e: Error) ;
(*
SetColor - informs the error module that this error will have had colors
assigned to it. If an error is issued without colors assigned

108
gcc/m2/gm2-compiler/M2Error.mod
View File

@@ -369,8 +369,8 @@ 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)
e := NewError (GetTokenNo ()) ;
e^.s := DoFormat3 (a, w1, w2, w3)
END WriteFormat3 ;
@@ -394,7 +394,7 @@ END MoveError ;
PROCEDURE NewError (AtTokenNo: CARDINAL) : Error ;
VAR
e, f: Error ;
e: Error ;
BEGIN
IF AtTokenNo = UnknownTokenNo
THEN
@@ -414,18 +414,7 @@ BEGIN
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 ;
AddToList (e) ;
RETURN( e )
END NewError ;
@@ -462,6 +451,95 @@ BEGIN
END NewNote ;
(*
AddToList - adds error e to the list of errors in token order.
*)
PROCEDURE AddToList (e: Error) ;
VAR
f: Error ;
BEGIN
IF (head=NIL) OR (head^.token > e^.token)
THEN
e^.next := head ;
head := e
ELSE
f := head ;
WHILE (f^.next # NIL) AND (f^.next^.token < e^.token) DO
f := f^.next
END ;
e^.next := f^.next ;
f^.next := e
END ;
END AddToList ;
(*
SubFromList - remove e from the global list.
*)
PROCEDURE SubFromList (e: Error) ;
VAR
f: Error ;
BEGIN
IF head = e
THEN
head := head^.next
ELSE
f := head ;
WHILE (f # NIL) AND (f^.next # e) DO
f := f^.next
END ;
IF (f # NIL) AND (f^.next = e)
THEN
f^.next := e^.next
ELSE
InternalError ('expecting e to be on the global list')
END
END ;
DISPOSE (e)
END SubFromList ;
(*
WipeReferences - remove any reference to e from the global list.
*)
PROCEDURE WipeReferences (e: Error) ;
VAR
f: Error ;
BEGIN
f := head ;
WHILE f # NIL DO
IF f^.parent = e
THEN
f^.parent := NIL
END ;
IF f^.child = e
THEN
f^.child := NIL
END ;
f := f^.next
END
END WipeReferences ;
(*
KillError - remove error e from the error list and deallocate
memory associated with e.
*)
PROCEDURE KillError (VAR e: Error) ;
BEGIN
IF head # NIL
THEN
SubFromList (e) ;
WipeReferences (e) ;
e := NIL
END
END KillError ;
(*
ChainError - creates and returns a new error handle, this new error
is associated with, e, and is chained onto the end of, e.

4
gcc/m2/gm2-compiler/M2LexBuf.mod
View File

@@ -1078,6 +1078,10 @@ BEGIN
THEN
caret := right
END ;
IF (caret = left) AND (left = right)
THEN
RETURN caret
END ;
IF isSrcToken (caret) AND isSrcToken (left) AND isSrcToken (right)
THEN
lc := TokenToLocation (caret) ;

212
gcc/m2/gm2-compiler/M2MetaError.mod
View File

@@ -26,7 +26,11 @@ 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 M2Error IMPORT Error, NewError, KillError,
NewWarning, NewNote, ErrorString, InternalError,
ChainError, SetColor, FlushErrors, FlushWarnings ;
FROM FIO IMPORT StdOut, WriteLine ;
FROM SFIO IMPORT WriteS ;
FROM StringConvert IMPORT ctos ;
@@ -67,6 +71,9 @@ FROM SymbolTable IMPORT NulSym,
IMPORT M2ColorString ;
IMPORT M2Error ;
IMPORT FilterError ;
FROM FilterError IMPORT Filter, AddSymError, IsSymError ;
CONST
@@ -85,6 +92,8 @@ TYPE
errorBlock = RECORD
useError : BOOLEAN ;
e : Error ;
symcause : CARDINAL ; (* The symbol (or NulSym) associated with the token no. *)
token : CARDINAL ;
type : errorType ;
out, in : String ;
highplus1 : CARDINAL ;
@@ -115,12 +124,13 @@ TYPE
VAR
lastRoot : Error ;
lastColor : colorType ;
seenAbort : BOOLEAN ;
dictionary : Index ;
outputStack: Index ;
freeEntry : dictionaryEntry ;
lastRoot : Error ;
lastColor : colorType ;
seenAbort : BOOLEAN ;
dictionary : Index ;
outputStack : Index ;
freeEntry : dictionaryEntry ;
FilterUnknown: Filter ;
(*
@@ -513,6 +523,8 @@ BEGIN
WITH eb DO
useError := TRUE ;
e := NIL ;
symcause := NulSym ;
token := UnknownTokenNo ;
type := error ; (* Default to the error color. *)
out := InitString ('') ;
in := input ;
@@ -543,9 +555,9 @@ END initErrorBlock ;
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. *)
pushColor (oldblock) ; (* Save the current color. *)
newblock := oldblock ; (* Now copy all the fields. *)
newblock.out := NIL ; (* We must do this before a clear as we have copied the address. *)
clear (newblock) ;
newblock.quotes := TRUE
END push ;
@@ -604,6 +616,10 @@ BEGIN
THEN
toblock.e := fromblock.e
END ;
IF toblock.symcause = NulSym
THEN
toblock.symcause := fromblock.symcause
END ;
toblock.chain := fromblock.chain ;
toblock.root := fromblock.root ;
toblock.ini := fromblock.ini ;
@@ -1173,35 +1189,54 @@ END doChain ;
doError - creates and returns an error note.
*)
PROCEDURE doError (VAR eb: errorBlock; tok: CARDINAL) ;
PROCEDURE doError (VAR eb: errorBlock; tok: CARDINAL; sym: CARDINAL) ;
BEGIN
IF eb.useError
THEN
chooseError (eb, tok)
chooseError (eb, tok, sym)
END
END doError ;
(*
defaultError - adds the default error location to, tok, if one has not already been
assigned.
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)
doError (eb, tok, NulSym)
END ;
IF eb.token = UnknownTokenNo
THEN
eb.token := tok
END
END defaultError ;
(*
updateTokSym - assign symcause to sym if not NulSym.
Update token.
*)
PROCEDURE updateTokSym (VAR eb: errorBlock; tok: CARDINAL; sym: CARDINAL) ;
BEGIN
IF sym # NulSym
THEN
eb.symcause := sym
END ;
eb.token := tok
END updateTokSym ;
(*
chooseError - choose the error kind dependant upon type.
Either an error, warning or note will be generated.
*)
PROCEDURE chooseError (VAR eb: errorBlock; tok: CARDINAL) ;
PROCEDURE chooseError (VAR eb: errorBlock; tok: CARDINAL; sym: CARDINAL) ;
BEGIN
IF eb.chain
THEN
@@ -1217,19 +1252,22 @@ BEGIN
eb.e := NewError (tok)
ELSE
eb.e := MoveError (eb.e, tok)
END |
END ;
updateTokSym (eb, tok, sym) |
warning: IF eb.e=NIL
THEN
eb.e := NewWarning (tok)
ELSE
eb.e := MoveError (eb.e, tok)
END |
END ;
updateTokSym (eb, tok, sym) |
note : IF eb.e=NIL
THEN
eb.e := NewNote (tok)
ELSE
eb.e := MoveError (eb.e, tok)
END
END ;
updateTokSym (eb, tok, sym)
ELSE
InternalError ('unexpected enumeration value')
@@ -1257,9 +1295,9 @@ BEGIN
THEN
IF IsInnerModule (scope)
THEN
doError (eb, GetDeclaredMod (sym))
doError (eb, GetDeclaredMod (sym), sym)
ELSE
doError (eb, GetDeclaredMod (sym))
doError (eb, GetDeclaredMod (sym), sym)
END
ELSE
Assert (IsDefImp (scope)) ;
@@ -1269,9 +1307,9 @@ BEGIN
UNTIL GetScope(OuterModule)=NulSym. *)
IF GetDeclaredModule (sym) = UnknownTokenNo
THEN
doError (eb, GetDeclaredDef (sym))
doError (eb, GetDeclaredDef (sym), sym)
ELSE
doError (eb, GetDeclaredMod (sym))
doError (eb, GetDeclaredMod (sym), sym)
END
END
END doErrorScopeModule ;
@@ -1290,9 +1328,9 @@ BEGIN
THEN
IF IsInnerModule (scope)
THEN
doError (eb, GetDeclaredFor (sym))
doError (eb, GetDeclaredFor (sym), sym)
ELSE
doError (eb, GetDeclaredFor (sym))
doError (eb, GetDeclaredFor (sym), sym)
END
ELSE
Assert (IsDefImp (scope)) ;
@@ -1302,9 +1340,9 @@ BEGIN
UNTIL GetScope(OuterModule)=NulSym. *)
IF GetDeclaredModule (sym) = UnknownTokenNo
THEN
doError (eb, GetDeclaredDef (sym))
doError (eb, GetDeclaredDef (sym), sym)
ELSE
doError (eb, GetDeclaredFor (sym))
doError (eb, GetDeclaredFor (sym), sym)
END
END
END doErrorScopeForward ;
@@ -1324,12 +1362,12 @@ BEGIN
IF scope = NulSym
THEN
M2Error.EnterErrorScope (NIL) ;
doError (eb, GetDeclaredMod (sym))
doError (eb, GetDeclaredMod (sym), sym)
ELSE
M2Error.EnterErrorScope (GetErrorScope (scope)) ;
IF IsProcedure (scope)
THEN
doError (eb, GetDeclaredMod (sym))
doError (eb, GetDeclaredMod (sym), sym)
ELSE
doErrorScopeModule (eb, sym)
END
@@ -1353,12 +1391,12 @@ BEGIN
IF scope = NulSym
THEN
M2Error.EnterErrorScope (NIL) ;
doError (eb, GetDeclaredFor (sym))
doError (eb, GetDeclaredFor (sym), sym)
ELSE
M2Error.EnterErrorScope (GetErrorScope (scope)) ;
IF IsProcedure (scope)
THEN
doError (eb, GetDeclaredFor (sym))
doError (eb, GetDeclaredFor (sym), sym)
ELSE
doErrorScopeForward (eb, sym)
END
@@ -1392,16 +1430,16 @@ BEGIN
IF IsModule (scope)
THEN
(* No definition module for a program module. *)
doError (eb, GetDeclaredMod (sym))
doError (eb, GetDeclaredMod (sym), 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))
doError (eb, GetDeclaredMod (sym), sym)
ELSE
doError (eb, GetDeclaredDef (sym))
doError (eb, GetDeclaredDef (sym), sym)
END
END
END doErrorScopeDefinition ;
@@ -1421,12 +1459,12 @@ BEGIN
IF scope = NulSym
THEN
M2Error.EnterErrorScope (NIL) ;
doError (eb, GetDeclaredFor (sym))
doError (eb, GetDeclaredFor (sym), sym)
ELSE
M2Error.EnterErrorScope (GetErrorScope (scope)) ;
IF IsProcedure (scope)
THEN
doError (eb, GetDeclaredDef (sym))
doError (eb, GetDeclaredDef (sym), sym)
ELSE
doErrorScopeDefinition (eb, sym)
END
@@ -1477,25 +1515,25 @@ BEGIN
IF scope = NulSym
THEN
M2Error.EnterErrorScope (NIL) ;
doError (eb, GetDeclaredDef (sym))
doError (eb, GetDeclaredDef (sym), sym)
ELSE
M2Error.EnterErrorScope (GetErrorScope (scope)) ;
IF IsVar (sym) OR IsParameter (sym)
THEN
doError (eb, GetVarParamTok (sym))
doError (eb, GetVarParamTok (sym), sym)
ELSIF IsProcedure (scope)
THEN
doError (eb, GetDeclaredDef (sym))
doError (eb, GetDeclaredDef (sym), sym)
ELSIF IsModule (scope)
THEN
doError (eb, GetDeclaredMod (sym))
doError (eb, GetDeclaredMod (sym), sym)
ELSE
Assert (IsDefImp (scope)) ;
IF GetDeclaredDefinition (sym) = UnknownTokenNo
THEN
doError (eb, GetDeclaredMod (sym))
doError (eb, GetDeclaredMod (sym), sym)
ELSE
doError (eb, GetDeclaredDef (sym))
doError (eb, GetDeclaredDef (sym), sym)
END
END
END ;
@@ -1550,7 +1588,7 @@ PROCEDURE used (VAR eb: errorBlock; sym: ARRAY OF CARDINAL; bol: CARDINAL) ;
BEGIN
IF bol <= HIGH (sym)
THEN
doError (eb, GetFirstUsed (sym[bol]))
doError (eb, GetFirstUsed (sym[bol]), sym[bol])
END
END used ;
@@ -1755,7 +1793,8 @@ BEGIN
'B': declaredType (eb, sym, bol) |
'C': eb.chain := TRUE |
'D': declaredDef (eb, sym, bol) |
'E': eb.type := error |
'E': eb.type := error ;
eb.symcause := sym[bol] |
'F': filename (eb) ;
DEC (eb.ini) |
'G': declaredFor (eb, sym, bol) |
@@ -1764,7 +1803,8 @@ BEGIN
DEC (eb.ini) |
'M': declaredMod (eb, sym, bol) |
'N': doCount (eb, sym, bol) |
'O': eb.type := note |
'O': eb.type := note ;
eb.symcause := sym[bol] |
'P': pushColor (eb) |
'Q': resetDictionary |
'R': eb.root := TRUE |
@@ -1772,7 +1812,8 @@ BEGIN
'T': doGetType (eb, sym, bol) |
'U': used (eb, sym, bol) |
'V': declaredVar (eb, sym, bol) |
'W': eb.type := warning |
'W': eb.type := warning ;
eb.symcause := sym[bol] |
'X': pushOutput (eb) |
'Y': processDefine (eb) |
'Z': popOutput (eb) |
@@ -2402,7 +2443,12 @@ BEGIN
ebnf (eb, sym) ;
flushColor (eb) ;
defaultError (eb, tok) ;
ErrorString (eb.e, Dup (eb.out)) ;
IF isUniqueError (eb)
THEN
ErrorString (eb.e, Dup (eb.out)) ;
ELSE
KillError (eb.e)
END ;
killErrorBlock (eb) ;
checkAbort
END MetaErrorStringT1 ;
@@ -2425,7 +2471,12 @@ BEGIN
ebnf (eb, sym) ;
flushColor (eb) ;
defaultError (eb, tok) ;
ErrorString (eb.e, Dup (eb.out)) ;
IF isUniqueError (eb)
THEN
ErrorString (eb.e, Dup (eb.out))
ELSE
KillError (eb.e)
END ;
killErrorBlock (eb) ;
checkAbort
END MetaErrorStringT2 ;
@@ -2450,7 +2501,12 @@ BEGIN
ebnf (eb, sym) ;
flushColor (eb) ;
defaultError (eb, tok) ;
ErrorString (eb.e, Dup (eb.out)) ;
IF isUniqueError (eb)
THEN
ErrorString (eb.e, Dup (eb.out))
ELSE
KillError (eb.e)
END ;
killErrorBlock (eb) ;
checkAbort
END MetaErrorStringT3 ;
@@ -2475,7 +2531,12 @@ BEGIN
ebnf (eb, sym) ;
flushColor (eb) ;
defaultError (eb, tok) ;
ErrorString (eb.e, Dup (eb.out)) ;
IF isUniqueError (eb)
THEN
ErrorString (eb.e, Dup (eb.out))
ELSE
KillError (eb.e)
END ;
killErrorBlock (eb) ;
checkAbort
END MetaErrorStringT4 ;
@@ -2517,6 +2578,31 @@ BEGIN
END MetaError4 ;
(*
isUniqueError - return TRUE if the symbol associated with the
error block is unknown and we have seen the same
token before.
*)
PROCEDURE isUniqueError (VAR eb: errorBlock) : BOOLEAN ;
BEGIN
IF (eb.symcause # NulSym) AND IsUnknown (eb.symcause)
THEN
(* A candidate for filtering. *)
IF IsSymError (FilterUnknown, eb.symcause, eb.token)
THEN
(* Seen and reported about this unknown and token
location before. *)
RETURN FALSE
ELSE
(* Remember this combination. *)
AddSymError (FilterUnknown, eb.symcause, eb.token)
END
END ;
RETURN TRUE
END isUniqueError ;
(*
wrapErrors -
*)
@@ -2531,15 +2617,20 @@ BEGIN
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)) ;
IF isUniqueError (eb)
THEN
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))
ELSE
KillError (eb.e)
END ;
killErrorBlock (eb)
END wrapErrors ;
@@ -2871,5 +2962,6 @@ BEGIN
seenAbort := FALSE ;
outputStack := InitIndex (1) ;
dictionary := InitIndex (1) ;
freeEntry := NIL
freeEntry := NIL ;
FilterUnknown := FilterError.Init ()
END M2MetaError.

3
gcc/m2/gm2-compiler/M2Quads.mod
View File

@@ -10776,8 +10776,9 @@ BEGIN
PutVar (ReturnVar, Cardinal) ;
GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, GetSType (OperandT (1)), FALSE)
ELSE
(* Spellcheck. *)
MetaErrorT1 (resulttok,
'{%E}SYSTEM procedure function {%kTSIZE} expects a variable or type as its first parameter, seen {%1Ed}',
'{%E}SYSTEM procedure function {%kTSIZE} expects a variable or type as its first parameter, seen {%1Ed} {%1&s}',
OperandT (1)) ;
ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal)
END

92
gcc/m2/gm2-libs/BinDict.def Normal file
View File

@@ -0,0 +1,92 @@
(* BinDict.def provides a generic binary dictionary.
Copyright (C) 2025 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaiusmod2@gmail.com>.
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.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. *)
DEFINITION MODULE BinDict ;
FROM SYSTEM IMPORT ADDRESS ;
TYPE
Dictionary ;
Node ;
Compare = PROCEDURE (ADDRESS, ADDRESS) : INTEGER ;
Delete = PROCEDURE (ADDRESS) ;
VisitNode = PROCEDURE (Node) ;
(*
Init - create and return a new binary dictionary which will use
the compare procedure to order the contents as they are added.
*)
PROCEDURE Init (KeyCompare: Compare;
KeyDelete, ValueDelete: Delete) : Dictionary ;
(*
Kill - delete the dictionary and its contents.
dict is assigned to NIL.
*)
PROCEDURE Kill (VAR dict: Dictionary) ;
(*
PostOrder - visit each dictionary entry in post order.
*)
PROCEDURE PostOrder (dict: Dictionary; visit: VisitNode) ;
(*
Insert - insert key value pair into the dictionary.
*)
PROCEDURE Insert (dict: Dictionary; key, value: ADDRESS) ;
(*
Get - return the value associated with the key or NIL
if it does not exist.
*)
PROCEDURE Get (dict: Dictionary; key: ADDRESS) : ADDRESS ;
(*
Value - return the value from node.
*)
PROCEDURE Value (node: Node) : ADDRESS ;
(*
Key - return the key from node.
*)
PROCEDURE Key (node: Node) : ADDRESS ;
END BinDict.

272
gcc/m2/gm2-libs/BinDict.mod Normal file
View File

@@ -0,0 +1,272 @@
(* BinDict.mod provides a generic binary dictionary.
Copyright (C) 2025 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaiusmod2@gmail.com>.
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.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. *)
IMPLEMENTATION MODULE BinDict ;
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
TYPE
Dictionary = POINTER TO RECORD
content : Node ;
compare : Compare ;
deleteKey,
deleteValue: Delete
END ;
Node = POINTER TO RECORD
dict : Dictionary ;
left,
right: Node ;
key,
value: ADDRESS ;
END ;
(*
Init - create and return a new binary dictionary which will use
the compare procedure to order the contents as they are
added.
*)
PROCEDURE Init (KeyCompare: Compare; KeyDelete,
ValueDelete: Delete) : Dictionary ;
VAR
dict: Dictionary ;
BEGIN
NEW (dict) ;
WITH dict^ DO
content := NIL ;
compare := KeyCompare ;
deleteKey := KeyDelete ;
deleteValue := ValueDelete
END ;
RETURN dict
END Init ;
(*
Kill - delete the dictionary and its contents.
dict is assigned to NIL.
*)
PROCEDURE Kill (VAR dict: Dictionary) ;
BEGIN
PostOrder (dict, DeleteNode) ;
DISPOSE (dict) ;
dict := NIL
END Kill ;
(*
DeleteNode - deletes node dict, key and value.
*)
PROCEDURE DeleteNode (node: Node) ;
BEGIN
IF node # NIL
THEN
WITH node^ DO
dict^.deleteKey (key) ;
dict^.deleteValue (value)
END ;
DISPOSE (node)
END
END DeleteNode ;
(*
Insert - insert key value pair into the dictionary.
*)
PROCEDURE Insert (dict: Dictionary; key, value: ADDRESS) ;
BEGIN
dict^.content := InsertNode (dict, dict^.content, key, value)
END Insert ;
(*
InsertNode - insert the key value pair as a new node in the
binary tree within dict.
*)
PROCEDURE InsertNode (dict: Dictionary;
node: Node;
key, value: ADDRESS) : Node ;
BEGIN
IF node = NIL
THEN
RETURN ConsNode (dict, key, value, NIL, NIL)
ELSE
CASE dict^.compare (key, node^.key) OF
0: HALT | (* Not expecting to replace a key value. *)
-1: RETURN ConsNode (dict, node^.key, node^.value,
InsertNode (dict, node^.left,
key, value), node^.right) |
+1: RETURN ConsNode (dict, node^.key, node^.value,
node^.left,
InsertNode (dict, node^.right,
key, value))
END
END
END InsertNode ;
(*
ConsNode - return a new node containing the pairing key and value.
The new node fields are assigned left, right and dict.
*)
PROCEDURE ConsNode (dict: Dictionary;
key, value: ADDRESS;
left, right: Node) : Node ;
VAR
node: Node ;
BEGIN
NEW (node) ;
node^.key := key ;
node^.value := value ;
node^.left := left ;
node^.right := right ;
node^.dict := dict ;
RETURN node
END ConsNode ;
(*
KeyExist - return TRUE if dictionary contains an entry key.
It compares the content and not the address pointer.
*)
PROCEDURE KeyExist (dict: Dictionary; key: ADDRESS) : BOOLEAN ;
BEGIN
RETURN KeyExistNode (dict^.content, key)
END KeyExist ;
(*
KeyExistNode - return TRUE if the binary tree under node contains
key.
*)
PROCEDURE KeyExistNode (node: Node; key: ADDRESS) : BOOLEAN ;
BEGIN
IF node # NIL
THEN
CASE node^.dict^.compare (key, node^.key) OF
0: RETURN TRUE |
-1: RETURN KeyExistNode (node^.left, key) |
+1: RETURN KeyExistNode (node^.right, key)
END
END ;
RETURN FALSE
END KeyExistNode ;
(*
Value - return the value from node.
*)
PROCEDURE Value (node: Node) : ADDRESS ;
BEGIN
RETURN node^.value
END Value ;
(*
Key - return the key from node.
*)
PROCEDURE Key (node: Node) : ADDRESS ;
BEGIN
RETURN node^.value
END Key ;
(*
Get - return the value associated with the key or NIL
if it does not exist.
*)
PROCEDURE Get (dict: Dictionary; key: ADDRESS) : ADDRESS ;
BEGIN
RETURN GetNode (dict^.content, key)
END Get ;
(*
GetNode - return the value in binary node tree which
is associated with key.
*)
PROCEDURE GetNode (node: Node; key: ADDRESS) : ADDRESS ;
BEGIN
IF node # NIL
THEN
CASE node^.dict^.compare (key, node^.key) OF
0: RETURN node^.value |
+1: RETURN GetNode (node^.right, key) |
-1: RETURN GetNode (node^.left, key)
END
END ;
RETURN NIL
END GetNode ;
(*
PostOrder - visit each dictionary entry in post order.
*)
PROCEDURE PostOrder (dict: Dictionary; visit: VisitNode) ;
BEGIN
IF dict # NIL
THEN
PostOrderNode (dict^.content, visit)
END
END PostOrder ;
(*
PostOrderNode - visit the tree node in post order.
*)
PROCEDURE PostOrderNode (node: Node; visit: VisitNode) ;
BEGIN
IF node # NIL
THEN
PostOrderNode (node^.left, visit) ;
PostOrderNode (node^.right, visit) ;
visit (node)
END
END PostOrderNode ;
END BinDict.

8
libgm2/libm2pim/Makefile.am
View File

@@ -96,8 +96,9 @@ FLAGS_TO_PASS = $(AM_MAKEFLAGS)
if BUILD_PIMLIB
toolexeclib_LTLIBRARIES = libm2pim.la
M2MODS = ASCII.mod IO.mod \
Args.mod M2RTS.mod \
M2MODS = ASCII.mod \
Args.mod BinDict.mod \
IO.mod M2RTS.mod \
M2Dependent.mod \
M2Diagnostic.mod \
M2WIDESET.mod \
@@ -130,7 +131,8 @@ M2MODS = ASCII.mod IO.mod \
# COROUTINES.mod has been removed as it is implemented in ../libm2iso.
M2DEFS = Args.def ASCII.def \
Assertion.def Break.def \
Assertion.def BinDict.def \
Break.def \
Builtins.def cbuiltin.def \
CmdArgs.def CFileSysOp.def \
COROUTINES.def \

22
libgm2/libm2pim/Makefile.in
View File

@@ -159,13 +159,13 @@ am__uninstall_files_from_dir = { \
am__installdirs = "$(DESTDIR)$(toolexeclibdir)"
LTLIBRARIES = $(toolexeclib_LTLIBRARIES)
libm2pim_la_LIBADD =
@BUILD_PIMLIB_TRUE@am__objects_1 = ASCII.lo IO.lo Args.lo M2RTS.lo \
@BUILD_PIMLIB_TRUE@ M2Dependent.lo M2Diagnostic.lo M2WIDESET.lo \
@BUILD_PIMLIB_TRUE@ Assertion.lo NumberIO.lo Break.lo SYSTEM.lo \
@BUILD_PIMLIB_TRUE@ CmdArgs.lo Scan.lo StrCase.lo FIO.lo \
@BUILD_PIMLIB_TRUE@ StrIO.lo StrLib.lo TimeString.lo \
@BUILD_PIMLIB_TRUE@ Environment.lo FpuIO.lo Debug.lo \
@BUILD_PIMLIB_TRUE@ SysStorage.lo Storage.lo StdIO.lo \
@BUILD_PIMLIB_TRUE@am__objects_1 = ASCII.lo Args.lo BinDict.lo IO.lo \
@BUILD_PIMLIB_TRUE@ M2RTS.lo M2Dependent.lo M2Diagnostic.lo \
@BUILD_PIMLIB_TRUE@ M2WIDESET.lo Assertion.lo NumberIO.lo \
@BUILD_PIMLIB_TRUE@ Break.lo SYSTEM.lo CmdArgs.lo Scan.lo \
@BUILD_PIMLIB_TRUE@ StrCase.lo FIO.lo StrIO.lo StrLib.lo \
@BUILD_PIMLIB_TRUE@ TimeString.lo Environment.lo FpuIO.lo \
@BUILD_PIMLIB_TRUE@ Debug.lo SysStorage.lo Storage.lo StdIO.lo \
@BUILD_PIMLIB_TRUE@ SEnvironment.lo DynamicStrings.lo SFIO.lo \
@BUILD_PIMLIB_TRUE@ SArgs.lo SCmdArgs.lo PushBackInput.lo \
@BUILD_PIMLIB_TRUE@ StringConvert.lo FormatStrings.lo \
@@ -479,8 +479,9 @@ AM_MAKEFLAGS = \
# Subdir rules rely on $(FLAGS_TO_PASS)
FLAGS_TO_PASS = $(AM_MAKEFLAGS)
@BUILD_PIMLIB_TRUE@toolexeclib_LTLIBRARIES = libm2pim.la
@BUILD_PIMLIB_TRUE@M2MODS = ASCII.mod IO.mod \
@BUILD_PIMLIB_TRUE@ Args.mod M2RTS.mod \
@BUILD_PIMLIB_TRUE@M2MODS = ASCII.mod \
@BUILD_PIMLIB_TRUE@ Args.mod BinDict.mod \
@BUILD_PIMLIB_TRUE@ IO.mod M2RTS.mod \
@BUILD_PIMLIB_TRUE@ M2Dependent.mod \
@BUILD_PIMLIB_TRUE@ M2Diagnostic.mod \
@BUILD_PIMLIB_TRUE@ M2WIDESET.mod \
@@ -513,7 +514,8 @@ FLAGS_TO_PASS = $(AM_MAKEFLAGS)
# COROUTINES.mod has been removed as it is implemented in ../libm2iso.
@BUILD_PIMLIB_TRUE@M2DEFS = Args.def ASCII.def \
@BUILD_PIMLIB_TRUE@ Assertion.def Break.def \
@BUILD_PIMLIB_TRUE@ Assertion.def BinDict.def \
@BUILD_PIMLIB_TRUE@ Break.def \
@BUILD_PIMLIB_TRUE@ Builtins.def cbuiltin.def \
@BUILD_PIMLIB_TRUE@ CmdArgs.def CFileSysOp.def \
@BUILD_PIMLIB_TRUE@ COROUTINES.def \