PR modula2/112946 set expression type checking

This patch adds type checking for binary set operators.
It also checks the IN operator and improves the := type checking.

gcc/m2/ChangeLog:

	PR modula2/112946
	* gm2-compiler/M2GenGCC.mod (IsExpressionCompatible): Import.
	(ExpressionTypeCompatible): Import.
	(CodeStatement): Remove op1, op2, op3 parameters from CodeSetOr,
	CodeSetAnd, CodeSetSymmetricDifference, CodeSetLogicalDifference.
	(checkArrayElements): Rename op1 to des and op3 to expr.
	Use despos and exprpos instead of CurrentQuadToken.
	(checkRecordTypes): Rename op1 to des and op2 to expr.
	Use virtpos instead of CurrentQuadToken.
	(checkIncorrectMeta): Ditto.
	(checkBecomes): Rename op1 to des and op3 to expr.
	Use virtpos instead of CurrentQuadToken.
	(NoWalkProcedure): New procedure stub.
	(CheckBinaryExpressionTypes): New procedure function.
	(CheckElementSetTypes): New procedure function.
	(CodeBinarySet): Re-write.
	(FoldBinarySet): Re-write.
	(CodeSetOr): Remove parameters op1, op2 and op3.
	(CodeSetAnd): Ditto.
	(CodeSetLogicalDifference): Ditto.
	(CodeSetSymmetricDifference): Ditto.
	(CodeIfIn): Call CheckBinaryExpressionTypes and
	CheckElementSetTypes.
	* gm2-compiler/M2Quads.mod (BuildRotateFunction): Correct
	parameters to MakeVirtualTok to reflect parameter block
	passed to Rotate.

gcc/testsuite/ChangeLog:

	PR modula2/112946
	* gm2/pim/fail/badbecomes.mod: New test.
	* gm2/pim/fail/badexpression.mod: New test.
	* gm2/pim/fail/badexpression2.mod: New test.
	* gm2/pim/fail/badifin.mod: New test.
	* gm2/pim/pass/goodifin.mod: New test.

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

2 files changed, 332 insertions, 159 deletions

diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index bfcff70..2261cb0 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -107,7 +107,8 @@ FROM M2Base IMPORT MixTypes, NegateType, ActivationPointer, IsMathType,
                    Cardinal, Char, Integer, IsTrunc,
                    Boolean, True,
                    Im, Re, Cmplx, GetCmplxReturnType, GetBaseTypeMinMax,
-                   CheckAssignmentCompatible, IsAssignmentCompatible ;
+                   CheckAssignmentCompatible,
+                   IsAssignmentCompatible, IsExpressionCompatible ;
 
 FROM M2Bitset IMPORT Bitset ;
 FROM NameKey IMPORT Name, MakeKey, KeyToCharStar, LengthKey, makekey, NulName ;
@@ -258,7 +259,7 @@ FROM M2Quads IMPORT QuadOperator, GetQuad, IsReferenced, GetNextQuad,
                     GetM2OperatorDesc, GetQuadOp,
                     DisplayQuadList ;
 
-FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible ;
+FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible,  ExpressionTypeCompatible ;
 FROM M2SSA IMPORT EnableSSA ;
 
 
@@ -504,10 +505,10 @@ BEGIN
    NegateOp           : CodeNegateChecked (q, op1, op3) |
    LogicalShiftOp     : CodeSetShift (q, op1, op2, op3) |
    LogicalRotateOp    : CodeSetRotate (q, op1, op2, op3) |
-   LogicalOrOp        : CodeSetOr (q, op1, op2, op3) |
-   LogicalAndOp       : CodeSetAnd (q, op1, op2, op3) |
-   LogicalXorOp       : CodeSetSymmetricDifference (q, op1, op2, op3) |
-   LogicalDiffOp      : CodeSetLogicalDifference (q, op1, op2, op3) |
+   LogicalOrOp        : CodeSetOr (q) |
+   LogicalAndOp       : CodeSetAnd (q) |
+   LogicalXorOp       : CodeSetSymmetricDifference (q) |
+   LogicalDiffOp      : CodeSetLogicalDifference (q) |
    IfLessOp           : CodeIfLess (q, op1, op2, op3) |
    IfEquOp            : CodeIfEqu (q, op1, op2, op3) |
    IfNotEquOp         : CodeIfNotEqu (q, op1, op2, op3) |
@@ -3098,30 +3099,32 @@ END PrepareCopyString ;
 
 
 (*
-   checkArrayElements - return TRUE if op1 or op3 are not arrays.
+   checkArrayElements - return TRUE if des or expr are not arrays.
                         If they are arrays and have different number of
                         elements return FALSE, otherwise TRUE.
 *)
 
-PROCEDURE checkArrayElements (op1, op3: CARDINAL) : BOOLEAN ;
+PROCEDURE checkArrayElements (des, expr: CARDINAL; virtpos, despos, exprpos: CARDINAL) : BOOLEAN ;
 VAR
    e1, e3  : Tree ;
    t1, t3  : CARDINAL ;
    location: location_t ;
 BEGIN
-   location := TokenToLocation(CurrentQuadToken) ;
-   t1 := GetType(op1) ;
-   t3 := GetType(op3) ;
-   IF (t1#NulSym) AND (t3#NulSym) AND
-      IsArray(SkipType(GetType(op3))) AND IsArray(SkipType(GetType(op1)))
+   t1 := GetType (des) ;
+   t3 := GetType (expr) ;
+   IF (t1 # NulSym) AND (t3 # NulSym) AND
+      IsArray (SkipType (GetType (expr))) AND IsArray (SkipType (GetType (des)))
    THEN
       (* both arrays continue checking *)
-      e1 := GetArrayNoOfElements(location, Mod2Gcc(SkipType(GetType(op1)))) ;
-      e3 := GetArrayNoOfElements(location, Mod2Gcc(SkipType(GetType(op3)))) ;
-      IF CompareTrees(e1, e3)#0
-      THEN
-         MetaErrorT2(CurrentQuadToken, 'not allowed to assign array {%2Ead} to {%1ad} as they have a different number of elements',
-                     op1, op3) ;
+      e1 := GetArrayNoOfElements (TokenToLocation (despos),
+                                  Mod2Gcc (SkipType (GetType (des)))) ;
+      e3 := GetArrayNoOfElements (TokenToLocation (exprpos),
+                                  Mod2Gcc (SkipType (GetType (expr)))) ;
+      IF CompareTrees (e1, e3) # 0
+      THEN
+         MetaErrorT2 (virtpos,
+                      'not allowed to assign array {%2Ead} to {%1ad} as they have a different number of elements',
+                      des, expr) ;
          RETURN( FALSE )
       END
    END ;
@@ -3151,32 +3154,36 @@ END CodeInitAddress ;
 
 
 (*
-   checkRecordTypes - returns TRUE if op1 is not a record or if the record
-                      is the same type as op2.
+   checkRecordTypes - returns TRUE if des is not a record or if the record
+                      is the same type as expr.
 *)
 
-PROCEDURE checkRecordTypes (op1, op2: CARDINAL) : BOOLEAN ;
+PROCEDURE checkRecordTypes (des, expr: CARDINAL; virtpos: CARDINAL) : BOOLEAN ;
 VAR
    t1, t2: CARDINAL ;
 BEGIN
-   IF (GetType(op1)=NulSym) OR (GetMode(op1)=LeftValue)
+   IF (GetType (des) = NulSym) OR (GetMode (des) = LeftValue)
    THEN
       RETURN( TRUE )
    ELSE
-      t1 := SkipType(GetType(op1)) ;
-      IF IsRecord(t1)
+      t1 := SkipType (GetType (des)) ;
+      IF IsRecord (t1)
       THEN
-         IF GetType(op2)=NulSym
+         IF GetType (expr) = NulSym
          THEN
-            MetaErrorT2 (CurrentQuadToken, 'cannot assign an operand of type {%1Ets} to a record type {%2tsa}', op2, op1) ;
+            MetaErrorT2 (virtpos,
+                         'cannot assign an operand of type {%1Ets} to a record type {%2tsa}',
+                         expr, des) ;
             RETURN( FALSE )
          ELSE
-            t2 := SkipType(GetType(op2)) ;
-	    IF t1=t2
+            t2 := SkipType (GetType (expr)) ;
+	    IF t1 = t2
             THEN
                RETURN( TRUE )
             ELSE
-               MetaErrorT2 (CurrentQuadToken, 'cannot assign an operand of type {%1ts} to a record type {%2tsa}', op2, op1) ;
+               MetaErrorT2 (virtpos,
+                            'cannot assign an operand of type {%1ts} to a record type {%2tsa}',
+                            expr, des) ;
 	       RETURN( FALSE )
             END
          END
@@ -3187,26 +3194,29 @@ END checkRecordTypes ;
 
 
 (*
-   checkIncorrectMeta -
+   checkIncorrectMeta - checks to see if des and expr are assignment compatible is allows
+                        generic system types to be assigned.
 *)
 
-PROCEDURE checkIncorrectMeta (op1, op2: CARDINAL) : BOOLEAN ;
+PROCEDURE checkIncorrectMeta (des, expr: CARDINAL; virtpos: CARDINAL) : BOOLEAN ;
 VAR
    t1, t2: CARDINAL ;
 BEGIN
-   t1 := SkipType(GetType(op1)) ;
-   t2 := SkipType(GetType(op2)) ;
-   IF (t1=NulSym) OR (GetMode(op1)=LeftValue) OR
-      (t2=NulSym) OR (GetMode(op2)=LeftValue)
+   t1 := SkipType (GetType (des)) ;
+   t2 := SkipType (GetType (expr)) ;
+   IF (t1 = NulSym) OR (GetMode(des) = LeftValue) OR
+      (t2 = NulSym) OR (GetMode(expr) = LeftValue)
    THEN
       RETURN( TRUE )
-   ELSIF (t1#t2) AND (NOT IsGenericSystemType(t1)) AND (NOT IsGenericSystemType(t2))
+   ELSIF (t1 # t2) AND (NOT IsGenericSystemType (t1)) AND (NOT IsGenericSystemType (t2))
    THEN
-      IF IsArray(t1) OR IsSet(t1) OR IsRecord(t1)
+      IF IsArray (t1) OR IsSet (t1) OR IsRecord (t1)
       THEN
-         IF NOT IsAssignmentCompatible(t1, t2)
+         IF NOT IsAssignmentCompatible (t1, t2)
          THEN
-            MetaErrorT2 (CurrentQuadToken, 'illegal assignment error between {%1Etad} and {%2tad}', op1, op2) ;
+            MetaErrorT2 (virtpos,
+                         'illegal assignment error between {%1Etad} and {%2tad}',
+                         des, expr) ;
 	    RETURN( FALSE )
          END
       END
@@ -3219,11 +3229,11 @@ END checkIncorrectMeta ;
    checkBecomes - returns TRUE if the checks pass.
 *)
 
-PROCEDURE checkBecomes (des, expr: CARDINAL) : BOOLEAN ;
+PROCEDURE checkBecomes (des, expr: CARDINAL; virtpos, despos, exprpos: CARDINAL) : BOOLEAN ;
 BEGIN
-   IF (NOT checkArrayElements (des, expr)) OR
-      (NOT checkRecordTypes (des, expr)) OR
-      (NOT checkIncorrectMeta (des, expr))
+   IF (NOT checkArrayElements (des, expr, virtpos, despos, exprpos)) OR
+      (NOT checkRecordTypes (des, expr, virtpos)) OR
+      (NOT checkIncorrectMeta (des, expr, virtpos))
    THEN
       RETURN FALSE
    END ;
@@ -3256,71 +3266,73 @@ PROCEDURE CodeBecomes (quad: CARDINAL) ;
 VAR
    overflowChecking: BOOLEAN ;
    op              : QuadOperator ;
-   op1, op2, op3   : CARDINAL ;
+   des, op2, expr   : CARDINAL ;
+   virtpos,
    becomespos,
-   op1pos,
+   despos,
    op2pos,
-   op3pos          : CARDINAL ;
+   exprpos          : CARDINAL ;
    length,
-   op3t            : Tree ;
+   exprt            : Tree ;
    location        : location_t ;
 BEGIN
-   GetQuadOtok (quad, becomespos, op, op1, op2, op3, overflowChecking,
-                op1pos, op2pos, op3pos) ;
+   GetQuadOtok (quad, becomespos, op, des, op2, expr, overflowChecking,
+                despos, op2pos, exprpos) ;
    Assert (op2pos = UnknownTokenNo) ;
-   DeclareConstant (CurrentQuadToken, op3) ;  (* Check to see whether op3 is a constant and declare it.  *)
-   DeclareConstructor (CurrentQuadToken, quad, op3) ;
-   location := TokenToLocation (CurrentQuadToken) ;
+   DeclareConstant (exprpos, expr) ;  (* Check to see whether expr is a constant and declare it.  *)
+   DeclareConstructor (exprpos, quad, expr) ;
+   virtpos := MakeVirtualTok (becomespos, despos, exprpos) ;
+   location := TokenToLocation (virtpos) ;
 
    IF StrictTypeChecking AND
-      (NOT AssignmentTypeCompatible (CurrentQuadToken, "", op1, op3))
+      (NOT AssignmentTypeCompatible (virtpos, "", des, expr))
    THEN
-      MetaErrorT2 (MakeVirtualTok (becomespos, op1pos, op3pos),
+      MetaErrorT2 (virtpos,
                    'assignment check caught mismatch between {%1Ead} and {%2ad}',
-                   op1, op3)
+                   des, expr)
    END ;
-   IF IsConst (op1) AND (NOT GccKnowsAbout (op1))
+   IF IsConst (des) AND (NOT GccKnowsAbout (des))
    THEN
-      ConstantKnownAndUsed (op1, CheckConstant (CurrentQuadToken, op1, op3))
-   ELSIF IsConstString (op3) AND (SkipTypeAndSubrange (GetType (op1)) # Char)
+      ConstantKnownAndUsed (des, CheckConstant (virtpos, des, expr))
+   ELSIF IsConstString (expr) AND (SkipTypeAndSubrange (GetType (des)) # Char)
    THEN
-      checkDeclare (op1) ;
-      IF NOT PrepareCopyString (becomespos, length, op3t, op3, SkipType (GetType (op1)))
+      checkDeclare (des) ;
+      IF NOT PrepareCopyString (becomespos, length, exprt, expr, SkipType (GetType (des)))
       THEN
-         MetaErrorT2 (MakeVirtualTok (becomespos, op1pos, op3pos),
+         MetaErrorT2 (virtpos,
                       'string constant {%1Ea} is too large to be assigned to the array {%2ad}',
-                      op3, op1)
+                      expr, des)
       END ;
       AddStatement (location,
-                    MaybeDebugBuiltinMemcpy (location, CurrentQuadToken,
-                                             BuildAddr (location, Mod2Gcc (op1), FALSE),
-                                             BuildAddr (location, op3t, FALSE),
+                    MaybeDebugBuiltinMemcpy (location, virtpos,
+                                             BuildAddr (location, Mod2Gcc (des), FALSE),
+                                             BuildAddr (location, exprt, FALSE),
                                              length))
    ELSE
-      IF ((IsGenericSystemType(SkipType(GetType(op1))) #
-           IsGenericSystemType(SkipType(GetType(op3)))) OR
-          (IsUnbounded(SkipType(GetType(op1))) AND
-           IsUnbounded(SkipType(GetType(op3))) AND
-           (IsGenericSystemType(SkipType(GetType(GetType(op1)))) #
-            IsGenericSystemType(SkipType(GetType(GetType(op3))))))) AND
-         (NOT IsConstant(op3))
-      THEN
-         checkDeclare (op1) ;
+      IF ((IsGenericSystemType(SkipType(GetType(des))) #
+           IsGenericSystemType(SkipType(GetType(expr)))) OR
+          (IsUnbounded(SkipType(GetType(des))) AND
+           IsUnbounded(SkipType(GetType(expr))) AND
+           (IsGenericSystemType(SkipType(GetType(GetType(des)))) #
+            IsGenericSystemType(SkipType(GetType(GetType(expr))))))) AND
+         (NOT IsConstant(expr))
+      THEN
+         checkDeclare (des) ;
          AddStatement (location,
-                       MaybeDebugBuiltinMemcpy (location, CurrentQuadToken,
-                                                BuildAddr(location, Mod2Gcc (op1), FALSE),
-                                                BuildAddr(location, Mod2Gcc (op3), FALSE),
-                                                BuildSize(location, Mod2Gcc (op1), FALSE)))
+                       MaybeDebugBuiltinMemcpy (location, virtpos,
+                                                BuildAddr(location, Mod2Gcc (des), FALSE),
+                                                BuildAddr(location, Mod2Gcc (expr), FALSE),
+                                                BuildSize(location, Mod2Gcc (des), FALSE)))
       ELSE
-         IF checkBecomes (op1, op3)
+         IF checkBecomes (des, expr, virtpos, despos, exprpos)
          THEN
-            IF IsVariableSSA (op1)
+            IF IsVariableSSA (des)
             THEN
-               Replace (op1, FoldConstBecomes (CurrentQuadToken, op1, op3))
+               Replace (des, FoldConstBecomes (virtpos, des, expr))
             ELSE
                BuildAssignmentStatement (location,
-                                         Mod2Gcc (op1),
-                                         FoldConstBecomes (CurrentQuadToken, op1, op3))
+                                         Mod2Gcc (des),
+                                         FoldConstBecomes (virtpos, des, expr))
             END
          ELSE
             SubQuad (quad)  (* we don't want multiple errors for the quad.  *)
@@ -3609,48 +3621,196 @@ END CodeBinary ;
 
 
 (*
-   CodeBinarySet - encode a binary set arithmetic operation.
-                   Set operands may be longer than a word.
+   NoWalkProcedure -
 *)
 
-PROCEDURE CodeBinarySet (binop: BuildBinProcedure; doOp: DoProcedure;
-                         quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE NoWalkProcedure (param: CARDINAL) ;
+BEGIN
+END NoWalkProcedure ;
+
+
+(*
+   CheckBinaryExpressionTypes - returns TRUE if all expression checks pass.
+                                If the expression check fails quad is removed,
+                                the walk procedure (des) is called and NoChange is
+                                set to FALSE.
+*)
+
+PROCEDURE CheckBinaryExpressionTypes (quad: CARDINAL; p: WalkAction) : BOOLEAN ;
 VAR
-   location: location_t ;
+   lefttype,
+   righttype,
+   des, left, right: CARDINAL ;
+   overflowChecking: BOOLEAN ;
+   despos, leftpos,
+   rightpos,
+   operatorpos,
+   subexprpos      : CARDINAL ;
+   op              : QuadOperator ;
 BEGIN
-   (* firstly ensure that constant literals are declared *)
-   DeclareConstant(CurrentQuadToken, op3) ;
-   DeclareConstant(CurrentQuadToken, op2) ;
-   DeclareConstructor(CurrentQuadToken, quad, op3) ;
-   DeclareConstructor(CurrentQuadToken, quad, op2) ;
-   location := TokenToLocation(CurrentQuadToken) ;
+   GetQuadOtok (quad, operatorpos, op,
+                des, left, right, overflowChecking,
+                despos, leftpos, rightpos) ;
+   IF ((op # LogicalRotateOp) AND (op # LogicalShiftOp))
+   THEN
+      subexprpos := MakeVirtualTok (operatorpos, leftpos, rightpos) ;
+      lefttype := GetType (left) ;
+      righttype := GetType (right) ;
+      IF StrictTypeChecking AND
+         (NOT ExpressionTypeCompatible (subexprpos, "", lefttype, righttype,
+                                        StrictTypeChecking, FALSE))
+      THEN
+         MetaErrorT2 (subexprpos,
+                      'expression mismatch between {%1Etad} and {%2tad}',
+                      left, right) ;
+         NoChange := FALSE ;
+         SubQuad (quad) ;
+         p (des) ;
+         RETURN FALSE
+      END ;
+      (* --fixme-- the ExpressionTypeCompatible above should be enough
+         and the code below can be removed once ExpressionTypeCompatible
+         is bug free.  *)
+      IF NOT IsExpressionCompatible (lefttype, righttype)
+      THEN
+         MetaErrorT2 (subexprpos,
+                      'expression mismatch between {%1Etad} and {%2tad}',
+                      left, right) ;
+         NoChange := FALSE ;
+         SubQuad (quad) ;
+         p (des) ;
+         RETURN FALSE
+      END
+   END ;
+   RETURN TRUE
+END CheckBinaryExpressionTypes ;
 
-   IF IsConst(op1)
+
+(*
+   CheckElementSetTypes - returns TRUE if all expression checks pass.
+                                If the expression check fails quad is removed,
+                                the walk procedure (des) is called and NoChange is
+                                set to FALSE.
+*)
+
+PROCEDURE CheckElementSetTypes (quad: CARDINAL; p: WalkAction) : BOOLEAN ;
+VAR
+   lefttype,
+   righttype,
+   ignore, left, right: CARDINAL ;
+   overflowChecking: BOOLEAN ;
+   ignorepos,
+   leftpos,
+   rightpos,
+   operatorpos,
+   subexprpos      : CARDINAL ;
+   op              : QuadOperator ;
+BEGIN
+   GetQuadOtok (quad, operatorpos, op,
+                left, right, ignore, overflowChecking,
+                leftpos, rightpos, ignorepos) ;
+   subexprpos := MakeVirtualTok (operatorpos, leftpos, rightpos) ;
+   lefttype := GetType (left) ;
+   righttype := GetType (right) ;
+   (* --fixme-- the ExpressionTypeCompatible below does not always catch
+      type errors, it needs to be fixed and then some of the subsequent tests
+      can be removed (and/or this procedure function rewritten).  *)
+   IF StrictTypeChecking AND
+      (NOT ExpressionTypeCompatible (subexprpos, "", lefttype, righttype,
+                                     StrictTypeChecking, TRUE))
    THEN
-      IF IsValueSolved(op2) AND IsValueSolved(op3)
-      THEN
-         Assert(MixTypes(FindType(op3), FindType(op2), CurrentQuadToken)#NulSym) ;
-         PutConst(op1, FindType(op3)) ;
-         PushValue(op2) ;
-         PushValue(op3) ;
-         doOp(CurrentQuadToken) ;
-         PopValue(op1) ;
-         PutConstSet(op1) ;
+      MetaErrorT2 (subexprpos,
+                   'the types used in expression {%1Etad} {%kIN} {%2tad} are incompatible',
+                   left, right) ;
+      NoChange := FALSE ;
+      SubQuad (quad) ;
+      RETURN FALSE
+   END ;
+   IF (righttype = NulSym) OR (NOT IsSet (SkipType (righttype)))
+   THEN
+      MetaErrorT1 (rightpos,
+                   'an {%kIN} expression is expecting {%1Etad} to be a {%kSET} type',
+                   right) ;
+      NoChange := FALSE ;
+      SubQuad (quad) ;
+      RETURN FALSE
+   END ;
+   righttype := GetType (SkipType (righttype)) ;
+   (* Now fall though and compare the set element left against the type of set righttype.  *)
+   IF NOT IsExpressionCompatible (lefttype, righttype)
+   THEN
+      MetaErrorT2 (subexprpos,
+                   'the types used in expression {%1Etad} {%kIN} {%2tad} are incompatible',
+                   left, right) ;
+      NoChange := FALSE ;
+      SubQuad (quad) ;
+      RETURN FALSE
+   END ;
+   RETURN TRUE
+END CheckElementSetTypes ;
+
+
+(*
+   CodeBinarySet - encode a binary set arithmetic operation.
+                   Set operands may be longer than a word.
+*)
+
+PROCEDURE CodeBinarySet (binop: BuildBinProcedure; doOp: DoProcedure;
+                         quad: CARDINAL) ;
+VAR
+   location        : location_t ;
+   overflowChecking: BOOLEAN ;
+   op              : QuadOperator ;
+   virttoken,
+   virtexpr,
+   des,
+   left,
+   right,
+   despos,
+   leftpos,
+   rightpos,
+   operatorpos     : CARDINAL ;
+BEGIN
+   GetQuadOtok (quad, operatorpos, op, des, left, right, overflowChecking,
+                despos, leftpos, rightpos) ;
+
+   (* Firstly ensure that constant literals are declared.  *)
+   DeclareConstant (rightpos, right) ;
+   DeclareConstant (leftpos, left) ;
+   DeclareConstructor (rightpos, quad, right) ;
+   DeclareConstructor (leftpos, quad, left) ;
+
+   virttoken := MakeVirtualTok (operatorpos, despos, rightpos) ;
+   location := TokenToLocation (virttoken) ;
+   IF CheckBinaryExpressionTypes (quad, NoWalkProcedure)
+   THEN
+      IF IsConst (des)
+      THEN
+         virtexpr := MakeVirtualTok (operatorpos, leftpos, rightpos) ;
+         IF IsValueSolved (left) AND IsValueSolved (right)
+         THEN
+            Assert (MixTypes (FindType (right), FindType (left), virtexpr) # NulSym) ;
+            PutConst (des, FindType (right)) ;
+            PushValue (left) ;
+            PushValue (right) ;
+            doOp (virttoken) ;
+            PopValue (des) ;
+            PutConstSet (des)
+         ELSE
+            MetaErrorT0 (virtexpr, '{%E}constant expression cannot be evaluated')
+         END
       ELSE
-         MetaErrorT0 (CurrentQuadToken,
-                      '{%E}constant expression cannot be evaluated')
+         checkDeclare (des) ;
+         BuildBinaryForeachWordDo (location,
+                                   Mod2Gcc (SkipType (GetType (des))),
+                                   Mod2Gcc (des), Mod2Gcc (left), Mod2Gcc (right), binop,
+                                   GetMode (des) = LeftValue,
+                                   GetMode (left) = LeftValue,
+                                   GetMode (right) = LeftValue,
+                                   IsConst (des),
+                                   IsConst (left),
+                                   IsConst (right))
       END
-   ELSE
-      checkDeclare (op1) ;
-      BuildBinaryForeachWordDo(location,
-                               Mod2Gcc(SkipType(GetType(op1))),
-                               Mod2Gcc(op1), Mod2Gcc(op2), Mod2Gcc(op3), binop,
-                               GetMode(op1)=LeftValue,
-                               GetMode(op2)=LeftValue,
-                               GetMode(op3)=LeftValue,
-                               IsConst(op1),
-                               IsConst(op2),
-                               IsConst(op3))
    END
 END CodeBinarySet ;
 
@@ -4695,27 +4855,30 @@ BEGIN
    TryDeclareConstant(tokenno, op3) ;
    location := TokenToLocation(tokenno) ;
 
-   IF IsConst(op2) AND IsConstSet(op2) AND
-      IsConst(op3) AND IsConstSet(op3) AND
-      IsConst(op1)
+   IF CheckBinaryExpressionTypes (quad, p)
    THEN
-      IF IsValueSolved(op2) AND IsValueSolved(op3)
+      IF IsConst(op2) AND IsConstSet(op2) AND
+         IsConst(op3) AND IsConstSet(op3) AND
+         IsConst(op1)
       THEN
-         Assert(MixTypes(FindType(op3), FindType(op2), tokenno)#NulSym) ;
-         PutConst(op1, MixTypes(FindType(op3), FindType(op2), tokenno)) ;
-         PushValue(op2) ;
-         PushValue(op3) ;
-         op(tokenno) ;
-         PopValue(op1) ;
-         PushValue(op1) ;
-         PutConstSet(op1) ;
-         AddModGcc(op1,
-                   DeclareKnownConstant(location,
-                                        Mod2Gcc(GetType(op3)),
-                                        PopSetTree(tokenno))) ;
-         p(op1) ;
-         NoChange := FALSE ;
-         SubQuad(quad)
+         IF IsValueSolved(op2) AND IsValueSolved(op3)
+         THEN
+            Assert(MixTypes(FindType(op3), FindType(op2), tokenno)#NulSym) ;
+            PutConst(op1, MixTypes(FindType(op3), FindType(op2), tokenno)) ;
+            PushValue(op2) ;
+            PushValue(op3) ;
+            op(tokenno) ;
+            PopValue(op1) ;
+            PushValue(op1) ;
+            PutConstSet(op1) ;
+            AddModGcc(op1,
+                      DeclareKnownConstant(location,
+                                           Mod2Gcc(GetType(op3)),
+                                           PopSetTree(tokenno))) ;
+            p(op1) ;
+            NoChange := FALSE ;
+            SubQuad(quad)
+         END
       END
    END
 END FoldBinarySet ;
@@ -4736,9 +4899,9 @@ END FoldSetOr ;
    CodeSetOr - encode set arithmetic or.
 *)
 
-PROCEDURE CodeSetOr (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetOr (quad: CARDINAL) ;
 BEGIN
-   CodeBinarySet (BuildLogicalOr, SetOr, quad, op1, op2, op3)
+   CodeBinarySet (BuildLogicalOr, SetOr, quad)
 END CodeSetOr ;
 
 
@@ -4757,9 +4920,9 @@ END FoldSetAnd ;
    CodeSetAnd - encode set arithmetic and.
 *)
 
-PROCEDURE CodeSetAnd (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetAnd (quad: CARDINAL) ;
 BEGIN
-   CodeBinarySet (BuildLogicalAnd, SetAnd, quad, op1, op2, op3)
+   CodeBinarySet (BuildLogicalAnd, SetAnd, quad)
 END CodeSetAnd ;
 
 
@@ -4909,10 +5072,9 @@ END FoldSetLogicalDifference ;
    CodeSetLogicalDifference - encode set arithmetic logical difference.
 *)
 
-PROCEDURE CodeSetLogicalDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetLogicalDifference (quad: CARDINAL) ;
 BEGIN
-   CodeBinarySet (BuildLogicalDifference, SetDifference,
-                  quad, op1, op2, op3)
+   CodeBinarySet (BuildLogicalDifference, SetDifference, quad)
 END CodeSetLogicalDifference ;
 
 
@@ -4931,10 +5093,9 @@ END FoldSymmetricDifference ;
    CodeSetSymmetricDifference - code set difference.
 *)
 
-PROCEDURE CodeSetSymmetricDifference (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetSymmetricDifference (quad: CARDINAL) ;
 BEGIN
-   CodeBinarySet (BuildSymmetricDifference, SetSymmetricDifference,
-                  quad, op1, op2, op3)
+   CodeBinarySet (BuildSymmetricDifference, SetSymmetricDifference, quad)
 END CodeSetSymmetricDifference ;
 
 
@@ -5052,11 +5213,16 @@ BEGIN
    THEN
       IF IsValueSolved (left) AND IsValueSolved (right)
       THEN
-         (* fine, we can take advantage of this and evaluate the condition *)
-         PushValue (right) ;
-         IF SetIn (tokenno, left)
+         IF CheckBinaryExpressionTypes (quad, NoWalkProcedure)
          THEN
-            PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
+            (* fine, we can take advantage of this and evaluate the condition *)
+            PushValue (right) ;
+            IF SetIn (tokenno, left)
+            THEN
+               PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
+            ELSE
+               SubQuad (quad)
+            END
          ELSE
             SubQuad (quad)
          END
@@ -5080,11 +5246,16 @@ BEGIN
    THEN
       IF IsValueSolved (left) AND IsValueSolved (right)
       THEN
-         (* fine, we can take advantage of this and evaluate the condition *)
-         PushValue (right) ;
-         IF NOT SetIn (tokenno, left)
+         IF CheckBinaryExpressionTypes (quad, NoWalkProcedure)
          THEN
-            PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
+            (* fine, we can take advantage of this and evaluate the condition *)
+            PushValue (right) ;
+            IF NOT SetIn (tokenno, left)
+            THEN
+               PutQuad (quad, GotoOp, NulSym, NulSym, destQuad)
+            ELSE
+               SubQuad (quad)
+            END
          ELSE
             SubQuad (quad)
          END
@@ -7200,7 +7371,8 @@ BEGIN
    IF IsConst(op1) AND IsConst(op2)
    THEN
       InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
-   ELSE
+   ELSIF CheckElementSetTypes (quad, NoWalkProcedure)
+   THEN
       IF IsConst(op1)
       THEN
          fieldno := GetFieldNo(CurrentQuadToken, op1, GetType(op2), offset) ;
@@ -7266,7 +7438,8 @@ BEGIN
    IF IsConst(op1) AND IsConst(op2)
    THEN
       InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
-   ELSE
+   ELSIF CheckElementSetTypes (quad, NoWalkProcedure)
+   THEN
       IF IsConst(op1)
       THEN
          fieldno := GetFieldNo(CurrentQuadToken, op1, SkipType(GetType(op2)), offset) ;
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index 4833ac0..45e2769 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -9032,14 +9032,14 @@ BEGIN
       MarkAsRead (r) ;
       PopTtok (varSet, vartok) ;
       PopT (procSym) ;
-      combinedtok := MakeVirtualTok (functok, exptok, vartok) ;
+      combinedtok := MakeVirtualTok (functok, functok, exptok) ;
       IF (GetSType (varSet) # NulSym) AND IsSet (GetDType (varSet))
       THEN
          derefExp := DereferenceLValue (exptok, Exp) ;
          BuildRange (InitShiftCheck (varSet, derefExp)) ;
          returnVar := MakeTemporary (combinedtok, RightValue) ;
          PutVar (returnVar, GetSType (varSet)) ;
-         GenQuad (LogicalShiftOp, returnVar, varSet, derefExp) ;
+         GenQuadO (combinedtok, LogicalShiftOp, returnVar, varSet, derefExp, TRUE) ;
          PushTFtok (returnVar, GetSType (varSet), combinedtok)
       ELSE
          MetaErrorT1 (vartok,