PR modula2/114333 set type comparison against cardinal should cause error addendum

This patch applies the new stricter type checking procedure function to
the remaining 6 comparisons: less, greater, lessequ, greequ, ifin and
ifnotin.

gcc/m2/ChangeLog:

	PR modula2/114333
	* gm2-compiler/M2GenGCC.mod (CodeStatement): Remove op1, op2 and
	op3 parameters to CodeIfLess, CodeIfLessEqu, CodeIfGreEqu, CodeIfGre,
	CodeIfIn, CodeIfNotIn.
	(CodeIfLess): Rewrite.
	(PerformCodeIfLess): New procedure.
	(CodeIfLess): Rewrite.
	(PerformCodeIfLess): New procedure.
	(CodeIfLessEqu): Rewrite.
	(PerformCodeIfLessEqu): New procedure.
	(CodeIfGreEqu): Rewrite.
	(PerformCodeIfGreEqu): New procedure.
	(CodeIfGre): Rewrite.
	(PerformCodeIfGre): New procedure.
	(CodeIfIn): Rewrite.
	(PerformCodeIfIn): New procedure.
	(CodeIfNotIn): Rewrite.
	(PerformCodeIfNotIn): New procedure.

gcc/testsuite/ChangeLog:

	PR modula2/114333
	* gm2/pim/fail/badset5.mod: New test.
	* gm2/pim/fail/badset6.mod: New test.

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

diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index 7633b8425aefa6d375e358c654d308c3d5b9c4d0..7e27373a6ac1466ea156f87bf837c0d1f73f335d 100644 (file)
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -510,14 +510,14 @@ BEGIN
    LogicalAndOp       : CodeSetAnd (q) |
    LogicalXorOp       : CodeSetSymmetricDifference (q) |
    LogicalDiffOp      : CodeSetLogicalDifference (q) |
-   IfLessOp           : CodeIfLess (q, op1, op2, op3) |
+   IfLessOp           : CodeIfLess (q) |
    IfEquOp            : CodeIfEqu (q) |
    IfNotEquOp         : CodeIfNotEqu (q) |
-   IfGreEquOp         : CodeIfGreEqu (q, op1, op2, op3) |
-   IfLessEquOp        : CodeIfLessEqu (q, op1, op2, op3) |
-   IfGreOp            : CodeIfGre (q, op1, op2, op3) |
-   IfInOp             : CodeIfIn (q, op1, op2, op3) |
-   IfNotInOp          : CodeIfNotIn (q, op1, op2, op3) |
+   IfGreEquOp         : CodeIfGreEqu (q) |
+   IfLessEquOp        : CodeIfLessEqu (q) |
+   IfGreOp            : CodeIfGre (q) |
+   IfInOp             : CodeIfIn (q) |
+   IfNotInOp          : CodeIfNotIn (q) |
    IndrXOp            : CodeIndrX (q, op1, op2, op3) |
    XIndrOp            : CodeXIndr (q) |
    CallOp             : CodeCall (CurrentQuadToken, op3) |
@@ -6831,50 +6831,67 @@ END CodeIfSetLess ;
 
 
 (*
-   CodeIfLess - codes the quadruple if op1 < op2 then goto op3
+   PerformCodeIfLess - codes the quadruple if op1 < op2 then goto op3
 *)
 
-PROCEDURE CodeIfLess (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE PerformCodeIfLess (quad: CARDINAL) ;
 VAR
    tl, tr  : Tree ;
-   location: location_t ;
+   location                   : location_t ;
+   left, right, dest, combined,
+   leftpos, rightpos, destpos : CARDINAL ;
+   overflow                   : BOOLEAN ;
+   op                         : QuadOperator ;
 BEGIN
-   location := TokenToLocation(CurrentQuadToken) ;
+   GetQuadOtok (quad, combined, op,
+                left, right, dest, overflow,
+                leftpos, rightpos, destpos) ;
+   location := TokenToLocation (combined) ;
 
-   (* firstly ensure that any constant literal is declared *)
-   DeclareConstant(CurrentQuadToken, op1) ;
-   DeclareConstant(CurrentQuadToken, op2) ;
-   IF IsConst(op1) AND IsConst(op2)
+   IF IsConst(left) AND IsConst(right)
    THEN
-      PushValue(op1) ;
-      PushValue(op2) ;
+      PushValue(left) ;
+      PushValue(right) ;
       IF Less(CurrentQuadToken)
       THEN
-         BuildGoto(location, string(CreateLabelName(op3)))
+         BuildGoto(location, string(CreateLabelName(dest)))
       ELSE
          (* fall through *)
       END
-   ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
-         IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
+   ELSIF IsConstSet(left) OR (IsVar(left) AND IsSet(SkipType(GetType(left)))) OR
+         IsConstSet(right) OR (IsVar(right) AND IsSet(SkipType(GetType(right))))
    THEN
-      CodeIfSetLess(quad, op1, op2, op3)
+      CodeIfSetLess(quad, left, right, dest)
    ELSE
-      IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
+      IF IsComposite(GetType(left)) OR IsComposite(GetType(right))
       THEN
-         MetaErrorT2 (CurrentQuadToken,
+         MetaErrorT2 (combined,
                       'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
-                      op1, op2)
+                      left, right)
       ELSE
-         ConvertBinaryOperands(location,
-                               tl, tr,
-                               ComparisonMixTypes (SkipType (GetType (op1)),
-                                                   SkipType (GetType (op2)),
-                                                   CurrentQuadToken),
-                               op1, op2) ;
-         DoJump(location,
-                BuildLessThan(location, tl, tr), NIL, string(CreateLabelName(op3)))
+         ConvertBinaryOperands (location,
+                                tl, tr,
+                                ComparisonMixTypes (SkipType (GetType (left)),
+                                                    SkipType (GetType (right)),
+                                                    combined),
+                                left, right) ;
+         DoJump (location,
+                 BuildLessThan (location, tl, tr), NIL, string (CreateLabelName (dest)))
       END
    END
+END PerformCodeIfLess ;
+
+
+(*
+   CodeIfLess - codes the quadruple if op1 < op2 then goto op3
+*)
+
+PROCEDURE CodeIfLess (quad: CARDINAL) ;
+BEGIN
+   IF IsValidExpressionRelOp (quad, FALSE)
+   THEN
+      PerformCodeIfLess (quad)
+   END
 END CodeIfLess ;
 
 
@@ -6926,51 +6943,65 @@ END CodeIfSetGre ;
 
 
 (*
-   CodeIfGre - codes the quadruple if op1 > op2 then goto op3
+   PerformCodeIfGre - codes the quadruple if op1 > op2 then goto op3
 *)
 
-PROCEDURE CodeIfGre (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE PerformCodeIfGre (quad: CARDINAL) ;
 VAR
    tl, tr  : Tree ;
-   location: location_t ;
+   location                   : location_t ;
+   left, right, dest, combined,
+   leftpos, rightpos, destpos : CARDINAL ;
+   overflow                   : BOOLEAN ;
+   op                         : QuadOperator ;
 BEGIN
-   location := TokenToLocation(CurrentQuadToken) ;
-
-   (* firstly ensure that any constant literal is declared *)
-   DeclareConstant(CurrentQuadToken, op1) ;
-   DeclareConstant(CurrentQuadToken, op2) ;
-   DeclareConstructor(CurrentQuadToken, quad, op1) ;
-   DeclareConstructor(CurrentQuadToken, quad, op2) ;
-   IF IsConst(op1) AND IsConst(op2)
+   GetQuadOtok (quad, combined, op,
+                left, right, dest, overflow,
+                leftpos, rightpos, destpos) ;
+   location := TokenToLocation (combined) ;
+   IF IsConst(left) AND IsConst(right)
    THEN
-      PushValue(op1) ;
-      PushValue(op2) ;
-      IF Gre(CurrentQuadToken)
+      PushValue(left) ;
+      PushValue(right) ;
+      IF Gre(combined)
       THEN
-         BuildGoto(location, string(CreateLabelName(op3)))
+         BuildGoto(location, string(CreateLabelName(dest)))
       ELSE
          (* fall through *)
       END
-   ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
-         IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
+   ELSIF IsConstSet(left) OR (IsVar(left) AND IsSet(SkipType(GetType(left)))) OR
+         IsConstSet(right) OR (IsVar(right) AND IsSet(SkipType(GetType(right))))
    THEN
-      CodeIfSetGre(quad, op1, op2, op3)
+      CodeIfSetGre(quad, left, right, dest)
    ELSE
-      IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
+      IF IsComposite(GetType(left)) OR IsComposite(GetType(right))
       THEN
-         MetaErrorT2 (CurrentQuadToken,
+         MetaErrorT2 (combined,
                       'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
-                      op1, op2)
+                      left, right)
       ELSE
          ConvertBinaryOperands(location,
                                tl, tr,
-                               ComparisonMixTypes (SkipType (GetType (op1)),
-                                                   SkipType (GetType (op2)),
-                                                   CurrentQuadToken),
-                               op1, op2) ;
-         DoJump(location, BuildGreaterThan(location, tl, tr), NIL, string(CreateLabelName(op3)))
+                               ComparisonMixTypes (SkipType (GetType (left)),
+                                                   SkipType (GetType (right)),
+                                                   combined),
+                               left, right) ;
+         DoJump(location, BuildGreaterThan(location, tl, tr), NIL, string(CreateLabelName(dest)))
       END
    END
+END PerformCodeIfGre ;
+
+
+(*
+   CodeIfGre - codes the quadruple if op1 > op2 then goto op3
+*)
+
+PROCEDURE CodeIfGre (quad: CARDINAL) ;
+BEGIN
+   IF IsValidExpressionRelOp (quad, FALSE)
+   THEN
+      PerformCodeIfGre (quad)
+   END
 END CodeIfGre ;
 
 
@@ -7022,51 +7053,66 @@ END CodeIfSetLessEqu ;
 
 
 (*
-   CodeIfLessEqu - codes the quadruple if op1 <= op2 then goto op3
+   PerformCodeIfLessEqu - codes the quadruple if op1 <= op2 then goto op3
 *)
 
-PROCEDURE CodeIfLessEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE PerformCodeIfLessEqu (quad: CARDINAL) ;
 VAR
    tl, tr  : Tree ;
-   location: location_t ;
+   location                   : location_t ;
+   left, right, dest, combined,
+   leftpos, rightpos, destpos : CARDINAL ;
+   overflow                   : BOOLEAN ;
+   op                         : QuadOperator ;
 BEGIN
-   location := TokenToLocation(CurrentQuadToken) ;
-
-   (* firstly ensure that any constant literal is declared *)
-   DeclareConstant(CurrentQuadToken, op1) ;
-   DeclareConstant(CurrentQuadToken, op2) ;
-   DeclareConstructor(CurrentQuadToken, quad, op1) ;
-   DeclareConstructor(CurrentQuadToken, quad, op2) ;
-   IF IsConst(op1) AND IsConst(op2)
+   GetQuadOtok (quad, combined, op,
+                left, right, dest, overflow,
+                leftpos, rightpos, destpos) ;
+   location := TokenToLocation (combined) ;
+   IF IsConst(left) AND IsConst(right)
    THEN
-      PushValue(op1) ;
-      PushValue(op2) ;
-      IF LessEqu(CurrentQuadToken)
+      PushValue(left) ;
+      PushValue(right) ;
+      IF LessEqu(combined)
       THEN
-         BuildGoto(location, string(CreateLabelName(op3)))
+         BuildGoto(location, string(CreateLabelName(dest)))
       ELSE
          (* fall through *)
       END
-   ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
-         IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
+   ELSIF IsConstSet (left) OR (IsVar (left) AND IsSet (SkipType (GetType (left)))) OR
+         IsConstSet (right) OR (IsVar (right) AND IsSet (SkipType (GetType (right))))
    THEN
-      CodeIfSetLessEqu(quad, op1, op2, op3)
+      CodeIfSetLessEqu (quad, left, right, dest)
    ELSE
-      IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
+      IF IsComposite (GetType (left)) OR IsComposite (GetType (right))
       THEN
-         MetaErrorT2 (CurrentQuadToken,
+         MetaErrorT2 (combined,
                       'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
-                      op1, op2)
+                      left, right)
       ELSE
-         ConvertBinaryOperands(location,
-                               tl, tr,
-                               ComparisonMixTypes (SkipType (GetType (op1)),
-                                                   SkipType (GetType (op2)),
-                                                   CurrentQuadToken),
-                               op1, op2) ;
-         DoJump(location, BuildLessThanOrEqual(location, tl, tr), NIL, string(CreateLabelName(op3)))
+         ConvertBinaryOperands (location,
+                                tl, tr,
+                                ComparisonMixTypes (SkipType (GetType (left)),
+                                                    SkipType (GetType (right)),
+                                                    combined),
+                                left, right) ;
+         DoJump (location, BuildLessThanOrEqual (location, tl, tr),
+                 NIL, string (CreateLabelName (dest)))
       END
    END
+END PerformCodeIfLessEqu ;
+
+
+(*
+   CodeIfLessEqu - codes the quadruple if op1 <= op2 then goto op3
+*)
+
+PROCEDURE CodeIfLessEqu (quad: CARDINAL) ;
+BEGIN
+   IF IsValidExpressionRelOp (quad, FALSE)
+   THEN
+      PerformCodeIfLessEqu (quad)
+   END
 END CodeIfLessEqu ;
 
 
@@ -7118,51 +7164,65 @@ END CodeIfSetGreEqu ;
 
 
 (*
-   CodeIfGreEqu - codes the quadruple if op1 >= op2 then goto op3
+   PerformCodeIfGreEqu - codes the quadruple if op1 >= op2 then goto op3
 *)
 
-PROCEDURE CodeIfGreEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE PerformCodeIfGreEqu (quad: CARDINAL) ;
 VAR
    tl, tr: Tree ;
-   location: location_t ;
+   location                   : location_t ;
+   left, right, dest, combined,
+   leftpos, rightpos, destpos : CARDINAL ;
+   overflow                   : BOOLEAN ;
+   op                         : QuadOperator ;
 BEGIN
-   location := TokenToLocation(CurrentQuadToken) ;
-
-   (* firstly ensure that any constant literal is declared *)
-   DeclareConstant(CurrentQuadToken, op1) ;
-   DeclareConstant(CurrentQuadToken, op2) ;
-   DeclareConstructor(CurrentQuadToken, quad, op1) ;
-   DeclareConstructor(CurrentQuadToken, quad, op2) ;
-   IF IsConst(op1) AND IsConst(op2)
+   GetQuadOtok (quad, combined, op,
+                left, right, dest, overflow,
+                leftpos, rightpos, destpos) ;
+   location := TokenToLocation (combined) ;
+   IF IsConst(left) AND IsConst(right)
    THEN
-      PushValue(op1) ;
-      PushValue(op2) ;
-      IF GreEqu(CurrentQuadToken)
+      PushValue(left) ;
+      PushValue(right) ;
+      IF GreEqu(combined)
       THEN
-         BuildGoto(location, string(CreateLabelName(op3)))
+         BuildGoto(location, string(CreateLabelName(dest)))
       ELSE
          (* fall through *)
       END
-   ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
-         IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
+   ELSIF IsConstSet(left) OR (IsVar(left) AND IsSet(SkipType(GetType(left)))) OR
+         IsConstSet(right) OR (IsVar(right) AND IsSet(SkipType(GetType(right))))
    THEN
-      CodeIfSetGreEqu(quad, op1, op2, op3)
+      CodeIfSetGreEqu(quad, left, right, dest)
    ELSE
-      IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
+      IF IsComposite(GetType(left)) OR IsComposite(GetType(right))
       THEN
-         MetaErrorT2 (CurrentQuadToken,
+         MetaErrorT2 (combined,
                       'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
-                      op1, op2)
+                      left, right)
       ELSE
          ConvertBinaryOperands(location,
                                tl, tr,
-                               ComparisonMixTypes (SkipType (GetType (op1)),
-                                                   SkipType (GetType (op2)),
-                                                   CurrentQuadToken),
-                               op1, op2) ;
-         DoJump(location, BuildGreaterThanOrEqual(location, tl, tr), NIL, string(CreateLabelName(op3)))
+                               ComparisonMixTypes (SkipType (GetType (left)),
+                                                   SkipType (GetType (right)),
+                                                   combined),
+                               left, right) ;
+         DoJump(location, BuildGreaterThanOrEqual(location, tl, tr), NIL, string(CreateLabelName(dest)))
       END
    END
+END PerformCodeIfGreEqu ;
+
+
+(*
+   CodeIfGreEqu - codes the quadruple if op1 >= op2 then goto op3
+*)
+
+PROCEDURE CodeIfGreEqu (quad: CARDINAL) ;
+BEGIN
+   IF IsValidExpressionRelOp (quad, FALSE)
+   THEN
+      PerformCodeIfGreEqu (quad)
+   END
 END CodeIfGreEqu ;
 
 
@@ -7302,7 +7362,6 @@ VAR
    overflow                   : BOOLEAN ;
    op                         : QuadOperator ;
 BEGIN
-   (* Ensure that any remaining undeclared constant literal is declared.  *)
    GetQuadOtok (quad, combined, op,
                 left, right, dest, overflow,
                 leftpos, rightpos, destpos) ;
@@ -7394,10 +7453,11 @@ END PerformCodeIfNotEqu ;
 
 
 (*
-   IsValidExpressionRelOp -
+   IsValidExpressionRelOp - declare left and right constants (if they are not already declared).
+                            Check whether left and right are expression compatible.
 *)
 
-PROCEDURE IsValidExpressionRelOp (quad: CARDINAL) : BOOLEAN ;
+PROCEDURE IsValidExpressionRelOp (quad: CARDINAL; isin: BOOLEAN) : BOOLEAN ;
 CONST
    Verbose = FALSE ;
 VAR
@@ -7418,7 +7478,7 @@ BEGIN
    lefttype := GetType (left) ;
    righttype := GetType (right) ;
    IF ExpressionTypeCompatible (combined, "", left, right,
-                                StrictTypeChecking, FALSE)
+                                StrictTypeChecking, isin)
    THEN
       RETURN TRUE
    ELSE
@@ -7439,7 +7499,7 @@ END IsValidExpressionRelOp ;
 
 PROCEDURE CodeIfEqu (quad: CARDINAL) ;
 BEGIN
-   IF IsValidExpressionRelOp (quad)
+   IF IsValidExpressionRelOp (quad, FALSE)
    THEN
       PerformCodeIfEqu (quad)
    END
@@ -7452,7 +7512,7 @@ END CodeIfEqu ;
 
 PROCEDURE CodeIfNotEqu (quad: CARDINAL) ;
 BEGIN
-   IF IsValidExpressionRelOp (quad)
+   IF IsValidExpressionRelOp (quad, FALSE)
    THEN
       PerformCodeIfNotEqu (quad)
    END
@@ -7541,10 +7601,10 @@ END BuildIfNotVarInConstValue ;
 
 
 (*
-   CodeIfIn - code the quadruple: if op1 in op2 then goto op3
+   PerformCodeIfIn - code the quadruple: if op1 in op2 then goto op3
 *)
 
-PROCEDURE CodeIfIn (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE PerformCodeIfIn (quad: CARDINAL) ;
 VAR
    low,
    high    : CARDINAL ;
@@ -7552,44 +7612,46 @@ VAR
    hightree,
    offset  : Tree ;
    fieldno : INTEGER ;
-   location: location_t ;
+   location                   : location_t ;
+   left, right, dest, combined,
+   leftpos, rightpos, destpos : CARDINAL ;
+   overflow                   : BOOLEAN ;
+   op                         : QuadOperator ;
 BEGIN
-   location := TokenToLocation(CurrentQuadToken) ;
-
-   (* firstly ensure that any constant literal is declared *)
-   DeclareConstant(CurrentQuadToken, op1) ;
-   DeclareConstant(CurrentQuadToken, op2) ;
-   DeclareConstructor(CurrentQuadToken, quad, op1) ;
-   DeclareConstructor(CurrentQuadToken, quad, op2) ;
-   IF IsConst(op1) AND IsConst(op2)
+   (* Ensure that any remaining undeclared constant literal is declared.  *)
+   GetQuadOtok (quad, combined, op,
+                left, right, dest, overflow,
+                leftpos, rightpos, destpos) ;
+   location := TokenToLocation (combined) ;
+   IF IsConst(left) AND IsConst(right)
    THEN
       InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
    ELSIF CheckElementSetTypes (quad)
    THEN
-      IF IsConst(op1)
+      IF IsConst(left)
       THEN
-         fieldno := GetFieldNo(CurrentQuadToken, op1, GetType(op2), offset) ;
+         fieldno := GetFieldNo(combined, left, GetType(right), offset) ;
          IF fieldno>=0
          THEN
-            PushValue(op1) ;
+            PushValue(left) ;
             PushIntegerTree(offset) ;
-            ConvertToType(GetType(op1)) ;
+            ConvertToType(GetType(left)) ;
             Sub ;
             BuildIfConstInVar(location,
-                              Mod2Gcc(SkipType(GetType(op2))),
-                              Mod2Gcc(op2), PopIntegerTree(),
-                              GetMode(op2)=LeftValue, fieldno,
-                              string(CreateLabelName(op3)))
+                              Mod2Gcc(SkipType(GetType(right))),
+                              Mod2Gcc(right), PopIntegerTree(),
+                              GetMode(right)=LeftValue, fieldno,
+                              string(CreateLabelName(dest)))
          ELSE
-            MetaErrorT1 (CurrentQuadToken, 'bit exceeded the range of set {%1Eatd}', op1)
+            MetaErrorT1 (combined, 'bit exceeded the range of set {%1Eatd}', left)
          END
-      ELSIF IsConst(op2)
+      ELSIF IsConst(right)
       THEN
          (* builds a cascaded list of if statements *)
-         PushValue(op2) ;
-         BuildIfVarInConstValue(location, CurrentQuadToken, GetValue(CurrentQuadToken), op1, op3)
+         PushValue(right) ;
+         BuildIfVarInConstValue(location, combined, GetValue(combined), left, dest)
       ELSE
-         GetSetLimits(SkipType(GetType(op2)), low, high) ;
+         GetSetLimits(SkipType(GetType(right)), low, high) ;
 
          PushValue(low) ;
          lowtree := PopIntegerTree() ;
@@ -7597,21 +7659,21 @@ BEGIN
          hightree := PopIntegerTree() ;
 
          BuildIfVarInVar(location,
-                         Mod2Gcc(SkipType(GetType(op2))),
-                         Mod2Gcc(op2), Mod2Gcc(op1),
-                         GetMode(op2)=LeftValue,
+                         Mod2Gcc(SkipType(GetType(right))),
+                         Mod2Gcc(right), Mod2Gcc(left),
+                         GetMode(right)=LeftValue,
                          lowtree, hightree,
-                         string(CreateLabelName(op3)))
+                         string(CreateLabelName(dest)))
       END
    END
-END CodeIfIn ;
+END PerformCodeIfIn ;
 
 
 (*
-   CodeIfNotIn - code the quadruple: if not (op1 in op2) then goto op3
+   PerformCodeIfNotIn - code the quadruple: if not (op1 in op2) then goto op3
 *)
 
-PROCEDURE CodeIfNotIn (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE PerformCodeIfNotIn (quad: CARDINAL) ;
 VAR
    low,
    high    : CARDINAL ;
@@ -7619,44 +7681,46 @@ VAR
    hightree,
    offset  : Tree ;
    fieldno : INTEGER ;
-   location: location_t ;
+   location                   : location_t ;
+   left, right, dest, combined,
+   leftpos, rightpos, destpos : CARDINAL ;
+   overflow                   : BOOLEAN ;
+   op                         : QuadOperator ;
 BEGIN
-   location := TokenToLocation(CurrentQuadToken) ;
-
-   (* firstly ensure that any constant literal is declared *)
-   DeclareConstant(CurrentQuadToken, op1) ;
-   DeclareConstant(CurrentQuadToken, op2) ;
-   DeclareConstructor(CurrentQuadToken, quad, op1) ;
-   DeclareConstructor(CurrentQuadToken, quad, op2) ;
-   IF IsConst(op1) AND IsConst(op2)
+   (* Ensure that any remaining undeclared constant literal is declared.  *)
+   GetQuadOtok (quad, combined, op,
+                left, right, dest, overflow,
+                leftpos, rightpos, destpos) ;
+   location := TokenToLocation (combined) ;
+   IF IsConst(left) AND IsConst(right)
    THEN
       InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
    ELSIF CheckElementSetTypes (quad)
    THEN
-      IF IsConst(op1)
+      IF IsConst(left)
       THEN
-         fieldno := GetFieldNo(CurrentQuadToken, op1, SkipType(GetType(op2)), offset) ;
+         fieldno := GetFieldNo(combined, left, SkipType(GetType(right)), offset) ;
          IF fieldno>=0
          THEN
-            PushValue(op1) ;
+            PushValue(left) ;
             PushIntegerTree(offset) ;
-            ConvertToType(GetType(op1)) ;
+            ConvertToType(GetType(left)) ;
             Sub ;
             BuildIfNotConstInVar(location,
-                                 Mod2Gcc(SkipType(GetType(op2))),
-                                 Mod2Gcc(op2), PopIntegerTree(),
-                                 GetMode(op2)=LeftValue, fieldno,
-                                 string(CreateLabelName(op3)))
+                                 Mod2Gcc(SkipType(GetType(right))),
+                                 Mod2Gcc(right), PopIntegerTree(),
+                                 GetMode(right)=LeftValue, fieldno,
+                                 string(CreateLabelName(dest)))
          ELSE
-            MetaErrorT1 (CurrentQuadToken, 'bit exceeded the range of set {%1Eatd}', op2)
+            MetaErrorT1 (combined, 'bit exceeded the range of set {%1Eatd}', right)
          END
-      ELSIF IsConst(op2)
+      ELSIF IsConst(right)
       THEN
          (* builds a cascaded list of if statements *)
-         PushValue(op2) ;
-         BuildIfNotVarInConstValue(quad, GetValue(CurrentQuadToken), op1, op3)
+         PushValue(right) ;
+         BuildIfNotVarInConstValue(quad, GetValue(combined), left, dest)
       ELSE
-         GetSetLimits(SkipType(GetType(op2)), low, high) ;
+         GetSetLimits(SkipType(GetType(right)), low, high) ;
 
          PushValue(low) ;
          lowtree := PopIntegerTree() ;
@@ -7664,13 +7728,39 @@ BEGIN
          hightree := PopIntegerTree() ;
 
          BuildIfNotVarInVar(location,
-                            Mod2Gcc(SkipType(GetType(op2))),
-                            Mod2Gcc(op2), Mod2Gcc(op1),
-                            GetMode(op2)=LeftValue,
+                            Mod2Gcc(SkipType(GetType(right))),
+                            Mod2Gcc(right), Mod2Gcc(left),
+                            GetMode(right)=LeftValue,
                             lowtree, hightree,
-                            string(CreateLabelName(op3)))
+                            string(CreateLabelName(dest)))
       END
    END
+END PerformCodeIfNotIn ;
+
+
+(*
+   CodeIfIn - code the quadruple: if op1 in op2 then goto op3
+*)
+
+PROCEDURE CodeIfIn (quad: CARDINAL) ;
+BEGIN
+   IF IsValidExpressionRelOp (quad, TRUE)
+   THEN
+      PerformCodeIfIn (quad)
+   END
+END CodeIfIn ;
+
+
+(*
+   CodeIfNotIn - code the quadruple: if not (op1 in op2) then goto op3
+*)
+
+PROCEDURE CodeIfNotIn (quad: CARDINAL) ;
+BEGIN
+   IF IsValidExpressionRelOp (quad, TRUE)
+   THEN
+      PerformCodeIfNotIn (quad)
+   END
 END CodeIfNotIn ;
 
 

diff --git a/gcc/testsuite/gm2/pim/fail/badset5.mod b/gcc/testsuite/gm2/pim/fail/badset5.mod
new file mode 100644 (file)
index 0000000..ecc7622
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badset5.mod
@@ -0,0 +1,13 @@
+MODULE badset5 ;
+
+FROM libc IMPORT printf ;
+
+VAR
+   s: SET OF [1..10] ;
+   c: CARDINAL ;
+BEGIN
+   IF c > s
+   THEN
+      printf ("broken\n")
+   END
+END badset5.

diff --git a/gcc/testsuite/gm2/pim/fail/badset6.mod b/gcc/testsuite/gm2/pim/fail/badset6.mod
new file mode 100644 (file)
index 0000000..d97f8e2
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badset6.mod
@@ -0,0 +1,23 @@
+MODULE badset6 ;
+
+FROM libc IMPORT printf ;
+
+TYPE
+   set = SET OF [1..10] ;
+
+PROCEDURE Init (s: set) ;
+VAR
+   c: CARDINAL ;
+BEGIN
+   IF c > s
+   THEN
+      printf ("broken\n")
+   ELSE
+      printf ("broken\n")
+   END
+END Init ;
+
+
+BEGIN
+   Init (set {5,6})
+END badset6.