TeamHeptaMirrors/gcc
1
0
Fork 1
mirror of https://github.com/gcc-mirror/gcc.git synced 2026-05-06 14:59:39 +02:00
Code Issues Packages Projects Releases Wiki Activity

PR modula2/118978 ICE when attempting to pass an incompatible parameter

Browse Source 
This bugfix is for a an ICE which occurs if an incompatible parameter
is passed to a procedure.  In particular if a REAL constant actual
parameter is passed to INTEGER formal parameter then M2Range is invoked
to check the type and then M2Range is called to check the value range.

The value range check causes an ICE.  The bug fix introduces range
dependencies on type checks.  If the type check fails an
error message is generated and any future range check cancelled.
These range and type checks are tightly coupled when generating
parameter quad intermediate code.

gcc/m2/ChangeLog:

	PR modula2/118978
	* gm2-compiler/M2Check.mod (checkConstMeta): Add check for
	typed constants.
	* gm2-compiler/M2Quads.mod (BoolFrame): New field RangeDep.
	(CheckProcedureParameters): Call PutRangeDep to associate the
	range dependency with the parameter on the quad stack.
	Pass ParamCheckId to CheckParameter.
	(CheckProcTypeAndProcedure): Add ParamCheckId parameter.
	Pass ParamCheckId to BuildRange.
	(CheckParameter): New parameter ParamCheckId.
	Pass ParamCheckId to CheckProcTypeAndProcedure.
	(CheckParameterOrdinals): Add extra range dep parameter to the
	call of InitParameterRangeCheck.
	(ConvertBooleanToVariable): Initialize RangeDep field.
	(PushBacktok): Ditto.
	(OperandRangeDep): New procedure.
	(PutRangeDep): Ditto.
	* gm2-compiler/M2Range.def (InitTypesParameterCheck): Add new
	parameter depRangeId.
	(InitParameterRangeCheck): Add new parameter parentRangeId.
	(FoldRangeCheck): Add new parameter range.
	* gm2-compiler/M2Range.mod (InitTypesParameterCheck): Add new
	parameter depRangeId.
	(InitParameterRangeCheck): Add new parameter parentRangeId.
	(FoldRangeCheck): Add new parameter range and rewrite.
	(FoldRangeCheckLower): New procedure.
	(Range): New field cancelled.
	New field dependantid.
	(PutRangeParam): Initialize dependantid.
	(PutRangeParamAssign): Ditto.
	(CheckCancelled): New procedure.
	(Cancel): Ditto.
	(IsCancelled): New procedure function.
	(FoldTypeParam): Add depRangeId parameter.
	(WriteRangeCheck): Add dependent debugging.

gcc/testsuite/ChangeLog:

	PR modula2/118978
	* gm2/pim/fail/badparamtype.mod: New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
This commit is contained in:
Gaius Mulley
2025-02-22 16:47:21 +00:00
parent 4de2d2f80e
commit a2f60c1ff5
5 changed files with 219 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/m2/gm2-compiler/M2Check.mod
View File

@@ -768,6 +768,7 @@ END checkVarEquivalence ;
PROCEDURE checkConstMeta (result: status; tinfo: tInfo;
left, right: CARDINAL) : status ;
VAR
typeLeft,
typeRight: CARDINAL ;
BEGIN
Assert (IsConst (left)) ;
@@ -798,6 +799,11 @@ BEGIN
RETURN doCheckPair (result, tinfo, Char, typeRight)
END
END
ELSIF IsTyped (left) AND IsTyped (right)
THEN
typeRight := GetDType (right) ;
typeLeft := GetDType (left) ;
RETURN doCheckPair (result, tinfo, typeLeft, typeRight)
END ;
RETURN result
END checkConstMeta ;

64
gcc/m2/gm2-compiler/M2Quads.mod
View File

@@ -300,6 +300,7 @@ TYPE
Dimension : CARDINAL ;
ReadWrite : CARDINAL ;
name : CARDINAL ;
RangeDep : CARDINAL ;
Annotation: String ;
tokenno : CARDINAL ;
END ;
@@ -5623,6 +5624,7 @@ VAR
proctok,
paramtok : CARDINAL ;
n1, n2 : Name ;
ParamCheckId,
Dim,
Actual,
FormalI,
@@ -5686,8 +5688,11 @@ BEGIN
s := InitString ('actual') ;
WarnStringAt (s, paramtok)
END ;
BuildRange (InitTypesParameterCheck (paramtok, Proc, i, FormalI, Actual)) ;
ParamCheckId := InitTypesParameterCheck (paramtok, Proc, i, FormalI, Actual, 0) ;
BuildRange (ParamCheckId) ;
(* Store the ParamCheckId on the quad stack so that any dependant checks
can be cancelled if the type check above detects an error. *)
PutRangeDep (pi, ParamCheckId) ;
IF IsConst(Actual)
THEN
IF IsVarParamAny (Proc, i)
@@ -5706,7 +5711,7 @@ BEGIN
(* Allow string literals to be passed to ARRAY [0..n] OF CHAR. *)
ELSIF (GetStringLength(paramtok, Actual) = 1) (* If = 1 then it maybe treated as a char. *)
THEN
CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL, ParamCheckId)
ELSIF NOT IsUnboundedParamAny (Proc, i)
THEN
IF IsForC AND (GetSType(FormalI)=Address)
@@ -5722,7 +5727,7 @@ BEGIN
END
END
ELSE
CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL, ParamCheckId)
END
ELSE
IF IsForC AND UsesVarArgs(Proc)
@@ -5752,7 +5757,8 @@ END CheckProcedureParameters ;
CheckProcTypeAndProcedure - checks the ProcType with the call.
*)
PROCEDURE CheckProcTypeAndProcedure (tokno: CARDINAL; ProcType: CARDINAL; call: CARDINAL) ;
PROCEDURE CheckProcTypeAndProcedure (tokno: CARDINAL; ProcType: CARDINAL;
call: CARDINAL; ParamCheckId: CARDINAL) ;
VAR
n1, n2 : Name ;
i, n, t : CARDINAL ;
@@ -5793,8 +5799,7 @@ BEGIN
END ;
BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i,
GetParam (CheckedProcedure, i),
GetParam (ProcType, i))) ;
(* CheckParameter(tokpos, GetParam(CheckedProcedure, i), 0, GetParam(ProcType, i), call, i, TypeList) ; *)
GetParam (ProcType, i), ParamCheckId)) ;
INC(i)
END
END
@@ -5911,7 +5916,7 @@ END LegalUnboundedParam ;
PROCEDURE CheckParameter (tokpos: CARDINAL;
Actual, Dimension, Formal, ProcSym: CARDINAL;
i: CARDINAL; TypeList: List) ;
i: CARDINAL; TypeList: List; ParamCheckId: CARDINAL) ;
VAR
NewList : BOOLEAN ;
ActualType, FormalType: CARDINAL ;
@@ -5991,7 +5996,7 @@ BEGIN
END
END ;
(* now to check each parameter of the proc type *)
CheckProcTypeAndProcedure (tokpos, FormalType, Actual)
CheckProcTypeAndProcedure (tokpos, FormalType, Actual, ParamCheckId)
ELSIF (ActualType#FormalType) AND (ActualType#NulSym)
THEN
IF IsUnknown(FormalType)
@@ -6657,9 +6662,10 @@ BEGIN
THEN
IF NOT IsSet (GetDType (FormalI))
THEN
(* tell code generator to test runtime values of assignment so ensure we
catch overflow and underflow *)
BuildRange (InitParameterRangeCheck (tokno, Proc, i, FormalI, Actual))
(* Tell the code generator to test the runtime values of the assignment
so ensure we catch overflow and underflow. *)
BuildRange (InitParameterRangeCheck (tokno, Proc, i, FormalI, Actual,
OperandRangeDep (pi)))
END
END
END ;
@@ -13108,7 +13114,8 @@ BEGIN
ReadWrite := NulSym ;
tokenno := tok ;
Annotation := KillString (Annotation) ;
Annotation := InitString ('%1s(%1d)|%2s(%2d)||boolean var|type')
Annotation := InitString ('%1s(%1d)|%2s(%2d)||boolean var|type') ;
RangeDep := 0
END
END ConvertBooleanToVariable ;
@@ -14443,7 +14450,8 @@ BEGIN
FalseExit := False ;
BooleanOp := TRUE ;
tokenno := tokno ;
Annotation := NIL
Annotation := NIL ;
RangeDep := 0
END ;
PushAddress (BoolStack, f) ;
Annotate ('<q%1d>|<q%2d>||true quad|false quad')
@@ -14585,6 +14593,34 @@ BEGIN
END OperandTok ;
(*
OperandRangeDep - return the range dependant associated with the quad stack.
*)
PROCEDURE OperandRangeDep (pos: CARDINAL) : CARDINAL ;
VAR
f: BoolFrame ;
BEGIN
Assert (NOT IsBoolean (pos)) ;
f := PeepAddress (BoolStack, pos) ;
RETURN f^.RangeDep
END OperandRangeDep ;
(*
PutRangeDep - assigns the quad stack pos RangeDep to dep.
*)
PROCEDURE PutRangeDep (pos: CARDINAL; dep: CARDINAL) ;
VAR
f: BoolFrame ;
BEGIN
Assert (NOT IsBoolean (pos)) ;
f := PeepAddress (BoolStack, pos) ;
f^.RangeDep := dep
END PutRangeDep ;
(*
BuildCodeOn - generates a quadruple declaring that code should be
emmitted from henceforth.

15
gcc/m2/gm2-compiler/M2Range.def
View File

@@ -265,8 +265,9 @@ PROCEDURE InitTypesAssignmentCheck (tokno: CARDINAL; d, e: CARDINAL) : CARDINAL
*)
PROCEDURE InitTypesParameterCheck (tokno: CARDINAL;
proc: CARDINAL; i: CARDINAL;
formal, actual: CARDINAL) : CARDINAL ;
proc: CARDINAL; paramno: CARDINAL;
formal, actual: CARDINAL;
depRangeId: CARDINAL) : CARDINAL ;
(*
@@ -275,8 +276,9 @@ PROCEDURE InitTypesParameterCheck (tokno: CARDINAL;
*)
PROCEDURE InitParameterRangeCheck (tokno: CARDINAL;
proc: CARDINAL; i: CARDINAL;
formal, actual: CARDINAL) : CARDINAL ;
proc: CARDINAL; paramno: CARDINAL;
formal, actual: CARDINAL;
parentRangeId: CARDINAL) : CARDINAL ;
(*
@@ -304,11 +306,10 @@ PROCEDURE CodeRangeCheck (r: CARDINAL; function: String) ;
(*
FoldRangeCheck - returns a Tree representing the code for a
range test defined by, r.
FoldRangeCheck - attempts to resolve the range check.
*)
PROCEDURE FoldRangeCheck (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
PROCEDURE FoldRangeCheck (tokenno: CARDINAL; quad: CARDINAL; range: CARDINAL) ;
(*

186
gcc/m2/gm2-compiler/M2Range.mod
View File

@@ -75,6 +75,7 @@ FROM M2LexBuf IMPORT UnknownTokenNo, GetTokenNo, FindFileNameFromToken,
TokenToLineNo, TokenToColumnNo, TokenToLocation, MakeVirtual2Tok ;
FROM StrIO IMPORT WriteString, WriteLn ;
FROM NumberIO IMPORT WriteCard ;
FROM M2GCCDeclare IMPORT TryDeclareConstant, DeclareConstructor ;
FROM M2Quads IMPORT QuadOperator, PutQuad, SubQuad, WriteOperand ;
FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc ;
@@ -145,6 +146,8 @@ TYPE
errorReported : BOOLEAN ; (* error message reported yet? *)
strict : BOOLEAN ; (* is it a comparison expression? *)
isin : BOOLEAN ; (* expression created by IN operator? *)
cancelled : BOOLEAN ; (* Has this range been cancelled? *)
dependantid : CARDINAL ; (* The associated dependant range test. *)
END ;
@@ -316,7 +319,9 @@ BEGIN
expr2tok := UnknownTokenNo ;
byconsttok := UnknownTokenNo ;
incrementquad := 0 ;
errorReported := FALSE
errorReported := FALSE ;
cancelled := FALSE ;
dependantid := 0
END ;
PutIndice(RangeIndex, r, p)
END ;
@@ -555,7 +560,8 @@ END PutRangeUnary ;
*)
PROCEDURE PutRangeParam (tokno: CARDINAL; p: Range; t: TypeOfRange; proc: CARDINAL;
i: CARDINAL; formal, actual: CARDINAL) : Range ;
paramno: CARDINAL; formal, actual: CARDINAL;
depRangeId: CARDINAL) : Range ;
BEGIN
WITH p^ DO
type := t ;
@@ -564,11 +570,12 @@ BEGIN
desLowestType := NulSym ;
exprLowestType := NulSym ;
procedure := proc ;
paramNo := i ;
paramNo := paramno ;
isLeftValue := FALSE ;
tokenNo := tokno ;
strict := FALSE ;
isin := FALSE
isin := FALSE ;
dependantid := depRangeId
END ;
RETURN p
END PutRangeParam ;
@@ -805,13 +812,16 @@ END InitTypesAssignmentCheck ;
and, e, are parameter compatible.
*)
PROCEDURE InitTypesParameterCheck (tokno: CARDINAL; proc: CARDINAL; i: CARDINAL;
formal, actual: CARDINAL) : CARDINAL ;
PROCEDURE InitTypesParameterCheck (tokno: CARDINAL;
proc: CARDINAL; paramno: CARDINAL;
formal, actual: CARDINAL;
depRangeId: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeParam (tokno, GetIndice (RangeIndex, r), typeparam, proc, i, formal, actual) # NIL) ;
Assert (PutRangeParam (tokno, GetIndice (RangeIndex, r), typeparam, proc,
paramno, formal, actual, depRangeId) # NIL) ;
RETURN r
END InitTypesParameterCheck ;
@@ -824,7 +834,7 @@ END InitTypesParameterCheck ;
*)
PROCEDURE PutRangeParamAssign (tokno: CARDINAL; p: Range; t: TypeOfRange; proc: CARDINAL;
i: CARDINAL; formal, actual: CARDINAL) : Range ;
i: CARDINAL; formal, actual: CARDINAL; parentRangeId: CARDINAL) : Range ;
BEGIN
WITH p^ DO
type := t ;
@@ -836,7 +846,8 @@ BEGIN
paramNo := i ;
dimension := i ;
isLeftValue := FALSE ;
tokenNo := tokno
tokenNo := tokno ;
dependantid := parentRangeId
END ;
RETURN( p )
END PutRangeParamAssign ;
@@ -847,13 +858,14 @@ END PutRangeParamAssign ;
are parameter compatible.
*)
PROCEDURE InitParameterRangeCheck (tokno: CARDINAL; proc: CARDINAL; i: CARDINAL;
formal, actual: CARDINAL) : CARDINAL ;
PROCEDURE InitParameterRangeCheck (tokno: CARDINAL; proc: CARDINAL; paramno: CARDINAL;
formal, actual: CARDINAL; parentRangeId: CARDINAL) : CARDINAL ;
VAR
r: CARDINAL ;
BEGIN
r := InitRange () ;
Assert (PutRangeParamAssign (tokno, GetIndice (RangeIndex, r), paramassign, proc, i, formal, actual) # NIL) ;
Assert (PutRangeParamAssign (tokno, GetIndice (RangeIndex, r), paramassign, proc,
paramno, formal, actual, parentRangeId) # NIL) ;
RETURN r
END InitParameterRangeCheck ;
@@ -1241,6 +1253,64 @@ BEGIN
END FoldAssignment ;
(*
CheckCancelled - check to see if the range has been cancelled and if so remove quad.
*)
PROCEDURE CheckCancelled (range: CARDINAL; quad: CARDINAL) ;
BEGIN
IF IsCancelled (range)
THEN
SubQuad (quad)
END
END CheckCancelled ;
(*
IsCancelled - return the cancelled flag associated with range.
*)
PROCEDURE IsCancelled (range: CARDINAL) : BOOLEAN ;
VAR
p: Range ;
BEGIN
p := GetIndice (RangeIndex, range) ;
WITH p^ DO
IF cancelled
THEN
RETURN TRUE
END ;
IF (dependantid # 0) AND IsCancelled (dependantid)
THEN
cancelled := TRUE
END ;
RETURN cancelled
END
END IsCancelled ;
(*
Cancel - set the cancelled flag in range.
*)
PROCEDURE Cancel (range: CARDINAL) ;
VAR
p: Range ;
BEGIN
IF range # 0
THEN
p := GetIndice (RangeIndex, range) ;
WITH p^ DO
IF NOT cancelled
THEN
cancelled := TRUE ;
Cancel (dependantid)
END
END
END
END Cancel ;
(*
FoldParameterAssign -
*)
@@ -1699,7 +1769,10 @@ END FoldTypeAssign ;
The quad is removed if the check succeeds.
*)
PROCEDURE FoldTypeParam (q: CARDINAL; tokenNo: CARDINAL; formal, actual, procedure: CARDINAL; paramNo: CARDINAL) ;
PROCEDURE FoldTypeParam (q: CARDINAL; tokenNo: CARDINAL;
formal, actual, procedure: CARDINAL;
paramNo: CARDINAL;
depRangeId: CARDINAL) ;
VAR
compatible: BOOLEAN ;
BEGIN
@@ -1724,6 +1797,8 @@ BEGIN
IF compatible
THEN
SubQuad(q)
ELSE
Cancel (depRangeId)
END
END FoldTypeParam ;
@@ -1836,7 +1911,7 @@ BEGIN
CASE type OF
typeassign: FoldTypeAssign(q, tokenNo, des, expr, r) |
typeparam: FoldTypeParam(q, tokenNo, des, expr, procedure, paramNo) |
typeparam: FoldTypeParam(q, tokenNo, des, expr, procedure, paramNo, r) |
typeexpr: FoldTypeExpr(q, tokenNo, des, expr, strict, isin, r)
ELSE
@@ -2271,7 +2346,7 @@ END FoldZeroRem ;
(*
FoldRangeCheck - attempts to resolve the range check, r.
FoldRangeCheck - attempts to resolve the range check.
If it evaluates to true then
it is replaced by an ErrorOp
elsif it evaluates to false then
@@ -2280,47 +2355,63 @@ END FoldZeroRem ;
it is left alone
*)
PROCEDURE FoldRangeCheck (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
PROCEDURE FoldRangeCheck (tokenno: CARDINAL; quad: CARDINAL; range: CARDINAL) ;
BEGIN
IF IsCancelled (range)
THEN
SubQuad (quad)
ELSE
FoldRangeCheckLower (tokenno, quad, range)
END
END FoldRangeCheck ;
(*
FoldRangeCheckLower - call the appropriate Fold procedure depending upon the type
of range.
*)
PROCEDURE FoldRangeCheckLower (tokenno: CARDINAL; quad: CARDINAL; range: CARDINAL) ;
VAR
p: Range ;
BEGIN
p := GetIndice(RangeIndex, r) ;
p := GetIndice(RangeIndex, range) ;
WITH p^ DO
CASE type OF
assignment : FoldAssignment(tokenno, q, r) |
returnassignment : FoldReturn(tokenno, q, r) |
assignment : FoldAssignment(tokenno, quad, range) |
returnassignment : FoldReturn(tokenno, quad, range) |
(* subrangeassignment : | unused currently *)
inc : FoldInc(tokenno, q, r) |
dec : FoldDec(tokenno, q, r) |
incl : FoldIncl(tokenno, q, r) |
excl : FoldExcl(tokenno, q, r) |
shift : FoldShift(tokenno, q, r) |
rotate : FoldRotate(tokenno, q, r) |
typeassign : FoldTypeCheck(tokenno, q, r) |
typeparam : FoldTypeCheck(tokenno, q, r) |
typeexpr : FoldTypeCheck(tokenno, q, r) |
paramassign : FoldParameterAssign(tokenno, q, r) |
staticarraysubscript : FoldStaticArraySubscript(tokenno, q, r) |
dynamicarraysubscript: FoldDynamicArraySubscript(tokenno, q, r) |
forloopbegin : FoldForLoopBegin(tokenno, q, r) |
forloopto : FoldForLoopTo(tokenno, q, r) |
inc : FoldInc(tokenno, quad, range) |
dec : FoldDec(tokenno, quad, range) |
incl : FoldIncl(tokenno, quad, range) |
excl : FoldExcl(tokenno, quad, range) |
shift : FoldShift(tokenno, quad, range) |
rotate : FoldRotate(tokenno, quad, range) |
typeassign : FoldTypeCheck(tokenno, quad, range) |
typeparam : FoldTypeCheck(tokenno, quad, range) |
typeexpr : FoldTypeCheck(tokenno, quad, range) |
paramassign : FoldParameterAssign(tokenno, quad, range) |
staticarraysubscript : FoldStaticArraySubscript(tokenno, quad, range) |
dynamicarraysubscript: FoldDynamicArraySubscript(tokenno, quad, range) |
forloopbegin : FoldForLoopBegin(tokenno, quad, range) |
forloopto : FoldForLoopTo(tokenno, quad, range) |
forloopend : RETURN (* unable to fold anything at this point, des, will be variable *) |
pointernil : FoldNil(tokenno, q, r) |
pointernil : FoldNil(tokenno, quad, range) |
noreturn : RETURN (* nothing to fold *) |
noelse : RETURN (* nothing to fold *) |
casebounds : FoldCaseBounds(tokenno, q, r) |
wholenonposdiv : FoldNonPosDiv(tokenno, q, r) |
wholenonposmod : FoldNonPosMod(tokenno, q, r) |
wholezerodiv : FoldZeroDiv(tokenno, q, r) |
wholezerorem : FoldZeroRem(tokenno, q, r) |
none : SubQuad(q)
casebounds : FoldCaseBounds(tokenno, quad, range) |
wholenonposdiv : FoldNonPosDiv(tokenno, quad, range) |
wholenonposmod : FoldNonPosMod(tokenno, quad, range) |
wholezerodiv : FoldZeroDiv(tokenno, quad, range) |
wholezerorem : FoldZeroRem(tokenno, quad, range) |
none : SubQuad(quad)
ELSE
InternalError ('unexpected case')
END
END
END FoldRangeCheck ;
END FoldRangeCheckLower ;
(*
@@ -3595,6 +3686,19 @@ VAR
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
WriteString ('range ') ;
WriteCard (r, 0) ;
WriteString (' ') ;
IF cancelled
THEN
WriteString ('cancelled ')
END ;
IF dependantid # 0
THEN
WriteString ('dep ') ;
WriteCard (dependantid, 0) ;
WriteString (' ')
END ;
CASE type OF
assignment : WriteString('assignment (') ; WriteOperand(des) ; WriteString(', ') ; WriteOperand(expr) |

10
gcc/testsuite/gm2/pim/fail/badparamtype.mod Normal file
View File

@@ -0,0 +1,10 @@
MODULE badparamtype ;
PROCEDURE foo (i: INTEGER) ;
BEGIN
END foo ;
BEGIN
foo (3.14)
END badparamtype.