diff options
-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. |