[Ada] Fix problems with deferred constants and address clauses

[Eric Botcazou <ebotcazou at adacore dot com>]

The Ada compiler accepts address clauses on deferred constants, e.g.

package P is

  C : constant Natural := 1;

  C2 : constant Natural;
  for C2'Address use C'Address;

private
  C2 : constant Natural := 1;

end P;

but it was not honoring them in all cases and was even ICEing on some 
particular form.  The attached patch should fix that by specializing
their handling in Gigi.

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


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 ?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.


-- 
Eric Botcazou

Index: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c	(revision 138440)
+++ gcc-interface/utils.c	(working copy)
@@ -3662,31 +3662,31 @@ update_pointer_to (tree old_type, tree n
     }
 }
 
-/* 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));
@@ -3702,30 +3702,31 @@ convert_to_fat_pointer (tree type, tree 
 			     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
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c	(revision 138440)
+++ gcc-interface/decl.c	(working copy)
@@ -367,12 +367,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
   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_entit
 	      != 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_entit
 	  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_entit
 	    && !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_entit
 	      || 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
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c	(revision 138424)
+++ gcc-interface/trans.c	(working copy)
@@ -3398,6 +3398,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;
@@ -4542,21 +4551,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:

-- { 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;

-- { 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;

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;

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;

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;

-- { 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;

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;