decl.c (gnat_to_gnu_entity): Constify a handful of local variables.

	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Constify
	a handful of local variables.
	For a derived untagged type that renames discriminants, change the type
	of the stored discriminants to a subtype with the bounds of the type
	of the visible discriminants.
	(build_subst_list): Rename local variable.

From-SVN: r199279

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 2c10c68653c23fd555a98611efe1c2466414123b..d7e6209746a51434a165340f2c6a4fb0c0766efc 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2013-05-24  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Constify
+       a handful of local variables.
+       For a derived untagged type that renames discriminants, change the type
+       of the stored discriminants to a subtype with the bounds of the type
+       of the visible discriminants.
+       (build_subst_list): Rename local variable.
+
 2013-05-16  Jason Merrill  <jason@redhat.com>
 
        * gcc-interface/Make-lang.in (gnat1$(exeext)): Use link mutex.

diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 98653243b8080326a59529c5844bb7e30722c026..b859731231c6096237db5ec79b9f2fb089140cae 100644 (file)
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -2913,10 +2913,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
       {
        Node_Id full_definition = Declaration_Node (gnat_entity);
        Node_Id record_definition = Type_Definition (full_definition);
+       Node_Id gnat_constr;
        Entity_Id gnat_field;
-       tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
+       tree gnu_field, gnu_field_list = NULL_TREE;
+       tree gnu_get_parent;
        /* Set PACKED in keeping with gnat_to_gnu_field.  */
-       int packed
+       const int packed
          = Is_Packed (gnat_entity)
            ? 1
            : Component_Alignment (gnat_entity) == Calign_Storage_Unit
@@ -2926,13 +2928,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
                     && Known_RM_Size (gnat_entity)))
                ? -2
                : 0;
-       bool has_discr = Has_Discriminants (gnat_entity);
-       bool has_rep = Has_Specified_Layout (gnat_entity);
-       bool all_rep = has_rep;
-       bool is_extension
+       const bool has_discr = Has_Discriminants (gnat_entity);
+       const bool has_rep = Has_Specified_Layout (gnat_entity);
+       const bool is_extension
          = (Is_Tagged_Type (gnat_entity)
             && Nkind (record_definition) == N_Derived_Type_Definition);
-       bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
+       const bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
+       bool all_rep = has_rep;
 
        /* See if all fields have a rep clause.  Stop when we find one
           that doesn't.  */
@@ -3171,6 +3173,51 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
                }
            }
 
+       /* If we have a derived untagged type that renames discriminants in
+          the root type, the (stored) discriminants are a just copy of the
+          discriminants of the root type.  This means that any constraints
+          added by the renaming in the derivation are disregarded as far
+          as the layout of the derived type is concerned.  To rescue them,
+          we change the type of the (stored) discriminants to a subtype
+          with the bounds of the type of the visible discriminants.  */
+       if (has_discr
+           && !is_extension
+           && Stored_Constraint (gnat_entity) != No_Elist)
+         for (gnat_constr = First_Elmt (Stored_Constraint (gnat_entity));
+              gnat_constr != No_Elmt;
+              gnat_constr = Next_Elmt (gnat_constr))
+           if (Nkind (Node (gnat_constr)) == N_Identifier
+               /* Ignore access discriminants.  */
+               && !Is_Access_Type (Etype (Node (gnat_constr)))
+               && Ekind (Entity (Node (gnat_constr))) == E_Discriminant)
+             {
+               Entity_Id gnat_discr = Entity (Node (gnat_constr));
+               tree gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
+               tree gnu_ref
+                 = gnat_to_gnu_entity (Original_Record_Component (gnat_discr),
+                                       NULL_TREE, 0);
+
+               /* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
+                  just above for one of the stored discriminants.  */
+               gcc_assert (TREE_TYPE (TREE_OPERAND (gnu_ref, 0)) == gnu_type);
+
+               if (gnu_discr_type != TREE_TYPE (gnu_ref))
+                 {
+                   const unsigned prec = TYPE_PRECISION (TREE_TYPE (gnu_ref));
+                   tree gnu_subtype
+                     = TYPE_UNSIGNED (TREE_TYPE (gnu_ref))
+                       ? make_unsigned_type (prec) : make_signed_type (prec);
+                   TREE_TYPE (gnu_subtype) = TREE_TYPE (gnu_ref);
+                   TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
+                   SET_TYPE_RM_MIN_VALUE (gnu_subtype,
+                                          TYPE_MIN_VALUE (gnu_discr_type));
+                   SET_TYPE_RM_MAX_VALUE (gnu_subtype,
+                                          TYPE_MAX_VALUE (gnu_discr_type));
+                   TREE_TYPE (gnu_ref)
+                     = TREE_TYPE (TREE_OPERAND (gnu_ref, 1)) = gnu_subtype;
+                 }
+             }
+
        /* Add the fields into the record type and finish it up.  */
        components_to_record (gnu_type, Component_List (record_definition),
                              gnu_field_list, packed, definition, false,
@@ -5969,7 +6016,7 @@ elaborate_entity (Entity_Id gnat_entity)
               Present (gnat_field);
               gnat_field = Next_Discriminant (gnat_field),
               gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
-           /* ??? For now, ignore access discriminants.  */
+           /* Ignore access discriminants.  */
            if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
              elaborate_expression (Node (gnat_discriminant_expr),
                                    gnat_entity, get_entity_name (gnat_field),
@@ -7623,20 +7670,20 @@ build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
 {
   vec<subst_pair> gnu_list = vNULL;
   Entity_Id gnat_discrim;
-  Node_Id gnat_value;
+  Node_Id gnat_constr;
 
   for (gnat_discrim = First_Stored_Discriminant (gnat_type),
-       gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
+       gnat_constr = First_Elmt (Stored_Constraint (gnat_subtype));
        Present (gnat_discrim);
        gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
-       gnat_value = Next_Elmt (gnat_value))
+       gnat_constr = Next_Elmt (gnat_constr))
     /* Ignore access discriminants.  */
-    if (!Is_Access_Type (Etype (Node (gnat_value))))
+    if (!Is_Access_Type (Etype (Node (gnat_constr))))
       {
        tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
        tree replacement = convert (TREE_TYPE (gnu_field),
                                    elaborate_expression
-                                   (Node (gnat_value), gnat_subtype,
+                                   (Node (gnat_constr), gnat_subtype,
                                     get_entity_name (gnat_discrim),
                                     definition, true, false));
        subst_pair s = {gnu_field, replacement};

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 521873ceacd66b8ad2b1aa531087ecd30fc50ae0..f9ef3c062a7e79cb79b609d06e5131bc2ce26c9d 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2013-05-24  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gnat.dg/derived_type4.adb: New test.
+
 2013-05-24  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gcc.dg/builtin-bswap-6.c: New test.

diff --git a/gcc/testsuite/gnat.dg/derived_type4.adb b/gcc/testsuite/gnat.dg/derived_type4.adb
new file mode 100644 (file)
index 0000000..22c41ec
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/derived_type4.adb
@@ -0,0 +1,16 @@
+-- { dg-do compile }
+
+procedure Derived_Type4 is
+
+  type Root (D : Positive) is record
+     S : String (1 .. D);
+  end record;
+
+  subtype Short is Positive range 1 .. 10;
+  type Derived (N : Short := 1) is new Root (D => N);
+
+  Obj : Derived;
+
+begin
+  Obj := (N => 5, S => "Hello");
+end;