sem_ch4.adb (Analyze_Selected_Component): Create Actual_Subtype even with expansion disabled.

	* sem_ch4.adb (Analyze_Selected_Component): Create Actual_Subtype even
	with expansion disabled. The actual subtype is needed among other
	places when the selected component appears in the context of a loop
	bound, and denotes a packed array.
	(Operator_Check): Always use the first subtype in the
	error message, to avoid the appearance of internal base types.
	(Transform_Object_Operation): Copy each actual in full
	to the parameter associations of the constructed call, rather than
	using the shallow copy mechanism of New_Copy_List. This ensures that
	the chaining of named associations is done properly.
	(Complete_Object_Operation): Rewrite node, rather than
	replacing it, so that we can trace back to the original selected
	component.

	* sem_elab.adb (Set_Elaboration_Constraint): For initialization calls,
	and calls that use object notation, if the called function is not
	declared  in a withed unit, place the elaboration constraint on the
	unit in the context that makes the function accessible.
	(Check_Elab_Subtype_Declaration): Check whether a subtype declaration
	imposes an elaboration constraint between two packages.

From-SVN: r94820

gcc/ada/sem_ch4.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- --
@@ -2650,10 +2650,7 @@ package body Sem_Ch4 is
                --  not make an actual subtype, we end up getting a direct
                --  reference to a discriminant which will not do.
 
-               --  Comment needs revision, "in all other cases" does not
-               --  reasonably describe the situation below with an elsif???
-
-               elsif Expander_Active then
+               else
                   Act_Decl :=
                     Build_Actual_Subtype_Of_Component (Etype (Comp), N);
                   Insert_Action (N, Act_Decl);
@@ -2675,9 +2672,6 @@ package body Sem_Ch4 is
                         Set_Etype (N, Subt);
                      end;
                   end if;
-
-               else
-                  Set_Etype (N, Etype (Comp));
                end if;
 
                return;
@@ -4400,7 +4394,7 @@ package body Sem_Ch4 is
                     and then not Is_Overloaded (R)
                     and then Base_Type (Etype (L)) = Base_Type (Etype (R))
                   then
-                     Error_Msg_Node_2 := Etype (R);
+                     Error_Msg_Node_2 := First_Subtype (Etype (R));
                      Error_Msg_N ("there is no applicable operator& for}", N);
 
                   else
@@ -4799,7 +4793,7 @@ package body Sem_Ch4 is
       begin
          Set_Name (Call_Node, New_Copy_Tree (Subprog));
          Set_Analyzed (Call_Node, False);
-         Replace (Node_To_Replace, Call_Node);
+         Rewrite (Node_To_Replace, Call_Node);
          Analyze (Node_To_Replace);
 
       end Complete_Object_Operation;
@@ -4830,8 +4824,19 @@ package body Sem_Ch4 is
          then
             Node_To_Replace := Parent_Node;
 
-            Append_List_To (Actuals,
-              New_Copy_List (Parameter_Associations (Parent_Node)));
+            --  Copy list of actuals in full before attempting to resolve call.
+            --  This is necessary to ensure that the chaining of named actuals
+            --  that happens during matching is done on a separate copy.
+
+            declare
+               Actual : Node_Id;
+            begin
+               Actual := First (Parameter_Associations (Parent_Node));
+               while Present (Actual) loop
+                  Append (New_Copy_Tree (Actual), Actuals);
+                  Next (Actual);
+               end loop;
+            end;
 
             if Nkind (Parent_Node) = N_Procedure_Call_Statement then
                Call_Node :=

gcc/ada/sem_elab.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1997-2004 Free Software Foundation, Inc.          --
+--          Copyright (C) 1997-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- --
@@ -159,7 +159,7 @@ package body Sem_Elab is
    -- Local Subprograms --
    -----------------------
 
-   --  Note: Outer_Scope in all these calls represents the scope of
+   --  Note: Outer_Scope in all following specs represents the scope of
    --  interest of the outer level call. If it is set to Standard_Standard,
    --  then it means the outer level call was at elaboration level, and that
    --  thus all calls are of interest. If it was set to some other scope,
@@ -224,6 +224,29 @@ package body Sem_Elab is
    --  to Check_Internal_Call. Outer_Scope is the outer level scope for
    --  the original call.
 
+   procedure Set_Elaboration_Constraint
+    (Call : Node_Id;
+     Subp : Entity_Id;
+     Scop : Entity_Id);
+   --  The current unit U may depend semantically on some unit P which is not
+   --  in the current context. If there is an elaboration call that reaches P,
+   --  we need to indicate that P requires an Elaborate_All, but this is not
+   --  effective in U's ali file, if there is no with_clause for P. In this
+   --  case we add the Elaborate_All on the unit Q that directly or indirectly
+   --  makes P available. This can happen in two cases:
+   --
+   --    a) Q declares a subtype of a type declared in P, and the call is an
+   --    initialization call for an object of that subtype.
+   --
+   --    b) Q declares an object of some tagged type whose root type is
+   --    declared in P, and the initialization call uses object notation on
+   --    that object to reach a primitive operation or a classwide operation
+   --    declared in P.
+   --
+   --  If P appears in the context of U, the current processing is correct.
+   --  Otherwise we must identify these two cases to retrieve Q and place the
+   --  Elaborate_All_Desirable on it.
+
    function Has_Generic_Body (N : Node_Id) return Boolean;
    --  N is a generic package instantiation node, and this routine determines
    --  if this package spec does in fact have a generic body. If so, then
@@ -308,11 +331,16 @@ package body Sem_Elab is
       --  elaboration check is required.
 
       W_Scope : Entity_Id;
-      --  Top level scope of directly called entity for subprogram.
-      --  This differs from E_Scope in the case where renamings or
-      --  derivations are involved, since it does not follow these
-      --  links, thus W_Scope is always in a visible unit. This is
-      --  the scope for the Elaborate_All if one is needed.
+      --  Top level scope of directly called entity for subprogram. This
+      --  differs from E_Scope in the case where renamings or derivations
+      --  are involved, since it does not follow these links. W_Scope is
+      --  generally in a visible unit, and it is this scope that may require
+      --  an Elaborate_All. However, there are some cases (initialization
+      --  calls and calls involving object notation) where W_Scope might not
+      --  be in the context of the current unit, and there is an intermediate
+      --  package that is, in which case the Elaborate_All has to be placed
+      --  on this intedermediate package. These special cases are handled in
+      --  Set_Elaboration_Constraint.
 
       Body_Acts_As_Spec : Boolean;
       --  Set to true if call is to body acting as spec (no separate spec)
@@ -751,8 +779,7 @@ package body Sem_Elab is
 
                --  Set indication for binder to generate Elaborate_All
 
-               Set_Elaborate_All_Desirable (W_Scope);
-               Set_Suppress_Elaboration_Warnings (W_Scope, True);
+               Set_Elaboration_Constraint (N, E, W_Scope);
             end if;
          end if;
 
@@ -1345,6 +1372,12 @@ package body Sem_Elab is
          return;
       end if;
 
+      --  Nothing to do if the instantiation is not in the main unit.
+
+      if not In_Extended_Main_Code_Unit (N) then
+         return;
+      end if;
+
       Ent := Get_Generic_Entity (N);
       From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
 
@@ -2000,6 +2033,96 @@ package body Sem_Elab is
       In_Task_Activation := False;
    end Check_Task_Activation;
 
+   --------------------------------
+   -- Set_Elaboration_Constraint --
+   --------------------------------
+
+   procedure Set_Elaboration_Constraint
+    (Call : Node_Id;
+     Subp : Entity_Id;
+     Scop : Entity_Id)
+   is
+      Elab_Unit  : Entity_Id;
+      Init_Call  : constant Boolean :=
+                     Chars (Subp) = Name_Initialize
+                       and then Comes_From_Source (Subp)
+                       and then Present (Parameter_Associations (Call))
+                       and then Is_Controlled
+                         (Etype (First (Parameter_Associations (Call))));
+   begin
+      --  If the unit is mentioned in a with_clause of the current
+      --  unit, it is visible, and we can set the elaboration flag.
+
+      if Is_Immediately_Visible (Scop)
+        or else
+          (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
+      then
+         Set_Elaborate_All_Desirable (Scop);
+         Set_Suppress_Elaboration_Warnings (Scop, True);
+         return;
+      end if;
+
+      --  If this is not an initialization call or a call using object notation
+      --  we know that the unit of the called entity is in the context, and
+      --  we can set the flag as well. The unit need not be visible if the call
+      --  occurs within an instantiation.
+
+      if Is_Init_Proc (Subp)
+        or else Init_Call
+        or else Nkind (Original_Node (Call)) = N_Selected_Component
+      then
+         null;  --  detailed processing follows.
+
+      else
+         Set_Elaborate_All_Desirable (Scop);
+         Set_Suppress_Elaboration_Warnings (Scop, True);
+         return;
+      end if;
+
+      --  If the unit is not in the context, there must be an intermediate
+      --  unit that is, on which we need to place to elaboration flag.
+
+      if Is_Init_Proc (Subp)
+        or else Init_Call
+      then
+         --  The initialization call is on an object whose type is not
+         --  declared in the same scope as the subprogram. The type of
+         --  the object must be a subtype of the type of operation. This
+         --  object is the first actual in the call.
+
+         declare
+            Typ  : constant Entity_Id :=
+                     Etype (First (Parameter_Associations (Call)));
+         begin
+            Elab_Unit := Scope (Typ);
+
+            while (Present (Elab_Unit))
+              and then not Is_Compilation_Unit (Elab_Unit)
+            loop
+               Elab_Unit := Scope (Elab_Unit);
+            end loop;
+         end;
+      elsif Nkind (Original_Node (Call)) = N_Selected_Component then
+
+         --  If original node uses selected component notation, the
+         --  prefix is visible and determines the scope that must be
+         --  elaborated. After rewriting, the prefix is the first actual
+         --  in the call.
+
+         Elab_Unit := Scope (Etype (First (Parameter_Associations (Call))));
+
+      else
+         --  Using previously computed scope. If the elaboration check is
+         --  done after analysis, the scope is not visible any longer, but
+         --  must still be in the context.
+
+         Elab_Unit := Scop;
+      end if;
+
+      Set_Elaborate_All_Desirable (Elab_Unit);
+      Set_Suppress_Elaboration_Warnings (Elab_Unit, True);
+   end Set_Elaboration_Constraint;
+
    ----------------------
    -- Has_Generic_Body --
    ----------------------