PR modula2/118453: Subranges types do not use virtual tokens during construction

P2SymBuild.mod.BuildSubrange does not use a virtual token and therefore
any error message containing a subrange type produces poor location carots.
This patch rewrites BuildSubrange and the buildError4 procedure in
M2Check.mod (which is only called when there is a formal/actual parameter
mismatch).  buildError4 now issues a sub error for the formal and actual
type declaration highlighing the type mismatch.

gcc/m2/ChangeLog:

	PR modula2/118453
	* gm2-compiler/M2Check.mod (buildError4): Call MetaError1
	for the actual and formal parameter type.
	* gm2-compiler/P2Build.bnf (SubrangeType): Construct a virtual
	token containing the subrange type declaration.
	(PrefixedSubrangeType): Ditto.
	* gm2-compiler/P2SymBuild.def (BuildSubrange): Add tok parameter.
	* gm2-compiler/P2SymBuild.mod (BuildSubrange): Use tok parameter,
	rather than the token at the start of the subrange.

gcc/testsuite/ChangeLog:

	PR modula2/118453
	* gm2/pim/fail/badbecomes2.mod: New test.
	* gm2/pim/fail/badparamset1.mod: New test.
	* gm2/pim/fail/badparamset2.mod: New test.
	* gm2/pim/fail/badsyntaxset1.mod: New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>

8 files changed, 68 insertions, 15 deletions

diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod
index 9e58ef0..d2bb4ab 100644
--- a/gcc/m2/gm2-compiler/M2Check.mod
+++ b/gcc/m2/gm2-compiler/M2Check.mod
@@ -36,7 +36,7 @@ FROM M2System IMPORT IsSystemType, IsGenericSystemType, IsSameSize, IsComplexN ;
 FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType, Char ;
 FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex, ForeachIndiceInIndexDo ;
 FROM M2Error IMPORT Error, InternalError, NewError, ErrorString, ChainError ;
-FROM M2MetaError IMPORT MetaErrorStringT2, MetaErrorStringT3, MetaErrorStringT4, MetaString2, MetaString3, MetaString4 ;
+FROM M2MetaError IMPORT MetaErrorStringT2, MetaErrorStringT3, MetaErrorStringT4, MetaString2, MetaString3, MetaString4, MetaError1 ;
 FROM StrLib IMPORT StrEqual ;
 FROM M2Debug IMPORT Assert ;
 
@@ -504,10 +504,8 @@ BEGIN
       (* and also generate a sub error containing detail.  *)
       IF (left # tinfo^.left) OR (right # tinfo^.right)
       THEN
-         tinfo^.error := ChainError (tinfo^.token, tinfo^.error) ;
-         s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible as formal and actual procedure parameters"),
-                           left, right) ;
-         ErrorString (tinfo^.error, s)
+         MetaError1 ('formal parameter {%1EDad}', right) ;
+         MetaError1 ('actual parameter {%1EDad}', left)
       END
    END
 END buildError4 ;
diff --git a/gcc/m2/gm2-compiler/P2Build.bnf b/gcc/m2/gm2-compiler/P2Build.bnf
index f1eafc8..b9a6daa 100644
--- a/gcc/m2/gm2-compiler/P2Build.bnf
+++ b/gcc/m2/gm2-compiler/P2Build.bnf
@@ -45,7 +45,9 @@ see <https://www.gnu.org/licenses/>.  *)
 
 IMPLEMENTATION MODULE P2Build ;
 
-FROM M2LexBuf IMPORT currentstring, currenttoken, GetToken, InsertToken, InsertTokenAndRewind, GetTokenNo ;
+FROM M2LexBuf IMPORT currentstring, currenttoken, GetToken, InsertToken,
+                     InsertTokenAndRewind, GetTokenNo, MakeVirtual2Tok ;
+
 FROM M2MetaError IMPORT MetaErrorStringT0, MetaErrorT1 ;
 FROM NameKey IMPORT NulName, Name, makekey, MakeKey ;
 FROM M2Reserved IMPORT tokToTok, toktype, NulTok, ImportTok, ExportTok, QualifiedTok, UnQualifiedTok ;
@@ -765,12 +767,17 @@ IdentList := Ident                                                         % VAR
                                                                              END %
              =:
 
-SubrangeType := "[" ConstExpression  ".." ConstExpression "]"              % BuildSubrange(NulSym) %
+SubrangeType :=                                                            % VAR start, combined: CARDINAL ; %
+                                                                           % start := GetTokenNo () %
+                "[" ConstExpression  ".." ConstExpression "]"              % combined := MakeVirtual2Tok (start, GetTokenNo ()-1) %
+		                                                           % BuildSubrange (combined, NulSym) %
               =:
 
-PrefixedSubrangeType := "[" ConstExpression  ".." ConstExpression "]"      % VAR t: CARDINAL ; %
-                                                                           % PopT(t) ;
-                                                                             BuildSubrange(t) %
+PrefixedSubrangeType :=                                                    % VAR qual, start, combined: CARDINAL ; %
+                                                                           % PopTtok (qual, start) %
+                "[" ConstExpression  ".." ConstExpression "]"									   
+                                                                           % combined := MakeVirtual2Tok (start, GetTokenNo ()-1) %
+                                                                           % BuildSubrange (combined, qual) %
               =:
 
 ArrayType := "ARRAY"                                                       % VAR arrayType, tok: CARDINAL ; %
diff --git a/gcc/m2/gm2-compiler/P2SymBuild.def b/gcc/m2/gm2-compiler/P2SymBuild.def
index b570286..eab8c42 100644
--- a/gcc/m2/gm2-compiler/P2SymBuild.def
+++ b/gcc/m2/gm2-compiler/P2SymBuild.def
@@ -432,7 +432,7 @@ PROCEDURE StartBuildEnumeration ;
                       |------------|        |------------|
 *)
 
-PROCEDURE BuildSubrange (Base: CARDINAL) ;
+PROCEDURE BuildSubrange (tok: CARDINAL; Base: CARDINAL) ;
 
 
 (*
diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod
index a625e7d..1b59f3d 100644
--- a/gcc/m2/gm2-compiler/P2SymBuild.mod
+++ b/gcc/m2/gm2-compiler/P2SymBuild.mod
@@ -907,14 +907,13 @@ END StartBuildEnumeration ;
                       |------------|        |------------|
 *)
 
-PROCEDURE BuildSubrange (Base: CARDINAL) ;
+PROCEDURE BuildSubrange (tok: CARDINAL; Base: CARDINAL) ;
 VAR
    name: Name ;
    Type: CARDINAL ;
-   tok : CARDINAL ;
 BEGIN
-   PopTtok(name, tok) ;
-   Type := MakeSubrange(tok, name) ;
+   PopT (name) ;
+   Type := MakeSubrange (tok, name) ;
    PutSubrangeIntoFifoQueue(Type) ;   (* Store Subrange away so that we can fill in *)
                                       (* its bounds during pass 3.                  *)
    PutSubrangeIntoFifoQueue(Base) ;   (* store Base type of subrange away as well.  *)
diff --git a/gcc/testsuite/gm2/pim/fail/badbecomes2.mod b/gcc/testsuite/gm2/pim/fail/badbecomes2.mod
new file mode 100644
index 0000000..3230439
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badbecomes2.mod
@@ -0,0 +1,9 @@
+MODULE badbecomes2 ;
+
+TYPE
+   enums = (red, blue, green) ;
+VAR
+   setvar: SET OF enums ;
+BEGIN
+   setvar := green ;    (* Should detect an error here.  *)
+END badbecomes2.
diff --git a/gcc/testsuite/gm2/pim/fail/badparamset1.mod b/gcc/testsuite/gm2/pim/fail/badparamset1.mod
new file mode 100644
index 0000000..35d4f48
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badparamset1.mod
@@ -0,0 +1,16 @@
+MODULE badparamset1 ;  
+
+TYPE
+   month = SET OF [1..12] ;
+   day = SET OF [1..31] ;   
+
+
+PROCEDURE foo (d: day) ;
+BEGIN
+END foo ;
+
+VAR
+   m: month ;
+BEGIN
+   foo (m)
+END badparamset1.
diff --git a/gcc/testsuite/gm2/pim/fail/badparamset2.mod b/gcc/testsuite/gm2/pim/fail/badparamset2.mod
new file mode 100644
index 0000000..bddc745
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badparamset2.mod
@@ -0,0 +1,16 @@
+MODULE badparamset2 ;  
+
+TYPE
+   month = SET OF [1..12] ;
+   day = SET OF [1..31] ;   
+
+
+PROCEDURE foo (d: day) ;
+BEGIN
+END foo ;
+
+VAR
+   m: month ;
+BEGIN
+   foo (m)
+END badparamset2.
diff --git a/gcc/testsuite/gm2/pim/fail/badsyntaxset1.mod b/gcc/testsuite/gm2/pim/fail/badsyntaxset1.mod
new file mode 100644
index 0000000..0bf498c
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badsyntaxset1.mod
@@ -0,0 +1,8 @@
+MODULE badsyntaxset1 ;  
+
+TYPE
+   foo = SET OF [cat..dog] ;
+
+BEGIN
+
+END badsyntaxset1.