re PR ada/19900 (ACATS c391002 c432002 ICE categorize_ctor_elements_1)

2005-03-08  Eric Botcazou  <ebotcazou@adacore.com>
	    Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>
	    Nicolas Setton  <setton@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	PR ada/19900
	PR ada/19408
	PR ada/19140
	PR ada/20255

	* decl.c (gnat_to_gnu_field): Reject aliased components with a
	representation clause that prescribes a size not equal to the rounded
	size of their types.
	(gnat_to_gnu_entity, case E_Component): Always look at
	Original_Record_Component if Present and not the entity.
	(gnat_to_gnu_entity, case E_Record_Subtype): Rework handling of subtypes
	of tagged extension types by not making field for components that are
	inside the parent.
	(gnat_to_gnu_entity) <E_Record_Type>: Fix typo in the alignment formula
	(gnat_to_gnu_entity) <E_Variable>: Do not convert again the
	expression to the type of the object when the object is constant.
	Reverse defer_debug_incomplete_list before traversing it, so that trees
	are processed in the order at which they were added to the list. This
	order is important when using the stabs debug format.
	If we are deferring the output of debug information, also defer this
	output for a function return type.
	When adding fields to a record, prevent emitting debug information
	for incomplete records, emit the information only when the record is
	complete.
	(components_to_record): New parameter defer_debug.
	(gnat_to_gnu_entity, case E_Array_Subtype): Call copy_alias_set.
	(gnat_to_gnu_field_decl): New function.
	(substitution_list, annotate_rep): Call it.
	(gnat_to_gnu_entity, case E_Record_Subtype): Likewise.
	(gnat_to_gnu_entity, case E_Record_Type): Likewise.
	No longer update discriminants to not be a COMPONENT_REF.
	(copy_alias_set): Strip padding from input type; also handle
	unconstrained arrays properly.

	* gigi.h (write_record_type_debug_info): New function.
	Convert to use ANSI-style prototypes. Remove unused
	declarations for emit_stack_check, elab_all_gnat and
	set_second_error_entity.
	(gnat_to_gnu_field_decl): New decl.

	* utils.c (write_record_type_debug_info): New function.
	(finish_record_type): Delegate generation of debug information to
	write_record_type_debug_info.
	(update_pointer_to): Remove unneeded calls to rest_of_decl_compilation.
	(update_pointer_to): Fix pasto.
	(convert) <UNION_TYPE>: Accept slight type variations when
	converting to an unchecked union type.

	* exp_ch13.adb (Expand_N_Freeze_Entity): If Freeze_Type returns True,
	replace the N_Freeze_Entity with a null statement.

	* freeze.adb (Freeze_Expression): If the freeze nodes are generated
	within a constrained subcomponent of an enclosing record, place the
	freeze nodes in the scope stack entry for the enclosing record.
	(Undelay_Type): New Subprogram.
	(Set_Small_Size): Pass T, the type to modify; all callers changed.
	(Freeze_Entity, Freeze_Record_Type): Change the way we handle types
	within records; allow them to have freeze nodes if their base types
	aren't frozen yet.

	* sem_ch3.adb (Derived_Type_Declaration): New predicate
	Comes_From_Generic, to recognize accurately that the parent type in a
	derived type declaration can be traced back to a formal type, because
	it is one or is derived from one, or because its completion is derived
	from one.
	(Constrain_Component_Type): If component comes from source and has no
	explicit constraint, no need to constrain in in a subtype of the
	enclosing record.
	(Constrain_Access, Constrain_Array): Allow itypes to be delayed.
	Minor change to propagate Is_Ada_2005 flag

	* trans.c (gnat_to_gnu, case N_Aggregate): Verify that
	Expansion_Delayed is False.
	(assoc_to_constructor): Ignore fields that have a
	Corresponding_Discriminant.
	(gnat_to_gnu) <N_Return_Statement>: Restructure. If the
	function returns "by target", dereference the target pointer using the
	type of the actual return value.
	<all>: Be prepared for a null gnu_result.
	(processed_inline_subprograms): Check flag_really_no_inline
	instead of flag_no_inline.
	(set_second_error_entity): Remove unused function.
	(gnat_to_gnu, case N_Selected_Component): Call
	gnat_to_gnu_field_decl.
	(assoc_to_constructor): Likewise.

From-SVN: r96492

gcc/ada/exp_ch13.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2004, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -243,6 +243,7 @@ package body Exp_Ch13 is
       In_Other_Scope : Boolean;
       In_Outer_Scope : Boolean;
       Decl           : Node_Id;
+      Delete         : Boolean := False;
 
    begin
       --  For object, with address clause, check alignment is OK
@@ -317,7 +318,7 @@ package body Exp_Ch13 is
       --  If type, freeze the type
 
       if Is_Type (E) then
-         Freeze_Type (N);
+         Delete := Freeze_Type (N);
 
          --  And for enumeration type, build the enumeration tables
 
@@ -388,6 +389,13 @@ package body Exp_Ch13 is
          end loop;
       end if;
 
+      --  If we are to delete this N_Freeze_Entity, do so by rewriting so that
+      --  a loop on all nodes being inserted will work propertly.
+
+      if Delete then
+         Rewrite (N, Make_Null_Statement (Sloc (N)));
+      end if;
+
       if In_Other_Scope then
          if Ekind (Current_Scope) = E_Package then
             End_Package_Scope (E_Scope);

gcc/ada/sem_ch3.adb

@@ -350,13 +350,13 @@ package body Sem_Ch3 is
    --  discriminant constraints for Typ.
 
    function Constrain_Component_Type
-     (Compon_Type     : Entity_Id;
+     (Comp            : Entity_Id;
       Constrained_Typ : Entity_Id;
       Related_Node    : Node_Id;
       Typ             : Entity_Id;
       Constraints     : Elist_Id) return Entity_Id;
    --  Given a discriminated base type Typ, a list of discriminant constraint
-   --  Constraints for Typ and the type of a component of Typ, Compon_Type,
+   --  Constraints for Typ and a component of Typ, with type Compon_Type,
    --  create and return the type corresponding to Compon_type where all
    --  discriminant references are replaced with the corresponding
    --  constraint. If no discriminant references occur in Compon_Typ then
@@ -2378,6 +2378,7 @@ package body Sem_Ch3 is
       Set_Is_Volatile       (Id, Is_Volatile       (T));
       Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
       Set_Is_Atomic         (Id, Is_Atomic         (T));
+      Set_Is_Ada_2005       (Id, Is_Ada_2005       (T));
 
       --  In the case where there is no constraint given in the subtype
       --  indication, Process_Subtype just returns the Subtype_Mark,
@@ -7374,12 +7375,7 @@ package body Sem_Ch3 is
       Set_Depends_On_Private       (Def_Id, Has_Private_Component (Def_Id));
       Set_Is_Access_Constant       (Def_Id, Is_Access_Constant (T));
 
-      --  Itypes created for constrained record components do not receive
-      --  a freeze node, they are elaborated when first seen.
-
-      if not Is_Record_Type (Current_Scope) then
-         Conditional_Delay (Def_Id, T);
-      end if;
+      Conditional_Delay (Def_Id, T);
    end Constrain_Access;
 
    ---------------------
@@ -7474,17 +7470,12 @@ package body Sem_Ch3 is
       Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
       Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
 
-      --  If the subtype is not that of a record component, build a freeze
-      --  node if parent still needs one.
-
-      --  If the subtype is not that of a record component, make sure
+      --  Build a freeze node if parent still needs one.  Also, make sure
       --  that the Depends_On_Private status is set (explanation ???)
       --  and also that a conditional delay is set.
 
-      if not Is_Type (Scope (Def_Id)) then
-         Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
-         Conditional_Delay (Def_Id, T);
-      end if;
+      Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
+      Conditional_Delay (Def_Id, T);
 
    end Constrain_Array;
 
@@ -7493,13 +7484,14 @@ package body Sem_Ch3 is
    ------------------------------
 
    function Constrain_Component_Type
-     (Compon_Type     : Entity_Id;
+     (Comp            : Entity_Id;
       Constrained_Typ : Entity_Id;
       Related_Node    : Node_Id;
       Typ             : Entity_Id;
       Constraints     : Elist_Id) return Entity_Id
    is
-      Loc : constant Source_Ptr := Sloc (Constrained_Typ);
+      Loc         : constant Source_Ptr := Sloc (Constrained_Typ);
+      Compon_Type : constant Entity_Id := Etype (Comp);
 
       function Build_Constrained_Array_Type
         (Old_Type : Entity_Id) return Entity_Id;
@@ -7876,7 +7868,17 @@ package body Sem_Ch3 is
    --  Start of processing for Constrain_Component_Type
 
    begin
-      if Is_Array_Type (Compon_Type) then
+      if Nkind (Parent (Comp)) = N_Component_Declaration
+        and then Comes_From_Source (Parent (Comp))
+        and then Comes_From_Source
+          (Subtype_Indication (Component_Definition (Parent (Comp))))
+        and then
+          Is_Entity_Name
+            (Subtype_Indication (Component_Definition (Parent (Comp))))
+      then
+         return Compon_Type;
+
+      elsif Is_Array_Type (Compon_Type) then
          return Build_Constrained_Array_Type (Compon_Type);
 
       elsif Has_Discriminants (Compon_Type) then
@@ -7884,9 +7886,10 @@ package body Sem_Ch3 is
 
       elsif Is_Access_Type (Compon_Type) then
          return Build_Constrained_Access_Type (Compon_Type);
-      end if;
 
-      return Compon_Type;
+      else
+         return Compon_Type;
+      end if;
    end Constrain_Component_Type;
 
    --------------------------
@@ -8723,7 +8726,7 @@ package body Sem_Ch3 is
             Set_Etype
               (New_C,
                Constrain_Component_Type
-                 (Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
+                 (Old_C, Subt, Decl_Node, Typ, Constraints));
             Set_Is_Public (New_C, Is_Public (Subt));
 
             Next_Elmt (Comp);
@@ -8875,7 +8878,7 @@ package body Sem_Ch3 is
             Set_Etype
               (New_C,
                Constrain_Component_Type
-                 (Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
+                 (Old_C, Subt, Decl_Node, Typ, Constraints));
             Set_Is_Public (New_C, Is_Public (Subt));
 
             Next_Component (Old_C);
@@ -9570,6 +9573,36 @@ package body Sem_Ch3 is
       Parent_Scope : Entity_Id;
       Taggd        : Boolean;
 
+      function Comes_From_Generic (Typ : Entity_Id) return Boolean;
+      --  Check whether the parent type is a generic formal, or derives
+      --  directly or indirectly from one.
+
+      ------------------------
+      -- Comes_From_Generic --
+      ------------------------
+
+      function Comes_From_Generic (Typ : Entity_Id) return Boolean is
+      begin
+         if Is_Generic_Type (Typ) then
+            return True;
+
+         elsif Is_Generic_Type (Root_Type (Parent_Type)) then
+            return True;
+
+         elsif Is_Private_Type (Typ)
+           and then Present (Full_View (Typ))
+           and then Is_Generic_Type (Root_Type (Full_View (Typ)))
+         then
+            return True;
+
+         elsif Is_Generic_Actual_Type (Typ) then
+            return True;
+
+         else
+            return False;
+         end if;
+      end Comes_From_Generic;
+
    begin
       Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
 
@@ -9645,9 +9678,7 @@ package body Sem_Ch3 is
          return;
 
       elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
-              and then not Is_Generic_Type (Parent_Type)
-              and then not Is_Generic_Type (Root_Type (Parent_Type))
-              and then not Is_Generic_Actual_Type (Parent_Type))
+              and then not Comes_From_Generic (Parent_Type))
         or else Has_Private_Component (Parent_Type)
       then
          --  The ancestor type of a formal type can be incomplete, in which
@@ -9666,7 +9697,7 @@ package body Sem_Ch3 is
               ("premature derivation of derived or private type", Indic);
 
             --  Flag the type itself as being in error, this prevents some
-            --  nasty problems with people looking at the malformed type.
+            --  nasty problems with subsequent uses of the malformed type.
 
             Set_Error_Posted (T);
 
@@ -10685,8 +10716,10 @@ package body Sem_Ch3 is
             then
                Set_Etype (New_C, Etype (Old_C));
             else
-               Set_Etype (New_C, Constrain_Component_Type (Etype (Old_C),
-                 Derived_Base, N, Parent_Base, Discs));
+               Set_Etype
+                 (New_C,
+                  Constrain_Component_Type
+                    (Old_C, Derived_Base, N, Parent_Base, Discs));
             end if;
          end if;
 

gcc/ada/trans.c

@@ -2956,7 +2956,7 @@ gnat_to_gnu (Node_Id gnat_node)
 				       NULL_TREE, gnu_prefix);
 	else
 	  {
-	    gnu_field = gnat_to_gnu_entity (gnat_field, NULL_TREE, 0);
+	    gnu_field = gnat_to_gnu_field_decl (gnat_field);
 
 	    /* If there are discriminants, the prefix might be
                evaluated more than once, which is a problem if it has
@@ -3013,6 +3013,8 @@ gnat_to_gnu (Node_Id gnat_node)
 	/* ??? It is wrong to evaluate the type now, but there doesn't
 	   seem to be any other practical way of doing it.  */
 
+	gcc_assert (!Expansion_Delayed (gnat_node));
+
 	gnu_aggr_type = gnu_result_type
 	  = get_unpadded_type (Etype (gnat_node));
 
@@ -3497,11 +3499,7 @@ gnat_to_gnu (Node_Id gnat_node)
 	/* The return value from the subprogram.  */
 	tree gnu_ret_val = NULL_TREE;
 	/* The place to put the return value.  */
-	tree gnu_lhs
-	  = (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
-	     ? build_unary_op (INDIRECT_REF, NULL_TREE,
-			       DECL_ARGUMENTS (current_function_decl))
-	     : DECL_RESULT (current_function_decl));
+	tree gnu_lhs;
 
 	/* If we are dealing with a "return;" from an Ada procedure with
 	   parameters passed by copy in copy out, we need to return a record
@@ -3524,6 +3522,7 @@ gnat_to_gnu (Node_Id gnat_node)
 
 	else if (TYPE_CI_CO_LIST (gnu_subprog_type))
 	  {
+	    gnu_lhs = DECL_RESULT (current_function_decl);
 	    if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
 	      gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
 	    else
@@ -3543,12 +3542,26 @@ gnat_to_gnu (Node_Id gnat_node)
 	       are doing a call, pass that target to the call.  */
 	    if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
 		&& Nkind (Expression (gnat_node)) == N_Function_Call)
-	      gnu_ret_val = call_to_gnu (Expression (gnat_node),
-					 &gnu_result_type, gnu_lhs);
+	      {
+	        gnu_lhs
+		  = build_unary_op (INDIRECT_REF, NULL_TREE,
+				    DECL_ARGUMENTS (current_function_decl));
+		gnu_result = call_to_gnu (Expression (gnat_node),
+					  &gnu_result_type, gnu_lhs);
+	      }
 	    else
 	      {
 		gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
 
+		if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
+		  /* The original return type was unconstrained so dereference
+		     the TARGET pointer in the actual return value's type. */
+		  gnu_lhs
+		    = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
+				      DECL_ARGUMENTS (current_function_decl));
+		else
+		  gnu_lhs = DECL_RESULT (current_function_decl);
+
 		/* Do not remove the padding from GNU_RET_VAL if the inner
 		   type is self-referential since we want to allocate the fixed
 		   size in that case.  */
@@ -3591,18 +3604,19 @@ gnat_to_gnu (Node_Id gnat_node)
 					   gnat_node);
 		  }
 	      }
+	  }
 
-	    gnu_result = build2 (MODIFY_EXPR, TREE_TYPE (gnu_ret_val),
-				 gnu_lhs, gnu_ret_val);
-	    if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
-	      {
-		add_stmt_with_node (gnu_result, gnat_node);
-		gnu_ret_val = NULL_TREE;
-	      }
+	if (gnu_ret_val)
+	  gnu_result = build2 (MODIFY_EXPR, TREE_TYPE (gnu_ret_val),
+			       gnu_lhs, gnu_ret_val);
+
+	if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
+	  {
+	    add_stmt_with_node (gnu_result, gnat_node);
+	    gnu_result = NULL_TREE;
 	  }
 
-	gnu_result =  build1 (RETURN_EXPR, void_type_node,
-			      gnu_ret_val ? gnu_result : gnu_ret_val);
+	gnu_result = build1 (RETURN_EXPR, void_type_node, gnu_result);
       }
       break;
 
@@ -4021,12 +4035,14 @@ gnat_to_gnu (Node_Id gnat_node)
       current_function_decl = NULL_TREE;
     }
 
-  /* Set the location information into the result.  If we're supposed to
-     return something of void_type, it means we have something we're
-     elaborating for effect, so just return.  */
-  if (EXPR_P (gnu_result))
+  /* Set the location information into the result.  Note that we may have
+     no result if we tried to build a CALL_EXPR node to a procedure with
+     no side-effects and optimization is enabled.  */
+  if (gnu_result && EXPR_P (gnu_result))
     annotate_with_node (gnu_result, gnat_node);
 
+  /* If we're supposed to return something of void_type, it means we have
+     something we're elaborating for effect, so just return.  */
   if (TREE_CODE (gnu_result_type) == VOID_TYPE)
     return gnu_result;
 
@@ -4807,7 +4823,7 @@ process_inlined_subprograms (Node_Id gnat_node)
 
   /* If we can inline, generate RTL for all the inlined subprograms.
      Define the entity first so we set DECL_EXTERNAL.  */
-  if (optimize > 0 && !flag_no_inline)
+  if (optimize > 0 && !flag_really_no_inline)
     for (gnat_entity = First_Inlined_Subprogram (gnat_node);
 	 Present (gnat_entity);
 	 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
@@ -5439,13 +5455,19 @@ assoc_to_constructor (Node_Id gnat_assoc, tree gnu_type)
        gnat_assoc = Next (gnat_assoc))
     {
       Node_Id gnat_field = First (Choices (gnat_assoc));
-      tree gnu_field = gnat_to_gnu_entity (Entity (gnat_field), NULL_TREE, 0);
+      tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
       tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
 
       /* The expander is supposed to put a single component selector name
 	 in every record component association */
       gcc_assert (No (Next (gnat_field)));
 
+      /* Ignore fields that have Corresponding_Discriminants since we'll
+	 be setting that field in the parent.  */
+      if (Present (Corresponding_Discriminant (Entity (gnat_field)))
+	  && Is_Tagged_Type (Scope (Entity (gnat_field))))
+	continue;
+
       /* Before assigning a value in an aggregate make sure range checks
 	 are done if required.  Then convert to the type of the field.  */
       if (Do_Range_Check (Expression (gnat_assoc)))
@@ -5956,14 +5978,6 @@ post_error_ne_tree_2 (const char *msg,
   Error_Msg_Uint_2 = UI_From_Int (num);
   post_error_ne_tree (msg, node, ent, t);
 }
-
-/* Set the node for a second '&' in the error message.  */
-
-void
-set_second_error_entity (Entity_Id e)
-{
-  Error_Msg_Node_2 = e;
-}
 
 /* Initialize the table that maps GNAT codes to GCC codes for simple
    binary and unary operations.  */