PR modula2/114026 Incorrect location during for loop type checking

If a for loop contains an incompatible type expression between the
designator and the second expression then the location
used when generating the error message is set to token 0.
The bug is fixed by extending the range checking
InitForLoopBeginRangeCheck.  The range checking is processed after
all types, constants have been resolved (and converted into gcc
trees).  The range check will check for assignment compatibility
between des and expr1, expression compatibility between des and expr2.
Separate token positions for des, exp1, expr2 and by are stored in the
Range record and used to create virtual tokens if they are on the same
source line.

gcc/m2/ChangeLog:

	PR modula2/114026
	* gm2-compiler/M2GenGCC.mod (Import): Remove DisplayQuadruples.
	Remove DisplayQuadList.
	(MixTypesBinary): Replace check with overflowCheck.
	New variable typeChecking.
	Use GenQuadOTypetok to retrieve typeChecking.
	Use typeChecking to suppress error message.
	* gm2-compiler/M2LexBuf.def (MakeVirtual2Tok): New procedure
	function.
	* gm2-compiler/M2LexBuf.mod (MakeVirtualTok): Improve comment.
	(MakeVirtual2Tok): New procedure function.
	* gm2-compiler/M2Quads.def (GetQuadOTypetok): New procedure.
	* gm2-compiler/M2Quads.mod (QuadFrame): New field CheckType.
	(PutQuadO): Rewrite using PutQuadOType.
	(PutQuadOType): New procedure.
	(GetQuadOTypetok): New procedure.
	(BuildPseudoBy): Rewrite.
	(BuildForToByDo): Remove type checking.
	Add parameters e2, e2tok, BySym, bytok to
	InitForLoopBeginRange.
	Push the RangeId.
	(BuildEndFor): Pop the RangeId.
	Use GenQuadOTypetok to generate AddOp without type checking.
	Call PutRangeForIncrement with the RangeId and IncQuad.
	(GenQuadOtok): Rewrite using GenQuadOTypetok.
	(GenQuadOTypetok): New procedure.
	* gm2-compiler/M2Range.def (InitForLoopBeginRangeCheck):
	Rename d as des, e as expr.
	Add expr1, expr1tok, expr2, expr2tok, byconst, byconsttok
	parameters.
	(PutRangeForIncrement): New procedure.
	* gm2-compiler/M2Range.mod (Import): MakeVirtual2Tok.
	(Range): Add expr2, byconst, destok, exprtok, expr2tok,
	incrementquad.
	(InitRange): Initialize expr2 to NulSym.
	Initialize byconst to NulSym.
	Initialize tokenNo, destok, exprtok, expr2tok, byconst to
	UnknownTokenNo.
	Initialize incrementquad to 0.
	(PutRangeForIncrement): New procedure.
	(PutRangeDesExpr2): New procedure.
	(InitForLoopBeginRangeCheck): Rewrite.
	(ForLoopBeginTypeCompatible): New procedure function.
	(CodeForLoopBegin): Call ForLoopBeginTypeCompatible and
	only code the for loop assignment if all the type checks
	succeed.

gcc/testsuite/ChangeLog:

	PR modula2/114026
	* gm2/extensions/run/pass/callingc10.mod: New test.
	* gm2/extensions/run/pass/callingc11.mod: New test.
	* gm2/extensions/run/pass/callingc9.mod: New test.
	* gm2/extensions/run/pass/strconst.def: New test.
	* gm2/pim/fail/forloop.mod: New test.
	* gm2/pim/pass/forloop2.mod: New test.

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

13 files changed, 386 insertions, 72 deletions

diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index c7581f8..aeba48d 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -93,7 +93,7 @@ FROM M2Error IMPORT InternalError, WriteFormat0, WriteFormat1, WriteFormat2, War
 FROM M2MetaError IMPORT MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3,
                         MetaError1, MetaError2, MetaErrorStringT1 ;
 
-FROM M2Options IMPORT DisplayQuadruples, UnboundedByReference, PedanticCast,
+FROM M2Options IMPORT UnboundedByReference, PedanticCast,
                       VerboseUnbounded, Iso, Pim, DebugBuiltins, WholeProgram,
                       StrictTypeChecking, AutoInit, cflag, ScaffoldMain,
                       ScaffoldDynamic, ScaffoldStatic,
@@ -256,9 +256,9 @@ FROM m2except IMPORT BuildThrow, BuildTryBegin, BuildTryEnd,
 
 FROM M2Quads IMPORT QuadOperator, GetQuad, IsReferenced, GetNextQuad,
                     SubQuad, PutQuad, MustCheckOverflow, GetQuadOtok,
+                    GetQuadOTypetok,
                     QuadToTokenNo, DisplayQuad, GetQuadtok,
-                    GetM2OperatorDesc, GetQuadOp,
-                    DisplayQuadList ;
+                    GetM2OperatorDesc, GetQuadOp ;
 
 FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible,  ExpressionTypeCompatible ;
 FROM M2SSA IMPORT EnableSSA ;
@@ -644,11 +644,6 @@ BEGIN
          Changed := TRUE
       END
    UNTIL NoChange ;
-   IF Debugging AND DisplayQuadruples AND FALSE
-   THEN
-      printf0('after resolving expressions with gcc\n') ;
-      DisplayQuadList
-   END ;
    RETURN Changed
 END ResolveConstantExpressions ;
 
@@ -3660,13 +3655,13 @@ END CodeBinaryCheck ;
 
 
 (*
-   MixTypesBinary - depending upon check do not check pointer arithmetic.
+   MixTypesBinary - depending upon overflowCheck do not check pointer arithmetic.
 *)
 
 PROCEDURE MixTypesBinary (left, right: CARDINAL;
-                          tokpos: CARDINAL; check: BOOLEAN) : CARDINAL ;
+                          tokpos: CARDINAL; overflowCheck: BOOLEAN) : CARDINAL ;
 BEGIN
-   IF (NOT check) AND
+   IF (NOT overflowCheck) AND
       (IsPointer (GetTypeMode (left)) OR IsPointer (GetTypeMode (right)))
    THEN
       RETURN Address
@@ -3743,6 +3738,7 @@ VAR
    lefttype,
    righttype,
    des, left, right: CARDINAL ;
+   typeChecking,
    overflowChecking: BOOLEAN ;
    despos, leftpos,
    rightpos,
@@ -3750,10 +3746,10 @@ VAR
    subexprpos      : CARDINAL ;
    op              : QuadOperator ;
 BEGIN
-   GetQuadOtok (quad, operatorpos, op,
-                des, left, right, overflowChecking,
-                despos, leftpos, rightpos) ;
-   IF ((op # LogicalRotateOp) AND (op # LogicalShiftOp))
+   GetQuadOTypetok (quad, operatorpos, op,
+                    des, left, right, overflowChecking, typeChecking,
+                    despos, leftpos, rightpos) ;
+   IF typeChecking AND (op # LogicalRotateOp) AND (op # LogicalShiftOp)
    THEN
       subexprpos := MakeVirtualTok (operatorpos, leftpos, rightpos) ;
       lefttype := GetType (left) ;
diff --git a/gcc/m2/gm2-compiler/M2LexBuf.def b/gcc/m2/gm2-compiler/M2LexBuf.def
index dd49f45..27610ec 100644
--- a/gcc/m2/gm2-compiler/M2LexBuf.def
+++ b/gcc/m2/gm2-compiler/M2LexBuf.def
@@ -42,7 +42,8 @@ EXPORT QUALIFIED OpenSource, CloseSource, ReInitialize, GetToken, InsertToken,
                  FindFileNameFromToken, GetFileName,
                  ResetForNewPass,
                  currenttoken, currentstring, currentinteger,
-                 AddTok, AddTokCharStar, AddTokInteger, MakeVirtualTok,
+                 AddTok, AddTokCharStar, AddTokInteger,
+                 MakeVirtualTok, MakeVirtual2Tok,
                  SetFile, PushFile, PopFile,
                  PrintTokenNo, DisplayToken, DumpTokens,
                  BuiltinTokenNo, UnknownTokenNo ;
@@ -197,12 +198,20 @@ PROCEDURE GetFileName () : String ;
 
 (*
    MakeVirtualTok - creates and return a new tokenno which is created from
-                    tokenno range1 and range2.
+                    tokenno caret, left and right.
 *)
 
 PROCEDURE MakeVirtualTok (caret, left, right: CARDINAL) : CARDINAL ;
 
 
+(*
+   MakeVirtual2Tok - creates and return a new tokenno which is created from
+                     two tokens left and right.
+*)
+
+PROCEDURE MakeVirtual2Tok (left, right: CARDINAL) : CARDINAL ;
+
+
 (* ***********************************************************************
  *
  * These functions allow m2.lex to deliver tokens into the buffer
diff --git a/gcc/m2/gm2-compiler/M2LexBuf.mod b/gcc/m2/gm2-compiler/M2LexBuf.mod
index 84a0e25..af43855 100644
--- a/gcc/m2/gm2-compiler/M2LexBuf.mod
+++ b/gcc/m2/gm2-compiler/M2LexBuf.mod
@@ -1154,7 +1154,7 @@ END isSrcToken ;
    MakeVirtualTok - providing caret, left, right are associated with a source file
                     and exist on the same src line then
                     create and return a new tokenno which is created from
-                    tokenno range1 and range2.  Otherwise return caret.
+                    tokenno left and right.  Otherwise return caret.
 *)
 
 PROCEDURE MakeVirtualTok (caret, left, right: CARDINAL) : CARDINAL ;
@@ -1184,6 +1184,17 @@ BEGIN
 END MakeVirtualTok ;
 
 
+(*
+   MakeVirtual2Tok - creates and return a new tokenno which is created from
+                     two tokens left and right.
+*)
+
+PROCEDURE MakeVirtual2Tok (left, right: CARDINAL) : CARDINAL ;
+BEGIN
+   RETURN MakeVirtualTok (left, left, right)
+END MakeVirtual2Tok ;
+
+
 (* ***********************************************************************
  *
  * These functions allow m2.flex to deliver tokens into the buffer
diff --git a/gcc/m2/gm2-compiler/M2Quads.def b/gcc/m2/gm2-compiler/M2Quads.def
index e9fd122..3e92e31 100644
--- a/gcc/m2/gm2-compiler/M2Quads.def
+++ b/gcc/m2/gm2-compiler/M2Quads.def
@@ -132,6 +132,7 @@ EXPORT QUALIFIED StartBuildDefFile, StartBuildModFile, EndBuildFile,
                  SubQuad, EraseQuad, GetRealQuad,
                  GetQuadtok, GetQuadOtok, PutQuadOtok,
                  GetQuadOp, GetM2OperatorDesc,
+                 GetQuadOTypetok,
                  CountQuads,
                  GetLastFileQuad,
                  GetLastQuadNo,
@@ -549,6 +550,17 @@ PROCEDURE GetQuadOtok (QuadNo: CARDINAL;
 
 
 (*
+   GetQuadOTypetok - returns the fields associated with quadruple QuadNo.
+*)
+
+PROCEDURE GetQuadOTypetok (QuadNo: CARDINAL;
+                           VAR tok: CARDINAL;
+                           VAR Op: QuadOperator;
+                           VAR Oper1, Oper2, Oper3: CARDINAL;
+                           VAR overflowChecking, typeChecking: BOOLEAN ;
+                           VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
+
+(*
    PutQuadOtok - alters a quadruple QuadNo with Op, Oper1, Oper2, Oper3, and
                  sets a boolean to determinine whether overflow should be checked.
 *)
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index e40e07d..1275ad2f 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -255,6 +255,7 @@ FROM M2Range IMPORT InitAssignmentRangeCheck,
                     InitWholeZeroDivisionCheck,
                     InitWholeZeroRemainderCheck,
                     InitParameterRangeCheck,
+                    PutRangeForIncrement,
                     WriteRangeCheck ;
 
 FROM M2CaseList IMPORT PushCase, PopCase, AddRange, BeginCaseList, EndCaseList, ElseCase ;
@@ -298,6 +299,7 @@ TYPE
                              LineNo             : CARDINAL ;     (* Line No of source text.         *)
                              TokenNo            : CARDINAL ;     (* Token No of source text.        *)
                              NoOfTimesReferenced: CARDINAL ;     (* No of times quad is referenced. *)
+                             CheckType,
                              CheckOverflow      : BOOLEAN ;      (* should backend check overflow   *)
                              op1pos,
                              op2pos,
@@ -1343,6 +1345,19 @@ PROCEDURE PutQuadO (QuadNo: CARDINAL;
                     Op: QuadOperator;
                     Oper1, Oper2, Oper3: CARDINAL;
                     overflow: BOOLEAN) ;
+BEGIN
+   PutQuadOType (QuadNo, Op, Oper1, Oper2, Oper3, overflow, TRUE)
+END PutQuadO ;
+
+
+(*
+   PutQuadOType -
+*)
+
+PROCEDURE PutQuadOType (QuadNo: CARDINAL;
+                        Op: QuadOperator;
+                        Oper1, Oper2, Oper3: CARDINAL;
+                        overflow, checktype: BOOLEAN) ;
 VAR
    f: QuadFrame ;
 BEGIN
@@ -1360,10 +1375,11 @@ BEGIN
          Operand1      := Oper1 ;
          Operand2      := Oper2 ;
          Operand3      := Oper3 ;
-         CheckOverflow := overflow
+         CheckOverflow := overflow ;
+         CheckType     := checktype
       END
    END
-END PutQuadO ;
+END PutQuadOType ;
 
 
 (*
@@ -1379,6 +1395,36 @@ END PutQuad ;
 
 
 (*
+   GetQuadOtok - returns the fields associated with quadruple QuadNo.
+*)
+
+PROCEDURE GetQuadOTypetok (QuadNo: CARDINAL;
+                           VAR tok: CARDINAL;
+                           VAR Op: QuadOperator;
+                           VAR Oper1, Oper2, Oper3: CARDINAL;
+                           VAR overflowChecking, typeChecking: BOOLEAN ;
+                           VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
+VAR
+   f: QuadFrame ;
+BEGIN
+   f := GetQF (QuadNo) ;
+   LastQuadNo := QuadNo ;
+   WITH f^ DO
+      Op := Operator ;
+      Oper1 := Operand1 ;
+      Oper2 := Operand2 ;
+      Oper3 := Operand3 ;
+      Op1Pos := op1pos ;
+      Op2Pos := op2pos ;
+      Op3Pos := op3pos ;
+      tok := TokenNo ;
+      overflowChecking := CheckOverflow ;
+      typeChecking := CheckType
+   END
+END GetQuadOTypetok ;
+
+
+(*
    UndoReadWriteInfo -
 *)
 
@@ -4379,15 +4425,22 @@ END PushZero ;
 
 PROCEDURE BuildPseudoBy ;
 VAR
-   e, t, dotok: CARDINAL ;
+   expr, type, dotok: CARDINAL ;
 BEGIN
-   PopTFtok (e, t, dotok) ;  (* as there is no BY token this position is the DO at the end of the last expression.  *)
-   PushTFtok (e, t, dotok) ;
-   IF t=NulSym
+   (* As there is no BY token this position is the DO at the end of the last expression.  *)
+   PopTFtok (expr, type, dotok) ;
+   PushTFtok (expr, type, dotok) ;
+   IF type = NulSym
+   THEN
+      (* type := ZType *)
+   ELSIF IsEnumeration (SkipType (type)) OR (SkipType (type) = Char)
    THEN
-      t := GetSType (e)
+      (* Use type.  *)
+   ELSIF IsOrdinalType (SkipType (type))
+   THEN
+      type := ZType
    END ;
-   PushOne (dotok, t, 'the implied FOR loop increment will cause an overflow {%1ad}')
+   PushOne (dotok, type, 'the implied {%kFOR} loop increment will cause an overflow {%1ad}')
 END BuildPseudoBy ;
 
 
@@ -4418,8 +4471,9 @@ END BuildForLoopToRangeCheck ;
                     Entry                   Exit
                     =====                   ====
 
-
-             Ptr ->                                           <- Ptr
+                                                               <- Ptr
+                                            +----------------+
+             Ptr ->                         | RangeId        |
                     +----------------+      |----------------|
                     | BySym | ByType |      | ForQuad        |
                     |----------------|      |----------------|
@@ -4490,6 +4544,7 @@ VAR
    BySym,
    ByType,
    ForLoop,
+   RangeId,
    t, f      : CARDINAL ;
    etype,
    t1        : CARDINAL ;
@@ -4503,24 +4558,8 @@ BEGIN
    PopTtok (e1, e1tok) ;
    PopTtok (Id, idtok) ;
    IdSym := RequestSym (idtok, Id) ;
-   IF NOT IsExpressionCompatible (GetSType (e1), GetSType (e2))
-   THEN
-      MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%1tsad} and final expression {%2tsad}',
-                 e1, e2) ;
-      CheckExpressionCompatible (idtok, GetSType (e1), GetSType (e2))
-   END ;
-   IF NOT IsExpressionCompatible( GetSType (e1), ByType)
-   THEN
-      MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%1tsad} and {%kBY} {%2tsad}',
-                  e2, BySym) ;
-      CheckExpressionCompatible (e1tok, GetSType (e1), ByType)
-   ELSIF NOT IsExpressionCompatible (GetSType (e2), ByType)
-   THEN
-      MetaError2 ('incompatible types found in {%EkFOR} loop header, final expression {%1tsad} and {%kBY} {%2tsad}',
-                  e2, BySym) ;
-      CheckExpressionCompatible (e1tok, GetSType (e2), ByType)
-   END ;
-   BuildRange (InitForLoopBeginRangeCheck (IdSym, e1)) ;
+   RangeId := InitForLoopBeginRangeCheck (IdSym, idtok, e1, e1tok, e2, e2tok, BySym, bytok) ;
+   BuildRange (RangeId) ;
    PushTtok (IdSym, idtok) ;
    PushTtok (e1, e1tok) ;
    BuildAssignmentWithoutBounds (idtok, TRUE, TRUE) ;
@@ -4593,7 +4632,8 @@ BEGIN
    PushTFtok (IdSym, GetSym (IdSym), idtok) ;
    PushTFtok (BySym, ByType, bytok) ;
    PushTFtok (FinalValue, GetSType (FinalValue), e2tok) ;
-   PushT (ForLoop)
+   PushT (ForLoop) ;
+   PushT (RangeId)
 END BuildForToByDo ;
 
 
@@ -4622,6 +4662,7 @@ PROCEDURE BuildEndFor (endpostok: CARDINAL) ;
 VAR
    t, f,
    tsym,
+   RangeId,
    IncQuad,
    ForQuad: CARDINAL ;
    LastSym,
@@ -4631,6 +4672,7 @@ VAR
    IdSym,
    idtok  : CARDINAL ;
 BEGIN
+   PopT (RangeId) ;
    PopT (ForQuad) ;
    PopT (LastSym) ;
    PopTFtok (BySym, ByType, bytok) ;
@@ -4661,10 +4703,11 @@ BEGIN
          is counting down.  The above test will generate a more
          precise error message, so we suppress overflow detection
          here.  *)
-      GenQuadOtok (bytok, AddOp, tsym, tsym, BySym, FALSE,
-                   bytok, bytok, bytok) ;
+      GenQuadOTypetok (bytok, AddOp, tsym, tsym, BySym, FALSE, FALSE,
+                       idtok, idtok, bytok) ;
       CheckPointerThroughNil (idtok, IdSym) ;
-      GenQuadOtok (idtok, XIndrOp, IdSym, GetSType (IdSym), tsym, FALSE,
+      GenQuadOtok (idtok, XIndrOp, IdSym, GetSType (IdSym),
+                   tsym, FALSE,
                    idtok, idtok, idtok)
    ELSE
       BuildRange (InitForLoopEndRangeCheck (IdSym, BySym)) ;
@@ -4673,13 +4716,20 @@ BEGIN
          this addition can legitimately overflow if a cardinal type
          is counting down.  The above test will generate a more
          precise error message, so we suppress overflow detection
-         here.  *)
-      GenQuadOtok (idtok, AddOp, IdSym, IdSym, BySym, FALSE,
-                   bytok, bytok, bytok)
+         here.
+
+         This quadruple suppresses the generic binary op type
+         check (performed in M2GenGCC.mod) as there
+         will be a more informative/exhaustive check performed by the
+         InitForLoopBeginRangeCheck setup in BuildForToByDo and
+         performed by M2Range.mod.  *)
+      GenQuadOTypetok (idtok, AddOp, IdSym, IdSym, BySym, FALSE, FALSE,
+                       idtok, idtok, bytok)
    END ;
    GenQuadO (endpostok, GotoOp, NulSym, NulSym, ForQuad, FALSE) ;
    BackPatch (PopFor (), NextQuad) ;
-   AddForInfo (ForQuad, NextQuad-1, IncQuad, IdSym, idtok)
+   AddForInfo (ForQuad, NextQuad-1, IncQuad, IdSym, idtok) ;
+   PutRangeForIncrement (RangeId, IncQuad)
 END BuildEndFor ;
 
 
@@ -13188,6 +13238,22 @@ PROCEDURE GenQuadOtok (TokPos: CARDINAL;
                        Operation: QuadOperator;
                        Op1, Op2, Op3: CARDINAL; overflow: BOOLEAN;
                        Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
+BEGIN
+   GenQuadOTypetok (TokPos, Operation, Op1, Op2, Op3, overflow, TRUE,
+                    Op1Pos, Op2Pos, Op3Pos)
+END GenQuadOtok ;
+
+
+(*
+   GenQuadOTypetok - assigns the fields of the quadruple with
+                     the parameters.
+*)
+
+PROCEDURE GenQuadOTypetok (TokPos: CARDINAL;
+                           Operation: QuadOperator;
+                           Op1, Op2, Op3: CARDINAL;
+                           overflow, typecheck: BOOLEAN;
+                           Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
 VAR
    f: QuadFrame ;
 BEGIN
@@ -13199,7 +13265,7 @@ BEGIN
          f := GetQF (NextQuad-1) ;
          f^.Next := NextQuad
       END ;
-      PutQuadO (NextQuad, Operation, Op1, Op2, Op3, overflow) ;
+      PutQuadOType (NextQuad, Operation, Op1, Op2, Op3, overflow, typecheck) ;
       f := GetQF (NextQuad) ;
       WITH f^ DO
          Next := 0 ;
@@ -13221,7 +13287,7 @@ BEGIN
       (* DisplayQuad(NextQuad) ; *)
       NewQuad (NextQuad)
    END
-END GenQuadOtok ;
+END GenQuadOTypetok ;
 
 
 (*
diff --git a/gcc/m2/gm2-compiler/M2Range.def b/gcc/m2/gm2-compiler/M2Range.def
index 14c30a7..2ffd74f 100644
--- a/gcc/m2/gm2-compiler/M2Range.def
+++ b/gcc/m2/gm2-compiler/M2Range.def
@@ -117,11 +117,23 @@ PROCEDURE InitDecRangeCheck (d, e: CARDINAL) : CARDINAL ;
 (*
    InitForLoopBeginRangeCheck - returns a range check node which
                                 remembers the information necessary
-                                so that a range check for FOR d := e TO .. DO
-                                can be generated later on.
+                                so that a range check for
+                                FOR des := expr1 TO expr2 DO
+                                can be generated later on.  expr2 is
+                                only used to type check with des.
 *)
 
-PROCEDURE InitForLoopBeginRangeCheck (d, e: CARDINAL) : CARDINAL ;
+PROCEDURE InitForLoopBeginRangeCheck (des, destok,
+                                      expr1, expr1tok,
+                                      expr2, expr2tok,
+                                      byconst, byconsttok: CARDINAL) : CARDINAL ;
+
+
+(*
+   PutRangeForIncrement - places incrementquad into the range record.
+*)
+
+PROCEDURE PutRangeForIncrement (range: CARDINAL; incrementquad: CARDINAL) ;
 
 
 (*
diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod
index 97abd3e..fa1ef35 100644
--- a/gcc/m2/gm2-compiler/M2Range.mod
+++ b/gcc/m2/gm2-compiler/M2Range.mod
@@ -69,7 +69,9 @@ FROM M2MetaError IMPORT MetaError1, MetaError2, MetaError3,
                         MetaErrorStringT1, MetaErrorStringT2, MetaErrorStringT3,
                         MetaString3 ;
 
-FROM M2LexBuf IMPORT UnknownTokenNo, GetTokenNo, FindFileNameFromToken, TokenToLineNo, TokenToColumnNo, TokenToLocation ;
+FROM M2LexBuf IMPORT UnknownTokenNo, GetTokenNo, FindFileNameFromToken,
+                     TokenToLineNo, TokenToColumnNo, TokenToLocation, MakeVirtual2Tok ;
+
 FROM StrIO IMPORT WriteString, WriteLn ;
 FROM M2GCCDeclare IMPORT TryDeclareConstant, DeclareConstructor ;
 FROM M2Quads IMPORT QuadOperator, PutQuad, SubQuad, WriteOperand ;
@@ -122,7 +124,8 @@ TYPE
    Range = POINTER TO RECORD
                          type          : TypeOfRange ;
                          des,
-                         expr,
+                         expr, expr2,
+                         byconst,
                          desLowestType,
                          exprLowestType: CARDINAL ;
                          procedure     : CARDINAL ;
@@ -131,7 +134,12 @@ TYPE
                                                         only used in pointernil *)
                          dimension     : CARDINAL ;
                          caseList      : CARDINAL ;
+                         destok,
+                         exprtok,
+                         expr2tok,
+                         byconsttok,
                          tokenNo       : CARDINAL ;
+                         incrementquad : CARDINAL ; (* Increment quad used in FOR the loop.  *)
                          errorReported : BOOLEAN ;  (* error message reported yet? *)
                          strict        : BOOLEAN ;  (* is it a comparison expression?  *)
                          isin          : BOOLEAN ;  (* expression created by IN operator?  *)
@@ -293,12 +301,19 @@ BEGIN
          type           := none ;
          des            := NulSym ;
          expr           := NulSym ;
+         expr2          := NulSym ;
+         byconst        := NulSym ;
          desLowestType  := NulSym ;
          exprLowestType := NulSym ;
          isLeftValue    := FALSE ;   (* ignored in all cases other *)
          dimension      := 0 ;
          caseList       := 0 ;
-         tokenNo        := 0 ;       (* than pointernil            *)
+         tokenNo        := UnknownTokenNo ;    (* than pointernil            *)
+         destok         := UnknownTokenNo ;
+         exprtok        := UnknownTokenNo ;
+         expr2tok       := UnknownTokenNo ;
+         byconsttok     := UnknownTokenNo ;
+         incrementquad  := 0 ;
          errorReported  := FALSE
       END ;
       PutIndice(RangeIndex, r, p)
@@ -335,6 +350,19 @@ END setReported ;
 
 
 (*
+   PutRangeForIncrement - places incrementquad into the range record.
+*)
+
+PROCEDURE PutRangeForIncrement (range: CARDINAL; incrementquad: CARDINAL) ;
+VAR
+   p: Range ;
+BEGIN
+   p := GetIndice (RangeIndex, range) ;
+   p^.incrementquad := incrementquad
+END PutRangeForIncrement ;
+
+
+(*
    PutRange - initializes contents of, p, to
               d, e and their lowest types.
               It also fills in the current token no
@@ -358,6 +386,38 @@ END PutRange ;
 
 
 (*
+   PutRangeDesExpr2 - initializes contents of, p, to
+                      des, expr1 and their lowest types.
+                      It also fills in the token numbers for
+                      des, expr, expr2 and returns, p.
+*)
+
+PROCEDURE PutRangeDesExpr2 (p: Range; t: TypeOfRange;
+                            des, destok,
+                            expr1, expr1tok,
+                            expr2, expr2tok,
+                            byconst, byconsttok: CARDINAL) : Range ;
+BEGIN
+   p^.des := des ;
+   p^.destok := destok ;
+   p^.expr := expr1 ;
+   p^.exprtok := expr1tok ;
+   p^.expr2 := expr2 ;
+   p^.expr2tok := expr2tok ;
+   p^.byconst := byconst ;
+   p^.byconsttok := byconsttok ;
+   WITH p^ DO
+      type           := t ;
+      desLowestType  := GetLowestType (des) ;
+      exprLowestType := GetLowestType (expr1) ;
+      strict         := FALSE ;
+      isin           := FALSE
+   END ;
+   RETURN p
+END PutRangeDesExpr2 ;
+
+
+(*
    chooseTokenPos - returns, tokenpos, if it is not the unknown location, otherwise
                     it returns GetTokenNo.
 *)
@@ -808,16 +868,25 @@ END InitTypesExpressionCheck ;
 (*
    InitForLoopBeginRangeCheck - returns a range check node which
                                 remembers the information necessary
-                                so that a range check for FOR d := e TO .. DO
-                                can be generated later on.
+                                so that a range check for
+                                FOR des := expr1 TO expr2 DO
+                                can be generated later on.  expr2 is
+                                only used to type check with des.
 *)
 
-PROCEDURE InitForLoopBeginRangeCheck (d, e: CARDINAL) : CARDINAL ;
+PROCEDURE InitForLoopBeginRangeCheck (des, destok,
+                                      expr1, expr1tok,
+                                      expr2, expr2tok,
+                                      byconst, byconsttok: CARDINAL) : CARDINAL ;
 VAR
    r: CARDINAL ;
 BEGIN
    r := InitRange () ;
-   Assert (PutRange (GetTokenNo (), GetIndice (RangeIndex, r), forloopbegin, d, e) # NIL) ;
+   Assert (PutRangeDesExpr2 (GetIndice (RangeIndex, r), forloopbegin,
+                             des, destok,
+                             expr1, expr1tok,
+                             expr2, expr2tok,
+                             byconst, byconsttok) # NIL) ;
    RETURN r
 END InitForLoopBeginRangeCheck ;
 
@@ -1786,6 +1855,58 @@ END CodeTypeCheck ;
 
 
 (*
+   ForLoopBeginTypeCompatible - check for designator assignment compatibility with
+                                expr1 and designator expression compatibility with expr2.
+                                FOR des := expr1 TO expr2 BY byconst DO
+                                END
+                                It generates composite tokens if the tokens are on
+                                the same source line.
+*)
+
+PROCEDURE ForLoopBeginTypeCompatible (p: Range) : BOOLEAN ;
+VAR
+   combinedtok: CARDINAL ;
+   success    : BOOLEAN ;
+BEGIN
+   success := TRUE ;
+   WITH p^ DO
+      combinedtok := MakeVirtual2Tok (destok, exprtok) ;
+      IF NOT AssignmentTypeCompatible (combinedtok, "", des, expr)
+      THEN
+         MetaErrorT2 (combinedtok,
+                      'type incompatibility between {%1Et} and {%2t} detected during the assignment of the designator {%1a} to the first expression {%2a} in the {%kFOR} loop',
+                      des, expr) ;
+         success := FALSE
+      END ;
+      combinedtok := MakeVirtual2Tok (destok, expr2tok) ;
+      IF NOT ExpressionTypeCompatible (combinedtok, "", des, expr2, TRUE, FALSE)
+      THEN
+         MetaErrorT2 (combinedtok,
+                      'type expression incompatibility between {%1Et} and {%2t} detected when comparing the designator {%1a} against the second expression {%2a} in the {%kFOR} loop',
+                      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',
+                      des, byconst) ;
+         success := FALSE
+      END ;
+*)
+      IF (NOT success) AND (incrementquad # 0)
+      THEN
+         (* Avoid a subsequent generic type check error.  *)
+         SubQuad (incrementquad)
+      END
+   END ;
+   RETURN success
+END ForLoopBeginTypeCompatible ;
+
+
+(*
    FoldForLoopBegin -
 *)
 
@@ -1802,14 +1923,17 @@ BEGIN
          IF GccKnowsAbout(expr) AND IsConst(expr) AND
             GetMinMax(tokenno, desLowestType, min, max)
          THEN
-            IF OutOfRange(tokenno, min, expr, max, desLowestType)
+            IF NOT ForLoopBeginTypeCompatible (p)
             THEN
-               MetaErrorT2(tokenNo,
+               SubQuad (q)
+            ELSIF OutOfRange (tokenno, min, expr, max, desLowestType)
+            THEN
+               MetaErrorT2 (tokenNo,
                            'attempting to assign a value {%2Wa} to a FOR loop designator {%1a} which will exceed the range of type {%1tad}',
-                           des, expr) ;
-               PutQuad(q, ErrorOp, NulSym, NulSym, r)
+                            des, expr) ;
+               PutQuad (q, ErrorOp, NulSym, NulSym, r)
             ELSE
-               SubQuad(q)
+               SubQuad (q)
             END
          END
       END
@@ -2872,7 +2996,10 @@ END CodeDynamicArraySubscript ;
 PROCEDURE CodeForLoopBegin (tokenno: CARDINAL;
                             r: CARDINAL; function, message: String) ;
 BEGIN
-   DoCodeAssignment(tokenno, r, function, message)
+   IF ForLoopBeginTypeCompatible (GetIndice (RangeIndex, r))
+   THEN
+      DoCodeAssignment(tokenno, r, function, message)
+   END
 END CodeForLoopBegin ;
 
 
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc10.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc10.mod
new file mode 100644
index 0000000..3a2d3e2
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc10.mod
@@ -0,0 +1,16 @@
+MODULE callingc10 ;
+
+FROM cvararg IMPORT funcptr ;
+FROM SYSTEM IMPORT ADR ;
+
+BEGIN
+   IF funcptr (1, "hello", 5) = 1
+   THEN
+   END ;
+   IF funcptr (1, "hello" + " ", 6) = 1
+   THEN
+   END ;
+   IF funcptr (1, "hello" + " " + "world", 11) = 1
+   THEN
+   END
+END callingc10.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc11.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc11.mod
new file mode 100644
index 0000000..9b8cb82
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc11.mod
@@ -0,0 +1,17 @@
+MODULE callingc11 ;
+
+FROM cvararg IMPORT funcptr ;
+FROM SYSTEM IMPORT ADR ;
+FROM strconst IMPORT WORLD ;
+
+BEGIN
+   IF funcptr (1, "hello", 5) = 1
+   THEN
+   END ;
+   IF funcptr (1, "hello" + " ", 6) = 1
+   THEN
+   END ;
+   IF funcptr (1, "hello" + " " + WORLD, 11) = 1
+   THEN
+   END
+END callingc11.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc9.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc9.mod
new file mode 100644
index 0000000..7e19a0a
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc9.mod
@@ -0,0 +1,7 @@
+MODULE callingc9 ;
+
+VAR
+   array: ARRAY [0..9] OF CHAR ;
+BEGIN
+   array := '0123456789'
+END callingc9.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/strconst.def b/gcc/testsuite/gm2/extensions/run/pass/strconst.def
new file mode 100644
index 0000000..af1111c
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/strconst.def
@@ -0,0 +1,6 @@
+DEFINITION MODULE FOR "C" strconst ;
+
+CONST
+   WORLD = "world" ;
+
+END strconst.
diff --git a/gcc/testsuite/gm2/pim/fail/forloop.mod b/gcc/testsuite/gm2/pim/fail/forloop.mod
new file mode 100644
index 0000000..be86a84
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/forloop.mod
@@ -0,0 +1,17 @@
+MODULE forloop ;
+
+
+PROCEDURE init ;
+VAR
+   i: INTEGER ;
+   c: CARDINAL ;
+BEGIN
+   c := 10 ;
+   FOR i := 0 TO c DO   (* INTEGER CARDINAL expression incompatible.  *)
+   END
+END init ;
+
+
+BEGIN
+   init
+END forloop.
diff --git a/gcc/testsuite/gm2/pim/pass/forloop2.mod b/gcc/testsuite/gm2/pim/pass/forloop2.mod
new file mode 100644
index 0000000..0bbc95d
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/forloop2.mod
@@ -0,0 +1,18 @@
+MODULE forloop2 ;
+
+TYPE
+   colour = (red, green, blue) ;
+
+
+PROCEDURE init ;
+VAR
+   c: colour ;
+BEGIN
+   FOR c := red TO blue DO
+   END
+END init ;
+
+
+BEGIN
+   init
+END forloop2.