[gcc r14-4560] modula2: Narrow subranges to int or unsigned int if ZTYPE is the base type.

[gcc r14-4560] modula2: Narrow subranges to int or unsigned int if ZTYPE is the base type.

[Gaius Mulley]

https://gcc.gnu.org/g:acfca27eaf4960069f7a49039f1407b956669ec1

commit r14-4560-gacfca27eaf4960069f7a49039f1407b956669ec1
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date:   Wed Oct 11 17:44:35 2023 +0100

    modula2: Narrow subranges to int or unsigned int if ZTYPE is the base type.
    
    This patch narrows the subrange base type to INTEGER or CARDINAL
    providing the range is satisfied.  It only does this when the subrange
    base type is the ZTYPE.
    
    gcc/m2/ChangeLog:
    
            * gm2-compiler/M2GCCDeclare.mod (DeclareSubrange): Check
            the base type of the subrange against the ZTYPE and call
            DeclareSubrangeNarrow if necessary.
            (DeclareSubrangeNarrow): New procedure function.
    
    Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>

Diff:
---
 gcc/m2/gm2-compiler/M2GCCDeclare.mod | 69 ++++++++++++++++++++++++++++--------
 1 file changed, 54 insertions(+), 15 deletions(-)

diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index c8c390ca122..a16e59d7670 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -156,8 +156,6 @@ FROM m2decl IMPORT BuildIntegerConstant, BuildStringConstant, BuildCStringConsta
                    BuildStartFunctionDeclaration,
                    BuildParameterDeclaration, BuildEndFunctionDeclaration,
                    DeclareKnownVariable, GetBitsPerBitset, BuildPtrToTypeString ;
-(*                   DeclareM2linkStaticInitialization,
-                   DeclareM2linkForcedModuleInitOrder ; *)
 
 FROM m2type IMPORT MarkFunctionReferenced, BuildStartRecord, BuildStartVarient, BuildStartFunctionType,
                    BuildStartFieldVarient, BuildStartVarient, BuildStartType, BuildStartArrayType,
@@ -181,12 +179,13 @@ FROM m2type IMPORT MarkFunctionReferenced, BuildStartRecord, BuildStartVarient,
                    BuildEndFieldVarient, BuildArrayIndexType, BuildEndFunctionType,
                    BuildSetType, BuildEndVarient, BuildEndArrayType, InitFunctionTypeParameters,
                    BuildProcTypeParameterDeclaration, DeclareKnownType,
-                   ValueOutOfTypeRange, ExceedsTypeRange ;
+                   ValueOutOfTypeRange, ExceedsTypeRange,
+                   GetMaxFrom, GetMinFrom ;
 
 FROM m2convert IMPORT BuildConvert ;
 
 FROM m2expr IMPORT BuildSub, BuildLSL, BuildTBitSize, BuildAdd, BuildDivTrunc, BuildModTrunc,
-                   BuildSize, TreeOverflow, AreConstantsEqual,
+                   BuildSize, TreeOverflow, AreConstantsEqual, CompareTrees,
                    GetPointerZero, GetIntegerZero, GetIntegerOne ;
 
 FROM m2block IMPORT RememberType, pushGlobalScope, popGlobalScope, pushFunctionScope, popFunctionScope,
@@ -3510,6 +3509,44 @@ BEGIN
 END DeclareEnumeration ;
 
 
+(*
+   DeclareSubrangeNarrow - will return cardinal, integer, or type depending on whether
+                           low..high fits in the C data type.
+*)
+
+PROCEDURE DeclareSubrangeNarrow (location: location_t;
+                                 high, low: CARDINAL; type: Tree) : Tree ;
+VAR
+   m2low, m2high,
+   lowtree,
+   hightree     : Tree ;
+BEGIN
+   (* No zero alignment, therefore the front end will prioritize subranges to match
+      unsigned int, int, or ZTYPE assuming the low..high range fits.  *)
+   lowtree := Mod2Gcc (low) ;
+   hightree := Mod2Gcc (high) ;
+   IF CompareTrees (lowtree, GetIntegerZero (location)) >= 0
+   THEN
+      (* low..high is always positive, can we use unsigned int?  *)
+      m2high := GetMaxFrom (location, GetM2CardinalType ()) ;
+      IF CompareTrees (hightree, m2high) <= 0
+      THEN
+         RETURN GetM2CardinalType ()
+      END
+   ELSE
+      (* Must be a signed subrange base, can we use int?  *)
+      m2high := GetMaxFrom (location, GetM2IntegerType ()) ;
+      m2low := GetMinFrom (location, GetM2IntegerType ()) ;
+      IF (CompareTrees (lowtree, m2low) >= 0) AND (CompareTrees (hightree, m2high) <= 0)
+      THEN
+         RETURN GetM2IntegerType ()
+      END
+   END ;
+   (* Fall back to the ZType.  *)
+   RETURN type
+END DeclareSubrangeNarrow ;
+
+
 (*
    DeclareSubrange - declare a subrange type.
 *)
@@ -3525,6 +3562,7 @@ BEGIN
    location := TokenToLocation (GetDeclaredMod (sym)) ;
    GetSubrange (sym, high, low) ;
    align := GetAlignment (sym) ;
+   type := Mod2Gcc (GetSType (sym)) ;
    IF align # NulSym
    THEN
       IF AreConstantsEqual (GetIntegerZero (location), Mod2Gcc (align))
@@ -3532,11 +3570,12 @@ BEGIN
          type := BuildSmallestTypeRange (location, Mod2Gcc (low), Mod2Gcc (high))
       ELSE
          MetaError1 ('a non-zero alignment in a subrange type {%1Wa} is currently not implemented and will be ignored',
-                     sym) ;
-         type := Mod2Gcc (GetSType (sym))
+                     sym)
       END
-   ELSE
-      type := Mod2Gcc (GetSType (sym))
+   ELSIF GetSType (sym) = ZType
+   THEN
+      (* Can we narrow the ZType subrange to CARDINAL or INTEGER?  *)
+      type := DeclareSubrangeNarrow (location, high, low, type)
    END ;
    gccsym := BuildSubrangeType (location,
                                 KeyToCharStar (GetFullSymName (sym)),
@@ -3553,18 +3592,18 @@ PROCEDURE IncludeGetNth (l: List; sym: CARDINAL) ;
 VAR
    i: CARDINAL ;
 BEGIN
-   printf0(' ListOfSons [') ;
+   printf0 (' ListOfSons [') ;
    i := 1 ;
-   WHILE GetNth(sym, i)#NulSym DO
+   WHILE GetNth (sym, i) # NulSym DO
       IF i>1
       THEN
-         printf0(', ') ;
+         printf0 (', ')
       END ;
-      IncludeItemIntoList(l, GetNth(sym, i)) ;
-      PrintTerse(GetNth(sym, i)) ;
-      INC(i)
+      IncludeItemIntoList (l, GetNth(sym, i)) ;
+      PrintTerse (GetNth (sym, i)) ;
+      INC (i)
    END ;
-   printf0(']')
+   printf0 (']')
 END IncludeGetNth ;