decl.c (gnat_to_gnu_entity): Remove dead code.

2008-08-01  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Constant>: Remove dead
	code.  Do not get full definition of deferred constants with address
	clause for a use.  Do not ignore deferred constant definitions with
	address clause.  Ignore constant definitions already marked with the
	error node.
	<object>: Remove obsolete comment.  For a deferred constant with
	address clause, get the initializer from the full view.
	* gcc-interface/trans.c (gnat_to_gnu) <N_Attribute_Definition_Clause>:
	Rework and remove obsolete comment.
	<N_Object_Declaration>: For a deferred constant with address clause,
	mark the full view with the error node.
	*  gcc-interface/utils.c (convert_to_fat_pointer): Rework and fix
	formatting nits.

From-SVN: r138513

gcc/ada/ChangeLog

+2008-08-01  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Constant>: Remove dead
+	code.  Do not get full definition of deferred constants with address
+	clause for a use.  Do not ignore deferred constant definitions with
+	address clause.  Ignore constant definitions already marked with the
+	error node.
+	<object>: Remove obsolete comment.  For a deferred constant with
+	address clause, get the initializer from the full view.
+	* gcc-interface/trans.c (gnat_to_gnu) <N_Attribute_Definition_Clause>:
+	Rework and remove obsolete comment.
+	<N_Object_Declaration>: For a deferred constant with address clause,
+	mark the full view with the error node.
+	* gcc-interface/utils.c (convert_to_fat_pointer): Rework and fix
+	formatting nits.
+
 2008-08-01  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* rtsfind.ads: Add block IO versions of stream routines for Strings.

gcc/ada/gcc-interface/decl.c

@@ -367,12 +367,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
   switch (kind)
     {
     case E_Constant:
-      /* If this is a use of a deferred constant, get its full
-	 declaration.  */
-      if (!definition && Present (Full_View (gnat_entity)))
+      /* If this is a use of a deferred constant without address clause,
+	 get its full definition.  */
+      if (!definition
+	  && No (Address_Clause (gnat_entity))
+	  && Present (Full_View (gnat_entity)))
 	{
-	  gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
-					 gnu_expr, 0);
+	  gnu_decl
+	    = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
 	  saved = true;
 	  break;
 	}
@@ -391,12 +393,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	      != N_Allocator))
 	gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
 
-      /* Ignore deferred constant definitions; they are processed fully in the
-	 front-end.  For deferred constant references get the full definition.
-	 On the other hand, constants that are renamings are handled like
-	 variable renamings.  If No_Initialization is set, this is not a
-	 deferred constant but a constant whose value is built manually.  */
-      if (definition && !gnu_expr
+      /* Ignore deferred constant definitions without address clause since
+	 they are processed fully in the front-end.  If No_Initialization
+	 is set, this is not a deferred constant but a constant whose value
+	 is built manually.  And constants that are renamings are handled
+	 like variables.  */
+      if (definition
+	  && !gnu_expr
+	  && No (Address_Clause (gnat_entity))
 	  && !No_Initialization (Declaration_Node (gnat_entity))
 	  && No (Renamed_Object (gnat_entity)))
 	{
@@ -404,12 +408,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	  saved = true;
 	  break;
 	}
-      else if (!definition && IN (kind, Incomplete_Or_Private_Kind)
-	       && Present (Full_View (gnat_entity)))
+
+      /* Ignore constant definitions already marked with the error node.  See
+	 the N_Object_Declaration case of gnat_to_gnu for the rationale.  */
+      if (definition
+	  && gnu_expr
+	  && present_gnu_tree (gnat_entity)
+	  && get_gnu_tree (gnat_entity) == error_mark_node)
 	{
-	  gnu_decl =  gnat_to_gnu_entity (Full_View (gnat_entity),
-					  NULL_TREE, 0);
-	  saved = true;
+	  maybe_present = true;
 	  break;
 	}
 
@@ -1037,17 +1044,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    && !Is_Imported (gnat_entity) && !gnu_expr)
 	  gnu_expr = integer_zero_node;
 
-	/* If we are defining the object and it has an Address clause we must
-	   get the address expression from the saved GCC tree for the
-	   object if the object has a Freeze_Node.  Otherwise, we elaborate
-	   the address expression here since the front-end has guaranteed
-	   in that case that the elaboration has no effects.  Note that
-	   only the latter mechanism is currently in use.  */
+	/* If we are defining the object and it has an Address clause, we must
+	   either get the address expression from the saved GCC tree for the
+	   object if it has a Freeze node, or elaborate the address expression
+	   here since the front-end has guaranteed that the elaboration has no
+	   effects in this case.  */
 	if (definition && Present (Address_Clause (gnat_entity)))
 	  {
 	    tree gnu_address
-	      = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity)
-		: gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
+	      = present_gnu_tree (gnat_entity)
+		? get_gnu_tree (gnat_entity)
+		: gnat_to_gnu (Expression (Address_Clause (gnat_entity)));
 
 	    save_gnu_tree (gnat_entity, NULL_TREE, false);
 
@@ -1064,6 +1071,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	      || compile_time_known_address_p (Expression (Address_Clause
 							   (gnat_entity)));
 
+	    /* If this is a deferred constant, the initializer is attached to
+	       the full view.  */
+	    if (kind == E_Constant && Present (Full_View (gnat_entity)))
+	      gnu_expr
+		= gnat_to_gnu
+		    (Expression (Declaration_Node (Full_View (gnat_entity))));
+
 	    /* If we don't have an initializing expression for the underlying
 	       variable, the initializing expression for the pointer is the
 	       specified address.  Otherwise, we have to make a COMPOUND_EXPR

gcc/ada/gcc-interface/trans.c

@@ -3397,6 +3397,15 @@ gnat_to_gnu (Node_Id gnat_node)
       if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
 	gnu_expr = NULL_TREE;
 
+      /* If this is a deferred constant with an address clause, we ignore the
+	 full view since the clause is on the partial view and we cannot have
+	 2 different GCC trees for the object.  The only bits of the full view
+	 we will use is the initializer, but it will be directly fetched.  */
+      if (Ekind(gnat_temp) == E_Constant
+	  && Present (Address_Clause (gnat_temp))
+	  && Present (Full_View (gnat_temp)))
+	save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
+
       if (No (Freeze_Node (gnat_temp)))
 	gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
       break;
@@ -4541,21 +4550,22 @@ gnat_to_gnu (Node_Id gnat_node)
     /***************************************************/
 
     case N_Attribute_Definition_Clause:
-
       gnu_result = alloc_stmt_list ();
 
-      /* The only one we need deal with is for 'Address.  For the others, SEM
-	 puts the information elsewhere.  We need only deal with 'Address
-	 if the object has a Freeze_Node (which it never will currently).  */
-      if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
-	  || No (Freeze_Node (Entity (Name (gnat_node)))))
+      /* The only one we need to deal with is 'Address since, for the others,
+	 the front-end puts the information elsewhere.  */
+      if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
+	break;
+
+      /* And we only deal with 'Address if the object has a Freeze node.  */
+      gnat_temp = Entity (Name (gnat_node));
+      if (No (Freeze_Node (gnat_temp)))
 	break;
 
-      /* Get the value to use as the address and save it as the
-	 equivalent for GNAT_TEMP.  When the object is frozen,
-	 gnat_to_gnu_entity will do the right thing. */
-      save_gnu_tree (Entity (Name (gnat_node)),
-                     gnat_to_gnu (Expression (gnat_node)), true);
+      /* Get the value to use as the address and save it as the equivalent
+	 for the object.  When it is frozen, gnat_to_gnu_entity will do the
+	 right thing.  */
+      save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
       break;
 
     case N_Enumeration_Representation_Clause:

gcc/ada/gcc-interface/utils.c

@@ -3869,31 +3869,31 @@ update_pointer_to (tree old_type, tree new_type)
     }
 }
 
-/* Convert a pointer to a constrained array into a pointer to a fat
-   pointer.  This involves making or finding a template.  */
+/* Convert EXPR, a pointer to a constrained array, into a pointer to an
+   unconstrained one.  This involves making or finding a template.  */
 
 static tree
 convert_to_fat_pointer (tree type, tree expr)
 {
   tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))));
-  tree template, template_addr;
+  tree p_array_type = TREE_TYPE (TYPE_FIELDS (type));
   tree etype = TREE_TYPE (expr);
+  tree template;
 
-  /* If EXPR is a constant of zero, we make a fat pointer that has a null
-     pointer to the template and array.  */
+  /* If EXPR is null, make a fat pointer that contains null pointers to the
+     template and array.  */
   if (integer_zerop (expr))
     return
       gnat_build_constructor
 	(type,
 	 tree_cons (TYPE_FIELDS (type),
-		    convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
+		    convert (p_array_type, expr),
 		    tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
 			       convert (build_pointer_type (template_type),
 					expr),
 			       NULL_TREE)));
 
-  /* If EXPR is a thin pointer, make the template and data from the record.  */
-
+  /* If EXPR is a thin pointer, make template and data from the record..  */
   else if (TYPE_THIN_POINTER_P (etype))
     {
       tree fields = TYPE_FIELDS (TREE_TYPE (etype));
@@ -3909,30 +3909,31 @@ convert_to_fat_pointer (tree type, tree expr)
 			     build_component_ref (expr, NULL_TREE,
 						  TREE_CHAIN (fields), false));
     }
+
+  /* Otherwise, build the constructor for the template.  */
   else
-    /* Otherwise, build the constructor for the template.  */
     template = build_template (template_type, TREE_TYPE (etype), expr);
 
-  template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
-
-  /* The result is a CONSTRUCTOR for the fat pointer.
+  /* The final result is a constructor for the fat pointer.
 
-     If expr is an argument of a foreign convention subprogram, the type it
-     points to is directly the component type. In this case, the expression
+     If EXPR is an argument of a foreign convention subprogram, the type it
+     points to is directly the component type.  In this case, the expression
      type may not match the corresponding FIELD_DECL type at this point, so we
-     call "convert" here to fix that up if necessary. This type consistency is
+     call "convert" here to fix that up if necessary.  This type consistency is
      required, for instance because it ensures that possible later folding of
-     component_refs against this constructor always yields something of the
+     COMPONENT_REFs against this constructor always yields something of the
      same type as the initial reference.
 
-     Note that the call to "build_template" above is still fine, because it
-     will only refer to the provided template_type in this case.  */
-   return
-     gnat_build_constructor
-     (type, tree_cons (TYPE_FIELDS (type),
- 		      convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
- 		      tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
- 				 template_addr, NULL_TREE)));
+     Note that the call to "build_template" above is still fine because it
+     will only refer to the provided TEMPLATE_TYPE in this case.  */
+  return
+    gnat_build_constructor
+      (type,
+       tree_cons (TYPE_FIELDS (type),
+		  convert (p_array_type, expr),
+		  tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
+			     build_unary_op (ADDR_EXPR, NULL_TREE, template),
+			     NULL_TREE)));
 }
 
 /* Convert to a thin pointer type, TYPE.  The only thing we know how to convert

gcc/testsuite/ChangeLog

+2008-08-01  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/deferred_const1.adb: New test.
+	* gnat.dg/deferred_const2.adb: Likewise.
+	* gnat.dg/deferred_const2_pkg.ad[sb]: New helper.
+	* gnat.dg/deferred_const3.adb: New test.
+	* gnat.dg/deferred_const3_pkg.ad[sb]: New helper.
+
 2008-08-01  Richard Guenther  <rguenther@suse.de>
 
 	PR tree-optimization/36988

gcc/testsuite/gnat.dg/deferred_const1.adb

+-- { dg-do compile }
+
+with Text_IO; use Text_IO;
+
+procedure Deferred_Const1 is
+  I : Integer := 16#20_3A_2D_28#;
+  S : constant string(1..4);
+  for S'address use I'address; -- { dg-warning "constant overlays a variable" } 
+  pragma Import (Ada, S);
+begin
+  Put_Line (S);
+end;

gcc/testsuite/gnat.dg/deferred_const2.adb

+-- { dg-do run }
+
+with System; use System;
+with Deferred_Const2_Pkg; use Deferred_Const2_Pkg;
+
+procedure Deferred_Const2 is
+begin
+  if I'Address /= S'Address then
+    raise Program_Error;
+  end if;
+end;

gcc/testsuite/gnat.dg/deferred_const2_pkg.adb

+with System; use System;
+
+package body Deferred_Const2_Pkg is
+
+  procedure Dummy is begin null; end;
+
+begin
+  if S'Address /= I'Address then
+    raise Program_Error;
+  end if;
+end Deferred_Const2_Pkg;

gcc/testsuite/gnat.dg/deferred_const2_pkg.ads

+package Deferred_Const2_Pkg is
+
+  I : Integer := 16#20_3A_2D_28#;
+
+  pragma Warnings (Off);
+  S : constant string(1..4);
+  for S'address use I'address;
+  pragma Import (Ada, S);
+
+  procedure Dummy;
+
+end Deferred_Const2_Pkg;

gcc/testsuite/gnat.dg/deferred_const3.adb

+-- { dg-do run }
+
+with System; use System;
+with Deferred_Const3_Pkg; use Deferred_Const3_Pkg;
+
+procedure Deferred_Const3 is
+begin
+  if C1'Address /= C'Address then
+    raise Program_Error;
+  end if;
+
+  if C2'Address /= C'Address then
+    raise Program_Error;
+  end if;
+
+  if C3'Address /= C'Address then
+    raise Program_Error;
+  end if;
+end;

gcc/testsuite/gnat.dg/deferred_const3_pkg.adb

+with System; use System;
+
+package body Deferred_Const3_Pkg is
+
+  procedure Dummy is begin null; end;
+
+begin
+  if C1'Address /= C'Address then
+    raise Program_Error;
+  end if;
+
+  if C2'Address /= C'Address then
+    raise Program_Error;
+  end if;
+
+  if C3'Address /= C'Address then
+    raise Program_Error;
+  end if;
+end Deferred_Const3_Pkg;

gcc/testsuite/gnat.dg/deferred_const3_pkg.ads

+package Deferred_Const3_Pkg is
+
+  C : constant Natural := 1;
+
+  C1 : constant Natural := 1;
+  for C1'Address use C'Address;
+
+  C2 : constant Natural;
+  for C2'Address use C'Address;
+
+  C3 : constant Natural;
+
+  procedure Dummy;
+
+private
+  C2 : constant Natural := 1;
+
+  C3 : constant Natural := 1;
+  for C3'Address use C'Address;
+
+end Deferred_Const3_Pkg;