exp_ch6.adb (Expand_Call): If an actual is a function call rewritten from object notation...

2005-09-01  Ed Schonberg  <schonberg@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* exp_ch6.adb (Expand_Call): If an actual is a function call rewritten
	from object notation, the original node is unanalyzed and carries no
	semantic information, so that accessiblity checks must be performed on
	the type of the actual itself.
	(Expand_N_Subprogram_Declaration): Change last actual parameter for
	compatibility with Build_Protected_Sub_Specification.
	(Check_Overriding_Inherited_Interfaces): Add suport to handle
	overloaded primitives.
	(Register_Interface_DT_Entry): Use the new name of the formal
	the the calls to Expand_Interface_Thunk

	* exp_dbug.ads: Augment comments on encoding of protected types to
	include the generation of dispatching subprograms when the type
	implements at least one interface.

	* lib.ads: Extend information in Load_Stack to include whether a given
	load comes from a Limited_With_Clause.

	* lib-load.adb (From_Limited_With_Chain): New predicate to determine
	whether a potential circularity is harmless, because it includes units
	loaded through a limited_with clause. Extends previous treatment which
	did not handle properly arbitrary combinations of limited and
	non-limited clauses.

From-SVN: r103861

gcc/ada/exp_ch6.adb

@@ -34,7 +34,6 @@ with Exp_Ch2;  use Exp_Ch2;
 with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch7;  use Exp_Ch7;
 with Exp_Ch9;  use Exp_Ch9;
-with Exp_Ch11; use Exp_Ch11;
 with Exp_Dbug; use Exp_Dbug;
 with Exp_Disp; use Exp_Disp;
 with Exp_Dist; use Exp_Dist;
@@ -172,10 +171,10 @@ package body Exp_Ch6 is
         and then In_Open_Scopes (Scope (Etype (Typ)))
         and then Typ = Base_Type (Typ)
       then
-         --  Subp overrides an inherited private operation if there is
-         --  an inherited operation with a different name than Subp (see
-         --  Derive_Subprogram) whose Alias is a hidden  subprogram with
-         --  the same name as Subp.
+         --  Subp overrides an inherited private operation if there is an
+         --  inherited operation with a different name than Subp (see
+         --  Derive_Subprogram) whose Alias is a hidden subprogram with the
+         --  same name as Subp.
 
          Op_Elmt := First_Elmt (Op_List);
          while Present (Op_Elmt) loop
@@ -211,12 +210,12 @@ package body Exp_Ch6 is
       --  List of recursive calls in body of procedure
 
       Shad_List : constant Elist_Id := New_Elmt_List;
-      --  List of entity id's for entities created to capture the
-      --  value of referenced globals on entry to the procedure.
+      --  List of entity id's for entities created to capture the value of
+      --  referenced globals on entry to the procedure.
 
       Scop : constant Uint := Scope_Depth (Spec);
-      --  This is used to record the scope depth of the current
-      --  procedure, so that we can identify global references.
+      --  This is used to record the scope depth of the current procedure, so
+      --  that we can identify global references.
 
       Max_Vars : constant := 4;
       --  Do not test more than four global variables
@@ -359,9 +358,9 @@ package body Exp_Ch6 is
    --  Start of processing for Detect_Infinite_Recursion
 
    begin
-      --  Do not attempt detection in No_Implicit_Conditional mode,
-      --  since we won't be able to generate the code to handle the
-      --  recursion in any case.
+      --  Do not attempt detection in No_Implicit_Conditional mode, since we
+      --  won't be able to generate the code to handle the recursion in any
+      --  case.
 
       if Restriction_Active (No_Implicit_Conditionals) then
          return;
@@ -372,9 +371,9 @@ package body Exp_Ch6 is
       if Traverse_Body (N) = Abandon then
          return;
 
-      --  We must have a call, since Has_Recursive_Call was set. If not
-      --  just ignore (this is only an error check, so if we have a funny
-      --  situation, due to bugs or errors, we do not want to bomb!)
+      --  We must have a call, since Has_Recursive_Call was set. If not just
+      --  ignore (this is only an error check, so if we have a funny situation,
+      --  due to bugs or errors, we do not want to bomb!)
 
       elsif Is_Empty_Elmt_List (Call_List) then
          return;
@@ -382,15 +381,15 @@ package body Exp_Ch6 is
 
       --  Here is the case where we detect recursion at compile time
 
-      --  Push our current scope for analyzing the declarations and
-      --  code that we will insert for the checking.
+      --  Push our current scope for analyzing the declarations and code that
+      --  we will insert for the checking.
 
       New_Scope (Spec);
 
-      --  This loop builds temporary variables for each of the
-      --  referenced globals, so that at the end of the loop the
-      --  list Shad_List contains these temporaries in one-to-one
-      --  correspondence with the elements in Var_List.
+      --  This loop builds temporary variables for each of the referenced
+      --  globals, so that at the end of the loop the list Shad_List contains
+      --  these temporaries in one-to-one correspondence with the elements in
+      --  Var_List.
 
       Last := Empty;
       Elm := First_Elmt (Var_List);
@@ -401,10 +400,10 @@ package body Exp_Ch6 is
              Chars => New_Internal_Name ('S'));
          Append_Elmt (Ent, Shad_List);
 
-         --  Insert a declaration for this temporary at the start of
-         --  the declarations for the procedure. The temporaries are
-         --  declared as constant objects initialized to the current
-         --  values of the corresponding temporaries.
+         --  Insert a declaration for this temporary at the start of the
+         --  declarations for the procedure. The temporaries are declared as
+         --  constant objects initialized to the current values of the
+         --  corresponding temporaries.
 
          Decl :=
            Make_Object_Declaration (Loc,
@@ -940,7 +939,6 @@ package body Exp_Ch6 is
 
       procedure Reset_Packed_Prefix is
          Pfx : Node_Id := Actual;
-
       begin
          loop
             Set_Analyzed (Pfx, False);
@@ -953,11 +951,10 @@ package body Exp_Ch6 is
    --  Start of processing for Expand_Actuals
 
    begin
-      Formal := First_Formal (Subp);
-      Actual := First_Actual (N);
-
       Post_Call := New_List;
 
+      Formal := First_Formal (Subp);
+      Actual := First_Actual (N);
       while Present (Formal) loop
          E_Formal := Etype (Formal);
 
@@ -1155,10 +1152,9 @@ package body Exp_Ch6 is
 
       if not Is_Empty_List (Post_Call) then
 
-         --  If call is not a list member, it must be the triggering
-         --  statement of a triggering alternative or an entry call
-         --  alternative, and we can add the post call stuff to the
-         --  corresponding statement list.
+         --  If call is not a list member, it must be the triggering statement
+         --  of a triggering alternative or an entry call alternative, and we
+         --  can add the post call stuff to the corresponding statement list.
 
          if not Is_List_Member (N) then
             declare
@@ -1219,22 +1215,27 @@ package body Exp_Ch6 is
       Actual        : Node_Id;
       Formal        : Entity_Id;
       Prev          : Node_Id := Empty;
-      Prev_Orig     : Node_Id;
+
+      Prev_Orig : Node_Id;
+      --  Original node for an actual, which may have been rewritten. If the
+      --  actual is a function call that has been transformed from a selected
+      --  component, the original node is unanalyzed. Otherwise, it carries
+      --  semantic information used to generate additional actuals.
+
       Scop          : Entity_Id;
       Extra_Actuals : List_Id := No_List;
-      Cond          : Node_Id;
 
       CW_Interface_Formals_Present : Boolean := False;
 
       procedure Add_Actual_Parameter (Insert_Param : Node_Id);
       --  Adds one entry to the end of the actual parameter list. Used for
-      --  default parameters and for extra actuals (for Extra_Formals).
-      --  The argument is an N_Parameter_Association node.
+      --  default parameters and for extra actuals (for Extra_Formals). The
+      --  argument is an N_Parameter_Association node.
 
       procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id);
-      --  Adds an extra actual to the list of extra actuals. Expr
-      --  is the expression for the value of the actual, EF is the
-      --  entity for the extra formal.
+      --  Adds an extra actual to the list of extra actuals. Expr is the
+      --  expression for the value of the actual, EF is the entity for the
+      --  extra formal.
 
       function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
       --  Within an instance, a type derived from a non-tagged formal derived
@@ -1324,8 +1325,8 @@ package body Exp_Ch6 is
 
          if Nkind (Parent (S)) /= N_Full_Type_Declaration
            or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
-           or else Nkind (Type_Definition (Original_Node (Parent (S))))
-             /= N_Derived_Type_Definition
+           or else Nkind (Type_Definition (Original_Node (Parent (S)))) /=
+                                                   N_Derived_Type_Definition
            or else not In_Instance
          then
             return Empty;
@@ -1353,31 +1354,29 @@ package body Exp_Ch6 is
             Gen_Par := Generic_Parent_Type (Parent (Par));
          end if;
 
-         --  If the generic parent type is still the generic type, this
-         --  is a private formal, not a derived formal, and there are no
-         --  operations inherited from the formal.
+         --  If the generic parent type is still the generic type, this is a
+         --  private formal, not a derived formal, and there are no operations
+         --  inherited from the formal.
 
          if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
             return Empty;
          end if;
 
          Gen_Prim := Collect_Primitive_Operations (Gen_Par);
-         Elmt := First_Elmt (Gen_Prim);
 
+         Elmt := First_Elmt (Gen_Prim);
          while Present (Elmt) loop
             if Chars (Node (Elmt)) = Chars (S) then
                declare
                   F1 : Entity_Id;
                   F2 : Entity_Id;
-               begin
 
+               begin
                   F1 := First_Formal (S);
                   F2 := First_Formal (Node (Elmt));
-
                   while Present (F1)
                     and then Present (F2)
                   loop
-
                      if Etype (F1) = Etype (F2)
                        or else Etype (F2) = Gen_Par
                      then
@@ -1448,7 +1447,8 @@ package body Exp_Ch6 is
 
             begin
                --  The case we catch is where the first argument is obtained
-               --  using the Identity attribute (which must always be non-null)
+               --  using the Identity attribute (which must always be
+               --  non-null).
 
                if Nkind (FA) = N_Attribute_Reference
                  and then Attribute_Name (FA) = Name_Identity
@@ -1490,8 +1490,14 @@ package body Exp_Ch6 is
          Prev := Actual;
          Prev_Orig := Original_Node (Prev);
 
+         if not Analyzed (Prev_Orig)
+           and then Nkind (Actual) = N_Function_Call
+         then
+            Prev_Orig := Prev;
+         end if;
+
          --  Ada 2005 (AI-251): Check if any formal is a class-wide interface
-         --  to expand it in a further round
+         --  to expand it in a further round.
 
          CW_Interface_Formals_Present :=
            CW_Interface_Formals_Present
@@ -1539,13 +1545,13 @@ package body Exp_Ch6 is
                --  test applies to the actual, not the target type.
 
                declare
-                  Act_Prev : Node_Id := Prev;
+                  Act_Prev : Node_Id;
 
                begin
-                  --  Test for unchecked conversions as well, which can
-                  --  occur as out parameter actuals on calls to stream
-                  --  procedures.
+                  --  Test for unchecked conversions as well, which can occur
+                  --  as out parameter actuals on calls to stream procedures.
 
+                  Act_Prev := Prev;
                   while Nkind (Act_Prev) = N_Type_Conversion
                     or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion
                   loop
@@ -1669,55 +1675,59 @@ package body Exp_Ch6 is
             end if;
          end if;
 
-         --  Perform the check of 4.6(49) that prevents a null value
-         --  from being passed as an actual to an access parameter.
-         --  Note that the check is elided in the common cases of
-         --  passing an access attribute or access parameter as an
-         --  actual. Also, we currently don't enforce this check for
-         --  expander-generated actuals and when -gnatdj is set.
+         --  Perform the check of 4.6(49) that prevents a null value from being
+         --  passed as an actual to an access parameter. Note that the check is
+         --  elided in the common cases of passing an access attribute or
+         --  access parameter as an actual. Also, we currently don't enforce
+         --  this check for expander-generated actuals and when -gnatdj is set.
 
-         if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
-           or else Access_Checks_Suppressed (Subp)
-         then
-            null;
+         if Ada_Version >= Ada_05 then
 
-         elsif Debug_Flag_J then
-            null;
+            --  Ada 2005 (AI-231): Check null-excluding access types
 
-         elsif not Comes_From_Source (Prev) then
-            null;
+            if Is_Access_Type (Etype (Formal))
+              and then Can_Never_Be_Null (Etype (Formal))
+              and then Nkind (Prev) /= N_Raise_Constraint_Error
+              and then (Nkind (Prev) = N_Null
+                          or else not Can_Never_Be_Null (Etype (Prev)))
+            then
+               Install_Null_Excluding_Check (Prev);
+            end if;
 
-         elsif Is_Entity_Name (Prev)
-           and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
-         then
-            null;
+         --  Ada_Version < Ada_05
 
-         elsif Nkind (Prev) = N_Allocator
-           or else Nkind (Prev) = N_Attribute_Reference
-         then
-            null;
+         else
+            if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
+              or else Access_Checks_Suppressed (Subp)
+            then
+               null;
 
-         --  Suppress null checks when passing to access parameters
-         --  of Java subprograms. (Should this be done for other
-         --  foreign conventions as well ???)
+            elsif Debug_Flag_J then
+               null;
 
-         elsif Convention (Subp) = Convention_Java then
-            null;
+            elsif not Comes_From_Source (Prev) then
+               null;
 
-            --  Ada 2005 (AI-231): do not force the check in case of Ada 2005
-            --  unless it is a null-excluding type
+            elsif Is_Entity_Name (Prev)
+              and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type
+            then
+               null;
 
-         elsif Ada_Version < Ada_05
-           or else Can_Never_Be_Null (Etype (Prev))
-         then
-            Cond :=
-              Make_Op_Eq (Loc,
-                Left_Opnd => Duplicate_Subexpr_No_Checks (Prev),
-                Right_Opnd => Make_Null (Loc));
-            Insert_Action (Prev,
-              Make_Raise_Constraint_Error (Loc,
-                Condition => Cond,
-                Reason    => CE_Access_Parameter_Is_Null));
+            elsif Nkind (Prev) = N_Allocator
+              or else Nkind (Prev) = N_Attribute_Reference
+            then
+               null;
+
+            --  Suppress null checks when passing to access parameters of Java
+            --  subprograms. (Should this be done for other foreign conventions
+            --  as well ???)
+
+            elsif Convention (Subp) = Convention_Java then
+               null;
+
+            else
+               Install_Null_Excluding_Check (Prev);
+            end if;
          end if;
 
          --  Perform appropriate validity checks on parameters that
@@ -1974,7 +1984,6 @@ package body Exp_Ch6 is
            or else Is_Generic_Instance (Parent_Subp)
          then
             while Present (Formal) loop
-
                if Etype (Formal) /= Etype (Parent_Formal)
                  and then Is_Scalar_Type (Etype (Formal))
                  and then Ekind (Formal) = E_In_Parameter
@@ -1989,8 +1998,8 @@ package body Exp_Ch6 is
                   Enable_Range_Check (Actual);
 
                elsif Is_Access_Type (Etype (Formal))
-                 and then Base_Type (Etype (Parent_Formal))
-                   /= Base_Type (Etype (Actual))
+                 and then Base_Type (Etype (Parent_Formal)) /=
+                          Base_Type (Etype (Actual))
                then
                   if Ekind (Formal) /= E_In_Parameter then
                      Rewrite (Actual,
@@ -2161,9 +2170,10 @@ package body Exp_Ch6 is
                --------------------------
 
                function In_Unfrozen_Instance return Boolean is
-                  S : Entity_Id := Scop;
+                  S : Entity_Id;
 
                begin
+                  S := Scop;
                   while Present (S)
                     and then S /= Standard_Standard
                   loop
@@ -2183,10 +2193,12 @@ package body Exp_Ch6 is
             --  Start of processing for Inlined_Subprogram
 
             begin
-               --  Verify that the body to inline has already been seen,
-               --  and that if the body is in the current unit the inlining
-               --  does not occur earlier. This avoids order-of-elaboration
-               --  problems in gigi.
+               --  Verify that the body to inline has already been seen, and
+               --  that if the body is in the current unit the inlining does
+               --  not occur earlier. This avoids order-of-elaboration problems
+               --  in the back end.
+
+               --  This should be documented in sinfo/einfo ???
 
                if No (Spec)
                  or else Nkind (Spec) /= N_Subprogram_Declaration
@@ -2683,15 +2695,14 @@ package body Exp_Ch6 is
                Original_Assignment : constant Node_Id := Parent (N);
 
             begin
-               --  Preserve the original assignment node to keep the
-               --  complete assignment subtree consistent enough for
-               --  Analyze_Assignment to proceed (specifically, the
-               --  original Lhs node must still have an assignment
-               --  statement as its parent).
+               --  Preserve the original assignment node to keep the complete
+               --  assignment subtree consistent enough for Analyze_Assignment
+               --  to proceed (specifically, the original Lhs node must still
+               --  have an assignment statement as its parent).
 
-               --  We cannot rely on Original_Node to go back from the
-               --  block node to the assignment node, because the
-               --  assignment might already be a rewrite substitution.
+               --  We cannot rely on Original_Node to go back from the block
+               --  node to the assignment node, because the assignment might
+               --  already be a rewrite substitution.
 
                Discard_Node (Relocate_Node (Original_Assignment));
                Rewrite (Original_Assignment, Blk);
@@ -2741,8 +2752,7 @@ package body Exp_Ch6 is
             if Nkind (N) = N_Identifier
               and then Present (Entity (N))
 
-               --  The original node's entity points to the one in the
-               --  copied body.
+               --  Original node's entity points to the one in the copied body
 
               and then Nkind (Entity (N)) = N_Identifier
               and then Present (Entity (Entity (N)))
@@ -2781,8 +2791,8 @@ package body Exp_Ch6 is
       --  Check for special case of To_Address call, and if so, just do an
       --  unchecked conversion instead of expanding the call. Not only is this
       --  more efficient, but it also avoids problem with order of elaboration
-      --  when address clauses are inlined (address expr elaborated at wrong
-      --  point).
+      --  when address clauses are inlined (address expression elaborated at
+      --  wrong point).
 
       if Subp = RTE (RE_To_Address) then
          Rewrite (N,
@@ -2848,15 +2858,14 @@ package body Exp_Ch6 is
          Ret_Type := Etype (Subp);
       end if;
 
-      F := First_Formal (Subp);
-      A := First_Actual (N);
-
       --  Create temporaries for the actuals that are expressions, or that
       --  are scalars and require copying to preserve semantics.
 
+      F := First_Formal (Subp);
+      A := First_Actual (N);
       while Present (F) loop
          if Present (Renamed_Object (F)) then
-            Error_Msg_N (" cannot inline call to recursive subprogram", N);
+            Error_Msg_N ("cannot inline call to recursive subprogram", N);
             return;
          end if;
 
@@ -3061,7 +3070,6 @@ package body Exp_Ch6 is
       --  Cleanup mapping between formals and actuals for other expansions
 
       F := First_Formal (Subp);
-
       while Present (F) loop
          Set_Renamed_Object (F, Empty);
          Next_Formal (F);
@@ -3090,7 +3098,7 @@ package body Exp_Ch6 is
       ---------------------------
 
       function Returned_By_Reference return Boolean is
-         S : Entity_Id := Current_Scope;
+         S : Entity_Id;
 
       begin
          if Is_Return_By_Reference_Type (Typ) then
@@ -3104,6 +3112,7 @@ package body Exp_Ch6 is
             --  Verify that the return type of the enclosing function has the
             --  same constrained status as that of the expression.
 
+            S := Current_Scope;
             while Ekind (S) /= E_Function loop
                S := Scope (S);
             end loop;
@@ -3202,9 +3211,9 @@ package body Exp_Ch6 is
                      --  object is not classwide.
 
                      Proc := Entity (Name (Parent (N)));
+
                      F    := First_Formal (Proc);
                      A    := First_Actual (Parent (N));
-
                      while A /= N loop
                         Next_Formal (F);
                         Next_Actual (A);
@@ -3535,9 +3544,10 @@ package body Exp_Ch6 is
         and then not Has_Pragma_Pure_Function (Spec_Id)
       then
          declare
-            F : Entity_Id := First_Formal (Spec_Id);
+            F : Entity_Id;
 
          begin
+            F := First_Formal (Spec_Id);
             while Present (F) loop
                if Is_Descendent_Of_Address (Etype (F)) then
                   Set_Is_Pure (Spec_Id, False);
@@ -3558,7 +3568,7 @@ package body Exp_Ch6 is
 
       if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then
          declare
-            F : Entity_Id        := First_Formal (Spec_Id);
+            F : Entity_Id;
             V : constant Boolean := Validity_Checks_On;
 
          begin
@@ -3570,6 +3580,7 @@ package body Exp_Ch6 is
 
             --  Loop through formals
 
+            F := First_Formal (Spec_Id);
             while Present (F) loop
                if Is_Scalar_Type (Etype (F))
                  and then Ekind (F) = E_Out_Parameter
@@ -3589,9 +3600,9 @@ package body Exp_Ch6 is
 
       Scop := Scope (Spec_Id);
 
-      --  Add discriminal renamings to protected subprograms.
-      --  Install new discriminals for expansion of the next
-      --  subprogram of this protected type, if any.
+      --  Add discriminal renamings to protected subprograms. Install new
+      --  discriminals for expansion of the next subprogram of this protected
+      --  type, if any.
 
       if Is_List_Member (N)
         and then Present (Parent (List_Containing (N)))
@@ -3602,9 +3613,8 @@ package body Exp_Ch6 is
          Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc);
 
          --  Associate privals and discriminals with the next protected
-         --  operation body to be expanded. These are used to expand
-         --  references to private data objects and discriminants,
-         --  respectively.
+         --  operation body to be expanded. These are used to expand references
+         --  to private data objects and discriminants, respectively.
 
          Next_Op := Next_Protected_Operation (N);
 
@@ -3633,7 +3643,7 @@ package body Exp_Ch6 is
       end if;
 
       --  Returns_By_Ref flag is normally set when the subprogram is frozen
-      --  but subprograms with no specs are not frozen
+      --  but subprograms with no specs are not frozen.
 
       declare
          Typ  : constant Entity_Id := Etype (Spec_Id);
@@ -3665,7 +3675,6 @@ package body Exp_Ch6 is
 
          if Present (Exception_Handlers (H)) then
             Except_H := First_Non_Pragma (Exception_Handlers (H));
-
             while Present (Except_H) loop
                Add_Return (Statements (Except_H));
                Next_Non_Pragma (Except_H);
@@ -3742,7 +3751,6 @@ package body Exp_Ch6 is
 
          begin
             Formal := First_Formal (Spec_Id);
-
             while Present (Formal) loop
                Floc := Sloc (Formal);
 
@@ -3769,18 +3777,6 @@ package body Exp_Ch6 is
          Expand_Thread_Body;
       end if;
 
-      --  If the subprogram does not have pending instantiations, then we
-      --  must generate the subprogram descriptor now, since the code for
-      --  the subprogram is complete, and this is our last chance. However
-      --  if there are pending instantiations, then the code is not
-      --  complete, and we will delay the generation.
-
-      if Is_Subprogram (Spec_Id)
-        and then not Delay_Subprogram_Descriptors (Spec_Id)
-      then
-         Generate_Subprogram_Descriptor_For_Subprogram (N, Spec_Id);
-      end if;
-
       --  Set to encode entity names in package body before gigi is called
 
       Qualify_Entity_Names (N);
@@ -3818,8 +3814,8 @@ package body Exp_Ch6 is
       Prot_Id   : Entity_Id;
 
    begin
-      --  Deal with case of protected subprogram. Do not generate
-      --  protected operation if operation is flagged as eliminated.
+      --  Deal with case of protected subprogram. Do not generate protected
+      --  operation if operation is flagged as eliminated.
 
       if Is_List_Member (N)
         and then Present (Parent (List_Containing (N)))
@@ -3833,7 +3829,7 @@ package body Exp_Ch6 is
               Make_Subprogram_Declaration (Loc,
                 Specification =>
                   Build_Protected_Sub_Specification
-                    (N, Scop, Unprotected => True));
+                    (N, Scop, Unprotected_Mode));
 
             --  The protected subprogram is declared outside of the protected
             --  body. Given that the body has frozen all entities so far, we
@@ -3907,18 +3903,16 @@ package body Exp_Ch6 is
       Rec := Make_Identifier (Loc, Name_uObject);
       Set_Etype (Rec, Corresponding_Record_Type (Scop));
 
-      --  Find enclosing protected operation, and retrieve its first
-      --  parameter, which denotes the enclosing protected object.
-      --  If the enclosing operation is an entry, we are immediately
-      --  within the protected body, and we can retrieve the object
-      --  from the service entries procedure. A barrier function has
-      --  has the same signature as an entry. A barrier function is
-      --  compiled within the protected object, but unlike protected
-      --  operations its never needs locks, so that its protected body
-      --  subprogram points to itself.
+      --  Find enclosing protected operation, and retrieve its first parameter,
+      --  which denotes the enclosing protected object. If the enclosing
+      --  operation is an entry, we are immediately within the protected body,
+      --  and we can retrieve the object from the service entries procedure. A
+      --  barrier function has has the same signature as an entry. A barrier
+      --  function is compiled within the protected object, but unlike
+      --  protected operations its never needs locks, so that its protected
+      --  body subprogram points to itself.
 
       Proc := Current_Scope;
-
       while Present (Proc)
         and then Scope (Proc) /= Scop
       loop
@@ -3946,17 +3940,16 @@ package body Exp_Ch6 is
 
          Set_Entity (Rec, Param);
 
-         --  Rec is a reference to an entity which will not be in scope
-         --  when the call is reanalyzed, and needs no further analysis.
+         --  Rec is a reference to an entity which will not be in scope when
+         --  the call is reanalyzed, and needs no further analysis.
 
          Set_Analyzed (Rec);
 
       else
-         --  Entry or barrier function for entry body.
-         --  The first parameter of the entry body procedure is a
-         --  pointer to the object. We create a local variable
-         --  of the proper type, duplicating what is done to define
-         --  _object later on.
+         --  Entry or barrier function for entry body. The first parameter of
+         --  the entry body procedure is pointer to the object. We create a
+         --  local variable of the proper type, duplicating what is done to
+         --  define _object later on.
 
          declare
             Decls : List_Id;
@@ -3982,9 +3975,8 @@ package body Exp_Ch6 is
                 Unchecked_Convert_To (Obj_Ptr,
                   New_Occurrence_Of (Param, Loc)));
 
-            --  Analyze new actual. Other actuals in calls are already
-            --  analyzed and the list of actuals is not renalyzed after
-            --  rewriting.
+            --  Analyze new actual. Other actuals in calls are already analyzed
+            --  and the list of actuals is not renalyzed after rewriting.
 
             Set_Parent (Rec, N);
             Analyze (Rec);
@@ -4065,7 +4057,7 @@ package body Exp_Ch6 is
 
       procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id);
       --  (Ada 2005): Check if the primitive E covers some interface already
-      --  implemented by some ancestor of the tagged-type associated with E
+      --  implemented by some ancestor of the tagged-type associated with E.
 
       procedure Register_Interface_DT_Entry
         (Prim                : Entity_Id;
@@ -4114,29 +4106,56 @@ package body Exp_Ch6 is
                while Present (Elmt) loop
                   Prim_Op := Node (Elmt);
 
-                  if DT_Position (Prim_Op) = DT_Position (E)
+                  if Chars (Prim_Op) = Chars (E)
+                    and then Type_Conformant
+                               (New_Id => Prim_Op,
+                                Old_Id => E,
+                                Skip_Controlling_Formals => True)
+                    and then DT_Position (Prim_Op) = DT_Position (E)
                     and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag)
                     and then not Present (Abstract_Interface_Alias (Prim_Op))
                   then
-                     if Overriden_Op /= Empty then
-                        raise Program_Error;
-                     end if;
+                     if Overriden_Op = Empty then
+                        Overriden_Op := Prim_Op;
+
+                     --  Additional check to ensure that if two candidates have
+                     --  been found then they refer to the same subprogram.
 
-                     Overriden_Op := Prim_Op;
+                     else
+                        declare
+                           A1 : Entity_Id;
+                           A2 : Entity_Id;
+
+                        begin
+                           A1 := Overriden_Op;
+                           while Present (Alias (A1)) loop
+                              A1 := Alias (A1);
+                           end loop;
+
+                           A2 := Prim_Op;
+                           while Present (Alias (A2)) loop
+                              A2 := Alias (A2);
+                           end loop;
+
+                           if A1 /= A2 then
+                              raise Program_Error;
+                           end if;
+                        end;
+                     end if;
                   end if;
 
                   Next_Elmt (Elmt);
                end loop;
 
-               --  if not found this is the first overriding of some
-               --  abstract interface
+               --  If not found this is the first overriding of some abstract
+               --  interface.
 
                if Overriden_Op /= Empty then
-                  Elmt := First_Elmt (Primitive_Operations (Typ));
 
                   --  Find the entries associated with interfaces that are
-                  --  alias of this primitive operation in the ancestor
+                  --  alias of this primitive operation in the ancestor.
 
+                  Elmt := First_Elmt (Primitive_Operations (Typ));
                   while Present (Elmt) loop
                      Prim_Op := Node (Elmt);
 
@@ -4178,7 +4197,7 @@ package body Exp_Ch6 is
                             Iface => Iface_Typ);
 
             --  Generate the code of the thunk only when this primitive
-            --  operation is associated with a secondary dispatch table
+            --  operation is associated with a secondary dispatch table.
 
             if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
                Thunk_Id  := Make_Defining_Identifier (Loc,
@@ -4188,7 +4207,7 @@ package body Exp_Ch6 is
                    (N           => Prim,
                     Thunk_Alias => Alias (Prim),
                     Thunk_Id    => Thunk_Id,
-                    Iface_Tag   => Iface_Tag);
+                    Thunk_Tag   => Iface_Tag);
 
                Insert_After (N, New_Thunk);
 
@@ -4238,7 +4257,7 @@ package body Exp_Ch6 is
                    (N           => Ancestor_Iface_Prim,
                     Thunk_Alias => Prim_Op,
                     Thunk_Id    => Thunk_Id,
-                    Iface_Tag   => Iface_Tag);
+                    Thunk_Tag   => Iface_Tag);
 
                Insert_After (N, New_Thunk);
 
@@ -4279,7 +4298,7 @@ package body Exp_Ch6 is
 
          else
             --  Ada 2005 (AI-251): Check if this entry corresponds with
-            --  a subprogram that covers an abstract interface type
+            --  a subprogram that covers an abstract interface type.
 
             if Present (Abstract_Interface_Alias (E)) then
                Register_Interface_DT_Entry (E);
@@ -4296,7 +4315,7 @@ package body Exp_Ch6 is
 
       --  Mark functions that return by reference. Note that it cannot be
       --  part of the normal semantic analysis of the spec since the
-      --  underlying returned type may not be known yet (for private types)
+      --  underlying returned type may not be known yet (for private types).
 
       declare
          Typ  : constant Entity_Id := Etype (E);

gcc/ada/exp_dbug.ads

@@ -89,7 +89,7 @@ package Exp_Dbug is
    --    x
    --    y.z
 
-   --  The separating dots are translated into double underscores.
+   --  The separating dots are translated into double underscores
 
       -----------------------------
       -- Handling of Overloading --
@@ -385,6 +385,28 @@ package Exp_Dbug is
       --    lock_update1sE
       --    lock_udpate2sB
 
+      --  If the protected type implements at least one interface, the
+      --  following additional operations are created:
+
+      --    lock_get
+
+      --    lock_set
+
+      --  These operations are used to ensure overriding of interface level
+      --  subprograms and proper dispatching on interface class-wide objects.
+      --  The bodies of these operations contain calls to their respective
+      --  protected versions:
+
+      --    function lock_get return Integer is
+      --    begin
+      --       return lock_getP;
+      --    end lock_get;
+
+      --    procedure lock_set (X : Integer) is
+      --    begin
+      --       lock_setP (X);
+      --    end lock_set;
+
    ----------------------------------------------------
    -- Conversion between Entities and External Names --
    ----------------------------------------------------
@@ -686,9 +708,9 @@ package Exp_Dbug is
       --  follows. In this description, let P represent the current
       --  bit position in the record.
 
-      --    1. Initialize P to 0.
+      --    1. Initialize P to 0
 
-      --    2. For each field in the record,
+      --    2. For each field in the record:
 
       --       2a. If an alignment is given (see below), then round P
       --       up, if needed, to the next multiple of that alignment.
@@ -697,7 +719,7 @@ package Exp_Dbug is
       --       amount (that is, treat it as an offset from the end of the
       --       preceding record).
 
-      --       2c. Assign P as the actual position of the field.
+      --       2c. Assign P as the actual position of the field
 
       --       2d. Compute the length, L, of the represented field (see below)
       --       and compute P'=P+L. Unless the field represents a variant part
@@ -963,7 +985,7 @@ package Exp_Dbug is
    --  name of the parent unit, to disambiguate child units with the same
    --  simple name and (of necessity) different parents.
 
-   --  Note: subprogram renamings are not encoded at the present time.
+   --  Note: subprogram renamings are not encoded at the present time
 
    --  The type is an enumeration type with a single enumeration literal
    --  that is an identifier which describes the renamed variable.

gcc/ada/lib-load.adb

@@ -53,6 +53,11 @@ package body Lib.Load is
    -- Local Subprograms --
    -----------------------
 
+   function From_Limited_With_Chain (Lim : Boolean) return Boolean;
+   --  Check whether a possible circular dependence includes units that
+   --  have been loaded through limited_with clauses, in which case there
+   --  is no real circularity.
+
    function Spec_Is_Irrelevant
      (Spec_Unit : Unit_Number_Type;
       Body_Unit : Unit_Number_Type) return Boolean;
@@ -165,6 +170,30 @@ package body Lib.Load is
       return Unum;
    end Create_Dummy_Package_Unit;
 
+   -----------------------------
+   -- From_Limited_With_Chain --
+   -----------------------------
+
+   function From_Limited_With_Chain (Lim : Boolean) return Boolean is
+   begin
+      --  True if the current load operation is through a limited_with clause
+
+      if Lim then
+         return True;
+
+      --  Examine the Load_Stack to locate any previous Limited_with clause
+
+      elsif Load_Stack.Last - 1 > Load_Stack.First then
+         for U in Load_Stack.First .. Load_Stack.Last - 1 loop
+            if Load_Stack.Table (U).From_Limited_With then
+               return True;
+            end if;
+         end loop;
+      end if;
+
+      return False;
+   end From_Limited_With_Chain;
+
    ----------------
    -- Initialize --
    ----------------
@@ -193,7 +222,7 @@ package body Lib.Load is
 
    begin
       Load_Stack.Increment_Last;
-      Load_Stack.Table (Load_Stack.Last) := Main_Unit;
+      Load_Stack.Table (Load_Stack.Last) := (Main_Unit, False);
 
       --  Initialize unit table entry for Main_Unit. Note that we don't know
       --  the unit name yet, that gets filled in when the parser parses the
@@ -465,10 +494,11 @@ package body Lib.Load is
          end loop;
       end if;
 
-      --  If we are proceeding with load, then make load stack entry
+      --  If we are proceeding with load, then make load stack entry,
+      --  and indicate the kind of with_clause responsible for the load.
 
       Load_Stack.Increment_Last;
-      Load_Stack.Table (Load_Stack.Last) := Unum;
+      Load_Stack.Table (Load_Stack.Last) := (Unum, From_Limited_With);
 
       --  Case of entry already in table
 
@@ -489,7 +519,7 @@ package body Lib.Load is
                        or else Acts_As_Spec (Units.Table (Unum).Cunit))
            and then (Nkind (Error_Node) /= N_With_Clause
                        or else not Limited_Present (Error_Node))
-           and then not From_Limited_With
+           and then not From_Limited_With_Chain (From_Limited_With)
          then
             if Debug_Flag_L then
                Write_Str ("  circular dependency encountered");
@@ -733,8 +763,10 @@ package body Lib.Load is
 
       if Load_Stack.Last - 1 > Load_Stack.First then
          for U in Load_Stack.First .. Load_Stack.Last - 1 loop
-            Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U));
-            Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1));
+            Error_Msg_Unit_1 :=
+              Unit_Name (Load_Stack.Table (U).Unit_Number);
+            Error_Msg_Unit_2 :=
+              Unit_Name (Load_Stack.Table (U + 1).Unit_Number);
             Error_Msg ("$ depends on $!", Load_Msg_Sloc);
          end loop;
       end if;

gcc/ada/lib.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          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- --
@@ -239,11 +239,6 @@ package Lib is
    --  Main_Unit is a body with a separate spec, in which case it is the
    --  entity for the spec.
 
-   Unit_Exception_Table_Present : Boolean;
-   --  Set true if a unit exception table is present for the unit (i.e.
-   --  zero cost exception handling is active and there is at least one
-   --  subprogram in the extended unit).
-
    -----------------
    -- Units Table --
    -----------------
@@ -623,7 +618,7 @@ package Lib is
 
    function Generic_Separately_Compiled
      (Sfile : File_Name_Type) return  Boolean;
-   --  Same as the previous function, but works directly on a unit file name.
+   --  Same as the previous function, but works directly on a unit file name
 
 private
    pragma Inline (Cunit);
@@ -722,16 +717,23 @@ private
    type Unit_Ref_Table is array (Pos range <>) of Unit_Number_Type;
    --  Type to hold list of indirect references to unit number table
 
-   --  The Load_Stack table contains a list of unit numbers (indexes into the
-   --  unit table) of units being loaded on a single dependency chain. The
-   --  First entry is the main unit. The second entry, if present is a unit
-   --  on which the first unit depends, etc. This stack is used to generate
-   --  error messages showing the dependency chain if a file is not found.
-   --  The Load function makes an entry in this table when it is called, and
-   --  removes the entry just before it returns.
+   type Load_Stack_Entry is record
+      Unit_Number       : Unit_Number_Type;
+      From_Limited_With : Boolean;
+   end record;
+
+   --  The Load_Stack table contains a list of unit numbers (indices into the
+   --  unit table) of units being loaded on a single dependency chain, and a
+   --  flag to indicate whether this unit is loaded through a limited_with
+   --  clause. The First entry is the main unit. The second entry, if present
+   --  is a unit on which the first unit depends, etc. This stack is used to
+   --  generate error messages showing the dependency chain if a file is not
+   --  found, or whether a true circular dependency exists.  The Load_Unit
+   --  function makes an entry in this table when it is called, and removes
+   --  the entry just before it returns.
 
    package Load_Stack is new Table.Table (
-     Table_Component_Type => Unit_Number_Type,
+     Table_Component_Type => Load_Stack_Entry,
      Table_Index_Type     => Nat,
      Table_Low_Bound      => 0,
      Table_Initial        => Alloc.Load_Stack_Initial,