https://gcc.gnu.org/g:e0ab8816ea53e2a343f7e945f4718172bff5ce95
commit r15-6093-ge0ab8816ea53e2a343f7e945f4718172bff5ce95
Author: Gaius Mulley <gaiusm...@gmail.com>
Date: Tue Dec 10 20:47:36 2024 +0000
PR modula2/117120: case ch with a nul char constant causes ICE
This patch fixes the ICE caused when a case clause contains
a character constant ''. The fix was to walk the caselist and
convert any 0 length string into a char constant of value 0.
gcc/m2/ChangeLog:
PR modula2/117120
* gm2-compiler/M2CaseList.mod (CaseBoundsResolved): Rewrite.
(ConvertNulStr2NulChar): New procedure function.
(NulStr2NulChar): Ditto.
(GetCaseExpression): Ditto.
(OverlappingCaseBound): Rewrite.
* gm2-compiler/M2GCCDeclare.mod (CheckResolveSubrange): Allow
'' to be used as the subrange low limit.
* gm2-compiler/M2GenGCC.mod (FoldConvert): Rewrite.
(PopKindTree): Ditto.
(BuildHighFromString): Reformat.
* gm2-compiler/SymbolTable.mod (PushConstString): Add test for
length 0 and PushChar (nul).
gcc/testsuite/ChangeLog:
PR modula2/117120
* gm2/pim/pass/forloopnulchar.mod: New test.
* gm2/pim/pass/nulcharcase.mod: New test.
* gm2/pim/pass/nulcharvar.mod: New test.
Signed-off-by: Gaius Mulley <gaiusm...@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2CaseList.mod | 150 +++++++++++++++++++++-----
gcc/m2/gm2-compiler/M2GCCDeclare.mod | 4 +-
gcc/m2/gm2-compiler/M2GenGCC.mod | 130 +++++++++++-----------
gcc/m2/gm2-compiler/SymbolTable.mod | 8 +-
gcc/testsuite/gm2/pim/pass/forloopnulchar.mod | 8 ++
gcc/testsuite/gm2/pim/pass/nulcharcase.mod | 16 +++
gcc/testsuite/gm2/pim/pass/nulcharvar.mod | 7 ++
7 files changed, 231 insertions(+), 92 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2CaseList.mod
b/gcc/m2/gm2-compiler/M2CaseList.mod
index 7a889bd5d8bf..7fcfe1b40722 100644
--- a/gcc/m2/gm2-compiler/M2CaseList.mod
+++ b/gcc/m2/gm2-compiler/M2CaseList.mod
@@ -27,10 +27,10 @@ FROM M2GCCDeclare IMPORT TryDeclareConstant, GetTypeMin,
GetTypeMax ;
FROM M2MetaError IMPORT MetaError1, MetaError2, MetaErrorT0, MetaErrorT1,
MetaErrorT2, MetaErrorT3, MetaErrorT4, MetaErrorStringT0, MetaErrorString1 ;
FROM M2Error IMPORT InternalError ;
FROM M2Range IMPORT OverlapsRange, IsEqual, IsGreater ;
-FROM M2ALU IMPORT PushIntegerTree, PopIntegerTree, Addn, Sub, PushInt ;
+FROM M2ALU IMPORT PushIntegerTree, PopIntegerTree, Addn, Sub, PushInt,
PushCard ;
FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice,
ForeachIndiceInIndexDo, HighIndice ;
FROM Lists IMPORT InitList, IncludeItemIntoList, RemoveItemFromList,
NoOfItemsInList, GetItemFromList ;
-FROM NameKey IMPORT KeyToCharStar ;
+FROM NameKey IMPORT NulName, KeyToCharStar ;
FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc, AddModGcc ;
FROM DynamicStrings IMPORT InitString, InitStringCharStar, InitStringChar,
ConCat, Mark, KillString ;
FROM gcctypes IMPORT tree ;
@@ -44,7 +44,8 @@ FROM NumberIO IMPORT WriteCard ;
FROM SymbolTable IMPORT NulSym, IsConst, IsFieldVarient, IsRecord,
IsRecordField, GetVarientTag, GetType,
ForeachLocalSymDo, GetSymName, IsEnumeration,
SkipType, NoOfElements, GetNth,
- IsSubrange ;
+ IsSubrange, MakeConstLit, IsConstString,
GetStringLength, MakeConstVar, PutConst,
+ PopValue ;
TYPE
RangePair = POINTER TO RECORD
@@ -64,6 +65,7 @@ TYPE
END ;
CaseDescriptor = POINTER TO RECORD
+ resolved : BOOLEAN ;
elseClause : BOOLEAN ;
elseField : CARDINAL ;
record : CARDINAL ;
@@ -110,6 +112,7 @@ BEGIN
InternalError ('out of memory error')
ELSE
WITH c^ DO
+ resolved := FALSE ;
elseClause := FALSE ;
elseField := NulSym ;
record := rec ;
@@ -244,7 +247,30 @@ END GetVariantTagType ;
PROCEDURE CaseBoundsResolved (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
VAR
- resolved: BOOLEAN ;
+ p: CaseDescriptor ;
+BEGIN
+ p := GetIndice (caseArray, c) ;
+ IF p^.resolved
+ THEN
+ RETURN TRUE
+ ELSE
+ IF CheckCaseBoundsResolved (tokenno, c)
+ THEN
+ ConvertNulStr2NulChar (tokenno, c) ;
+ RETURN TRUE
+ ELSE
+ RETURN FALSE
+ END
+ END
+END CaseBoundsResolved ;
+
+
+(*
+ CheckCaseBoundsResolved - return TRUE if all constants in the case list c
are known to GCC.
+*)
+
+PROCEDURE CheckCaseBoundsResolved (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
+VAR
p : CaseDescriptor ;
q : CaseList ;
r : RangePair ;
@@ -327,7 +353,62 @@ BEGIN
END
END ;
RETURN( TRUE )
-END CaseBoundsResolved ;
+END CheckCaseBoundsResolved ;
+
+
+(*
+ ConvertNulStr2NulChar -
+*)
+
+PROCEDURE ConvertNulStr2NulChar (tokenno: CARDINAL; c: CARDINAL) ;
+VAR
+ p : CaseDescriptor ;
+ q : CaseList ;
+ r : RangePair ;
+ i, j: CARDINAL ;
+BEGIN
+ p := GetIndice (caseArray, c) ;
+ WITH p^ DO
+ i := 1 ;
+ WHILE i <= maxCaseId DO
+ q := GetIndice (caseListArray, i) ;
+ j := 1 ;
+ WHILE j<=q^.maxRangeId DO
+ r := GetIndice (q^.rangeArray, j) ;
+ r^.low := NulStr2NulChar (tokenno, r^.low) ;
+ r^.high := NulStr2NulChar (tokenno, r^.high) ;
+ INC (j)
+ END ;
+ INC (i)
+ END
+ END
+END ConvertNulStr2NulChar ;
+
+
+(*
+ NulStr2NulChar - if sym is a const string of length 0 then return
+ a nul char instead otherwise return sym.
+*)
+
+PROCEDURE NulStr2NulChar (tok: CARDINAL; sym: CARDINAL) : CARDINAL ;
+BEGIN
+ IF sym # NulSym
+ THEN
+ IF IsConst (sym) AND IsConstString (sym) AND GccKnowsAbout (sym)
+ THEN
+ IF GetStringLength (tok, sym) = 0
+ THEN
+ sym := MakeConstVar (tok, NulName) ;
+ PutConst (sym, Char) ;
+ PushCard (0) ;
+ PopValue (sym) ;
+ TryDeclareConstant (tok, sym) ;
+ Assert (GccKnowsAbout (sym))
+ END
+ END
+ END ;
+ RETURN sym
+END NulStr2NulChar ;
(*
@@ -439,6 +520,26 @@ BEGIN
END Overlaps ;
+(*
+ GetCaseExpression - return the type from the expression.
+*)
+
+PROCEDURE GetCaseExpression (p: CaseDescriptor) : CARDINAL ;
+VAR
+ type: CARDINAL ;
+BEGIN
+ WITH p^ DO
+ IF expression = NulSym
+ THEN
+ type := NulSym
+ ELSE
+ type := SkipType (GetType (expression))
+ END
+ END ;
+ RETURN type
+END GetCaseExpression ;
+
+
(*
OverlappingCaseBound - returns TRUE if, r, overlaps any case bound in the
case statement, c.
@@ -488,15 +589,15 @@ VAR
i, j : CARDINAL ;
overlap: BOOLEAN ;
BEGIN
- p := GetIndice(caseArray, c) ;
+ p := GetIndice (caseArray, c) ;
overlap := FALSE ;
WITH p^ DO
i := 1 ;
WHILE i<=maxCaseId DO
- q := GetIndice(caseListArray, i) ;
+ q := GetIndice (caseListArray, i) ;
j := 1 ;
WHILE j<=q^.maxRangeId DO
- r := GetIndice(q^.rangeArray, j) ;
+ r := GetIndice (q^.rangeArray, j) ;
IF OverlappingCaseBound (r, c)
THEN
overlap := TRUE
@@ -1121,27 +1222,24 @@ BEGIN
WITH p^ DO
IF NOT elseClause
THEN
- IF expression # NulSym
+ type := GetCaseExpression (p) ;
+ IF type # NulSym
THEN
- type := SkipType (GetType (expression)) ;
- IF type # NulSym
+ IF IsEnumeration (type) OR IsSubrange (type)
THEN
- IF IsEnumeration (type) OR IsSubrange (type)
+ (* A case statement sequence without an else clause but
+ selecting using an enumeration type. *)
+ set := NewSet (type) ;
+ set := ExcludeCaseRanges (set, p) ;
+ IF set # NIL
THEN
- (* A case statement sequence without an else clause but
- selecting using an enumeration type. *)
- set := NewSet (type) ;
- set := ExcludeCaseRanges (set, p) ;
- IF set # NIL
- THEN
- missing := TRUE ;
- MetaErrorT1 (tokenno,
- 'not all {%1Wd} values in the {%kCASE}
statements are specified, hint you either need to specify each value of {%1ad}
or use an {%kELSE} clause',
- type) ;
- EmitMissingRangeErrors (tokenno, type, set)
- END ;
- set := DisposeRanges (set)
- END
+ missing := TRUE ;
+ MetaErrorT1 (tokenno,
+ 'not all {%1Wd} values in the {%kCASE}
statements are specified, hint you either need to specify each value of {%1ad}
or use an {%kELSE} clause',
+ type) ;
+ EmitMissingRangeErrors (tokenno, type, set)
+ END ;
+ set := DisposeRanges (set)
END
END
END
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index 2680faad7b69..d084096148f4 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -1934,7 +1934,7 @@ BEGIN
IF IsConstStringKnown (sym)
THEN
size := GetStringLength (tokenno, sym) ;
- IF size=1
+ IF size = 1
THEN
DeclareCharConstant (tokenno, sym)
ELSE
@@ -5570,7 +5570,7 @@ BEGIN
IF IsConstString (low) AND IsConstStringKnown (low)
THEN
size := GetStringLength (tokenno, low) ;
- IF size=1
+ IF size <= 1
THEN
PutSubrange(sym, low, high, Char)
ELSE
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index c5f5a7825956..5811c9d77943 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -6420,12 +6420,12 @@ PROCEDURE BuildHighFromString (operand: CARDINAL) :
tree ;
VAR
location: location_t ;
BEGIN
- location := TokenToLocation(GetDeclaredMod(operand)) ;
- IF GccKnowsAbout(operand) AND (StringLength(Mod2Gcc(operand))>0)
+ location := TokenToLocation (GetDeclaredMod (operand)) ;
+ IF GccKnowsAbout (operand) AND (StringLength (Mod2Gcc (operand)) > 0)
THEN
- RETURN( BuildIntegerConstant(StringLength(Mod2Gcc(operand))-1) )
+ RETURN( BuildIntegerConstant (StringLength (Mod2Gcc (operand))-1) )
ELSE
- RETURN( GetIntegerZero(location) )
+ RETURN( GetIntegerZero (location) )
END
END BuildHighFromString ;
@@ -6765,96 +6765,102 @@ PROCEDURE PopKindTree (op: CARDINAL; tokenno:
CARDINAL) : tree ;
VAR
type: CARDINAL ;
BEGIN
- type := SkipType (GetType (op)) ;
- IF IsSet (type)
- THEN
- RETURN( PopSetTree (tokenno) )
- ELSIF IsRealType (type)
+ IF IsConst (op) AND IsConstString (op)
THEN
- RETURN( PopRealTree () )
+ (* Converting a nul char or char for example. *)
+ RETURN PopIntegerTree ()
ELSE
- RETURN( PopIntegerTree () )
+ type := SkipType (GetType (op)) ;
+ IF IsSet (type)
+ THEN
+ RETURN( PopSetTree (tokenno) )
+ ELSIF IsRealType (type)
+ THEN
+ RETURN( PopRealTree () )
+ ELSE
+ RETURN( PopIntegerTree () )
+ END
END
END PopKindTree ;
(*
- FoldConvert - attempts to fold op3 to type op2 placing the result into
- op1, providing that op1 and op3 are constants.
- Convert will, if need be, alter the machine representation
- of op3 to comply with TYPE op2.
+ FoldConvert - attempts to fold expr to type into result
+ providing that result and expr are constants.
+ If required convert will alter the machine representation
+ of expr to comply with type.
*)
PROCEDURE FoldConvert (tokenno: CARDINAL; p: WalkAction;
- quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+ quad: CARDINAL; result, type, expr: CARDINAL) ;
VAR
tl : tree ;
location: location_t ;
BEGIN
- location := TokenToLocation(tokenno) ;
- (* firstly ensure that constant literals are declared *)
- TryDeclareConstant(tokenno, op3) ;
- IF IsConstant(op3)
+ location := TokenToLocation (tokenno) ;
+ (* First ensure that constant literals are declared. *)
+ TryDeclareConstant (tokenno, expr) ;
+ IF IsConstant (expr)
THEN
- IF GccKnowsAbout(op2) AND
- (IsProcedure(op3) OR IsValueSolved(op3)) AND
- GccKnowsAbout(SkipType(op2))
+ IF GccKnowsAbout (type) AND
+ (IsProcedure (expr) OR IsValueSolved (expr)) AND
+ GccKnowsAbout (SkipType (type))
THEN
- (* fine, we can take advantage of this and fold constant *)
- IF IsConst(op1)
+ (* The type is known and expr is resolved so fold the convert. *)
+ IF IsConst (result)
THEN
- PutConst(op1, op2) ;
- tl := Mod2Gcc(SkipType(op2)) ;
- IF IsProcedure(op3)
+ PutConst (result, type) ; (* Change result type just in case. *)
+ tl := Mod2Gcc (SkipType (type)) ;
+ IF IsProcedure (expr)
THEN
- AddModGcc(op1, BuildConvert(location, tl, Mod2Gcc(op3), TRUE))
+ AddModGcc (result, BuildConvert (location, tl, Mod2Gcc (expr),
TRUE))
ELSE
- PushValue(op3) ;
- IF IsConstSet(op3)
+ PushValue (expr) ;
+ IF IsConstSet (expr)
THEN
- IF IsSet(SkipType(op2))
+ IF IsSet (SkipType (type))
THEN
- WriteFormat0('cannot convert values between sets')
+ WriteFormat0 ('cannot convert values between sets')
ELSE
- PushIntegerTree(FoldAndStrip(BuildConvert(location, tl,
PopSetTree(tokenno), TRUE))) ;
- PopValue(op1) ;
- PushValue(op1) ;
- AddModGcc(op1, PopIntegerTree())
+ PushIntegerTree (FoldAndStrip (BuildConvert (location,
tl, PopSetTree (tokenno), TRUE))) ;
+ PopValue (result) ;
+ PushValue (result) ;
+ AddModGcc (result, PopIntegerTree())
END
ELSE
- IF IsSet(SkipType(op2))
+ IF IsSet (SkipType (type))
THEN
- PushSetTree(tokenno,
- FoldAndStrip(BuildConvert(location, tl,
PopKindTree(op3, tokenno),
- TRUE)),
SkipType(op2)) ;
- PopValue(op1) ;
- PutConstSet(op1) ;
- PushValue(op1) ;
- AddModGcc(op1, PopSetTree(tokenno))
- ELSIF IsRealType(SkipType(op2))
+ PushSetTree (tokenno,
+ FoldAndStrip (BuildConvert (location, tl,
PopKindTree (expr, tokenno),
+ TRUE)), SkipType
(type)) ;
+ PopValue (result) ;
+ PutConstSet (result) ;
+ PushValue (result) ;
+ AddModGcc (result, PopSetTree (tokenno))
+ ELSIF IsRealType (SkipType (type))
THEN
- PushRealTree(FoldAndStrip(BuildConvert(location, tl,
PopKindTree(op3, tokenno),
- TRUE))) ;
- PopValue(op1) ;
- PushValue(op1) ;
- AddModGcc(op1, PopKindTree(op1, tokenno))
+ PushRealTree (FoldAndStrip (BuildConvert (location, tl,
PopKindTree (expr, tokenno),
+ TRUE))) ;
+ PopValue (result) ;
+ PushValue (result) ;
+ AddModGcc (result, PopKindTree (result, tokenno))
ELSE
- (* we let CheckOverflow catch a potential overflow rather
than BuildConvert *)
- PushIntegerTree(FoldAndStrip(BuildConvert(location, tl,
-
PopKindTree(op3, tokenno),
- FALSE))) ;
- PopValue(op1) ;
- PushValue(op1) ;
- CheckOrResetOverflow(tokenno, PopKindTree(op1, tokenno),
MustCheckOverflow(quad)) ;
- PushValue(op1) ;
- AddModGcc(op1, PopKindTree(op1, tokenno))
+ (* Let CheckOverflow catch a potential overflow rather
than BuildConvert. *)
+ PushIntegerTree (FoldAndStrip (BuildConvert (location, tl,
+ PopKindTree
(expr, tokenno),
+ FALSE))) ;
+ PopValue (result) ;
+ PushValue (result) ;
+ CheckOrResetOverflow (tokenno, PopKindTree (result,
tokenno), MustCheckOverflow (quad)) ;
+ PushValue (result) ;
+ AddModGcc (result, PopKindTree (result, tokenno))
END
END
END ;
- p(op1) ;
+ p (result) ;
NoChange := FALSE ;
- SubQuad(quad)
+ SubQuad (quad)
END
END
END
diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod
b/gcc/m2/gm2-compiler/SymbolTable.mod
index a502fb576411..56a04a9106a8 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -26,6 +26,7 @@ FROM SYSTEM IMPORT ADDRESS, ADR ;
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM M2Debug IMPORT Assert ;
FROM libc IMPORT printf ;
+FROM ASCII IMPORT nul ;
IMPORT Indexing ;
@@ -14958,12 +14959,15 @@ BEGIN
CASE SymbolType OF
ConstStringSym: WITH ConstString DO
- IF Length = 1
+ IF Length = 0
+ THEN
+ PushChar (nul)
+ ELSIF Length = 1
THEN
GetKey (Contents, a) ;
PushChar (a[0])
ELSE
- WriteFormat0 ('ConstString must be length 1')
+ WriteFormat0 ('ConstString must be length 0 or 1')
END
END
diff --git a/gcc/testsuite/gm2/pim/pass/forloopnulchar.mod
b/gcc/testsuite/gm2/pim/pass/forloopnulchar.mod
new file mode 100644
index 000000000000..a20dc4e884b7
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/forloopnulchar.mod
@@ -0,0 +1,8 @@
+MODULE forloopnulchar ;
+
+VAR
+ ch: CHAR ;
+BEGIN
+ FOR ch := '' TO 'z' DO
+ END
+END forloopnulchar.
diff --git a/gcc/testsuite/gm2/pim/pass/nulcharcase.mod
b/gcc/testsuite/gm2/pim/pass/nulcharcase.mod
new file mode 100644
index 000000000000..9d3bbdcf1945
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/nulcharcase.mod
@@ -0,0 +1,16 @@
+MODULE nulcharcase ;
+
+FROM libc IMPORT printf ;
+
+VAR
+ ch: CHAR;
+BEGIN
+ ch := '';
+ CASE ch OF
+
+ '' : printf ("null char seen\n") |
+ '1': printf ("1\n")
+
+ ELSE
+ END
+END nulcharcase.
diff --git a/gcc/testsuite/gm2/pim/pass/nulcharvar.mod
b/gcc/testsuite/gm2/pim/pass/nulcharvar.mod
new file mode 100644
index 000000000000..846cbe6b588a
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/nulcharvar.mod
@@ -0,0 +1,7 @@
+MODULE nulcharvar ;
+
+VAR
+ ch: CHAR ;
+BEGIN
+ ch := ''
+END nulcharvar.
