PR modula2/114055 improve error message when checking the BY constant

The fix marks a constant created during the default BY clause of the
FOR loop as internal.  The type checker will always return true if
checking against an internal const.

gcc/m2/ChangeLog:

	PR modula2/114055
	* gm2-compiler/M2Check.mod (Import): IsConstLitInternal and
	IsConstLit.
	(isInternal): New procedure function.
	(doCheck): Test for isInternal in either operand and early
	return true.
	* gm2-compiler/M2Quads.mod (PushOne): Rewrite with extra
	parameter internal.
	(BuildPseudoBy): Add TRUE parameter to PushOne call.
	(BuildIncProcedure): Add FALSE parameter to PushOne call.
	(BuildDecProcedure): Add FALSE parameter to PushOne call.
	* gm2-compiler/M2Range.mod (ForLoopBeginTypeCompatible):
	Uncomment code and tidy up error string.
	* gm2-compiler/SymbolTable.def (PutConstLitInternal):
	New procedure.
	(IsConstLitInternal): New procedure function.
	* gm2-compiler/SymbolTable.mod (PutConstLitInternal):
	New procedure.
	(IsConstLitInternal): New procedure function.
	(SymConstLit): New field IsInternal.
	(CreateConstLit): Initialize IsInternal to FALSE.

gcc/testsuite/ChangeLog:

	PR modula2/114055
	* gm2/pim/fail/forloopby.mod: New test.
	* gm2/pim/pass/forloopby2.mod: New test.

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

7 files changed, 154 insertions, 13 deletions

diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod
index a296766..5b45ad3 100644
--- a/gcc/m2/gm2-compiler/M2Check.mod
+++ b/gcc/m2/gm2-compiler/M2Check.mod
@@ -39,7 +39,15 @@ FROM M2Error IMPORT Error, InternalError, NewError, ErrorString, ChainError ;
 FROM M2MetaError IMPORT MetaErrorStringT2, MetaErrorStringT3, MetaErrorStringT4, MetaString2, MetaString3, MetaString4 ;
 FROM StrLib IMPORT StrEqual ;
 FROM M2Debug IMPORT Assert ;
-FROM SymbolTable IMPORT NulSym, IsRecord, IsSet, GetDType, GetSType, IsType, SkipType, IsProcedure, NoOfParam, IsVarParam, GetNth, GetNthParam, IsProcType, IsVar, IsEnumeration, IsArray, GetDeclaredMod, IsSubrange, GetArraySubscript, IsConst, IsReallyPointer, IsPointer, IsParameter, ModeOfAddr, GetMode, GetType, IsUnbounded, IsComposite, IsConstructor, IsParameter, IsConstString ;
+
+FROM SymbolTable IMPORT NulSym, IsRecord, IsSet, GetDType, GetSType, IsType,
+                        SkipType, IsProcedure, NoOfParam, IsVarParam, GetNth,
+                        GetNthParam, IsProcType, IsVar, IsEnumeration, IsArray,
+                        GetDeclaredMod, IsSubrange, GetArraySubscript, IsConst,
+                        IsReallyPointer, IsPointer, IsParameter, ModeOfAddr,
+                        GetMode, GetType, IsUnbounded, IsComposite, IsConstructor,
+                        IsParameter, IsConstString, IsConstLitInternal, IsConstLit ;
+
 FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax ;
 FROM M2System IMPORT Address ;
 FROM M2ALU IMPORT Equ, PushIntegerTree ;
@@ -1371,6 +1379,17 @@ END get ;
 
 
 (*
+   isInternal - return TRUE if sym is a constant lit which was declared
+                as internal.
+*)
+
+PROCEDURE isInternal (sym: CARDINAL) : BOOLEAN ;
+BEGIN
+   RETURN IsConstLit (sym) AND IsConstLitInternal (sym)
+END isInternal ;
+
+
+(*
    doCheck - keep obtaining an unresolved pair and check for the
              type compatibility.  This is the main check routine used by
              parameter, assignment and expression compatibility.
@@ -1393,6 +1412,13 @@ BEGIN
          printf ("doCheck (%d, %d)\n", left, right) ;
          dumptInfo (tinfo)
       END ;
+      IF isInternal (left) OR isInternal (right)
+      THEN
+         (* Do not check constants which have been generated internally.
+            Currently these are generated by the default BY constant value
+            in a FOR loop.  *)
+         RETURN TRUE
+      END ;
       (*
       IF in (tinfo^.visited, left, right)
       THEN
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index 1275ad2f..ff0fda9 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -85,6 +85,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
                         PutPriority, GetPriority,
                         PutProcedureBegin, PutProcedureEnd,
                         PutVarConst, IsVarConst,
+                        PutConstLitInternal,
                         PutVarHeap,
                         IsVarParam, IsProcedure, IsPointer, IsParameter,
                         IsUnboundedParam, IsEnumeration, IsDefinitionForC,
@@ -4347,11 +4348,16 @@ END BuildElsif2 ;
                                             |------------|
 *)
 
-PROCEDURE PushOne (tok: CARDINAL; type: CARDINAL; message: ARRAY OF CHAR) ;
+PROCEDURE PushOne (tok: CARDINAL; type: CARDINAL;
+                   message: ARRAY OF CHAR; internal: BOOLEAN) ;
+VAR
+   const: CARDINAL ;
 BEGIN
    IF type = NulSym
    THEN
-      PushTF (MakeConstLit (tok, MakeKey('1'), NulSym), NulSym)
+      const := MakeConstLit (tok, MakeKey('1'), NulSym) ;
+      PutConstLitInternal (const, TRUE) ;
+      PushTFtok (const, NulSym, tok)
    ELSIF IsEnumeration (type)
    THEN
       IF NoOfElements (type) = 0
@@ -4361,14 +4367,16 @@ BEGIN
                            type) ;
          PushZero (tok, type)
       ELSE
-         PushTF (Convert, NulSym) ;
+         PushTFtok (Convert, NulSym, tok) ;
          PushT (type) ;
-         PushT (MakeConstLit (tok, MakeKey ('1'), ZType)) ;
+         PushTFtok (MakeConstLit (tok, MakeKey ('1'), ZType), ZType, tok) ;
          PushT (2) ;          (* Two parameters *)
          BuildConvertFunction
       END
    ELSE
-      PushTF (MakeConstLit (tok, MakeKey ('1'), type), type)
+      const := MakeConstLit (tok, MakeKey ('1'), type) ;
+      PutConstLitInternal (const, TRUE) ;
+      PushTFtok (const, type, tok)
    END
 END PushOne ;
 
@@ -4440,7 +4448,8 @@ BEGIN
    THEN
       type := ZType
    END ;
-   PushOne (dotok, type, 'the implied {%kFOR} loop increment will cause an overflow {%1ad}')
+   PushOne (dotok, type,
+            'the implied {%kFOR} loop increment will cause an overflow {%1ad}', TRUE)
 END BuildPseudoBy ;
 
 
@@ -4648,6 +4657,8 @@ END BuildForToByDo ;
 
          Ptr ->
                  +----------------+
+                 | RangeId        |
+                 |----------------|
                  | ForQuad        |
                  |----------------|
                  | LastValue      |
@@ -7294,7 +7305,8 @@ BEGIN
          THEN
             OperandSym := DereferenceLValue (OperandTok (1), OperandT (1))
          ELSE
-            PushOne (proctok, dtype, 'the {%EkINC} will cause an overflow {%1ad}') ;
+            PushOne (proctok, dtype,
+                     'the {%EkINC} will cause an overflow {%1ad}', FALSE) ;
 	    PopT (OperandSym)
          END ;
 
@@ -7366,7 +7378,8 @@ BEGIN
          THEN
             OperandSym := DereferenceLValue (OperandTok (1), OperandT (1))
          ELSE
-            PushOne (proctok, dtype, 'the {%EkDEC} will cause an overflow {%1ad}') ;
+            PushOne (proctok, dtype,
+                     'the {%EkDEC} will cause an overflow {%1ad}', FALSE) ;
 	    PopT (OperandSym)
          END ;
 
diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod
index fa1ef35..654ac04 100644
--- a/gcc/m2/gm2-compiler/M2Range.mod
+++ b/gcc/m2/gm2-compiler/M2Range.mod
@@ -1886,16 +1886,14 @@ BEGIN
                       des, expr2) ;
          success := FALSE
       END ;
-(*
       combinedtok := MakeVirtual2Tok (destok, byconsttok) ;
       IF NOT ExpressionTypeCompatible (combinedtok, "", des, byconst, TRUE, FALSE)
       THEN
          MetaErrorT2 (combinedtok,
-                      'type expression incompatibility between {%1Et} and {%2t} detected between the the designator {%1a} and the {%kBY} constant expression {%2a} in the {%kFOR} loop',
+                      'type expression incompatibility between {%1Et} and {%2t} detected between the designator {%1a} and the {%kBY} constant expression {%2a} in the {%kFOR} loop',
                       des, byconst) ;
          success := FALSE
       END ;
-*)
       IF (NOT success) AND (incrementquad # 0)
       THEN
          (* Avoid a subsequent generic type check error.  *)
diff --git a/gcc/m2/gm2-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def
index 508b818..ec48631 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.def
+++ b/gcc/m2/gm2-compiler/SymbolTable.def
@@ -3315,4 +3315,23 @@ PROCEDURE PutProcedureParameterHeapVars (sym: CARDINAL) ;
 PROCEDURE IsProcedureBuiltinAvailable (procedure: CARDINAL) : BOOLEAN ;
 
 
+(*
+   PutConstLitInternal - marks the sym as being an internal constant.
+                         Currently this is used when generating a default
+                         BY constant expression during a FOR loop.
+                         A constant marked as internal will always pass
+                         an expression type check.
+*)
+
+PROCEDURE PutConstLitInternal (sym: CARDINAL; value: BOOLEAN) ;
+
+
+(*
+   IsConstLitInternal - returns the value of the IsInternal field within
+                        a constant expression.
+*)
+
+PROCEDURE IsConstLitInternal (sym: CARDINAL) : BOOLEAN ;
+
+
 END SymbolTable.
diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod
index 6fe36da..c57c033 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -487,7 +487,8 @@ TYPE
                     Value        : PtrToValue ;   (* Value of the constant.      *)
                     Type         : CARDINAL ;     (* TYPE of constant, char etc  *)
                     IsSet        : BOOLEAN ;      (* is the constant a set?      *)
-                    IsConstructor: BOOLEAN ;      (* is the constant a set?      *)
+                    IsConstructor: BOOLEAN ;      (* is it a constructor?        *)
+                    IsInternal   : BOOLEAN ;      (* Generated internally?       *)
                     FromType     : CARDINAL ;     (* type is determined FromType *)
                     RangeError   : BOOLEAN ;      (* Have we reported an error?  *)
                     UnresFromType: BOOLEAN ;      (* is Type unresolved?         *)
@@ -4865,6 +4866,8 @@ BEGIN
                     PopInto (ConstLit.Value) ;
                     ConstLit.Type := constType ;
                     ConstLit.IsSet := FALSE ;
+                    ConstLit.IsInternal := FALSE ;   (* Is it a default BY constant
+                                                        expression?  *)
                     ConstLit.IsConstructor := FALSE ;
                     ConstLit.FromType := NulSym ;     (* type is determined FromType *)
                     ConstLit.RangeError := overflow ;
@@ -6791,6 +6794,53 @@ END PutConst ;
 
 
 (*
+   PutConstLitInternal - marks the sym as being an internal constant.
+                         Currently this is used when generating a default
+                         BY constant expression during a FOR loop.
+                         A constant marked as internal will always pass
+                         an expression type check.
+*)
+
+PROCEDURE PutConstLitInternal (sym: CARDINAL; value: BOOLEAN) ;
+VAR
+   pSym: PtrToSymbol ;
+BEGIN
+   pSym := GetPsym (sym) ;
+   WITH pSym^ DO
+      CASE SymbolType OF
+
+      ConstLitSym: ConstLit.IsInternal := value
+
+      ELSE
+         InternalError ('expecting ConstLitSym')
+      END
+   END
+END PutConstLitInternal ;
+
+
+(*
+   IsConstLitInternal - returns the value of the IsInternal field within
+                        a constant expression.
+*)
+
+PROCEDURE IsConstLitInternal (sym: CARDINAL) : BOOLEAN ;
+VAR
+   pSym: PtrToSymbol ;
+BEGIN
+   pSym := GetPsym (sym) ;
+   WITH pSym^ DO
+      CASE SymbolType OF
+
+      ConstLitSym: RETURN ConstLit.IsInternal
+
+      ELSE
+         InternalError ('expecting ConstLitSym')
+      END
+   END
+END IsConstLitInternal ;
+
+
+(*
    PutVarArrayRef - assigns ArrayRef field with value.
 *)
 
diff --git a/gcc/testsuite/gm2/pim/fail/forloopby.mod b/gcc/testsuite/gm2/pim/fail/forloopby.mod
new file mode 100644
index 0000000..522563b
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/forloopby.mod
@@ -0,0 +1,17 @@
+MODULE forloopby ;
+
+
+PROCEDURE init ;
+CONST
+   increment = CARDINAL (1) ;
+VAR
+   i: INTEGER ;
+BEGIN
+   FOR i := 0 TO 10 BY increment DO
+   END
+END init ;
+
+
+BEGIN
+   init
+END forloopby.
diff --git a/gcc/testsuite/gm2/pim/pass/forloopby2.mod b/gcc/testsuite/gm2/pim/pass/forloopby2.mod
new file mode 100644
index 0000000..a81ecb0
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/forloopby2.mod
@@ -0,0 +1,18 @@
+MODULE forloopby2 ;
+
+TYPE
+   negative = [-10..-1] ;
+
+
+PROCEDURE init ;
+VAR
+   i: negative ;
+BEGIN
+   FOR i := MIN (negative) TO MAX (negative) DO
+   END
+END init ;
+
+
+BEGIN
+   init
+END forloopby2.