public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-9475] PR modula2/114333 set type comparison against cardinal should cause error addendum
@ 2024-03-14 15:35 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2024-03-14 15:35 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:7aeedff6a426cc05024af0bc92116d676a5ba42b
commit r14-9475-g7aeedff6a426cc05024af0bc92116d676a5ba42b
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Thu Mar 14 15:34:36 2024 +0000
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:
---
gcc/m2/gm2-compiler/M2GenGCC.mod | 438 ++++++++++++++++++++-------------
gcc/testsuite/gm2/pim/fail/badset5.mod | 13 +
gcc/testsuite/gm2/pim/fail/badset6.mod | 23 ++
3 files changed, 300 insertions(+), 174 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index 7633b8425ae..7e27373a6ac 100644
--- 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
index 00000000000..ecc7622f37f
--- /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
index 00000000000..d97f8e25444
--- /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.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2024-03-14 15:35 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-03-14 15:35 [gcc r14-9475] PR modula2/114333 set type comparison against cardinal should cause error addendum Gaius Mulley
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).