From: Gaius Mulley Date: Thu, 11 Jan 2024 00:53:56 +0000 (+0000) Subject: PR modula2/112946 set expression type checking X-Git-Tag: basepoints/gcc-15~3016 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=96a9355a3d5b24f010fa6ad0b51bba5cc3f334f1;p=thirdparty%2Fgcc.git 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 --- diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod index bfcff70f38e1..2261cb0348af 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 4833ac0b28cc..45e2769af793 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, diff --git a/gcc/testsuite/gm2/pim/fail/badbecomes.mod b/gcc/testsuite/gm2/pim/fail/badbecomes.mod new file mode 100644 index 000000000000..b902c2807ab6 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badbecomes.mod @@ -0,0 +1,10 @@ +MODULE badbecomes ; + +TYPE + enums = (red, blue, green) ; + set = SET OF enums ; +VAR + setvar : set; +BEGIN + setvar := green ; (* Should detect an error here. *) +END badbecomes. diff --git a/gcc/testsuite/gm2/pim/fail/badexpression.mod b/gcc/testsuite/gm2/pim/fail/badexpression.mod new file mode 100644 index 000000000000..da2ec268c150 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badexpression.mod @@ -0,0 +1,16 @@ +MODULE badexpression3 ; + +TYPE + enums = (red, blue, green) ; + set = SET OF enums ; +VAR + setvar : set; + enumvar: enums; +BEGIN + setvar := set {red, blue} ; + setvar := setvar + green ; (* Should detect an error here. *) + IF NOT (green IN setvar) + THEN + HALT + END +END badexpression3. \ No newline at end of file diff --git a/gcc/testsuite/gm2/pim/fail/badexpression2.mod b/gcc/testsuite/gm2/pim/fail/badexpression2.mod new file mode 100644 index 000000000000..b61eb3e1c8a8 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badexpression2.mod @@ -0,0 +1,17 @@ +MODULE badexpression2 ; + +TYPE + enums = (red, blue, green) ; + set = SET OF enums ; +VAR + setvar : set; + enumvar: enums; +BEGIN + setvar := set {red, blue} ; + enumvar := green ; + setvar := setvar + enumvar ; (* Should detect an error here. *) + IF NOT (green IN setvar) + THEN + HALT + END +END badexpression2. diff --git a/gcc/testsuite/gm2/pim/fail/badifin.mod b/gcc/testsuite/gm2/pim/fail/badifin.mod new file mode 100644 index 000000000000..86a04ddd42a6 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badifin.mod @@ -0,0 +1,15 @@ +MODULE badifin ; + +TYPE + enums = (red, blue, green) ; + set = SET OF enums ; +VAR + setvar : set; + enumvar: enums; +BEGIN + setvar := set {red, blue} ; + IF NOT (setvar IN setvar) + THEN + HALT + END +END badifin. diff --git a/gcc/testsuite/gm2/pim/pass/goodifin.mod b/gcc/testsuite/gm2/pim/pass/goodifin.mod new file mode 100644 index 000000000000..a8993204f744 --- /dev/null +++ b/gcc/testsuite/gm2/pim/pass/goodifin.mod @@ -0,0 +1,15 @@ +MODULE goodifin ; + +TYPE + enums = (red, blue, green) ; + set = SET OF enums ; +VAR + setvar : set; + enumvar: enums; +BEGIN + setvar := set {red, blue} ; + IF green IN setvar + THEN + HALT + END +END goodifin.