checks.adb (Null_Exclusion_Static_Checks): In the case of N_Object_Declaration...

2005-07-04  Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* checks.adb (Null_Exclusion_Static_Checks): In the case of
	N_Object_Declaration, only perform the checks if the Object_Definition
	is not an Access_Definition.

        * sem_ch3.adb (Access_Subprogram_Declaration): Add test for the case
        where the parent of an the access definition is an N_Object_Declaration
        when determining the Associated_Node_For_Itype and scope of an
        anonymous access-to-subprogram type.

	* exp_ch6.adb (Expand_N_Subprogram_Declaration): Set the
	Corresponding_Spec on the body created for a null procedure. Add ???
	comment. Remove New_Copy_Tree call on body argument to
	Set_Body_To_Inline.

	* exp_ch6.adb (Add_Simple_Call_By_Copy_Code): For an out parameter with
	discriminants, use the type of the actual as well, because the
	discriminants may be read by the called subprogram.

	* sem_ch3.adb (Access_Type_Declaration): If the designated type is an
	access type we do not need to handle non-limited views.
	(Build_Derived_Record_Type): Additional check to check that in case of
	private types, interfaces are only allowed in private extensions.

From-SVN: r101575

3 files changed, 53 insertions, 15 deletions

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index f93594c2700..68eb16e2d72 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2637,13 +2637,17 @@ package body Checks is
 
          when N_Object_Declaration =>
             Msg_K := Objects;
-            Has_Null_Exclusion := Null_Exclusion_Present (N);
-            Typ := Entity (Object_Definition (N));
-            Related_Nod := Object_Definition (N);
-            Check_Must_Be_Access (Typ, Has_Null_Exclusion);
-            Check_Already_Null_Excluding_Type
-              (Typ, Has_Null_Exclusion, Related_Nod);
-            Check_Must_Be_Initialized (N, Related_Nod);
+
+            if Nkind (Object_Definition (N)) /= N_Access_Definition then
+               Has_Null_Exclusion := Null_Exclusion_Present (N);
+               Typ := Entity (Object_Definition (N));
+               Related_Nod := Object_Definition (N);
+               Check_Must_Be_Access (Typ, Has_Null_Exclusion);
+               Check_Already_Null_Excluding_Type
+                 (Typ, Has_Null_Exclusion, Related_Nod);
+               Check_Must_Be_Initialized (N, Related_Nod);
+            end if;
+
             Check_Null_Not_Allowed (N);
 
          when N_Discriminant_Specification =>
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 2b188bb3e3d..ee7278cc426 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -760,13 +760,25 @@ package body Exp_Ch6 is
          Outcod := New_Copy_Tree (Incod);
 
          --  Generate declaration of temporary variable, initializing it
-         --  with the input parameter unless we have an OUT variable or
+         --  with the input parameter unless we have an OUT formal or
          --  this is an initialization call.
 
+         --  If the formal is an out parameter with discriminants, the
+         --  discriminants must be captured even if the rest of the object
+         --  is in principle uninitialized, because the discriminants may
+         --  be read by the called subprogram.
+
          if Ekind (Formal) = E_Out_Parameter then
             Incod := Empty;
 
+            if Has_Discriminants (Etype (Formal)) then
+               Indic := New_Occurrence_Of (Etype (Actual), Loc);
+            end if;
+
          elsif Inside_Init_Proc then
+
+            --  Could use a comment here to match comment below ???
+
             if Nkind (Actual) /= N_Selected_Component
               or else
                 not Has_Discriminant_Dependent_Constraint
@@ -774,11 +786,10 @@ package body Exp_Ch6 is
             then
                Incod := Empty;
 
-            else
-               --  We need the component in order to generate the proper
-               --  actual subtype, that depends on enclosing discriminants.
-               --  What is the comment for, given code below is null ???
+            --  Otherwise, keep the component in order to generate the proper
+            --  actual subtype, that depends on enclosing discriminants.
 
+            else
                null;
             end if;
          end if;
@@ -3859,9 +3870,20 @@ package body Exp_Ch6 is
                         Make_Handled_Sequence_Of_Statements (Loc,
                           Statements => New_List (Make_Null_Statement (Loc))));
          begin
-            Set_Body_To_Inline (N, New_Copy_Tree (Bod));
+            Set_Body_To_Inline (N, Bod);
             Insert_After (N, Bod);
             Analyze (Bod);
+
+            --  Corresponding_Spec isn't being set by Analyze_Subprogram_Body,
+            --  evidently because Set_Has_Completion is called earlier for null
+            --  procedures in Analyze_Subprogram_Declaration, so we force its
+            --  setting here. If the setting of Has_Completion is not set
+            --  earlier, then it can result in missing body errors if other
+            --  errors were already reported (since expansion is turned off).
+
+            --  Should creation of the empty body be moved to the analyzer???
+
+            Set_Corresponding_Spec (Bod, Defining_Entity (Specification (N)));
          end;
       end if;
    end Expand_N_Subprogram_Declaration;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 00983b6e238..124adbbb07c 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -818,6 +818,7 @@ package body Sem_Ch3 is
       while Nkind (D_Ityp) /= N_Full_Type_Declaration
          and then Nkind (D_Ityp) /= N_Procedure_Specification
          and then Nkind (D_Ityp) /= N_Function_Specification
+         and then Nkind (D_Ityp) /= N_Object_Declaration
          and then Nkind (D_Ityp) /= N_Object_Renaming_Declaration
          and then Nkind (D_Ityp) /= N_Formal_Type_Declaration
       loop
@@ -833,6 +834,7 @@ package body Sem_Ch3 is
          Set_Scope (Desig_Type, Scope (Defining_Unit_Name (D_Ityp)));
 
       elsif Nkind (D_Ityp) = N_Full_Type_Declaration
+        or else Nkind (D_Ityp) = N_Object_Declaration
         or else Nkind (D_Ityp) = N_Object_Renaming_Declaration
         or else Nkind (D_Ityp) = N_Formal_Type_Declaration
       then
@@ -981,7 +983,9 @@ package body Sem_Ch3 is
          N_Desig : Entity_Id;
 
       begin
-         if From_With_Type (Desig) then
+         if From_With_Type (Desig)
+           and then Ekind (Desig) /= E_Access_Type
+         then
             Set_From_With_Type (T);
 
             if Ekind (Desig) = E_Incomplete_Type then
@@ -5870,9 +5874,17 @@ package body Sem_Ch3 is
                   Same_Interfaces    : Boolean := True;
 
                begin
+                  if Nkind (N_Partial) /= N_Private_Extension_Declaration then
+                     Error_Msg_N
+                       ("(Ada 2005) interfaces only allowed in private"
+                        & " extension declarations", N_Partial);
+                  end if;
+
                   --  Count the interfaces implemented by the partial view
 
-                  if not Is_Empty_List (Interface_List (N_Partial)) then
+                  if Nkind (N_Partial) = N_Private_Extension_Declaration
+                    and then not Is_Empty_List (Interface_List (N_Partial))
+                  then
                      Iface_Partial := First (Interface_List (N_Partial));
 
                      while Present (Iface_Partial) loop