public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-9116] PR modula2/114026 Incorrect location during for loop type checking
@ 2024-02-21 16:21 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2024-02-21 16:21 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:161a67b2bee84d8fd5ab7711e411f76221c1ea52
commit r14-9116-g161a67b2bee84d8fd5ab7711e411f76221c1ea52
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Wed Feb 21 16:21:05 2024 +0000
PR modula2/114026 Incorrect location during for loop type checking
If a for loop contains an incompatible type expression between the
designator and the second expression then the location
used when generating the error message is set to token 0.
The bug is fixed by extending the range checking
InitForLoopBeginRangeCheck. The range checking is processed after
all types, constants have been resolved (and converted into gcc
trees). The range check will check for assignment compatibility
between des and expr1, expression compatibility between des and expr2.
Separate token positions for des, exp1, expr2 and by are stored in the
Range record and used to create virtual tokens if they are on the same
source line.
gcc/m2/ChangeLog:
PR modula2/114026
* gm2-compiler/M2GenGCC.mod (Import): Remove DisplayQuadruples.
Remove DisplayQuadList.
(MixTypesBinary): Replace check with overflowCheck.
New variable typeChecking.
Use GenQuadOTypetok to retrieve typeChecking.
Use typeChecking to suppress error message.
* gm2-compiler/M2LexBuf.def (MakeVirtual2Tok): New procedure
function.
* gm2-compiler/M2LexBuf.mod (MakeVirtualTok): Improve comment.
(MakeVirtual2Tok): New procedure function.
* gm2-compiler/M2Quads.def (GetQuadOTypetok): New procedure.
* gm2-compiler/M2Quads.mod (QuadFrame): New field CheckType.
(PutQuadO): Rewrite using PutQuadOType.
(PutQuadOType): New procedure.
(GetQuadOTypetok): New procedure.
(BuildPseudoBy): Rewrite.
(BuildForToByDo): Remove type checking.
Add parameters e2, e2tok, BySym, bytok to
InitForLoopBeginRange.
Push the RangeId.
(BuildEndFor): Pop the RangeId.
Use GenQuadOTypetok to generate AddOp without type checking.
Call PutRangeForIncrement with the RangeId and IncQuad.
(GenQuadOtok): Rewrite using GenQuadOTypetok.
(GenQuadOTypetok): New procedure.
* gm2-compiler/M2Range.def (InitForLoopBeginRangeCheck):
Rename d as des, e as expr.
Add expr1, expr1tok, expr2, expr2tok, byconst, byconsttok
parameters.
(PutRangeForIncrement): New procedure.
* gm2-compiler/M2Range.mod (Import): MakeVirtual2Tok.
(Range): Add expr2, byconst, destok, exprtok, expr2tok,
incrementquad.
(InitRange): Initialize expr2 to NulSym.
Initialize byconst to NulSym.
Initialize tokenNo, destok, exprtok, expr2tok, byconst to
UnknownTokenNo.
Initialize incrementquad to 0.
(PutRangeForIncrement): New procedure.
(PutRangeDesExpr2): New procedure.
(InitForLoopBeginRangeCheck): Rewrite.
(ForLoopBeginTypeCompatible): New procedure function.
(CodeForLoopBegin): Call ForLoopBeginTypeCompatible and
only code the for loop assignment if all the type checks
succeed.
gcc/testsuite/ChangeLog:
PR modula2/114026
* gm2/extensions/run/pass/callingc10.mod: New test.
* gm2/extensions/run/pass/callingc11.mod: New test.
* gm2/extensions/run/pass/callingc9.mod: New test.
* gm2/extensions/run/pass/strconst.def: New test.
* gm2/pim/fail/forloop.mod: New test.
* gm2/pim/pass/forloop2.mod: New test.
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2GenGCC.mod | 26 ++--
gcc/m2/gm2-compiler/M2LexBuf.def | 13 +-
gcc/m2/gm2-compiler/M2LexBuf.mod | 13 +-
gcc/m2/gm2-compiler/M2Quads.def | 12 ++
gcc/m2/gm2-compiler/M2Quads.mod | 142 ++++++++++++++-----
gcc/m2/gm2-compiler/M2Range.def | 18 ++-
gcc/m2/gm2-compiler/M2Range.mod | 153 +++++++++++++++++++--
.../gm2/extensions/run/pass/callingc10.mod | 16 +++
.../gm2/extensions/run/pass/callingc11.mod | 17 +++
.../gm2/extensions/run/pass/callingc9.mod | 7 +
gcc/testsuite/gm2/extensions/run/pass/strconst.def | 6 +
gcc/testsuite/gm2/pim/fail/forloop.mod | 17 +++
gcc/testsuite/gm2/pim/pass/forloop2.mod | 18 +++
13 files changed, 386 insertions(+), 72 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index c7581f859374..aeba48d356e6 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -93,7 +93,7 @@ FROM M2Error IMPORT InternalError, WriteFormat0, WriteFormat1, WriteFormat2, War
FROM M2MetaError IMPORT MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3,
MetaError1, MetaError2, MetaErrorStringT1 ;
-FROM M2Options IMPORT DisplayQuadruples, UnboundedByReference, PedanticCast,
+FROM M2Options IMPORT UnboundedByReference, PedanticCast,
VerboseUnbounded, Iso, Pim, DebugBuiltins, WholeProgram,
StrictTypeChecking, AutoInit, cflag, ScaffoldMain,
ScaffoldDynamic, ScaffoldStatic,
@@ -256,9 +256,9 @@ FROM m2except IMPORT BuildThrow, BuildTryBegin, BuildTryEnd,
FROM M2Quads IMPORT QuadOperator, GetQuad, IsReferenced, GetNextQuad,
SubQuad, PutQuad, MustCheckOverflow, GetQuadOtok,
+ GetQuadOTypetok,
QuadToTokenNo, DisplayQuad, GetQuadtok,
- GetM2OperatorDesc, GetQuadOp,
- DisplayQuadList ;
+ GetM2OperatorDesc, GetQuadOp ;
FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible, ExpressionTypeCompatible ;
FROM M2SSA IMPORT EnableSSA ;
@@ -644,11 +644,6 @@ BEGIN
Changed := TRUE
END
UNTIL NoChange ;
- IF Debugging AND DisplayQuadruples AND FALSE
- THEN
- printf0('after resolving expressions with gcc\n') ;
- DisplayQuadList
- END ;
RETURN Changed
END ResolveConstantExpressions ;
@@ -3660,13 +3655,13 @@ END CodeBinaryCheck ;
(*
- MixTypesBinary - depending upon check do not check pointer arithmetic.
+ MixTypesBinary - depending upon overflowCheck do not check pointer arithmetic.
*)
PROCEDURE MixTypesBinary (left, right: CARDINAL;
- tokpos: CARDINAL; check: BOOLEAN) : CARDINAL ;
+ tokpos: CARDINAL; overflowCheck: BOOLEAN) : CARDINAL ;
BEGIN
- IF (NOT check) AND
+ IF (NOT overflowCheck) AND
(IsPointer (GetTypeMode (left)) OR IsPointer (GetTypeMode (right)))
THEN
RETURN Address
@@ -3743,6 +3738,7 @@ VAR
lefttype,
righttype,
des, left, right: CARDINAL ;
+ typeChecking,
overflowChecking: BOOLEAN ;
despos, leftpos,
rightpos,
@@ -3750,10 +3746,10 @@ VAR
subexprpos : CARDINAL ;
op : QuadOperator ;
BEGIN
- GetQuadOtok (quad, operatorpos, op,
- des, left, right, overflowChecking,
- despos, leftpos, rightpos) ;
- IF ((op # LogicalRotateOp) AND (op # LogicalShiftOp))
+ GetQuadOTypetok (quad, operatorpos, op,
+ des, left, right, overflowChecking, typeChecking,
+ despos, leftpos, rightpos) ;
+ IF typeChecking AND (op # LogicalRotateOp) AND (op # LogicalShiftOp)
THEN
subexprpos := MakeVirtualTok (operatorpos, leftpos, rightpos) ;
lefttype := GetType (left) ;
diff --git a/gcc/m2/gm2-compiler/M2LexBuf.def b/gcc/m2/gm2-compiler/M2LexBuf.def
index dd49f4539f35..27610ec49dd3 100644
--- a/gcc/m2/gm2-compiler/M2LexBuf.def
+++ b/gcc/m2/gm2-compiler/M2LexBuf.def
@@ -42,7 +42,8 @@ EXPORT QUALIFIED OpenSource, CloseSource, ReInitialize, GetToken, InsertToken,
FindFileNameFromToken, GetFileName,
ResetForNewPass,
currenttoken, currentstring, currentinteger,
- AddTok, AddTokCharStar, AddTokInteger, MakeVirtualTok,
+ AddTok, AddTokCharStar, AddTokInteger,
+ MakeVirtualTok, MakeVirtual2Tok,
SetFile, PushFile, PopFile,
PrintTokenNo, DisplayToken, DumpTokens,
BuiltinTokenNo, UnknownTokenNo ;
@@ -197,12 +198,20 @@ PROCEDURE GetFileName () : String ;
(*
MakeVirtualTok - creates and return a new tokenno which is created from
- tokenno range1 and range2.
+ tokenno caret, left and right.
*)
PROCEDURE MakeVirtualTok (caret, left, right: CARDINAL) : CARDINAL ;
+(*
+ MakeVirtual2Tok - creates and return a new tokenno which is created from
+ two tokens left and right.
+*)
+
+PROCEDURE MakeVirtual2Tok (left, right: CARDINAL) : CARDINAL ;
+
+
(* ***********************************************************************
*
* These functions allow m2.lex to deliver tokens into the buffer
diff --git a/gcc/m2/gm2-compiler/M2LexBuf.mod b/gcc/m2/gm2-compiler/M2LexBuf.mod
index 84a0e2501825..af43855e7a70 100644
--- a/gcc/m2/gm2-compiler/M2LexBuf.mod
+++ b/gcc/m2/gm2-compiler/M2LexBuf.mod
@@ -1154,7 +1154,7 @@ END isSrcToken ;
MakeVirtualTok - providing caret, left, right are associated with a source file
and exist on the same src line then
create and return a new tokenno which is created from
- tokenno range1 and range2. Otherwise return caret.
+ tokenno left and right. Otherwise return caret.
*)
PROCEDURE MakeVirtualTok (caret, left, right: CARDINAL) : CARDINAL ;
@@ -1184,6 +1184,17 @@ BEGIN
END MakeVirtualTok ;
+(*
+ MakeVirtual2Tok - creates and return a new tokenno which is created from
+ two tokens left and right.
+*)
+
+PROCEDURE MakeVirtual2Tok (left, right: CARDINAL) : CARDINAL ;
+BEGIN
+ RETURN MakeVirtualTok (left, left, right)
+END MakeVirtual2Tok ;
+
+
(* ***********************************************************************
*
* These functions allow m2.flex to deliver tokens into the buffer
diff --git a/gcc/m2/gm2-compiler/M2Quads.def b/gcc/m2/gm2-compiler/M2Quads.def
index e9fd1224d860..3e92e3181dc1 100644
--- a/gcc/m2/gm2-compiler/M2Quads.def
+++ b/gcc/m2/gm2-compiler/M2Quads.def
@@ -132,6 +132,7 @@ EXPORT QUALIFIED StartBuildDefFile, StartBuildModFile, EndBuildFile,
SubQuad, EraseQuad, GetRealQuad,
GetQuadtok, GetQuadOtok, PutQuadOtok,
GetQuadOp, GetM2OperatorDesc,
+ GetQuadOTypetok,
CountQuads,
GetLastFileQuad,
GetLastQuadNo,
@@ -548,6 +549,17 @@ PROCEDURE GetQuadOtok (QuadNo: CARDINAL;
VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
+(*
+ GetQuadOTypetok - returns the fields associated with quadruple QuadNo.
+*)
+
+PROCEDURE GetQuadOTypetok (QuadNo: CARDINAL;
+ VAR tok: CARDINAL;
+ VAR Op: QuadOperator;
+ VAR Oper1, Oper2, Oper3: CARDINAL;
+ VAR overflowChecking, typeChecking: BOOLEAN ;
+ VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
+
(*
PutQuadOtok - alters a quadruple QuadNo with Op, Oper1, Oper2, Oper3, and
sets a boolean to determinine whether overflow should be checked.
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index e40e07d55c58..1275ad2fe1cf 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -255,6 +255,7 @@ FROM M2Range IMPORT InitAssignmentRangeCheck,
InitWholeZeroDivisionCheck,
InitWholeZeroRemainderCheck,
InitParameterRangeCheck,
+ PutRangeForIncrement,
WriteRangeCheck ;
FROM M2CaseList IMPORT PushCase, PopCase, AddRange, BeginCaseList, EndCaseList, ElseCase ;
@@ -298,6 +299,7 @@ TYPE
LineNo : CARDINAL ; (* Line No of source text. *)
TokenNo : CARDINAL ; (* Token No of source text. *)
NoOfTimesReferenced: CARDINAL ; (* No of times quad is referenced. *)
+ CheckType,
CheckOverflow : BOOLEAN ; (* should backend check overflow *)
op1pos,
op2pos,
@@ -1343,6 +1345,19 @@ PROCEDURE PutQuadO (QuadNo: CARDINAL;
Op: QuadOperator;
Oper1, Oper2, Oper3: CARDINAL;
overflow: BOOLEAN) ;
+BEGIN
+ PutQuadOType (QuadNo, Op, Oper1, Oper2, Oper3, overflow, TRUE)
+END PutQuadO ;
+
+
+(*
+ PutQuadOType -
+*)
+
+PROCEDURE PutQuadOType (QuadNo: CARDINAL;
+ Op: QuadOperator;
+ Oper1, Oper2, Oper3: CARDINAL;
+ overflow, checktype: BOOLEAN) ;
VAR
f: QuadFrame ;
BEGIN
@@ -1360,10 +1375,11 @@ BEGIN
Operand1 := Oper1 ;
Operand2 := Oper2 ;
Operand3 := Oper3 ;
- CheckOverflow := overflow
+ CheckOverflow := overflow ;
+ CheckType := checktype
END
END
-END PutQuadO ;
+END PutQuadOType ;
(*
@@ -1378,6 +1394,36 @@ BEGIN
END PutQuad ;
+(*
+ GetQuadOtok - returns the fields associated with quadruple QuadNo.
+*)
+
+PROCEDURE GetQuadOTypetok (QuadNo: CARDINAL;
+ VAR tok: CARDINAL;
+ VAR Op: QuadOperator;
+ VAR Oper1, Oper2, Oper3: CARDINAL;
+ VAR overflowChecking, typeChecking: BOOLEAN ;
+ VAR Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
+VAR
+ f: QuadFrame ;
+BEGIN
+ f := GetQF (QuadNo) ;
+ LastQuadNo := QuadNo ;
+ WITH f^ DO
+ Op := Operator ;
+ Oper1 := Operand1 ;
+ Oper2 := Operand2 ;
+ Oper3 := Operand3 ;
+ Op1Pos := op1pos ;
+ Op2Pos := op2pos ;
+ Op3Pos := op3pos ;
+ tok := TokenNo ;
+ overflowChecking := CheckOverflow ;
+ typeChecking := CheckType
+ END
+END GetQuadOTypetok ;
+
+
(*
UndoReadWriteInfo -
*)
@@ -4379,15 +4425,22 @@ END PushZero ;
PROCEDURE BuildPseudoBy ;
VAR
- e, t, dotok: CARDINAL ;
+ expr, type, dotok: CARDINAL ;
BEGIN
- PopTFtok (e, t, dotok) ; (* as there is no BY token this position is the DO at the end of the last expression. *)
- PushTFtok (e, t, dotok) ;
- IF t=NulSym
+ (* As there is no BY token this position is the DO at the end of the last expression. *)
+ PopTFtok (expr, type, dotok) ;
+ PushTFtok (expr, type, dotok) ;
+ IF type = NulSym
+ THEN
+ (* type := ZType *)
+ ELSIF IsEnumeration (SkipType (type)) OR (SkipType (type) = Char)
THEN
- t := GetSType (e)
+ (* Use type. *)
+ ELSIF IsOrdinalType (SkipType (type))
+ THEN
+ type := ZType
END ;
- PushOne (dotok, t, 'the implied FOR loop increment will cause an overflow {%1ad}')
+ PushOne (dotok, type, 'the implied {%kFOR} loop increment will cause an overflow {%1ad}')
END BuildPseudoBy ;
@@ -4418,8 +4471,9 @@ END BuildForLoopToRangeCheck ;
Entry Exit
===== ====
-
- Ptr -> <- Ptr
+ <- Ptr
+ +----------------+
+ Ptr -> | RangeId |
+----------------+ |----------------|
| BySym | ByType | | ForQuad |
|----------------| |----------------|
@@ -4490,6 +4544,7 @@ VAR
BySym,
ByType,
ForLoop,
+ RangeId,
t, f : CARDINAL ;
etype,
t1 : CARDINAL ;
@@ -4503,24 +4558,8 @@ BEGIN
PopTtok (e1, e1tok) ;
PopTtok (Id, idtok) ;
IdSym := RequestSym (idtok, Id) ;
- IF NOT IsExpressionCompatible (GetSType (e1), GetSType (e2))
- THEN
- MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%1tsad} and final expression {%2tsad}',
- e1, e2) ;
- CheckExpressionCompatible (idtok, GetSType (e1), GetSType (e2))
- END ;
- IF NOT IsExpressionCompatible( GetSType (e1), ByType)
- THEN
- MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%1tsad} and {%kBY} {%2tsad}',
- e2, BySym) ;
- CheckExpressionCompatible (e1tok, GetSType (e1), ByType)
- ELSIF NOT IsExpressionCompatible (GetSType (e2), ByType)
- THEN
- MetaError2 ('incompatible types found in {%EkFOR} loop header, final expression {%1tsad} and {%kBY} {%2tsad}',
- e2, BySym) ;
- CheckExpressionCompatible (e1tok, GetSType (e2), ByType)
- END ;
- BuildRange (InitForLoopBeginRangeCheck (IdSym, e1)) ;
+ RangeId := InitForLoopBeginRangeCheck (IdSym, idtok, e1, e1tok, e2, e2tok, BySym, bytok) ;
+ BuildRange (RangeId) ;
PushTtok (IdSym, idtok) ;
PushTtok (e1, e1tok) ;
BuildAssignmentWithoutBounds (idtok, TRUE, TRUE) ;
@@ -4593,7 +4632,8 @@ BEGIN
PushTFtok (IdSym, GetSym (IdSym), idtok) ;
PushTFtok (BySym, ByType, bytok) ;
PushTFtok (FinalValue, GetSType (FinalValue), e2tok) ;
- PushT (ForLoop)
+ PushT (ForLoop) ;
+ PushT (RangeId)
END BuildForToByDo ;
@@ -4622,6 +4662,7 @@ PROCEDURE BuildEndFor (endpostok: CARDINAL) ;
VAR
t, f,
tsym,
+ RangeId,
IncQuad,
ForQuad: CARDINAL ;
LastSym,
@@ -4631,6 +4672,7 @@ VAR
IdSym,
idtok : CARDINAL ;
BEGIN
+ PopT (RangeId) ;
PopT (ForQuad) ;
PopT (LastSym) ;
PopTFtok (BySym, ByType, bytok) ;
@@ -4661,10 +4703,11 @@ BEGIN
is counting down. The above test will generate a more
precise error message, so we suppress overflow detection
here. *)
- GenQuadOtok (bytok, AddOp, tsym, tsym, BySym, FALSE,
- bytok, bytok, bytok) ;
+ GenQuadOTypetok (bytok, AddOp, tsym, tsym, BySym, FALSE, FALSE,
+ idtok, idtok, bytok) ;
CheckPointerThroughNil (idtok, IdSym) ;
- GenQuadOtok (idtok, XIndrOp, IdSym, GetSType (IdSym), tsym, FALSE,
+ GenQuadOtok (idtok, XIndrOp, IdSym, GetSType (IdSym),
+ tsym, FALSE,
idtok, idtok, idtok)
ELSE
BuildRange (InitForLoopEndRangeCheck (IdSym, BySym)) ;
@@ -4673,13 +4716,20 @@ BEGIN
this addition can legitimately overflow if a cardinal type
is counting down. The above test will generate a more
precise error message, so we suppress overflow detection
- here. *)
- GenQuadOtok (idtok, AddOp, IdSym, IdSym, BySym, FALSE,
- bytok, bytok, bytok)
+ here.
+
+ This quadruple suppresses the generic binary op type
+ check (performed in M2GenGCC.mod) as there
+ will be a more informative/exhaustive check performed by the
+ InitForLoopBeginRangeCheck setup in BuildForToByDo and
+ performed by M2Range.mod. *)
+ GenQuadOTypetok (idtok, AddOp, IdSym, IdSym, BySym, FALSE, FALSE,
+ idtok, idtok, bytok)
END ;
GenQuadO (endpostok, GotoOp, NulSym, NulSym, ForQuad, FALSE) ;
BackPatch (PopFor (), NextQuad) ;
- AddForInfo (ForQuad, NextQuad-1, IncQuad, IdSym, idtok)
+ AddForInfo (ForQuad, NextQuad-1, IncQuad, IdSym, idtok) ;
+ PutRangeForIncrement (RangeId, IncQuad)
END BuildEndFor ;
@@ -13188,6 +13238,22 @@ PROCEDURE GenQuadOtok (TokPos: CARDINAL;
Operation: QuadOperator;
Op1, Op2, Op3: CARDINAL; overflow: BOOLEAN;
Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
+BEGIN
+ GenQuadOTypetok (TokPos, Operation, Op1, Op2, Op3, overflow, TRUE,
+ Op1Pos, Op2Pos, Op3Pos)
+END GenQuadOtok ;
+
+
+(*
+ GenQuadOTypetok - assigns the fields of the quadruple with
+ the parameters.
+*)
+
+PROCEDURE GenQuadOTypetok (TokPos: CARDINAL;
+ Operation: QuadOperator;
+ Op1, Op2, Op3: CARDINAL;
+ overflow, typecheck: BOOLEAN;
+ Op1Pos, Op2Pos, Op3Pos: CARDINAL) ;
VAR
f: QuadFrame ;
BEGIN
@@ -13199,7 +13265,7 @@ BEGIN
f := GetQF (NextQuad-1) ;
f^.Next := NextQuad
END ;
- PutQuadO (NextQuad, Operation, Op1, Op2, Op3, overflow) ;
+ PutQuadOType (NextQuad, Operation, Op1, Op2, Op3, overflow, typecheck) ;
f := GetQF (NextQuad) ;
WITH f^ DO
Next := 0 ;
@@ -13221,7 +13287,7 @@ BEGIN
(* DisplayQuad(NextQuad) ; *)
NewQuad (NextQuad)
END
-END GenQuadOtok ;
+END GenQuadOTypetok ;
(*
diff --git a/gcc/m2/gm2-compiler/M2Range.def b/gcc/m2/gm2-compiler/M2Range.def
index 14c30a71387d..2ffd74f2c378 100644
--- a/gcc/m2/gm2-compiler/M2Range.def
+++ b/gcc/m2/gm2-compiler/M2Range.def
@@ -117,11 +117,23 @@ PROCEDURE InitDecRangeCheck (d, e: CARDINAL) : CARDINAL ;
(*
InitForLoopBeginRangeCheck - returns a range check node which
remembers the information necessary
- so that a range check for FOR d := e TO .. DO
- can be generated later on.
+ so that a range check for
+ FOR des := expr1 TO expr2 DO
+ can be generated later on. expr2 is
+ only used to type check with des.
*)
-PROCEDURE InitForLoopBeginRangeCheck (d, e: CARDINAL) : CARDINAL ;
+PROCEDURE InitForLoopBeginRangeCheck (des, destok,
+ expr1, expr1tok,
+ expr2, expr2tok,
+ byconst, byconsttok: CARDINAL) : CARDINAL ;
+
+
+(*
+ PutRangeForIncrement - places incrementquad into the range record.
+*)
+
+PROCEDURE PutRangeForIncrement (range: CARDINAL; incrementquad: CARDINAL) ;
(*
diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod
index 97abd3eda1a8..fa1ef35c4c4e 100644
--- a/gcc/m2/gm2-compiler/M2Range.mod
+++ b/gcc/m2/gm2-compiler/M2Range.mod
@@ -69,7 +69,9 @@ FROM M2MetaError IMPORT MetaError1, MetaError2, MetaError3,
MetaErrorStringT1, MetaErrorStringT2, MetaErrorStringT3,
MetaString3 ;
-FROM M2LexBuf IMPORT UnknownTokenNo, GetTokenNo, FindFileNameFromToken, TokenToLineNo, TokenToColumnNo, TokenToLocation ;
+FROM M2LexBuf IMPORT UnknownTokenNo, GetTokenNo, FindFileNameFromToken,
+ TokenToLineNo, TokenToColumnNo, TokenToLocation, MakeVirtual2Tok ;
+
FROM StrIO IMPORT WriteString, WriteLn ;
FROM M2GCCDeclare IMPORT TryDeclareConstant, DeclareConstructor ;
FROM M2Quads IMPORT QuadOperator, PutQuad, SubQuad, WriteOperand ;
@@ -122,7 +124,8 @@ TYPE
Range = POINTER TO RECORD
type : TypeOfRange ;
des,
- expr,
+ expr, expr2,
+ byconst,
desLowestType,
exprLowestType: CARDINAL ;
procedure : CARDINAL ;
@@ -131,7 +134,12 @@ TYPE
only used in pointernil *)
dimension : CARDINAL ;
caseList : CARDINAL ;
+ destok,
+ exprtok,
+ expr2tok,
+ byconsttok,
tokenNo : CARDINAL ;
+ incrementquad : CARDINAL ; (* Increment quad used in FOR the loop. *)
errorReported : BOOLEAN ; (* error message reported yet? *)
strict : BOOLEAN ; (* is it a comparison expression? *)
isin : BOOLEAN ; (* expression created by IN operator? *)
@@ -293,12 +301,19 @@ BEGIN
type := none ;
des := NulSym ;
expr := NulSym ;
+ expr2 := NulSym ;
+ byconst := NulSym ;
desLowestType := NulSym ;
exprLowestType := NulSym ;
isLeftValue := FALSE ; (* ignored in all cases other *)
dimension := 0 ;
caseList := 0 ;
- tokenNo := 0 ; (* than pointernil *)
+ tokenNo := UnknownTokenNo ; (* than pointernil *)
+ destok := UnknownTokenNo ;
+ exprtok := UnknownTokenNo ;
+ expr2tok := UnknownTokenNo ;
+ byconsttok := UnknownTokenNo ;
+ incrementquad := 0 ;
errorReported := FALSE
END ;
PutIndice(RangeIndex, r, p)
@@ -334,6 +349,19 @@ BEGIN
END setReported ;
+(*
+ PutRangeForIncrement - places incrementquad into the range record.
+*)
+
+PROCEDURE PutRangeForIncrement (range: CARDINAL; incrementquad: CARDINAL) ;
+VAR
+ p: Range ;
+BEGIN
+ p := GetIndice (RangeIndex, range) ;
+ p^.incrementquad := incrementquad
+END PutRangeForIncrement ;
+
+
(*
PutRange - initializes contents of, p, to
d, e and their lowest types.
@@ -357,6 +385,38 @@ BEGIN
END PutRange ;
+(*
+ PutRangeDesExpr2 - initializes contents of, p, to
+ des, expr1 and their lowest types.
+ It also fills in the token numbers for
+ des, expr, expr2 and returns, p.
+*)
+
+PROCEDURE PutRangeDesExpr2 (p: Range; t: TypeOfRange;
+ des, destok,
+ expr1, expr1tok,
+ expr2, expr2tok,
+ byconst, byconsttok: CARDINAL) : Range ;
+BEGIN
+ p^.des := des ;
+ p^.destok := destok ;
+ p^.expr := expr1 ;
+ p^.exprtok := expr1tok ;
+ p^.expr2 := expr2 ;
+ p^.expr2tok := expr2tok ;
+ p^.byconst := byconst ;
+ p^.byconsttok := byconsttok ;
+ WITH p^ DO
+ type := t ;
+ desLowestType := GetLowestType (des) ;
+ exprLowestType := GetLowestType (expr1) ;
+ strict := FALSE ;
+ isin := FALSE
+ END ;
+ RETURN p
+END PutRangeDesExpr2 ;
+
+
(*
chooseTokenPos - returns, tokenpos, if it is not the unknown location, otherwise
it returns GetTokenNo.
@@ -808,16 +868,25 @@ END InitTypesExpressionCheck ;
(*
InitForLoopBeginRangeCheck - returns a range check node which
remembers the information necessary
- so that a range check for FOR d := e TO .. DO
- can be generated later on.
+ so that a range check for
+ FOR des := expr1 TO expr2 DO
+ can be generated later on. expr2 is
+ only used to type check with des.
*)
-PROCEDURE InitForLoopBeginRangeCheck (d, e: CARDINAL) : CARDINAL ;
+PROCEDURE InitForLoopBeginRangeCheck (des, destok,
+ expr1, expr1tok,
+ expr2, expr2tok,
+ byconst, byconsttok: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
- Assert (PutRange (GetTokenNo (), GetIndice (RangeIndex, r), forloopbegin, d, e) # NIL) ;
+ Assert (PutRangeDesExpr2 (GetIndice (RangeIndex, r), forloopbegin,
+ des, destok,
+ expr1, expr1tok,
+ expr2, expr2tok,
+ byconst, byconsttok) # NIL) ;
RETURN r
END InitForLoopBeginRangeCheck ;
@@ -1785,6 +1854,58 @@ BEGIN
END CodeTypeCheck ;
+(*
+ ForLoopBeginTypeCompatible - check for designator assignment compatibility with
+ expr1 and designator expression compatibility with expr2.
+ FOR des := expr1 TO expr2 BY byconst DO
+ END
+ It generates composite tokens if the tokens are on
+ the same source line.
+*)
+
+PROCEDURE ForLoopBeginTypeCompatible (p: Range) : BOOLEAN ;
+VAR
+ combinedtok: CARDINAL ;
+ success : BOOLEAN ;
+BEGIN
+ success := TRUE ;
+ WITH p^ DO
+ combinedtok := MakeVirtual2Tok (destok, exprtok) ;
+ IF NOT AssignmentTypeCompatible (combinedtok, "", des, expr)
+ THEN
+ MetaErrorT2 (combinedtok,
+ 'type incompatibility between {%1Et} and {%2t} detected during the assignment of the designator {%1a} to the first expression {%2a} in the {%kFOR} loop',
+ des, expr) ;
+ success := FALSE
+ END ;
+ combinedtok := MakeVirtual2Tok (destok, expr2tok) ;
+ IF NOT ExpressionTypeCompatible (combinedtok, "", des, expr2, TRUE, FALSE)
+ THEN
+ MetaErrorT2 (combinedtok,
+ 'type expression incompatibility between {%1Et} and {%2t} detected when comparing the designator {%1a} against the second expression {%2a} in the {%kFOR} loop',
+ des, expr2) ;
+ success := FALSE
+ END ;
+(*
+ combinedtok := MakeVirtual2Tok (destok, byconsttok) ;
+ IF NOT ExpressionTypeCompatible (combinedtok, "", des, byconst, TRUE, FALSE)
+ THEN
+ MetaErrorT2 (combinedtok,
+ 'type expression incompatibility between {%1Et} and {%2t} detected between the the designator {%1a} and the {%kBY} constant expression {%2a} in the {%kFOR} loop',
+ des, byconst) ;
+ success := FALSE
+ END ;
+*)
+ IF (NOT success) AND (incrementquad # 0)
+ THEN
+ (* Avoid a subsequent generic type check error. *)
+ SubQuad (incrementquad)
+ END
+ END ;
+ RETURN success
+END ForLoopBeginTypeCompatible ;
+
+
(*
FoldForLoopBegin -
*)
@@ -1802,14 +1923,17 @@ BEGIN
IF GccKnowsAbout(expr) AND IsConst(expr) AND
GetMinMax(tokenno, desLowestType, min, max)
THEN
- IF OutOfRange(tokenno, min, expr, max, desLowestType)
+ IF NOT ForLoopBeginTypeCompatible (p)
THEN
- MetaErrorT2(tokenNo,
+ SubQuad (q)
+ ELSIF OutOfRange (tokenno, min, expr, max, desLowestType)
+ THEN
+ MetaErrorT2 (tokenNo,
'attempting to assign a value {%2Wa} to a FOR loop designator {%1a} which will exceed the range of type {%1tad}',
- des, expr) ;
- PutQuad(q, ErrorOp, NulSym, NulSym, r)
+ des, expr) ;
+ PutQuad (q, ErrorOp, NulSym, NulSym, r)
ELSE
- SubQuad(q)
+ SubQuad (q)
END
END
END
@@ -2872,7 +2996,10 @@ END CodeDynamicArraySubscript ;
PROCEDURE CodeForLoopBegin (tokenno: CARDINAL;
r: CARDINAL; function, message: String) ;
BEGIN
- DoCodeAssignment(tokenno, r, function, message)
+ IF ForLoopBeginTypeCompatible (GetIndice (RangeIndex, r))
+ THEN
+ DoCodeAssignment(tokenno, r, function, message)
+ END
END CodeForLoopBegin ;
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc10.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc10.mod
new file mode 100644
index 000000000000..3a2d3e210dcc
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc10.mod
@@ -0,0 +1,16 @@
+MODULE callingc10 ;
+
+FROM cvararg IMPORT funcptr ;
+FROM SYSTEM IMPORT ADR ;
+
+BEGIN
+ IF funcptr (1, "hello", 5) = 1
+ THEN
+ END ;
+ IF funcptr (1, "hello" + " ", 6) = 1
+ THEN
+ END ;
+ IF funcptr (1, "hello" + " " + "world", 11) = 1
+ THEN
+ END
+END callingc10.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc11.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc11.mod
new file mode 100644
index 000000000000..9b8cb82d645f
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc11.mod
@@ -0,0 +1,17 @@
+MODULE callingc11 ;
+
+FROM cvararg IMPORT funcptr ;
+FROM SYSTEM IMPORT ADR ;
+FROM strconst IMPORT WORLD ;
+
+BEGIN
+ IF funcptr (1, "hello", 5) = 1
+ THEN
+ END ;
+ IF funcptr (1, "hello" + " ", 6) = 1
+ THEN
+ END ;
+ IF funcptr (1, "hello" + " " + WORLD, 11) = 1
+ THEN
+ END
+END callingc11.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/callingc9.mod b/gcc/testsuite/gm2/extensions/run/pass/callingc9.mod
new file mode 100644
index 000000000000..7e19a0a0b749
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/callingc9.mod
@@ -0,0 +1,7 @@
+MODULE callingc9 ;
+
+VAR
+ array: ARRAY [0..9] OF CHAR ;
+BEGIN
+ array := '0123456789'
+END callingc9.
diff --git a/gcc/testsuite/gm2/extensions/run/pass/strconst.def b/gcc/testsuite/gm2/extensions/run/pass/strconst.def
new file mode 100644
index 000000000000..af1111c57cbf
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/strconst.def
@@ -0,0 +1,6 @@
+DEFINITION MODULE FOR "C" strconst ;
+
+CONST
+ WORLD = "world" ;
+
+END strconst.
diff --git a/gcc/testsuite/gm2/pim/fail/forloop.mod b/gcc/testsuite/gm2/pim/fail/forloop.mod
new file mode 100644
index 000000000000..be86a84edb53
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/forloop.mod
@@ -0,0 +1,17 @@
+MODULE forloop ;
+
+
+PROCEDURE init ;
+VAR
+ i: INTEGER ;
+ c: CARDINAL ;
+BEGIN
+ c := 10 ;
+ FOR i := 0 TO c DO (* INTEGER CARDINAL expression incompatible. *)
+ END
+END init ;
+
+
+BEGIN
+ init
+END forloop.
diff --git a/gcc/testsuite/gm2/pim/pass/forloop2.mod b/gcc/testsuite/gm2/pim/pass/forloop2.mod
new file mode 100644
index 000000000000..0bbc95db4bbf
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/forloop2.mod
@@ -0,0 +1,18 @@
+MODULE forloop2 ;
+
+TYPE
+ colour = (red, green, blue) ;
+
+
+PROCEDURE init ;
+VAR
+ c: colour ;
+BEGIN
+ FOR c := red TO blue DO
+ END
+END init ;
+
+
+BEGIN
+ init
+END forloop2.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2024-02-21 16:21 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-02-21 16:21 [gcc r14-9116] PR modula2/114026 Incorrect location during for loop type checking 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).