public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-7633] PR modula2/109810 ICE fix when an array is assigned by a larger string
@ 2023-07-28 18:28 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2023-07-28 18:28 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:52405b14b7e6a8d13ac53525a341ebfd27ef67cc
commit r13-7633-g52405b14b7e6a8d13ac53525a341ebfd27ef67cc
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Fri Jul 28 19:27:18 2023 +0100
PR modula2/109810 ICE fix when an array is assigned by a larger string
This patch fixes an ICE when an array variable is assigned with
a string which exceeds the array size. It improves the accuracy
of the virtual token used to indicate the error message.
gcc/m2/ChangeLog:
PR modula2/109810
* gm2-compiler/M2ALU.mod (ConvertConstToType): Use
PrepareCopyString in place of DoCopyString.
* gm2-compiler/M2GenGCC.def (DoCopyString): Rename to ...
(PrepareCopyString): ... this.
* gm2-compiler/M2GenGCC.mod (CodeStatement): Call CodeReturnValue
with a single parameter. Call CodeXIndr with a single parameter.
(CodeReturnValue): Remove parameters and replace with a single
quadno. Reimplement using PrepareCopyString. Issue error
if the string exceeds designator space.
(DoCopyString): Reimplement and rename to ...
(PrepareCopyString): ... this.
(CodeXIndr): Remove parameters and replace with a single
quadno. Reimplement using PrepareCopyString. Issue error
if the string exceeds designator space.
(CodeBecomes): Remove parameters and replace with a single
quadno. Reimplement using PrepareCopyString. Issue error
if the string exceeds designator space.
* gm2-compiler/M2Quads.def (BuildReturn): Rename parameter to
tokreturn.
* gm2-compiler/M2Quads.mod (BuildReturn): Rename parameter to
tokreturn. Rename tokno to tokcombined.
gcc/testsuite/ChangeLog:
PR modula2/109810
* gm2/pim/fail/highice.mod: New test.
(cherry picked from commit c787f593e62869ae0b230949b4791f4f3a26e50e)
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2ALU.mod | 11 +-
gcc/m2/gm2-compiler/M2GenGCC.def | 21 +++-
gcc/m2/gm2-compiler/M2GenGCC.mod | 208 +++++++++++++++++----------------
gcc/m2/gm2-compiler/M2Quads.def | 2 +-
gcc/m2/gm2-compiler/M2Quads.mod | 73 +++++++-----
gcc/testsuite/gm2/pim/fail/highice.mod | 7 ++
6 files changed, 183 insertions(+), 139 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2ALU.mod b/gcc/m2/gm2-compiler/M2ALU.mod
index ef3b934bccf..5cad8746d60 100644
--- a/gcc/m2/gm2-compiler/M2ALU.mod
+++ b/gcc/m2/gm2-compiler/M2ALU.mod
@@ -40,7 +40,7 @@ FROM M2Debug IMPORT Assert ;
FROM Storage IMPORT ALLOCATE ;
FROM StringConvert IMPORT ostoi, bstoi, stoi, hstoi ;
FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax, CompletelyResolved, DeclareConstant ;
-FROM M2GenGCC IMPORT DoCopyString, StringToChar ;
+FROM M2GenGCC IMPORT PrepareCopyString, StringToChar ;
FROM M2Bitset IMPORT Bitset ;
FROM SymbolConversion IMPORT Mod2Gcc, GccKnowsAbout ;
FROM M2Printf IMPORT printf0, printf2 ;
@@ -4528,8 +4528,13 @@ BEGIN
IF IsConstString(init) AND IsArray(SkipType(GetType(field))) AND
(SkipTypeAndSubrange(GetType(GetType(field)))=Char)
THEN
- DoCopyString(tokenno, nBytes, initT, GetType(field), init) ;
- RETURN( initT )
+ IF NOT PrepareCopyString (tokenno, nBytes, initT, init, GetType (field))
+ THEN
+ MetaErrorT2 (tokenno,
+ 'string constant {%1Ea} is too large to be assigned to the {%2d} {%2a}',
+ init, field)
+ END ;
+ RETURN initT
ELSE
RETURN( ConvertConstantAndCheck(TokenToLocation(tokenno), Mod2Gcc(GetType(field)), Mod2Gcc(init)) )
END
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.def b/gcc/m2/gm2-compiler/M2GenGCC.def
index e29649dc1f6..646e09eb2bc 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.def
+++ b/gcc/m2/gm2-compiler/M2GenGCC.def
@@ -37,7 +37,7 @@ FROM m2linemap IMPORT location_t ;
EXPORT QUALIFIED ConvertQuadsToTree, ResolveConstantExpressions,
GetHighFromUnbounded, StringToChar,
LValueToGenericPtr, ZConstToTypedConst,
- DoCopyString ;
+ PrepareCopyString ;
(*
@@ -91,13 +91,22 @@ PROCEDURE ZConstToTypedConst (t: Tree; op1, op2: CARDINAL) : Tree ;
(*
- DoCopyString - returns trees:
- t number of bytes to be copied (including the nul)
- op3t the string with the extra nul character
- providing it fits.
+ PrepareCopyString - returns two trees:
+ length number of bytes to be copied (including the nul if room)
+ srcTreeType the new string type (with the extra nul character).
+
+ Pre condition: destStrType the dest type string.
+ src is the original string (without a nul)
+ to be copied.
+ Post condition: TRUE or FALSE is returned.
+ if true length and srcTreeType will be assigned
+ else length is set to the maximum length to be
+ copied and srcTree is set to the max length
+ which fits in dest.
*)
-PROCEDURE DoCopyString (tokenno: CARDINAL; VAR length, op3t: Tree; op1t, op3: CARDINAL) ;
+PROCEDURE PrepareCopyString (tokenno: CARDINAL; VAR length, srcTree: Tree;
+ src, destStrType: CARDINAL) : BOOLEAN ;
END M2GenGCC.
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index 15fb929cd87..9e975ba735d 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -80,7 +80,10 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
NulSym ;
FROM M2Batch IMPORT MakeDefinitionSource ;
-FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToLocation, MakeVirtualTok ;
+
+FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToLocation,
+ MakeVirtualTok, UnknownTokenNo ;
+
FROM M2Code IMPORT CodeBlock ;
FROM M2Debug IMPORT Assert ;
FROM M2Error IMPORT InternalError, WriteFormat0, WriteFormat1, WriteFormat2, WarnStringAt ;
@@ -167,6 +170,7 @@ FROM m2expr IMPORT GetIntegerZero, GetIntegerOne,
CompareTrees,
StringLength,
AreConstantsEqual,
+ GetCstInteger,
BuildForeachWordInSetDoIfExpr,
BuildIfConstInVar,
BuildIfVarInVar,
@@ -467,7 +471,7 @@ BEGIN
KillLocalVarOp : CodeKillLocalVar (op3) |
ProcedureScopeOp : CodeProcedureScope (op3) |
ReturnOp : (* Not used as return is achieved by KillLocalVar. *) |
- ReturnValueOp : CodeReturnValue (op1, op3) |
+ ReturnValueOp : CodeReturnValue (q) |
TryOp : CodeTry |
ThrowOp : CodeThrow (op3) |
CatchBeginOp : CodeCatchBegin |
@@ -507,7 +511,7 @@ BEGIN
IfInOp : CodeIfIn (q, op1, op2, op3) |
IfNotInOp : CodeIfNotIn (q, op1, op2, op3) |
IndrXOp : CodeIndrX (q, op1, op2, op3) |
- XIndrOp : CodeXIndr (q, op1, op2, op3) |
+ XIndrOp : CodeXIndr (q) |
CallOp : CodeCall (CurrentQuadToken, op3) |
ParamOp : CodeParam (q, op1, op2, op3) |
FunctValueOp : CodeFunctValue (location, op1) |
@@ -1832,68 +1836,39 @@ END CodeProcedureScope ;
allocated by the function call.
*)
-PROCEDURE CodeReturnValue (res, Procedure: CARDINAL) ;
+PROCEDURE CodeReturnValue (quad: CARDINAL) ;
VAR
- value, length, op3t : Tree ;
- location: location_t ;
+ op : QuadOperator ;
+ expr, none, procedure : CARDINAL ;
+ combinedpos,
+ returnpos, exprpos, nonepos, procpos: CARDINAL ;
+ value, length : Tree ;
+ location : location_t ;
BEGIN
- location := TokenToLocation (CurrentQuadToken) ;
- TryDeclareConstant (CurrentQuadToken, res) ; (* checks to see whether it is a constant and declares it *)
- TryDeclareConstructor (CurrentQuadToken, res) ;
- IF IsConstString (res) AND (SkipTypeAndSubrange (GetType (Procedure)) # Char)
+ GetQuadOtok (quad, returnpos, op, expr, none, procedure,
+ exprpos, nonepos, procpos) ;
+ combinedpos := MakeVirtualTok (returnpos, returnpos, exprpos) ;
+ location := TokenToLocation (combinedpos) ;
+ TryDeclareConstant (exprpos, expr) ; (* checks to see whether it is a constant and declares it *)
+ TryDeclareConstructor (exprpos, expr) ;
+ IF IsConstString (expr) AND (SkipTypeAndSubrange (GetType (procedure)) # Char)
THEN
- DoCopyString (CurrentQuadToken, length, op3t, GetType (Procedure), res) ;
+ IF NOT PrepareCopyString (returnpos, length, value, expr, GetType (procedure))
+ THEN
+ MetaErrorT3 (MakeVirtualTok (returnpos, returnpos, exprpos),
+ 'string constant {%1Ea} is too large to be returned from procedure {%2a} via the {%3d} {%3a}',
+ expr, procedure, GetType (procedure))
+ END ;
value := BuildArrayStringConstructor (location,
- Mod2Gcc (GetType (Procedure)), op3t, length)
+ Mod2Gcc (GetType (procedure)),
+ value, length)
ELSE
- value := Mod2Gcc (res)
+ value := Mod2Gcc (expr)
END ;
- BuildReturnValueCode (location, Mod2Gcc (Procedure), value)
+ BuildReturnValueCode (location, Mod2Gcc (procedure), value)
END CodeReturnValue ;
-(* *******************************
-(*
- GenerateCleanup - generates a try/catch/clobber tree containing the call to ptree
-*)
-
-PROCEDURE GenerateCleanup (location: location_t; procedure: CARDINAL; p, call: Tree) : Tree ;
-VAR
- i, n: CARDINAL ;
- t : Tree ;
-BEGIN
- t := push_statement_list (begin_statement_list ()) ;
- i := 1 ;
- n := NoOfParam (procedure) ;
- WHILE i<=n DO
- IF IsParameterVar (GetNthParam (procedure, i))
- THEN
- AddStatement (location, BuildCleanUp (GetParamTree (call, i-1)))
- END ;
- INC(i)
- END ;
- RETURN BuildTryFinally (location, p, pop_statement_list ())
-END GenerateCleanup ;
-
-
-(*
- CheckCleanup - checks whether a cleanup is required for a procedure with
- VAR parameters. The final tree is returned.
-*)
-
-PROCEDURE CheckCleanup (location: location_t; procedure: CARDINAL; tree, call: Tree) : Tree ;
-BEGIN
- IF HasVarParameters(procedure)
- THEN
- RETURN tree ;
- (* RETURN GenerateCleanup(location, procedure, tree, call) *)
- ELSE
- RETURN tree
- END
-END CheckCleanup ;
-************************************** *)
-
-
(*
CodeCall - determines whether the procedure call is a direct call
or an indirect procedure call.
@@ -1920,7 +1895,6 @@ BEGIN
THEN
location := TokenToLocation (tokenno) ;
AddStatement (location, tree)
- (* was AddStatement(location, CheckCleanup(location, procedure, tree, tree)) *)
ELSE
(* leave tree alone - as it will be picked up when processing FunctValue *)
END
@@ -2882,57 +2856,67 @@ END FoldConstBecomes ;
(*
- DoCopyString - returns trees:
- length number of bytes to be copied (including the nul)
- op1t the new string _type_ (with the extra nul character).
- op3t the actual string with the extra nul character.
+ PrepareCopyString - returns two trees:
+ length number of bytes to be copied (including the nul if room)
+ srcTreeType the new string type (with the extra nul character).
+
+ Pre condition: destStrType the dest type string.
+ src is the original string (without a nul)
+ to be copied.
+ Post condition: TRUE or FALSE is returned.
+ if true length and srcTreeType will be assigned
+ else length is set to the maximum length to be
+ copied and srcTree is set to the max length
+ which fits in dest.
*)
-PROCEDURE DoCopyString (tokenno: CARDINAL; VAR length, op3t: Tree; op1t, op3: CARDINAL) ;
+PROCEDURE PrepareCopyString (tokenno: CARDINAL; VAR length, srcTree: Tree;
+ src, destStrType: CARDINAL) : BOOLEAN ;
VAR
- location: location_t ;
+ location : location_t ;
+ intLength: INTEGER ;
BEGIN
- location := TokenToLocation(tokenno) ;
- Assert(IsArray(SkipType(op1t))) ;
- (* handle string assignments:
+ location := TokenToLocation (tokenno) ;
+ Assert (IsArray (SkipType (destStrType))) ;
+ (* Handle string assignments:
VAR
str: ARRAY [0..10] OF CHAR ;
ch : CHAR ;
str := 'abcde' but not ch := 'a'
*)
- IF GetType (op3) = Char
+ IF GetType (src) = Char
THEN
(*
- * create string from char and add nul to the end, nul is
+ * Create string from char and add nul to the end, nul is
* added by BuildStringConstant
*)
- op3t := BuildStringConstant (KeyToCharStar (GetString (op3)), 1)
+ srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), 1)
ELSE
- op3t := Mod2Gcc (op3)
+ srcTree := Mod2Gcc (src)
END ;
- op3t := ConvertString (Mod2Gcc (op1t), op3t) ;
-
- PushIntegerTree(FindSize(tokenno, op3)) ;
- PushIntegerTree(FindSize(tokenno, op1t)) ;
- IF Less(tokenno)
- THEN
- (* there is room for the extra <nul> character *)
- length := BuildAdd(location, FindSize(tokenno, op3), GetIntegerOne(location), FALSE)
+ srcTree := ConvertString (Mod2Gcc (destStrType), srcTree) ;
+ PushIntegerTree (FindSize (tokenno, src)) ;
+ PushIntegerTree (FindSize (tokenno, destStrType)) ;
+ IF Less (tokenno)
+ THEN
+ (* There is room for the extra <nul> character. *)
+ length := BuildAdd (location, FindSize (tokenno, src),
+ GetIntegerOne (location), FALSE)
ELSE
- PushIntegerTree(FindSize(tokenno, op3)) ;
- PushIntegerTree(FindSize(tokenno, op1t)) ;
+ length := FindSize (tokenno, destStrType) ;
+ PushIntegerTree (FindSize (tokenno, src)) ;
+ PushIntegerTree (length) ;
+ (* Greater or Equal so return max characters in the array. *)
IF Gre (tokenno)
THEN
- WarnStringAt (InitString('string constant is too large to be assigned to the array'),
- tokenno) ;
- length := FindSize (tokenno, op1t)
- ELSE
- (* equal so return max characters in the array *)
- length := FindSize (tokenno, op1t)
+ intLength := GetCstInteger (length) ;
+ srcTree := BuildStringConstant (KeyToCharStar (GetString (src)), intLength) ;
+ RETURN FALSE
END
- END
-END DoCopyString ;
+ END ;
+ RETURN TRUE
+END PrepareCopyString ;
(*
@@ -3104,7 +3088,8 @@ VAR
location : location_t ;
BEGIN
GetQuadOtok (quad, becomespos, op, op1, op2, op3, op1pos, op2pos, op3pos) ;
- DeclareConstant (CurrentQuadToken, op3) ; (* checks to see whether it is a constant and declares it *)
+ Assert (op2pos = UnknownTokenNo) ;
+ DeclareConstant (CurrentQuadToken, op3) ; (* Check to see whether op3 is a constant and declare it. *)
DeclareConstructor (CurrentQuadToken, quad, op3) ;
location := TokenToLocation (CurrentQuadToken) ;
@@ -3121,7 +3106,12 @@ BEGIN
ELSIF IsConstString (op3) AND (SkipTypeAndSubrange (GetType (op1)) # Char)
THEN
checkDeclare (op1) ;
- DoCopyString (CurrentQuadToken, length, op3t, SkipType (GetType (op1)), op3) ;
+ IF NOT PrepareCopyString (becomespos, length, op3t, op3, SkipType (GetType (op1)))
+ THEN
+ MetaErrorT2 (MakeVirtualTok (becomespos, op1pos, op3pos),
+ 'string constant {%1Ea} is too large to be assigned to the array {%2ad}',
+ op3, op1)
+ END ;
AddStatement (location,
MaybeDebugBuiltinMemcpy (location, CurrentQuadToken,
BuildAddr (location, Mod2Gcc (op1), FALSE),
@@ -7177,17 +7167,28 @@ END CodeIndrX ;
(op2 is the type of the data being indirectly copied)
*)
-PROCEDURE CodeXIndr (quad: CARDINAL; op1, type, op3: CARDINAL) ;
+PROCEDURE CodeXIndr (quad: CARDINAL) ;
VAR
+ op : QuadOperator ;
+ tokenno,
+ op1,
+ type,
+ op3,
+ op1pos,
+ op3pos,
+ typepos,
+ xindrpos: CARDINAL ;
length,
newstr : Tree ;
location: location_t ;
BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
+ GetQuadOtok (quad, xindrpos, op, op1, type, op3, op1pos, typepos, op3pos) ;
+ tokenno := MakeVirtualTok (xindrpos, op1pos, op3pos) ;
+ location := TokenToLocation (tokenno) ;
type := SkipType (type) ;
- DeclareConstant(CurrentQuadToken, op3) ;
- DeclareConstructor(CurrentQuadToken, quad, op3) ;
+ DeclareConstant (op3pos, op3) ;
+ DeclareConstructor (op3pos, quad, op3) ;
(*
Follow the Quadruple rule:
@@ -7195,8 +7196,8 @@ BEGIN
*)
IF IsProcType(SkipType(type))
THEN
- BuildAssignmentStatement (location, BuildIndirect(location, Mod2Gcc(op1), GetPointerType()), Mod2Gcc(op3))
- ELSIF IsConstString(op3) AND (GetStringLength(op3)=0) AND (GetMode(op1)=LeftValue)
+ BuildAssignmentStatement (location, BuildIndirect (location, Mod2Gcc (op1), GetPointerType ()), Mod2Gcc (op3))
+ ELSIF IsConstString (op3) AND (GetStringLength (op3) = 0) AND (GetMode (op1) = LeftValue)
THEN
(*
no need to check for type errors,
@@ -7205,13 +7206,18 @@ BEGIN
contents.
*)
BuildAssignmentStatement (location,
- BuildIndirect(location, LValueToGenericPtr(location, op1), Mod2Gcc(Char)),
- StringToChar(Mod2Gcc(op3), Char, op3))
- ELSIF IsConstString(op3) AND (SkipTypeAndSubrange(GetType(op1))#Char)
+ BuildIndirect (location, LValueToGenericPtr (location, op1), Mod2Gcc (Char)),
+ StringToChar (Mod2Gcc (op3), Char, op3))
+ ELSIF IsConstString (op3) AND (SkipTypeAndSubrange (GetType (op1)) # Char)
THEN
- DoCopyString (CurrentQuadToken, length, newstr, type, op3) ;
+ IF NOT PrepareCopyString (tokenno, length, newstr, op3, type)
+ THEN
+ MetaErrorT2 (MakeVirtualTok (xindrpos, op1pos, op3pos),
+ 'string constant {%1Ea} is too large to be assigned to the array {%2ad}',
+ op3, op1)
+ END ;
AddStatement (location,
- MaybeDebugBuiltinMemcpy (location, CurrentQuadToken,
+ MaybeDebugBuiltinMemcpy (location, tokenno,
Mod2Gcc (op1),
BuildAddr (location, newstr, FALSE),
length))
diff --git a/gcc/m2/gm2-compiler/M2Quads.def b/gcc/m2/gm2-compiler/M2Quads.def
index 84c01e23693..582daeb21a7 100644
--- a/gcc/m2/gm2-compiler/M2Quads.def
+++ b/gcc/m2/gm2-compiler/M2Quads.def
@@ -1705,7 +1705,7 @@ PROCEDURE BuildProcedureEnd ;
|------------|
*)
-PROCEDURE BuildReturn (tokno: CARDINAL) ;
+PROCEDURE BuildReturn (tokreturn: CARDINAL) ;
(*
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index 57f272f6106..65e3c49cf50 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -260,7 +260,7 @@ IMPORT M2Error ;
CONST
DebugStackOn = TRUE ;
DebugVarients = FALSE ;
- BreakAtQuad = 4423 ;
+ BreakAtQuad = 133 ;
DebugTokPos = FALSE ;
TYPE
@@ -301,8 +301,8 @@ TYPE
RecordSym : CARDINAL ;
RecordType : CARDINAL ;
RecordRef : CARDINAL ;
- rw : CARDINAL ; (* The record variable. *)
- RecordTokPos: CARDINAL ; (* Token of the record. *)
+ rw : CARDINAL ; (* The record variable. *)
+ RecordTokPos: CARDINAL ; (* Token of the record. *)
END ;
ForLoopInfo = POINTER TO RECORD
@@ -333,8 +333,9 @@ VAR
WhileStack,
ForStack,
ExitStack,
- ReturnStack : StackOfWord ; (* Return quadruple of the procedure. *)
- PriorityStack : StackOfWord ; (* Temporary variable holding old priority. *)
+ ReturnStack : StackOfWord ; (* Return quadruple of the procedure. *)
+ PriorityStack : StackOfWord ; (* Temporary variable holding old *)
+ (* priority. *)
SuppressWith : BOOLEAN ;
QuadArray : Index ;
NextQuad : CARDINAL ; (* Next quadruple number to be created. *)
@@ -3195,7 +3196,7 @@ BEGIN
IF IsConstString(Exp) AND IsConst(Des)
THEN
GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
- tokno, destok, exptok) ;
+ destok, UnknownTokenNo, exptok) ;
PutConstString (tokno, Des, GetString (Exp))
ELSE
IF GetMode(Des)=RightValue
@@ -3206,7 +3207,7 @@ BEGIN
doIndrX (tokno, Des, Exp)
ELSE
GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
- tokno, destok, exptok)
+ destok, UnknownTokenNo, exptok)
END
ELSIF GetMode(Des)=LeftValue
THEN
@@ -3227,7 +3228,7 @@ BEGIN
END
ELSE
GenQuadOtok (tokno, BecomesOp, Des, NulSym, Exp, TRUE,
- tokno, destok, exptok)
+ destok, UnknownTokenNo, exptok)
END
END
END MoveWithMode ;
@@ -3542,6 +3543,17 @@ BEGIN
MarkAsWrite (w) ;
CheckCompatibleWithBecomes (Des, Exp, destok, exptok) ;
combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
+ IF DebugTokPos
+ THEN
+ MetaErrorT1 (becomesTokNo, 'becomestok {%1Oad}', Des) ;
+ MetaErrorT1 (destok, 'destok {%1Oad}', Des) ;
+ MetaErrorT1 (exptok, 'exptok {%1Oad}', Exp)
+ END ;
+ combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
+ IF DebugTokPos
+ THEN
+ MetaErrorT1 (combinedtok, 'combined {%1Oad}', Des)
+ END ;
IF (GetSType (Des) # NulSym) AND (NOT IsSet (GetDType (Des)))
THEN
(* Tell code generator to test runtime values of assignment so ensure we
@@ -3552,7 +3564,7 @@ BEGIN
THEN
CheckBecomesMeta (Des, Exp, combinedtok, destok, exptok)
END ;
- (* Traditional Assignment. *)
+ (* Simple assignment. *)
MoveWithMode (becomesTokNo, Des, Exp, Array, destok, exptok, checkOverflow) ;
IF checkTypes
THEN
@@ -10925,7 +10937,7 @@ END CheckReturnType ;
(*
BuildReturn - Builds the Return part of the procedure.
- tokno is the location of the RETURN keyword.
+ tokreturn is the location of the RETURN keyword.
The Stack is expected to contain:
@@ -10938,48 +10950,53 @@ END CheckReturnType ;
|------------|
*)
-PROCEDURE BuildReturn (tokno: CARDINAL) ;
+PROCEDURE BuildReturn (tokreturn: CARDINAL) ;
VAR
+ tokcombined,
+ tokexpr : CARDINAL ;
e2, t2,
e1, t1,
t, f,
- Des : CARDINAL ;
+ Des : CARDINAL ;
BEGIN
IF IsBoolean (1)
THEN
- PopBool(t, f) ;
+ PopBooltok (t, f, tokexpr) ;
(* Des will be a boolean type *)
- Des := MakeTemporary (tokno, RightValue) ;
+ Des := MakeTemporary (tokexpr, RightValue) ;
PutVar (Des, Boolean) ;
- PushTF (Des, Boolean) ;
- PushBool (t, f) ;
- BuildAssignmentWithoutBounds (tokno, FALSE, TRUE) ;
- PushTF (Des, Boolean)
+ PushTFtok (Des, Boolean, tokexpr) ;
+ PushBooltok (t, f, tokexpr) ;
+ BuildAssignmentWithoutBounds (tokreturn, FALSE, TRUE) ;
+ PushTFtok (Des, Boolean, tokexpr)
END ;
- PopTF (e1, t1) ;
+ PopTFtok (e1, t1, tokexpr) ;
+ tokcombined := MakeVirtualTok (tokreturn, tokreturn, tokexpr) ;
IF e1 # NulSym
THEN
(* this will check that the type returned is compatible with
the formal return type of the procedure. *)
- CheckReturnType (tokno, CurrentProc, e1, t1) ;
+ CheckReturnType (tokcombined, CurrentProc, e1, t1) ;
(* dereference LeftValue if necessary *)
IF GetMode (e1) = LeftValue
THEN
t2 := GetSType (CurrentProc) ;
- e2 := MakeTemporary (tokno, RightValue) ;
+ e2 := MakeTemporary (tokexpr, RightValue) ;
PutVar(e2, t2) ;
- CheckPointerThroughNil (tokno, e1) ;
- doIndrX (tokno, e2, e1) ;
+ CheckPointerThroughNil (tokexpr, e1) ;
+ doIndrX (tokexpr, e2, e1) ;
(* here we check the data contents to ensure no overflow. *)
- BuildRange (InitReturnRangeCheck (tokno, CurrentProc, e2)) ;
- GenQuadO (tokno, ReturnValueOp, e2, NulSym, CurrentProc, FALSE)
+ BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e2)) ;
+ GenQuadOtok (tokcombined, ReturnValueOp, e2, NulSym, CurrentProc, FALSE,
+ tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc))
ELSE
(* here we check the data contents to ensure no overflow. *)
- BuildRange (InitReturnRangeCheck (tokno, CurrentProc, e1)) ;
- GenQuadO (tokno, ReturnValueOp, e1, NulSym, CurrentProc, FALSE)
+ BuildRange (InitReturnRangeCheck (tokcombined, CurrentProc, e1)) ;
+ GenQuadOtok (tokcombined, ReturnValueOp, e1, NulSym, CurrentProc, FALSE,
+ tokcombined, UnknownTokenNo, GetDeclaredMod (CurrentProc))
END
END ;
- GenQuadO (tokno, GotoOp, NulSym, NulSym, PopWord(ReturnStack), FALSE) ;
+ GenQuadO (tokcombined, GotoOp, NulSym, NulSym, PopWord (ReturnStack), FALSE) ;
PushWord (ReturnStack, NextQuad-1)
END BuildReturn ;
diff --git a/gcc/testsuite/gm2/pim/fail/highice.mod b/gcc/testsuite/gm2/pim/fail/highice.mod
new file mode 100644
index 00000000000..78743ddc8cc
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/highice.mod
@@ -0,0 +1,7 @@
+MODULE highice ;
+
+VAR
+ a: ARRAY [0..0] OF CHAR ;
+BEGIN
+ a := '12'
+END highice.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-07-28 18:28 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-07-28 18:28 [gcc r13-7633] PR modula2/109810 ICE fix when an array is assigned by a larger string Gaius Mulley
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).