PR modula2/111675 Incorrect packed record field value passed to a procedure

This patch allows a packed field to be extracted and passed to a
procedure.  It ensures that the subrange type is the same for both the
procedure and record field.  It also extends the <* bytealignment (0) *>
to cover packed subrange types.

gcc/m2/ChangeLog:

	PR modula2/111675
	* gm2-compiler/M2CaseList.mod (appendTree): Replace
	InitStringCharStar with InitString.
	* gm2-compiler/M2GCCDeclare.mod: Import AreConstantsEqual.
	(DeclareSubrange): Add zero alignment test and call
	BuildSmallestTypeRange if necessary.
	(WalkSubrangeDependants): Walk the align expression.
	(IsSubrangeDependants): Test the align expression.
	* gm2-compiler/M2Quads.mod (BuildStringAdrParam): Correct end name.
	* gm2-compiler/P2SymBuild.mod (BuildTypeAlignment): Allow subranges
	to be zero aligned (packed).
	* gm2-compiler/SymbolTable.mod (Subrange): Add Align field.
	(MakeSubrange): Set Align to NulSym.
	(PutAlignment): Assign Subrange.Align to align.
	(GetAlignment): Return Subrange.Align.
	* gm2-gcc/m2expr.cc (noBitsRequired): Rewrite.
	(calcNbits): Rename ...
	(m2expr_calcNbits): ... to this and test for negative values.
	(m2expr_BuildTBitSize): Replace calcNBits with m2expr_calcNbits.
	* gm2-gcc/m2expr.def (calcNbits): Export.
	* gm2-gcc/m2expr.h (m2expr_calcNbits): New prototype.
	* gm2-gcc/m2type.cc (noBitsRequired): Remove.
	(m2type_BuildSmallestTypeRange): Call m2expr_calcNbits.
	(m2type_BuildSubrangeType): Create range_type from
	build_range_type (type, lowval, highval).

gcc/testsuite/ChangeLog:

	PR modula2/111675
	* gm2/extensions/run/pass/packedrecord3.mod: New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>

diff --git a/gcc/m2/gm2-compiler/M2CaseList.mod b/gcc/m2/gm2-compiler/M2CaseList.mod
index b7155e306924a1c162b5f5db9009a74cc263ecdc..9a5dab4ea9df90ce0a10380573f36be72e8938a5 100644 (file)
--- a/gcc/m2/gm2-compiler/M2CaseList.mod
+++ b/gcc/m2/gm2-compiler/M2CaseList.mod
@@ -975,7 +975,7 @@ BEGIN
              appendString (InitStringChar ("'"))
           END
        ELSE
-          appendString (InitStringCharStar ('CHR (')) ;
+          appendString (InitString ('CHR (')) ;
           appendString (InitStringCharStar (CSTIntToString (value))) ;
           appendString (InitStringChar (')'))
        END

diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index 87ca0da1eafc54f72a598a2ca220aef46260f347..c8c390ca122fd23c6d769c52c3f5e66f9ff3452a 100644 (file)
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -186,7 +186,7 @@ FROM m2type IMPORT MarkFunctionReferenced, BuildStartRecord, BuildStartVarient,
 FROM m2convert IMPORT BuildConvert ;
 
 FROM m2expr IMPORT BuildSub, BuildLSL, BuildTBitSize, BuildAdd, BuildDivTrunc, BuildModTrunc,
-                   BuildSize, TreeOverflow,
+                   BuildSize, TreeOverflow, AreConstantsEqual,
                    GetPointerZero, GetIntegerZero, GetIntegerOne ;
 
 FROM m2block IMPORT RememberType, pushGlobalScope, popGlobalScope, pushFunctionScope, popFunctionScope,
@@ -3518,15 +3518,28 @@ PROCEDURE DeclareSubrange (sym: CARDINAL) : Tree ;
 VAR
    type,
    gccsym   : Tree ;
+   align,
    high, low: CARDINAL ;
    location: location_t ;
 BEGIN
    location := TokenToLocation (GetDeclaredMod (sym)) ;
    GetSubrange (sym, high, low) ;
-   (* type := BuildSmallestTypeRange (location, Mod2Gcc(low), Mod2Gcc(high)) ; *)
-   type := Mod2Gcc (GetSType (sym)) ;
+   align := GetAlignment (sym) ;
+   IF align # NulSym
+   THEN
+      IF AreConstantsEqual (GetIntegerZero (location), Mod2Gcc (align))
+      THEN
+         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))
+      END
+   ELSE
+      type := Mod2Gcc (GetSType (sym))
+   END ;
    gccsym := BuildSubrangeType (location,
-                                KeyToCharStar (GetFullSymName(sym)),
+                                KeyToCharStar (GetFullSymName (sym)),
                                 type, Mod2Gcc (low), Mod2Gcc (high)) ;
    RETURN gccsym
 END DeclareSubrange ;
@@ -5314,8 +5327,8 @@ END WalkEnumerationDependants ;
 
 PROCEDURE WalkSubrangeDependants (sym: CARDINAL; p: WalkAction) ;
 VAR
-   type,
-   high, low: CARDINAL ;
+   type, align,
+   high, low  : CARDINAL ;
 BEGIN
    GetSubrange(sym, high, low) ;
    CheckResolveSubrange (sym) ;
@@ -5326,7 +5339,12 @@ BEGIN
    END ;
    (* low and high are not types but constants and they are resolved by M2GenGCC *)
    p(low) ;
-   p(high)
+   p(high) ;
+   align := GetAlignment (sym) ;
+   IF align # NulSym
+   THEN
+      p(align)
+   END
 END WalkSubrangeDependants ;
 
 
@@ -5338,6 +5356,7 @@ END WalkSubrangeDependants ;
 PROCEDURE IsSubrangeDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
 VAR
    result   : BOOLEAN ;
+   align,
    type,
    high, low: CARDINAL ;
 BEGIN
@@ -5358,6 +5377,11 @@ BEGIN
    THEN
       result := FALSE
    END ;
+   align := GetAlignment(sym) ;
+   IF (align#NulSym) AND (NOT q(align))
+   THEN
+      result := FALSE
+   END ;
    RETURN( result )
 END IsSubrangeDependants ;
 

diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index f3a5c05a15a8e319fb53efd6bc412507ad419f51..02a7db4efc2755393cf70a96d2703bdbdbe4f5ab 100644 (file)
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -2594,7 +2594,7 @@ BEGIN
    PushTtok (m2strnul, tok) ;
    PushT (1) ;
    BuildAdrFunction
-END BuildAdrFunction ;
+END BuildStringAdrParam ;
 
 
 (*

diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod
index 71f6b1c82c68ecb5ff6c701350fc5547da90cc0c..a2e3eb1cce9b3172ec9d4224d485d83ad8790406 100644 (file)
--- a/gcc/m2/gm2-compiler/P2SymBuild.mod
+++ b/gcc/m2/gm2-compiler/P2SymBuild.mod
@@ -1018,25 +1018,26 @@ VAR
    type,
    align    : CARDINAL ;
 BEGIN
-   PopT(alignment) ;
-   IF alignment=MakeKey('bytealignment')
+   PopT (alignment) ;
+   IF alignment = MakeKey ('bytealignment')
    THEN
-      PopT(align) ;
-      PopT(type) ;
-      IF align#NulSym
+      PopT (align) ;
+      PopT (type) ;
+      IF align # NulSym
       THEN
-         IF IsRecord(type) OR IsRecordField(type) OR IsType(type) OR IsArray(type) OR IsPointer(type)
+         IF IsRecord (type) OR IsRecordField (type) OR IsType (type) OR
+            IsArray (type) OR IsPointer( type) OR IsSubrange (type)
          THEN
-            PutAlignment(type, align)
+            PutAlignment (type, align)
          ELSE
-            MetaError1('not allowed to add an alignment attribute to type {%1ad}', type)
+            MetaError1 ('not allowed to add an alignment attribute to type {%1ad}', type)
          END
       END
-   ELSIF alignment#NulName
+   ELSIF alignment # NulName
    THEN
-      WriteFormat1('unknown type alignment attribute, %a', alignment)
+      WriteFormat1 ('unknown type alignment attribute, %a', alignment)
    ELSE
-      PopT(type)
+      PopT (type)
    END
 END BuildTypeAlignment ;
 

diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod
index dc41c1255254559083be9a2139d2d9faeb7b7832..2414517dd3d7ab03198e2f63d76836078cbc349e 100644 (file)
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -280,6 +280,7 @@ TYPE
                     Size        : PtrToValue ; (* Size of subrange type.      *)
                     Type        : CARDINAL ;   (* Index to type symbol for    *)
                                                (* the type of subrange.       *)
+                    Align       : CARDINAL ;   (* Alignment for this type.    *)
                     ConstLitTree: SymbolTree ; (* constants of this type.     *)
                     packedInfo  : PackedInfo ; (* the equivalent packed type  *)
                     oafamily    : CARDINAL ;   (* The oafamily for this sym   *)
@@ -6152,6 +6153,7 @@ BEGIN
                                         (* ConstExpression.              *)
             Type := NulSym ;            (* Index to a type. Determines   *)
                                         (* the type of subrange.         *)
+            Align := NulSym ;           (* The alignment of this type.   *)
             InitPacked(packedInfo) ;    (* not packed and no equivalent  *)
             InitTree(ConstLitTree) ;    (* constants of this type.       *)
             Size := InitValue() ;       (* Size determines the type size *)
@@ -14600,10 +14602,11 @@ BEGIN
       RecordFieldSym:  RecordField.Align := align |
       TypeSym       :  Type.Align := align |
       ArraySym      :  Array.Align := align |
-      PointerSym    :  Pointer.Align := align
+      PointerSym    :  Pointer.Align := align |
+      SubrangeSym   :  Subrange.Align := align
 
       ELSE
-         InternalError ('expecting record, field, pointer, type or an array symbol')
+         InternalError ('expecting record, field, pointer, type, subrange or an array symbol')
       END
    END
 END PutAlignment ;
@@ -14628,10 +14631,11 @@ BEGIN
       ArraySym       :  RETURN( Array.Align ) |
       PointerSym     :  RETURN( Pointer.Align ) |
       VarientFieldSym:  RETURN( GetAlignment(VarientField.Parent) ) |
-      VarientSym     :  RETURN( GetAlignment(Varient.Parent) )
+      VarientSym     :  RETURN( GetAlignment(Varient.Parent) ) |
+      SubrangeSym    :  RETURN( Subrange.Align )
 
       ELSE
-         InternalError ('expecting record, field, pointer, type or an array symbol')
+         InternalError ('expecting record, field, pointer, type, subrange or an array symbol')
       END
    END
 END GetAlignment ;

diff --git a/gcc/m2/gm2-gcc/m2expr.cc b/gcc/m2/gm2-gcc/m2expr.cc
index 32222d2561585093ef8c3f1fbe16dd95de1ff6d5..bb56a572320b986cef39f1c5f35c61bf227eba9f 100644 (file)
--- a/gcc/m2/gm2-gcc/m2expr.cc
+++ b/gcc/m2/gm2-gcc/m2expr.cc
@@ -2758,13 +2758,10 @@ noBitsRequired (tree values)
 {
   int bits = tree_floor_log2 (values);
 
-  if (integer_pow2p (values))
-    return m2decl_BuildIntegerConstant (bits + 1);
-  else
-    return m2decl_BuildIntegerConstant (bits + 1);
+  return m2decl_BuildIntegerConstant (bits + 1);
 }
 
-/* getMax return the result of max(a, b).  */
+/* getMax return the result of max (a, b).  */
 
 static tree
 getMax (tree a, tree b)
@@ -2778,8 +2775,8 @@ getMax (tree a, tree b)
 /* calcNbits return the smallest number of bits required to
    represent: min..max.  */
 
-static tree
-calcNbits (location_t location, tree min, tree max)
+tree
+m2expr_calcNbits (location_t location, tree min, tree max)
 {
   int negative = false;
   tree t = testLimits (location, m2type_GetIntegerType (), min, max);
@@ -2832,7 +2829,7 @@ m2expr_BuildTBitSize (location_t location, tree type)
                                     TYPE_MAX_VALUE (type), false);
       min = m2convert_BuildConvert (location, m2type_GetIntegerType (),
                                     TYPE_MIN_VALUE (type), false);
-      return calcNbits (location, min, max);
+      return m2expr_calcNbits (location, min, max);
     case BOOLEAN_TYPE:
       return m2expr_GetIntegerOne (location);
     default:

diff --git a/gcc/m2/gm2-gcc/m2expr.def b/gcc/m2/gm2-gcc/m2expr.def
index e8027a6ca55b7a3c6c00806e888b63a8084ccd20..e1ae799a7dbf094fefebf19a1fd7ffd0b3819c71 100644 (file)
--- a/gcc/m2/gm2-gcc/m2expr.def
+++ b/gcc/m2/gm2-gcc/m2expr.def
@@ -721,4 +721,12 @@ PROCEDURE ConstantExpressionWarning (value: Tree) ;
 PROCEDURE BuildAddAddress (location: location_t; op1, op2: Tree) : Tree ;
 
 
+(*
+   calcNbits - return the smallest number of bits required to
+               represent: min..max.
+*)
+
+PROCEDURE calcNbits (location: location_t; min, max: Tree) : Tree ;
+
+
 END m2expr.

diff --git a/gcc/m2/gm2-gcc/m2expr.h b/gcc/m2/gm2-gcc/m2expr.h
index d15f00b58d6b11033d66adc44deabaa0dff9805c..bf5e0b81d575ac6ee9bb9bb7a568541d121cf15b 100644 (file)
--- a/gcc/m2/gm2-gcc/m2expr.h
+++ b/gcc/m2/gm2-gcc/m2expr.h
@@ -240,7 +240,7 @@ EXTERN tree m2expr_BuildAddAddress (location_t location, tree op1, tree op2);
 EXTERN tree m2expr_BuildRDiv (location_t location, tree op1, tree op2,
                               bool needconvert);
 EXTERN int m2expr_GetCstInteger (tree cst);
-
+EXTERN tree m2expr_calcNbits (location_t location, tree min, tree max);
 EXTERN void m2expr_init (location_t location);
 
 #undef EXTERN

diff --git a/gcc/m2/gm2-gcc/m2type.cc b/gcc/m2/gm2-gcc/m2type.cc
index 86edde50b729fa77e7c2856d8c88f586a824eb39..f6a0f073b4d7bd1463a8b6a7fa310e929e9899e1 100644 (file)
--- a/gcc/m2/gm2-gcc/m2type.cc
+++ b/gcc/m2/gm2-gcc/m2type.cc
@@ -894,22 +894,6 @@ m2type_GetCardinalAddressType (void)
   return m2_cardinal_address_type_node;
 }
 
-/* noBitsRequired returns the number of bits required to contain,
-   values.  How many bits are required to represent all numbers
-   between: 0..values-1 */
-
-static tree
-noBitsRequired (tree values)
-{
-  int bits = tree_floor_log2 (values);
-
-  if (integer_pow2p (values))
-    /* remember we start counting from zero.  */
-    return m2decl_BuildIntegerConstant (bits);
-  else
-    return m2decl_BuildIntegerConstant (bits + 1);
-}
-
 #if 0
 /* build_set_type creates a set type from the, domain, [low..high].
    The values low..high all have type, range_type.  */
@@ -1118,9 +1102,7 @@ m2type_BuildSmallestTypeRange (location_t location, tree low, tree high)
   m2assert_AssertLocation (location);
   low = fold (low);
   high = fold (high);
-  bits = fold (noBitsRequired (
-      m2expr_BuildAdd (location, m2expr_BuildSub (location, high, low, false),
-                       m2expr_GetIntegerOne (location), false)));
+  bits = fold (m2expr_calcNbits (location, low, high));
   return build_m2_specific_size_type (location, INTEGER_TYPE,
                                       TREE_INT_CST_LOW (bits),
                                       tree_int_cst_sgn (low) < 0);
@@ -2519,8 +2501,7 @@ m2type_BuildSubrangeType (location_t location, char *name, tree type,
     error ("high bound for the subrange has overflowed");
 
   /* First build a type with the base range.  */
-  range_type = build_range_type (type, TYPE_MIN_VALUE (type),
-                                TYPE_MAX_VALUE (type));
+  range_type = build_range_type (type, lowval, highval);
 
   TYPE_UNSIGNED (range_type) = TYPE_UNSIGNED (type);
 #if 0

diff --git a/gcc/testsuite/gm2/extensions/run/pass/packedrecord3.mod b/gcc/testsuite/gm2/extensions/run/pass/packedrecord3.mod
new file mode 100644 (file)
index 0000000..627f9b6
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/packedrecord3.mod
@@ -0,0 +1,49 @@
+MODULE packedrecord3 ;  (*!m2iso+gm2*)
+
+FROM libc IMPORT printf, exit ;
+
+TYPE
+   subrange = [0..63] <* bytealignment (0) *> ;
+
+   packedrec = RECORD
+                  <* bytealignment (0) *>
+                  bool: BOOLEAN ;
+                  col : (white, black) ;
+                  sub : subrange ;
+               END ;
+
+
+VAR
+   global: subrange ;
+   pr    : packedrec ;
+
+
+PROCEDURE test (s: subrange; level: CARDINAL) ;
+BEGIN
+   IF s # global
+   THEN
+      printf ("failed to pass %d into test\n", ORD (s)) ;
+      exit (1)
+   END ;
+   IF level > 0
+   THEN
+      test (s, level-1)
+   END
+END test ;
+
+
+BEGIN
+   IF SIZE (pr) # 1
+   THEN
+      printf ("test failed as SIZE (pr) should be 1 not %d\n", SIZE (pr)) ;
+      exit (1)
+   END ;
+   FOR global := MIN (subrange) TO MAX (subrange) DO
+      test (global, 2)
+   END ;
+   FOR global := MIN (subrange) TO MAX (subrange) DO
+      pr.bool := FALSE ;
+      pr.sub := global ;
+      test (pr.sub, 2)
+   END
+END packedrecord3.