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 <gaiusmod2@gmail.com>
This commit is contained in:
Gaius Mulley
parent
b26d92f4f7
commit
e0ab8816ea
7 changed files with 231 additions and 92 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
IF IsConst (op) AND IsConstString (op)
|
||||
THEN
|
||||
RETURN( PopSetTree (tokenno) )
|
||||
ELSIF IsRealType (type)
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
8
gcc/testsuite/gm2/pim/pass/forloopnulchar.mod
Normal file
8
gcc/testsuite/gm2/pim/pass/forloopnulchar.mod
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
MODULE forloopnulchar ;
|
||||
|
||||
VAR
|
||||
ch: CHAR ;
|
||||
BEGIN
|
||||
FOR ch := '' TO 'z' DO
|
||||
END
|
||||
END forloopnulchar.
|
||||
16
gcc/testsuite/gm2/pim/pass/nulcharcase.mod
Normal file
16
gcc/testsuite/gm2/pim/pass/nulcharcase.mod
Normal file
|
|
@ -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.
|
||||
7
gcc/testsuite/gm2/pim/pass/nulcharvar.mod
Normal file
7
gcc/testsuite/gm2/pim/pass/nulcharvar.mod
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
MODULE nulcharvar ;
|
||||
|
||||
VAR
|
||||
ch: CHAR ;
|
||||
BEGIN
|
||||
ch := ''
|
||||
END nulcharvar.
|
||||
Loading…
Add table
Reference in a new issue