[multiple changes]

2010-10-07  Robert Dewar  <dewar@adacore.com>

	* par-ch3.adb, par-ch6.adb, par-ch7.adb, par-ch9.adb, par-ch10.adb: Add
	Pexp to Pf_Rec constants
	(P_Subprogram): Expression is always enclosed in parentheses
	* par.adb (Pf_Rec): add Pexp flag for parametrized expression
	* sinfo.ads (N_Parametrized_Expression): Expression must be in parens

2010-10-07  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Subprogram_Specification): Implement Ada2012
	checks on functions that return an abstract type or have a controlling
	result whose designated type is an abstract type.
	(Check_Private_Overriding): Implement Ada2012 checks on functions
	declared in the private part, if an abstract type is involved.
	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): In Ada2012,
	reject a generic function that returns an abstract type.
	* exp_ch5.adb (Expand_Simple_Function_Return): in Ada2012, if a
	function has a controlling access result, check that the tag of the
	return value matches the designated type of the return expression.

From-SVN: r165100

gcc/ada/ChangeLog

 2010-10-07  Robert Dewar  <dewar@adacore.com>
 
+	* par-ch3.adb, par-ch6.adb, par-ch7.adb, par-ch9.adb, par-ch10.adb: Add
+	Pexp to Pf_Rec constants
+	(P_Subprogram): Expression is always enclosed in parentheses
+	* par.adb (Pf_Rec): add Pexp flag for parametrized expression
+	* sinfo.ads (N_Parametrized_Expression): Expression must be in parens
+
+2010-10-07  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch6.adb (Analyze_Subprogram_Specification): Implement Ada2012
+	checks on functions that return an abstract type or have a controlling
+	result whose designated type is an abstract type.
+	(Check_Private_Overriding): Implement Ada2012 checks on functions
+	declared in the private part, if an abstract type is involved.
+	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): In Ada2012,
+	reject a generic function that returns an abstract type.
+	* exp_ch5.adb (Expand_Simple_Function_Return): in Ada2012, if a
+	function has a controlling access result, check that the tag of the
+	return value matches the designated type of the return expression.
+
+2010-10-07  Robert Dewar  <dewar@adacore.com>
+
 	* par-ch6.adb: Fix error in handling of parametrized expressions.
 	* par-ch4.adb (P_Name): Allow qualified expression as name in Ada 2012
 	mode.

gcc/ada/exp_ch5.adb

@@ -4246,6 +4246,29 @@ package body Exp_Ch5 is
                         Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
                 Reason => PE_Accessibility_Check_Failed));
          end;
+
+      --  AI05-0073 : if function has a controlling access result, check that
+      --  the tag of the return value matches the designated type.
+
+      elsif Ekind (R_Type) = E_Anonymous_Access_Type
+        and then Has_Controlling_Result (Scope_Id)
+        and then Ada_Version >= Ada_12
+      then
+         Insert_Action (Exp,
+           Make_Raise_Constraint_Error (Loc,
+             Condition =>
+               Make_Op_Ne (Loc,
+                 Left_Opnd =>
+                   Make_Selected_Component (Loc,
+                     Prefix => Duplicate_Subexpr (Exp),
+                     Selector_Name =>
+                       Make_Identifier (Loc, Chars => Name_uTag)),
+                 Right_Opnd =>
+                   Make_Attribute_Reference (Loc,
+                     Prefix =>
+                       New_Occurrence_Of (Designated_Type (R_Type), Loc),
+                     Attribute_Name => Name_Tag)),
+           Reason => CE_Tag_Check_Failed));
       end if;
 
       --  If we are returning an object that may not be bit-aligned, then copy

gcc/ada/par-ch10.adb

@@ -347,10 +347,10 @@ package body Ch10 is
             Error_Msg_BC -- CODEFIX
               ("keyword BODY expected here [see file name]");
             Restore_Scan_State (Scan_State);
-            Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod));
+            Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod_Pexp));
          else
             Restore_Scan_State (Scan_State);
-            Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam));
+            Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam_Pexp));
          end if;
 
       elsif Token = Tok_Generic then
@@ -364,7 +364,7 @@ package body Ch10 is
         or else Token = Tok_Overriding
         or else Token = Tok_Procedure
       then
-         Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
+         Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp));
 
          --  A little bit of an error recovery check here. If we just scanned
          --  a subprogram declaration (as indicated by an SIS entry being
@@ -1034,10 +1034,10 @@ package body Ch10 is
         or else Token = Tok_Overriding
         or else Token = Tok_Procedure
       then
-         Body_Node := P_Subprogram (Pf_Pbod);
+         Body_Node := P_Subprogram (Pf_Pbod_Pexp);
 
       elsif Token = Tok_Package then
-         Body_Node := P_Package (Pf_Pbod);
+         Body_Node := P_Package (Pf_Pbod_Pexp);
 
       elsif Token = Tok_Protected then
          Scan; -- past PROTECTED

gcc/ada/par-ch3.adb

@@ -4142,7 +4142,7 @@ package body Ch3 is
 
          when Tok_Function =>
             Check_Bad_Layout;
-            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
             Done := False;
 
          when Tok_For =>
@@ -4186,7 +4186,7 @@ package body Ch3 is
                Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
 
                Token := Tok_Overriding;
-               Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+               Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
                Done := False;
 
             --  Normal case, no overriding, or overriding followed by colon
@@ -4201,17 +4201,17 @@ package body Ch3 is
 
          when Tok_Not =>
             Check_Bad_Layout;
-            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
             Done := False;
 
          when Tok_Overriding =>
             Check_Bad_Layout;
-            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
             Done := False;
 
          when Tok_Package =>
             Check_Bad_Layout;
-            Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+            Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
             Done := False;
 
          when Tok_Pragma =>
@@ -4220,7 +4220,7 @@ package body Ch3 is
 
          when Tok_Procedure =>
             Check_Bad_Layout;
-            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
             Done := False;
 
          when Tok_Protected =>

gcc/ada/par-ch7.adb

@@ -109,7 +109,7 @@ package body Ch7 is
       --  Case of package body. Note that we demand a package body if that
       --  is the only possibility (even if the BODY keyword is not present)
 
-      if Token = Tok_Body or else Pf_Flags = Pf_Pbod then
+      if Token = Tok_Body or else Pf_Flags = Pf_Pbod_Pexp then
          if not Pf_Flags.Pbod then
             Error_Msg_SC ("package body cannot appear here!");
          end if;

gcc/ada/par-ch9.adb

@@ -651,7 +651,7 @@ package body Ch9 is
                Set_Must_Not_Override (Decl, Not_Overriding);
 
             elsif Token = Tok_Function or else Token = Tok_Procedure then
-               Decl := P_Subprogram (Pf_Decl);
+               Decl := P_Subprogram (Pf_Decl_Pexp);
 
                Set_Must_Override     (Specification (Decl), Is_Overriding);
                Set_Must_Not_Override (Specification (Decl), Not_Overriding);
@@ -682,7 +682,7 @@ package body Ch9 is
             return P_Entry_Declaration;
 
          elsif Token = Tok_Function or else Token = Tok_Procedure then
-            return P_Subprogram (Pf_Decl);
+            return P_Subprogram (Pf_Decl_Pexp);
 
          elsif Token = Tok_Identifier then
             L := New_List;
@@ -754,7 +754,7 @@ package body Ch9 is
                  or else
                Token = Tok_Not or else Bad_Spelling_Of (Tok_Not)
          then
-            Append (P_Subprogram (Pf_Decl_Pbod), Item_List);
+            Append (P_Subprogram (Pf_Decl_Pbod_Pexp), Item_List);
 
          elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then
             P_Pragmas_Opt (Item_List);

gcc/ada/par.adb

@@ -352,7 +352,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
       Pbod : Boolean;                  -- True if proper body OK
       Rnam : Boolean;                  -- True if renaming declaration OK
       Stub : Boolean;                  -- True if body stub OK
-      Fil1 : Boolean;                  -- Filler to fill to 8 bits
+      Pexp : Boolean;                  -- True if parametried expression OK
       Fil2 : Boolean;                  -- Filler to fill to 8 bits
    end record;
    pragma Pack (Pf_Rec);
@@ -360,18 +360,18 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
    function T return Boolean renames True;
    function F return Boolean renames False;
 
-   Pf_Decl_Gins_Pbod_Rnam_Stub : constant Pf_Rec :=
-                                   Pf_Rec'(F, T, T, T, T, T, F, F);
-   Pf_Decl                     : constant Pf_Rec :=
-                                   Pf_Rec'(F, T, F, F, F, F, F, F);
-   Pf_Decl_Gins_Pbod_Rnam      : constant Pf_Rec :=
-                                   Pf_Rec'(F, T, T, T, T, F, F, F);
-   Pf_Decl_Pbod                : constant Pf_Rec :=
-                                   Pf_Rec'(F, T, F, T, F, F, F, F);
-   Pf_Pbod                     : constant Pf_Rec :=
-                                   Pf_Rec'(F, F, F, T, F, F, F, F);
-   Pf_Spcn                     : constant Pf_Rec :=
-                                   Pf_Rec'(T, F, F, F, F, F, F, F);
+   Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp : constant Pf_Rec :=
+                                       Pf_Rec'(F, T, T, T, T, T, T, F);
+   Pf_Decl_Pexp                     : constant Pf_Rec :=
+                                       Pf_Rec'(F, T, F, F, F, F, T, F);
+   Pf_Decl_Gins_Pbod_Rnam_Pexp      : constant Pf_Rec :=
+                                       Pf_Rec'(F, T, T, T, T, F, T, F);
+   Pf_Decl_Pbod_Pexp                : constant Pf_Rec :=
+                                       Pf_Rec'(F, T, F, T, F, F, T, F);
+   Pf_Pbod_Pexp                     : constant Pf_Rec :=
+                                       Pf_Rec'(F, F, F, T, F, F, T, F);
+   Pf_Spcn                         : constant Pf_Rec :=
+                                       Pf_Rec'(T, F, F, F, F, F, F, F);
    --  The above are the only allowed values of Pf_Rec arguments
 
    type SS_Rec is record

gcc/ada/sem_ch12.adb

@@ -2800,10 +2800,28 @@ package body Sem_Ch12 is
          if Nkind (Result_Definition (Spec)) = N_Access_Definition then
             Result_Type := Access_Definition (Spec, Result_Definition (Spec));
             Set_Etype (Id, Result_Type);
+
+            --  Check restriction imposed by AI05-073 : a generic function
+            --  cannot return an abstract type or an access to such.
+
+            if Is_Abstract_Type (Designated_Type (Result_Type))
+              and then Ada_Version >= Ada_12
+            then
+               Error_Msg_N ("generic function cannot have an access result"
+                 & " that designates an abstract type", Spec);
+            end if;
+
          else
             Find_Type (Result_Definition (Spec));
             Typ := Entity (Result_Definition (Spec));
 
+            if Is_Abstract_Type (Typ)
+              and then Ada_Version >= Ada_12
+            then
+               Error_Msg_N
+                 ("generic function cannot have abstract result type", Spec);
+            end if;
+
             --  If a null exclusion is imposed on the result type, then create
             --  a null-excluding itype (an access subtype) and use it as the
             --  function's Etype.

gcc/ada/sem_ch6.adb

@@ -2960,16 +2960,29 @@ package body Sem_Ch6 is
          --  In case of primitives associated with abstract interface types
          --  the check is applied later (see Analyze_Subprogram_Declaration).
 
-         if Is_Abstract_Type (Etype (Designator))
-           and then not Is_Interface (Etype (Designator))
-           and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
-           and then Nkind (Parent (N)) /=
-                      N_Abstract_Subprogram_Declaration
-           and then
-             (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration
+         if not Nkind_In (Parent (N),
+             N_Subprogram_Renaming_Declaration,
+             N_Abstract_Subprogram_Declaration,
+             N_Formal_Abstract_Subprogram_Declaration)
          then
-            Error_Msg_N
-              ("function that returns abstract type must be abstract", N);
+            if Is_Abstract_Type (Etype (Designator))
+              and then not Is_Interface (Etype (Designator))
+            then
+               Error_Msg_N
+                 ("function that returns abstract type must be abstract", N);
+
+            --  Ada 2012 (AI-0073) : extend this test to subprograms with an
+            --  access result whose designated type is abstract.
+
+            elsif Nkind (Result_Definition (N)) = N_Access_Definition
+              and then
+                not Is_Class_Wide_Type (Designated_Type (Etype (Designator)))
+              and then Is_Abstract_Type (Designated_Type (Etype (Designator)))
+              and then Ada_Version >= Ada_12
+            then
+               Error_Msg_N ("function whose access result designates "
+                 & "abstract type must be abstract", N);
+            end if;
          end if;
       end if;
 
@@ -7029,16 +7042,34 @@ package body Sem_Ch6 is
                      & "(RM 3.9.3(10))!", S);
 
                elsif Ekind (S) = E_Function
-                 and then Is_Tagged_Type (T)
-                 and then T = Base_Type (Etype (S))
                  and then not Is_Overriding
                then
-                  Error_Msg_N
-                    ("private function with tagged result must"
-                     & " override visible-part function", S);
-                  Error_Msg_N
-                    ("\move subprogram to the visible part"
-                     & " (RM 3.9.3(10))", S);
+                  if Is_Tagged_Type (T)
+                    and then T = Base_Type (Etype (S))
+                  then
+                     Error_Msg_N
+                       ("private function with tagged result must"
+                        & " override visible-part function", S);
+                     Error_Msg_N
+                       ("\move subprogram to the visible part"
+                        & " (RM 3.9.3(10))", S);
+
+                  --  AI05-0073: extend this test to the case of a function
+                  --  with a controlling access result.
+
+                  elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
+                    and then Is_Tagged_Type (Designated_Type (Etype (S)))
+                    and then
+                      not Is_Class_Wide_Type (Designated_Type (Etype (S)))
+                    and then Ada_Version >= Ada_12
+                  then
+                     Error_Msg_N
+                       ("private function with controlling access result "
+                          & "must override visible-part function", S);
+                     Error_Msg_N
+                       ("\move subprogram to the visible part"
+                          & " (RM 3.9.3(10))", S);
+                  end if;
                end if;
             end if;
          end Check_Private_Overriding;

gcc/ada/sinfo.ads

@@ -4435,10 +4435,7 @@ package Sinfo is
       --  and put in its proper section when we know exactly where that is!
 
       --  PARAMETRIZED_EXPRESSION ::=
-      --    FUNCTION SPECIFICATION IS EXPRESSION;
-
-      --  Note: there are no separate nodes for the profiles, instead the
-      --  information appears directly in the following nodes.
+      --    FUNCTION SPECIFICATION IS (EXPRESSION);
 
       --  N_Parametrized_Expression
       --  Sloc points to FUNCTION