Patchwork [Ada] Use discriminant subtype constraints in derivation

login
register
mail settings
Submitter Eric Botcazou
Date May 24, 2013, 8:29 a.m.
Message ID <3074629.FtM1CVYSgb@polaris>
Download mbox | patch
Permalink /patch/246107/
State New
Headers show

Comments

Eric Botcazou - May 24, 2013, 8:29 a.m.
With the attached change, the compiler willl now take into account the subtype 
constraints added by renaming discriminants in the derivation of untagged 
discriminated types to determine the size of mutable objects of the derived 
types, instead of using the same size as for the root type.

Tested on x86_64-suse-linux, applied on the mainline.


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-24  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/derived_type4.adb: New test.

Patch

Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c	(revision 199275)
+++ gcc-interface/decl.c	(working copy)
@@ -2913,10 +2913,12 @@  gnat_to_gnu_entity (Entity_Id gnat_entit
       {
 	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_entit
 		     && 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_entit
 		}
 	    }
 
+	/* 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
 {
   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};