aboutsummaryrefslogtreecommitdiff
path: root/gcc/m2/gm2-compiler
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/m2/gm2-compiler')
-rw-r--r--gcc/m2/gm2-compiler/FilterError.def56
-rw-r--r--gcc/m2/gm2-compiler/FilterError.mod224
-rw-r--r--gcc/m2/gm2-compiler/M2Error.def8
-rw-r--r--gcc/m2/gm2-compiler/M2Error.mod108
-rw-r--r--gcc/m2/gm2-compiler/M2LexBuf.mod4
-rw-r--r--gcc/m2/gm2-compiler/M2MetaError.mod212
-rw-r--r--gcc/m2/gm2-compiler/M2Quads.mod207
7 files changed, 651 insertions, 168 deletions
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
generated by cgit v1.1 at 2025-10-28 16:30:32 +0000