ASCII.def \
Args.def \
Assertion.def \
+ BinDict.def \
Break.def \
CmdArgs.def \
Debug.def \
ASCII.mod \
Args.mod \
Assertion.mod \
+ BinDict.mod \
Break.mod \
CmdArgs.mod \
Debug.mod \
# Definition modules for the front end found in gm2-compiler.
GM2-COMP-BOOT-DEFS = \
+ FilterError.def \
FifoQueue.def \
Lists.def \
M2ALU.def \
# Implementation modules for the front end found in gm2-compiler.
GM2-COMP-BOOT-MODS = \
+ FilterError.mod \
FifoQueue.mod \
Lists.mod \
Lists.mod \
ASCII.def \
Args.def \
Assertion.def \
+ BinDict.def \
Break.def \
Builtins.def \
COROUTINES.def \
ASCII.mod \
Args.mod \
Assertion.mod \
+ BinDict.mod \
Break.mod \
Builtins.mod \
COROUTINES.mod \
# cc1gm2$(exeext) uses these definition modules found in the gm2-compiler directory.
GM2-COMP-DEFS = \
+ FilterError.def \
FifoQueue.def \
Lists.def \
M2ALU.def \
# cc1gm2$(exeext) uses these implementation modules found in the gm2-compiler directory.
GM2-COMP-MODS = \
+ FilterError.mod \
FifoQueue.mod \
Lists.mod \
M2ALU.mod \
--- /dev/null
+(* 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.
--- /dev/null
+(* 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.
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
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 ;
PROCEDURE NewError (AtTokenNo: CARDINAL) : Error ;
VAR
- e, f: Error ;
+ e: Error ;
BEGIN
IF AtTokenNo = UnknownTokenNo
THEN
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 ;
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.
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) ;
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 ;
IMPORT M2ColorString ;
IMPORT M2Error ;
+IMPORT FilterError ;
+
+FROM FilterError IMPORT Filter, AddSymError, IsSymError ;
CONST
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 ;
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 ;
(*
WITH eb DO
useError := TRUE ;
e := NIL ;
+ symcause := NulSym ;
+ token := UnknownTokenNo ;
type := error ; (* Default to the error color. *)
out := InitString ('') ;
in := input ;
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 ;
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 ;
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
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')
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)) ;
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 ;
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)) ;
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 ;
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
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
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 ;
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
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 ;
BEGIN
IF bol <= HIGH (sym)
THEN
- doError (eb, GetFirstUsed (sym[bol]))
+ doError (eb, GetFirstUsed (sym[bol]), sym[bol])
END
END used ;
'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) |
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 |
'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) |
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 ;
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 ;
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 ;
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 ;
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 -
*)
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 ;
seenAbort := FALSE ;
outputStack := InitIndex (1) ;
dictionary := InitIndex (1) ;
- freeEntry := NIL
+ freeEntry := NIL ;
+ FilterUnknown := FilterError.Init ()
END M2MetaError.
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
--- /dev/null
+(* 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.
--- /dev/null
+(* 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.
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 \
# 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 \
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 \
# 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 \
# 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 \
projects / thirdparty / gcc.git / commitdiff
