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>

7 files changed, 231 insertions, 92 deletions

diff --git a/gcc/m2/gm2-compiler/M2CaseList.mod b/gcc/m2/gm2-compiler/M2CaseList.mod
index 7a889bd..7fcfe1b 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 ;
 
 
 (*
@@ -440,6 +521,26 @@ 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 2680faa..d084096 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 c5f5a78..5811c9d 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 a502fb5..56a04a9 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 0000000..a20dc4e
--- /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 0000000..9d3bbdc
--- /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 0000000..846cbe6
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/nulcharvar.mod
@@ -0,0 +1,7 @@
+MODULE nulcharvar ;
+
+VAR
+   ch: CHAR ;
+BEGIN
+   ch := ''
+END nulcharvar.