diff options
Diffstat (limited to 'gcc/m2')
| -rw-r--r-- | gcc/m2/ChangeLog | 76 | ||||
| -rw-r--r-- | gcc/m2/Make-lang.in | 8 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/FilterError.def | 56 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/FilterError.mod | 224 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/M2Error.def | 8 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/M2Error.mod | 108 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/M2LexBuf.mod | 4 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/M2MetaError.mod | 212 | ||||
| -rw-r--r-- | gcc/m2/gm2-compiler/M2Quads.mod | 207 | ||||
| -rw-r--r-- | gcc/m2/gm2-libs/BinDict.def | 92 | ||||
| -rw-r--r-- | gcc/m2/gm2-libs/BinDict.mod | 272 |
11 files changed, 1099 insertions, 168 deletions
diff --git a/gcc/m2/ChangeLog b/gcc/m2/ChangeLog index b605bf2..155c082 100644 --- a/gcc/m2/ChangeLog +++ b/gcc/m2/ChangeLog @@ -1,3 +1,79 @@ +2025-10-24 Gaius Mulley <gaiusmod2@gmail.com> + + PR modula2/122407 + * gm2-compiler/FilterError.def (Copyright): Use correct + licence. + * gm2-compiler/FilterError.mod (Copyright): Ditto. + * gm2-compiler/M2Quads.mod (BuildNewProcedure): Rewrite. + (BuildIncProcedure): Ditto. + (BuildDecProcedure): Ditto. + (BuildInclProcedure): Ditto. + (BuildExclProcedure): Ditto. + (BuildAbsFunction): Ditto. + (BuildCapFunction): Ditto. + (BuildChrFunction): Ditto. + (BuildOrdFunction): Ditto. + (BuildIntFunction): Ditto. + (BuildMinFunction): Ditto. + (BuildMaxFunction): Ditto. + (BuildTruncFunction): Ditto. + (BuildTBitSizeFunction): Ditto. + (BuildTSizeFunction): Ditto. + (BuildSizeFunction): Ditto. + +2025-10-24 Gaius Mulley <gaiusmod2@gmail.com> + + 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. + 2025-10-19 Gaius Mulley <gaiusmod2@gmail.com> PR modula2/122333 diff --git a/gcc/m2/Make-lang.in b/gcc/m2/Make-lang.in index cd4dc9f..110a8a1 100644 --- a/gcc/m2/Make-lang.in +++ b/gcc/m2/Make-lang.in @@ -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 \ diff --git a/gcc/m2/gm2-compiler/FilterError.def b/gcc/m2/gm2-compiler/FilterError.def new file mode 100644 index 0000000..2a8e96c --- /dev/null +++ b/gcc/m2/gm2-compiler/FilterError.def @@ -0,0 +1,56 @@ +(* FilterError.def provides a filter for token and symbol. + +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. + +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/>. *) + +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. diff --git a/gcc/m2/gm2-compiler/FilterError.mod b/gcc/m2/gm2-compiler/FilterError.mod new file mode 100644 index 0000000..6f2b2f3 --- /dev/null +++ b/gcc/m2/gm2-compiler/FilterError.mod @@ -0,0 +1,224 @@ +(* FilterError.mod implements a filter for token and symbol. + +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. + +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 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. diff --git a/gcc/m2/gm2-compiler/M2Error.def b/gcc/m2/gm2-compiler/M2Error.def index 427bd08..7f945e4 100644 --- a/gcc/m2/gm2-compiler/M2Error.def +++ b/gcc/m2/gm2-compiler/M2Error.def @@ -130,6 +130,14 @@ 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 then the default colors will be assigned to the legacy error diff --git a/gcc/m2/gm2-compiler/M2Error.mod b/gcc/m2/gm2-compiler/M2Error.mod index 561f42c..095e732 100644 --- a/gcc/m2/gm2-compiler/M2Error.mod +++ b/gcc/m2/gm2-compiler/M2Error.mod @@ -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 ; @@ -463,6 +452,95 @@ 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. If, e, is NIL then the result to NewError is returned. diff --git a/gcc/m2/gm2-compiler/M2LexBuf.mod b/gcc/m2/gm2-compiler/M2LexBuf.mod index 143190e0..5198243 100644 --- a/gcc/m2/gm2-compiler/M2LexBuf.mod +++ b/gcc/m2/gm2-compiler/M2LexBuf.mod @@ -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) ; diff --git a/gcc/m2/gm2-compiler/M2MetaError.mod b/gcc/m2/gm2-compiler/M2MetaError.mod index dc14e6b..aae0f02 100644 --- a/gcc/m2/gm2-compiler/M2MetaError.mod +++ b/gcc/m2/gm2-compiler/M2MetaError.mod @@ -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 ; @@ -2518,6 +2579,31 @@ 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. diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod index 3bdf8c5..5ceeb4f 100644 --- a/gcc/m2/gm2-compiler/M2Quads.mod +++ b/gcc/m2/gm2-compiler/M2Quads.mod @@ -7244,7 +7244,8 @@ BEGIN PushT (2) ; (* Two parameters *) BuildProcedureCall (combinedtok) ELSE - MetaErrorT0 (paramtok, 'parameter to {%EkNEW} must be a pointer') + MetaErrorT1 (paramtok, 'parameter to {%EkNEW} must be a pointer,' + + ' seen {%1Ed} {%1&s}', PtrSym) END ELSE MetaErrorT0 (functok, '{%E}ALLOCATE procedure not found for NEW substitution') @@ -7333,7 +7334,8 @@ BEGIN PushT (2) ; (* Two parameters *) BuildProcedureCall (combinedtok) ELSE - MetaErrorT0 (paramtok, 'argument to {%EkDISPOSE} must be a pointer') + MetaErrorT1 (paramtok, 'argument to {%EkDISPOSE} must be a pointer,' + + ' seen {%1Ed} {%1&s}', PtrSym) END ELSE MetaErrorT0 (functok, '{%E}DEALLOCATE procedure not found for DISPOSE substitution') @@ -7442,6 +7444,7 @@ END CheckRangeIncDec ; PROCEDURE BuildIncProcedure (proctok: CARDINAL) ; VAR + vartok : CARDINAL ; NoOfParam, dtype, OperandSym, @@ -7452,6 +7455,7 @@ BEGIN IF (NoOfParam = 1) OR (NoOfParam = 2) THEN VarSym := OperandT (NoOfParam) ; (* Bottom/first parameter. *) + vartok := OperandTok (NoOfParam) ; IF IsVar (VarSym) THEN dtype := GetDType (VarSym) ; @@ -7464,13 +7468,13 @@ BEGIN PopT (OperandSym) END ; - PushTtok (VarSym, proctok) ; - TempSym := DereferenceLValue (proctok, VarSym) ; + PushTtok (VarSym, vartok) ; + TempSym := DereferenceLValue (vartok, VarSym) ; CheckRangeIncDec (proctok, TempSym, OperandSym, PlusTok) ; (* TempSym + OperandSym. *) BuildAssignmentWithoutBounds (proctok, FALSE, TRUE) (* VarSym := TempSym + OperandSym. *) ELSE - MetaErrorT1 (proctok, - 'base procedure {%EkINC} expects a variable as a parameter but was given {%1Ed}', + MetaErrorT1 (vartok, + 'base procedure {%EkINC} expects a variable as a parameter but was given {%1Ed} {%1&s}', VarSym) END ELSE @@ -7513,6 +7517,7 @@ END BuildIncProcedure ; PROCEDURE BuildDecProcedure (proctok: CARDINAL) ; VAR + vartok : CARDINAL ; NoOfParam, dtype, OperandSym, @@ -7523,6 +7528,7 @@ BEGIN IF (NoOfParam = 1) OR (NoOfParam = 2) THEN VarSym := OperandT (NoOfParam) ; (* Bottom/first parameter. *) + vartok := OperandTok (NoOfParam) ; IF IsVar (VarSym) THEN dtype := GetDType (VarSym) ; @@ -7535,13 +7541,13 @@ BEGIN PopT (OperandSym) END ; - PushTtok (VarSym, proctok) ; - TempSym := DereferenceLValue (OperandTok (NoOfParam), VarSym) ; + PushTtok (VarSym, vartok) ; + TempSym := DereferenceLValue (vartok, VarSym) ; CheckRangeIncDec (proctok, TempSym, OperandSym, MinusTok) ; (* TempSym - OperandSym. *) BuildAssignmentWithoutBounds (proctok, FALSE, TRUE) (* VarSym := TempSym - OperandSym. *) ELSE - MetaErrorT1 (proctok, - 'base procedure {%EkDEC} expects a variable as a parameter but was given {%1Ed}', + MetaErrorT1 (vartok, + 'base procedure {%EkDEC} expects a variable as a parameter but was given {%1Ed} {%1&s}', VarSym) END ELSE @@ -7604,6 +7610,7 @@ END DereferenceLValue ; PROCEDURE BuildInclProcedure (proctok: CARDINAL) ; VAR + vartok, optok : CARDINAL ; NoOfParam, DerefSym, @@ -7614,6 +7621,7 @@ BEGIN IF NoOfParam = 2 THEN VarSym := OperandT (2) ; + vartok := OperandTok (2) ; MarkArrayWritten (OperandA (2)) ; OperandSym := OperandT (1) ; optok := OperandTok (1) ; @@ -7625,14 +7633,14 @@ BEGIN BuildRange (InitInclCheck (VarSym, DerefSym)) ; GenQuadO (proctok, InclOp, VarSym, NulSym, DerefSym, FALSE) ELSE - MetaErrorT1 (proctok, - 'the first parameter to {%EkINCL} must be a set variable but is {%1Ed}', - VarSym) + MetaErrorT1 (vartok, + 'the first parameter to {%EkINCL} must be a set variable,' + + ' seen {%1Ed} {%1&s}', VarSym) END ELSE - MetaErrorT1 (proctok, - 'base procedure {%EkINCL} expects a variable as a parameter but is {%1Ed}', - VarSym) + MetaErrorT1 (vartok, + 'base procedure {%EkINCL} expects a variable as a parameter,' + + ' seen {%1Ed} {%1&s}', VarSym) END ELSE MetaErrorT0 (proctok, 'the base procedure {%EkINCL} expects 1 or 2 parameters') @@ -7668,6 +7676,7 @@ END BuildInclProcedure ; PROCEDURE BuildExclProcedure (proctok: CARDINAL) ; VAR + vartok, optok : CARDINAL ; NoOfParam, DerefSym, @@ -7678,6 +7687,7 @@ BEGIN IF NoOfParam=2 THEN VarSym := OperandT (2) ; + vartok := OperandTok (2) ; MarkArrayWritten (OperandA(2)) ; OperandSym := OperandT (1) ; optok := OperandTok (1) ; @@ -7689,14 +7699,14 @@ BEGIN BuildRange (InitExclCheck (VarSym, DerefSym)) ; GenQuadO (proctok, ExclOp, VarSym, NulSym, DerefSym, FALSE) ELSE - MetaErrorT1 (proctok, - 'the first parameter to {%EkEXCL} must be a set variable but is {%1Ed}', - VarSym) + MetaErrorT1 (vartok, + 'the first parameter to {%EkEXCL} must be a set variable,' + + ' seen {%1Ed} {%1&s}', VarSym) END ELSE - MetaErrorT1 (proctok, - 'base procedure {%EkEXCL} expects a variable as a parameter but is {%1Ed}', - VarSym) + MetaErrorT1 (vartok, + 'base procedure {%EkEXCL} expects a variable as a parameter,' + + ' seen {%1Ed} {%1&s}', VarSym) END ELSE MetaErrorT0 (proctok, @@ -7986,7 +7996,7 @@ BEGIN proctok := OperandTok (NoOfParam+1) ; IF NOT IsAModula2Type (ProcSym) THEN - MetaError1 ('coersion expecting a type, seen {%1Ea} which is {%1Ed}', ProcSym) + MetaError1 ('coersion expecting a type, seen {%1Ea} which is {%1Ed} {%1&s}', ProcSym) END ; IF NoOfParam = 1 THEN @@ -8674,7 +8684,7 @@ BEGIN IF ConstExpr AND IsVar (Var) THEN MetaErrorT2 (optok, - 'the procedure function {%1Ea} is being called from within a constant expression and therefore the parameter {%2a} must be a constant, seen a {%2dav}', + 'the procedure function {%1Ea} is being called from within a constant expression and therefore the parameter {%2a} must be a constant, seen a {%2dav} {%2&s}', Func, Var) ; RETURN TRUE ELSE @@ -8884,7 +8894,7 @@ BEGIN PushTtok (Res, combinedtok) ELSE MetaErrorT1 (optok, - 'the parameter to {%1EkODD} must be a variable or constant, seen {%1ad}', + 'the parameter to {%1EkODD} must be a variable or constant, seen {%1ad} {%1&s}', Var) ; PushTtok (False, combinedtok) END @@ -8963,13 +8973,13 @@ BEGIN PushTFtok (Res, GetSType (Var), combinedtok) ELSE MetaErrorT1 (vartok, - 'the parameter to {%AkABS} must be a variable or constant, seen {%1ad}', - Var) + 'the parameter to {%AkABS} must be a variable or constant,' + + ' seen {%1ad} {%1&s}', Var) END ELSE MetaErrorT1 (functok, - 'the pseudo procedure {%AkABS} only has one parameter, seen {%1n} parameters', - NoOfParam) + 'the pseudo procedure {%AkABS} only has one parameter,' + + ' seen {%1n} parameters', NoOfParam) END END BuildAbsFunction ; @@ -9027,13 +9037,13 @@ BEGIN PushTFtok (Res, Char, combinedtok) ELSE MetaErrorT1 (optok, - 'the parameter to {%AkCAP} must be a variable or constant, seen {%1ad}', - Var) + 'the parameter to {%AkCAP} must be a variable or constant,' + + ' seen {%1ad} {%1&s}', Var) END ELSE MetaErrorT1 (functok, - 'the pseudo procedure {%AkCAP} only has one parameter, seen {%1n} parameters', - NoOfParam) + 'the pseudo procedure {%AkCAP} only has one parameter,' + + ' seen {%1n} parameters', NoOfParam) END END BuildCapFunction ; @@ -9106,13 +9116,13 @@ BEGIN BuildConvertFunction (Convert, ConstExpr) ELSE MetaErrorT1 (optok, - 'the parameter to {%AkCHR} must be a variable or constant, seen {%1ad}', - Var) + 'the parameter to {%AkCHR} must be a variable or constant,' + + ' seen {%1ad} {%1&s}', Var) END ELSE MetaErrorT1 (functok, - 'the pseudo procedure {%AkCHR} only has one parameter, seen {%1n} parameters', - NoOfParam) + 'the pseudo procedure {%AkCHR} only has one parameter,' + + ' seen {%1n} parameters', NoOfParam) END END BuildChrFunction ; @@ -9186,13 +9196,14 @@ BEGIN BuildConvertFunction (Convert, ConstExpr) ELSE MetaErrorT2 (optok, - 'the parameter to {%1Aa} must be a variable or constant, seen {%2ad}', + 'the parameter to {%1Aa} must be a variable or constant,' + + ' seen {%2ad} {%2&s}', Sym, Var) END ELSE MetaErrorT2 (functok, - 'the pseudo procedure {%1Aa} only has one parameter, seen {%2n} parameters', - Sym, NoOfParam) + 'the pseudo procedure {%1Aa} only has one parameter,' + + ' seen {%2n} parameters', Sym, NoOfParam) END END BuildOrdFunction ; @@ -9265,14 +9276,14 @@ BEGIN ELSE combinedtok := MakeVirtualTok (functok, optok, optok) ; MetaErrorT2 (optok, - 'the parameter to {%1Ea} must be a variable or constant, seen {%2ad}', - Sym, Var) ; + 'the parameter to {%1Ea} must be a variable or constant,' + + ' seen {%2ad} {%2&s}', Sym, Var) ; PushTtok (combinedtok, MakeConstLit (combinedtok, MakeKey ('0'), ZType)) END ELSE MetaErrorT2 (functok, - 'the pseudo procedure {%1Ea} only has one parameter, seen {%2n} parameters', - Sym, NoOfParam) ; + 'the pseudo procedure {%1Ea} only has one parameter,' + + ' seen {%2n} parameters', Sym, NoOfParam) ; PushTtok (functok, MakeConstLit (functok, MakeKey ('0'), ZType)) END END BuildIntFunction ; @@ -9338,7 +9349,8 @@ BEGIN AreConst := FALSE ; ELSIF NOT IsConst (OperandT (i)) THEN - MetaError1 ('problem in the {%1EN} argument for {%kMAKEADR}, all arguments to {%kMAKEADR} must be either variables or constants', i) + MetaError1 ('problem in the {%1EN} argument for {%kMAKEADR},' + + ' all arguments to {%kMAKEADR} must be either variables or constants', i) END ; INC (i) END ; @@ -9350,7 +9362,8 @@ BEGIN PopN (NoOfParameters+1) ; PushTFtok (ReturnVar, GetSType (MakeAdr), resulttok) ELSE - MetaError1 ('the pseudo procedure {%EkMAKEADR} requires at least one parameter, seen {%1n}', NoOfParameters) ; + MetaError1 ('the pseudo procedure {%EkMAKEADR} requires at least one parameter,' + + ' seen {%1n}', NoOfParameters) ; PopN (1) ; PushTFtok (Nil, GetSType (MakeAdr), functok) END @@ -9422,15 +9435,16 @@ BEGIN PushTFtok (returnVar, GetSType (varSet), combinedtok) ELSE MetaErrorT1 (vartok, - 'SYSTEM procedure {%1EkSHIFT} expects a constant or variable which has a type of SET as its first parameter, seen {%1ad}', + 'SYSTEM procedure {%1EkSHIFT} expects a constant or variable which has a type of SET as its first parameter,' + + ' seen {%1ad} {%1&s}', varSet) ; PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), Cardinal, combinedtok) END ELSE combinedtok := MakeVirtualTok (functok, functok, paramtok) ; MetaErrorT1 (functok, - 'the pseudo procedure {%kSHIFT} requires at least two parameters, seen {%1En}', - NoOfParam) ; + 'the pseudo procedure {%kSHIFT} requires at least two parameters,' + + ' seen {%1En}', NoOfParam) ; PopN (NoOfParam + 1) ; PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Cardinal), Cardinal, combinedtok) END @@ -9499,8 +9513,8 @@ BEGIN PushTFtok (returnVar, GetSType (varSet), combinedtok) ELSE MetaErrorT1 (vartok, - 'SYSTEM procedure {%EkROTATE} expects a constant or variable which has a type of SET as its first parameter, seen {%1ad}', - varSet) ; + 'SYSTEM procedure {%EkROTATE} expects a constant or variable which has a type of SET as its first parameter,' + + ' seen {%1ad} {%1&s}', varSet) ; PushTFtok (MakeConstLit (functok, MakeKey('0'), Cardinal), Cardinal, functok) END ELSE @@ -9570,8 +9584,8 @@ BEGIN (* Spellcheck. *) (* It is sensible not to try and recover when we dont know the return type. *) MetaErrorT1 (typetok, - 'undeclared type found in builtin procedure function {%AkVAL} {%1ad} {%1&s}', - Type) ; + 'undeclared type found in builtin procedure function' + + ' {%AkVAL} {%1ad} {%1&s}', Type) ; (* Non recoverable error. *) UnknownReported (Type) ELSIF ConstExprError (ProcSym, Exp, exptok, ConstExpr) @@ -10001,15 +10015,15 @@ BEGIN ELSE (* we dont know the type therefore cannot fake a return. *) MetaErrorT1 (vartok, - 'parameter to {%AkMIN} must be a type or a variable, seen {%1ad}', - Var) + 'parameter to {%AkMIN} must be a type or a variable,' + + ' seen {%1ad} {%1&s}', Var) (* non recoverable error. *) END ELSE (* we dont know the type therefore cannot fake a return. *) MetaErrorT1 (functok, - 'the pseudo builtin procedure function {%AkMIN} only has one parameter, seen {%1n}', - NoOfParam) + 'the pseudo builtin procedure function {%AkMIN} only has one parameter,' + + ' seen {%1n}', NoOfParam) (* non recoverable error. *) END END BuildMinFunction ; @@ -10062,15 +10076,15 @@ BEGIN ELSE (* we dont know the type therefore cannot fake a return. *) MetaErrorT1 (vartok, - 'parameter to {%AkMAX} must be a type or a variable, seen {%1ad}', - Var) + 'parameter to {%AkMAX} must be a type or a variable,' + + ' seen {%1ad} {%1&s}', Var) (* non recoverable error. *) ; END ELSE (* we dont know the type therefore cannot fake a return. *) MetaErrorT1 (functok, - 'the pseudo builtin procedure function {%AkMAX} only has one parameter, seen {%1n}', - NoOfParam) + 'the pseudo builtin procedure function {%AkMAX} only has one parameter,' + + ' seen {%1n}', NoOfParam) (* non recoverable error. *) END END BuildMaxFunction ; @@ -10156,8 +10170,8 @@ BEGIN END ELSE MetaErrorT2 (vartok, - 'argument to {%1Ead} must be a variable or constant, seen {%2ad}', - Sym, Var) ; + 'argument to {%1Ead} must be a variable or constant,' + + ' seen {%2ad} {%2&s}', Sym, Var) ; PushTFtok (MakeConstLit (functok, MakeKey('0'), Type), Type, functok) END ELSE @@ -10166,7 +10180,8 @@ BEGIN ELSE (* we dont know the type therefore cannot fake a return. *) MetaErrorT1 (functok, - 'the pseudo builtin procedure function {%AkTRUNC} only has one parameter, seen {%1n}', NoOfParam) + 'the pseudo builtin procedure function {%AkTRUNC} only has one parameter,' + + ' seen {%1n}', NoOfParam) (* non recoverable error. *) END END BuildTruncFunction ; @@ -10323,8 +10338,8 @@ BEGIN ELSE PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), RType), RType, combinedtok) ; MetaErrorT2 (vartok, - 'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable, seen {%2ad}', - func, Var) + 'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable,' + + ' seen {%2ad} {%2&s}', func, Var) END ELSE PopN (NoOfParam+1) ; (* destroy arguments to this function *) @@ -10399,8 +10414,8 @@ BEGIN ELSE PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), RType), RType, combinedtok) ; MetaErrorT2 (vartok, - 'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable, seen {%2ad}', - func, Var) + 'the parameter to the builtin procedure function {%1Ead} must be a constant or a variable,' + + ' seen {%2ad} {%2&s}', func, Var) END ELSE PopN (NoOfParam+1) ; (* destroy arguments to this function *) @@ -10489,11 +10504,13 @@ BEGIN IF IsVar (l) OR IsConst (l) THEN MetaErrorT2 (functok, - 'the builtin procedure {%1Ead} requires two parameters, both must be variables or constants but the second parameter is {%2d}', + 'the builtin procedure {%1Ead} requires two parameters,' + + ' both must be variables or constants but the second parameter is {%2d}', func, r) ELSE MetaErrorT2 (functok, - 'the builtin procedure {%1Ead} requires two parameters, both must be variables or constants but the first parameter is {%2d}', + 'the builtin procedure {%1Ead} requires two parameters,' + + ' both must be variables or constants but the first parameter is {%2d}', func, l) END ; PushTFtok (MakeConstLit (combinedtok, MakeKey ('1.0'), CType), CType, combinedtok) @@ -10536,7 +10553,8 @@ END BuildCmplxFunction ; PROCEDURE BuildAdrFunction ; VAR - endtok, + param, + paramTok, combinedTok, procTok, t, @@ -10552,7 +10570,8 @@ BEGIN PopT (noOfParameters) ; procSym := OperandT (noOfParameters + 1) ; procTok := OperandTok (noOfParameters + 1) ; (* token of procedure ADR. *) - endtok := OperandTok (1) ; (* last parameter. *) + paramTok := OperandTok (1) ; (* last parameter. *) + param := OperandT (1) ; combinedTok := MakeVirtualTok (procTok, procTok, endtok) ; IF noOfParameters # 1 THEN @@ -10560,28 +10579,29 @@ BEGIN 'SYSTEM procedure ADR expects 1 parameter') ; PopN (noOfParameters + 1) ; (* destroy the arguments and function *) PushTF (Nil, Address) - ELSIF IsConstString (OperandT (1)) + ELSIF IsConstString (param) THEN - returnVar := MakeLeftValue (combinedTok, OperandT (1), RightValue, + returnVar := MakeLeftValue (combinedTok, param, RightValue, GetSType (procSym)) ; PopN (noOfParameters + 1) ; (* destroy the arguments and function *) PushTFtok (returnVar, GetSType (returnVar), combinedTok) - ELSIF (NOT IsVar(OperandT(1))) AND (NOT IsProcedure(OperandT(1))) + ELSIF (NOT IsVar (param)) AND (NOT IsProcedure (param)) THEN - MetaErrorNT0 (combinedTok, - 'SYSTEM procedure ADR expects a variable, procedure or a constant string as its parameter') ; + MetaErrorT1 (paramTok, + 'SYSTEM procedure ADR expects a variable, procedure or a constant string as its parameter,' + + ' seen {%1Ed} {%1&s}', param) ; PopN (noOfParameters + 1) ; (* destroy the arguments and function *) PushTFtok (Nil, Address, combinedTok) - ELSIF IsProcedure (OperandT (1)) + ELSIF IsProcedure (param) THEN - returnVar := MakeLeftValue (combinedTok, OperandT (1), RightValue, + returnVar := MakeLeftValue (combinedTok, param, RightValue, GetSType (procSym)) ; PopN (noOfParameters + 1) ; (* destroy the arguments and function *) PushTFtok (returnVar, GetSType (returnVar), combinedTok) ELSE - Type := GetSType (OperandT (1)) ; + Type := GetSType (param) ; Dim := OperandD (1) ; - MarkArrayWritten (OperandT (1)) ; + MarkArrayWritten (param) ; MarkArrayWritten (OperandA (1)) ; (* if the operand is an unbounded which has not been indexed then we will lookup its address from the unbounded record. @@ -10590,7 +10610,7 @@ BEGIN IF IsUnbounded (Type) AND (Dim = 0) THEN (* we will reference the address field of the unbounded structure *) - UnboundedSym := OperandT (1) ; + UnboundedSym := param ; rw := OperandRW (1) ; PushTFrw (UnboundedSym, GetSType (UnboundedSym), rw) ; Field := GetUnboundedAddressOffset (GetSType (UnboundedSym)) ; @@ -10614,14 +10634,14 @@ BEGIN ELSE returnVar := MakeTemporary (combinedTok, RightValue) ; PutVar (returnVar, GetSType (procSym)) ; - IF GetMode (OperandT (1)) = LeftValue + IF GetMode (param) = LeftValue THEN PutVar (returnVar, GetSType (procSym)) ; - GenQuadO (combinedTok, ConvertOp, returnVar, GetSType (procSym), OperandT (1), FALSE) + GenQuadO (combinedTok, ConvertOp, returnVar, GetSType (procSym), param, FALSE) ELSE - GenQuadO (combinedTok, AddrOp, returnVar, NulSym, OperandT (1), FALSE) + GenQuadO (combinedTok, AddrOp, returnVar, NulSym, param, FALSE) END ; - PutWriteQuad (OperandT (1), GetMode (OperandT (1)), NextQuad-1) ; + PutWriteQuad (param, GetMode (param), NextQuad-1) ; rw := OperandMergeRW (1) ; Assert (IsLegal (rw)) END ; @@ -10710,9 +10730,9 @@ BEGIN GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, Type, TRUE) END ELSE - resulttok := functok ; - MetaErrorT1 (resulttok, - '{%E}SYSTEM procedure {%kSIZE} expects a variable or type as its parameter, seen {%1Ed}', + paramtok := OperandTok (1) ; + MetaErrorT1 (paramtok, + '{%E}SYSTEM procedure {%kSIZE} expects a variable or type as its parameter, seen {%1Ed} {%1&s}', OperandT (1)) ; ReturnVar := MakeConstLit (resulttok, MakeKey('0'), Cardinal) END ; @@ -10776,8 +10796,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 @@ -10801,7 +10822,7 @@ BEGIN ELSE resulttok := MakeVirtualTok (functok, functok, paramtok) ; MetaErrorT1 (resulttok, - '{%E}SYSTEM procedure function {%kTSIZE} expects the first parameter to be a record type, seen {%1d}', + '{%E}SYSTEM procedure function {%kTSIZE} expects the first parameter to be a record type, seen {%1d} {%1&s}', Record) ; ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal) END @@ -10865,7 +10886,7 @@ BEGIN GenQuadO (resulttok, StandardFunctionOp, ReturnVar, ProcSym, OperandT(1), FALSE) ELSE MetaErrorT1 (resulttok, - '{%E}SYSTEM procedure function {%kTBITSIZE} expects a variable as its first parameter, seen {%1d}', + '{%E}SYSTEM procedure function {%kTBITSIZE} expects a variable as its first parameter, seen {%1d} {%1&s}', OperandT (1)) ; ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal) END @@ -10888,7 +10909,7 @@ BEGIN ELSE resulttok := MakeVirtualTok (functok, functok, paramtok) ; MetaErrorT1 (resulttok, - '{%E}SYSTEM procedure function {%kTBITSIZE} expects the first parameter to be a record type, seen {%1d}', + '{%E}SYSTEM procedure function {%kTBITSIZE} expects the first parameter to be a record type, seen {%1d} {%1&s}', Record) ; ReturnVar := MakeConstLit (resulttok, MakeKey ('0'), Cardinal) END diff --git a/gcc/m2/gm2-libs/BinDict.def b/gcc/m2/gm2-libs/BinDict.def new file mode 100644 index 0000000..16272fd --- /dev/null +++ b/gcc/m2/gm2-libs/BinDict.def @@ -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. diff --git a/gcc/m2/gm2-libs/BinDict.mod b/gcc/m2/gm2-libs/BinDict.mod new file mode 100644 index 0000000..f8bb873 --- /dev/null +++ b/gcc/m2/gm2-libs/BinDict.mod @@ -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. |