aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/m2/gm2-compiler/M2GenGCC.mod26
-rw-r--r--gcc/m2/gm2-compiler/M2LexBuf.def13
-rw-r--r--gcc/m2/gm2-compiler/M2LexBuf.mod13
-rw-r--r--gcc/m2/gm2-compiler/M2Quads.def12
-rw-r--r--gcc/m2/gm2-compiler/M2Quads.mod142
-rw-r--r--gcc/m2/gm2-compiler/M2Range.def18
-rw-r--r--gcc/m2/gm2-compiler/M2Range.mod153
-rw-r--r--gcc/testsuite/gm2/extensions/run/pass/callingc10.mod16
-rw-r--r--gcc/testsuite/gm2/extensions/run/pass/callingc11.mod17
-rw-r--r--gcc/testsuite/gm2/extensions/run/pass/callingc9.mod7
-rw-r--r--gcc/testsuite/gm2/extensions/run/pass/strconst.def6
-rw-r--r--gcc/testsuite/gm2/pim/fail/forloop.mod17
-rw-r--r--gcc/testsuite/gm2/pim/pass/forloop2.mod18
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.
generated by cgit v1.1 at 2024-10-20 00:33:03 +0000