procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

PR modula2/114026 Incorrect location during for loop type checking

Browse source 
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>
This commit is contained in:
Gaius Mulley 2024-02-21 16:21:05 +00:00
parent c8742849e2
commit 161a67b2be
13 changed files with 386 additions and 72 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
gcc/m2/gm2-compiler/M2GenGCC.mod
View file

@ -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) ;

13
gcc/m2/gm2-compiler/M2LexBuf.def
View file

@ -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

13
gcc/m2/gm2-compiler/M2LexBuf.mod
View file

@ -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

12
gcc/m2/gm2-compiler/M2Quads.def
View file

@ -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.

142
gcc/m2/gm2-compiler/M2Quads.mod
View file

@ -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
t := GetSType (e)
(* type := ZType *)
ELSIF IsEnumeration (SkipType (type)) OR (SkipType (type) = Char)
THEN
(* 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 ;
(*

18
gcc/m2/gm2-compiler/M2Range.def
View file

@ -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) ;
(*

153
gcc/m2/gm2-compiler/M2Range.mod
View file

@ -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 ;

16
gcc/testsuite/gm2/extensions/run/pass/callingc10.mod Normal file
View file

@ -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.

17
gcc/testsuite/gm2/extensions/run/pass/callingc11.mod Normal file
View file

@ -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.

7
gcc/testsuite/gm2/extensions/run/pass/callingc9.mod Normal file
View file

@ -0,0 +1,7 @@
MODULE callingc9 ;
VAR
array: ARRAY [0..9] OF CHAR ;
BEGIN
array := '0123456789'
END callingc9.

6
gcc/testsuite/gm2/extensions/run/pass/strconst.def Normal file
View file

@ -0,0 +1,6 @@
DEFINITION MODULE FOR "C" strconst ;
CONST
WORLD = "world" ;
END strconst.

17
gcc/testsuite/gm2/pim/fail/forloop.mod Normal file
View file

@ -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.

18
gcc/testsuite/gm2/pim/pass/forloop2.mod Normal file
View file

@ -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.