diff options
author | Gaius Mulley <gaiusmod2@gmail.com> | 2024-02-21 16:21:05 +0000 |
---|---|---|
committer | Gaius Mulley <gaiusmod2@gmail.com> | 2024-02-21 16:21:05 +0000 |
commit | 161a67b2bee84d8fd5ab7711e411f76221c1ea52 (patch) | |
tree | a440546e7d672ac52c5b830ea155ea3cbe2267a3 | |
parent | c8742849e22d004b6ab94b3f573639f763e42e3a (diff) | |
download | gcc-161a67b2bee84d8fd5ab7711e411f76221c1ea52.zip gcc-161a67b2bee84d8fd5ab7711e411f76221c1ea52.tar.gz gcc-161a67b2bee84d8fd5ab7711e411f76221c1ea52.tar.bz2 |
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>
-rw-r--r-- | gcc/m2/gm2-compiler/M2GenGCC.mod | 26 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2LexBuf.def | 13 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2LexBuf.mod | 13 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Quads.def | 12 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Quads.mod | 142 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Range.def | 18 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Range.mod | 153 | ||||
-rw-r--r-- | gcc/testsuite/gm2/extensions/run/pass/callingc10.mod | 16 | ||||
-rw-r--r-- | gcc/testsuite/gm2/extensions/run/pass/callingc11.mod | 17 | ||||
-rw-r--r-- | gcc/testsuite/gm2/extensions/run/pass/callingc9.mod | 7 | ||||
-rw-r--r-- | gcc/testsuite/gm2/extensions/run/pass/strconst.def | 6 | ||||
-rw-r--r-- | gcc/testsuite/gm2/pim/fail/forloop.mod | 17 | ||||
-rw-r--r-- | 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 c7581f8..aeba48d 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 dd49f45..27610ec 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 84a0e25..af43855 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 e9fd122..3e92e31 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, @@ -549,6 +550,17 @@ PROCEDURE GetQuadOtok (QuadNo: 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 e40e07d..1275ad2f 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 ; (* @@ -1379,6 +1395,36 @@ 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 14c30a7..2ffd74f 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 97abd3e..fa1ef35 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) @@ -335,6 +350,19 @@ 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. It also fills in the current token no @@ -358,6 +386,38 @@ 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 ; @@ -1786,6 +1855,58 @@ 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 0000000..3a2d3e2 --- /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 0000000..9b8cb82 --- /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 0000000..7e19a0a --- /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 0000000..af1111c --- /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 0000000..be86a84 --- /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 0000000..0bbc95d --- /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. |