sem_ch3.adb (Access_Definition): A formal object declaration is a legal context for...

2008-08-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Access_Definition): A formal object declaration is a
	legal context for an anonymous access to subprogram.

	* sem_ch4.adb (Analyze_One_Call): If the call can be interpreted as an
	indirect call, report success to the caller to include possible
	interpretation.

	* sem_ch6.adb (Check_Return_Type_Indication): Apply proper conformance
	check when the type
	of the extended return is an anonymous access_to_subprogram type.

	* sem_res.adb:
	(Resolve_Call): Insert a dereference if the type of the subprogram is an
	access_to_subprogram and the context requires its return type, and a
	dereference has not been introduced previously.

From-SVN: r138591

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index c95f5da65352f7d3900a49199336281e5f1e2adf..0ac17bf2efc7c8db2f22bf7921ffad3471a13a19 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -1054,6 +1054,7 @@ package body Sem_Ch3 is
                    or else
                  Nkind_In (D_Ityp, N_Object_Declaration,
                                    N_Object_Renaming_Declaration,
+                                   N_Formal_Object_Declaration,
                                    N_Formal_Type_Declaration,
                                    N_Task_Type_Declaration,
                                    N_Protected_Type_Declaration))

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index eb9b52e3d178fbe33e9164b1480a1205af4dac11..5f23ca28c4f345dd9abc485e65fb34556eb532a6 100644 (file)
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2127,11 +2127,12 @@ package body Sem_Ch4 is
       --  is already known to be compatible, and because this may be an
       --  indexing of a call with default parameters.
 
-      Formal     : Entity_Id;
-      Actual     : Node_Id;
-      Is_Indexed : Boolean := False;
-      Subp_Type  : constant Entity_Id := Etype (Nam);
-      Norm_OK    : Boolean;
+      Formal      : Entity_Id;
+      Actual      : Node_Id;
+      Is_Indexed  : Boolean := False;
+      Is_Indirect : Boolean := False;
+      Subp_Type   : constant Entity_Id := Etype (Nam);
+      Norm_OK     : Boolean;
 
       function Operator_Hidden_By (Fun : Entity_Id) return Boolean;
       --  There may be a user-defined operator that hides the current
@@ -2240,6 +2241,13 @@ package body Sem_Ch4 is
       --  in prefix notation, so that the rebuilt parameter list has more than
       --  one actual.
 
+      if not Is_Overloadable (Nam)
+        and then Ekind (Nam) /= E_Subprogram_Type
+        and then Ekind (Nam) /= E_Entry_Family
+      then
+         return;
+      end if;
+
       if Present (Actuals)
         and then
           (Needs_No_Actuals (Nam)
@@ -2259,11 +2267,13 @@ package body Sem_Ch4 is
 
          --  The prefix can also be a parameterless function that returns an
          --  access to subprogram, in which case this is an indirect call.
+         --  If this succeeds, an explicit dereference is added later on,
+         --  in Analyze_Call or Resolve_Call.
 
          elsif Is_Access_Type (Subp_Type)
            and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type
          then
-            Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type);
+            Is_Indirect := Try_Indirect_Call (N, Nam, Subp_Type);
          end if;
 
       end if;
@@ -2278,13 +2288,21 @@ package body Sem_Ch4 is
          return;
       end if;
 
-      Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK);
+      Normalize_Actuals
+        (N, Nam, (Report and not Is_Indexed and not Is_Indirect), Norm_OK);
 
       if not Norm_OK then
 
+         --  If an indirect call is a possible interpretation, indicate
+         --  success to the caller.
+
+         if Is_Indirect then
+            Success := True;
+            return;
+
          --  Mismatch in number or names of parameters
 
-         if Debug_Flag_E then
+         elsif Debug_Flag_E then
             Write_Str (" normalization fails in call ");
             Write_Int (Int (N));
             Write_Str (" with subprogram ");
@@ -2410,7 +2428,7 @@ package body Sem_Ch4 is
                      Write_Eol;
                   end if;
 
-                  if Report and not Is_Indexed then
+                  if Report and not Is_Indexed and not Is_Indirect then
 
                      --  Ada 2005 (AI-251): Complete the error notification
                      --  to help new Ada 2005 users

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 794a05730e5c91482d7423a89bc0d118b1b8f6bc..1ab798240a0c76a56f456924f4c03a0b2494d5ea 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -542,16 +542,33 @@ package body Sem_Ch6 is
 
          --  "return access T" case; check that the return statement also has
          --  "access T", and that the subtypes statically match:
+         --   if this is an access to subprogram the signatures must match.
 
          if R_Type_Is_Anon_Access then
             if R_Stm_Type_Is_Anon_Access then
-               if Base_Type (Designated_Type (R_Stm_Type)) /=
-                    Base_Type (Designated_Type (R_Type))
-                 or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
+               if
+                 Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
                then
-                  Error_Msg_N
-                    ("subtype must statically match function result subtype",
-                     Subtype_Mark (Subtype_Ind));
+                  if Base_Type (Designated_Type (R_Stm_Type)) /=
+                     Base_Type (Designated_Type (R_Type))
+                    or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
+                  then
+                     Error_Msg_N
+                      ("subtype must statically match function result subtype",
+                       Subtype_Mark (Subtype_Ind));
+                  end if;
+
+               else
+                  --  For two anonymous access to subprogram types, the
+                  --  types themselves must be type conformant.
+
+                  if not Conforming_Types
+                    (R_Stm_Type, R_Type, Fully_Conformant)
+                  then
+                     Error_Msg_N
+                      ("subtype must statically match function result subtype",
+                         Subtype_Ind);
+                  end if;
                end if;
 
             else

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 7a767a391794fc33f32c42eb94f0af0601d54511..62822aa7b8c6a20c7dce408c4493f5daf65c6075 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4692,6 +4692,25 @@ package body Sem_Res is
          end loop;
       end if;
 
+      if Ekind (Etype (Nam)) = E_Access_Subprogram_Type
+         and then Ekind (Typ) /= E_Access_Subprogram_Type
+         and then Nkind (Subp) /= N_Explicit_Dereference
+         and then Present (Parameter_Associations (N))
+      then
+         --  The prefix is a parameterless function call that returns an
+         --  access to subprogram. If parameters are present in the current
+         --  call  add an explicit dereference.
+
+         --  The dereference is added either in Analyze_Call or here. Should
+         --  be consolidated ???
+
+         Set_Is_Overloaded (Subp, False);
+         Set_Etype (Subp, Etype (Nam));
+         Insert_Explicit_Dereference (Subp);
+         Nam := Designated_Type (Etype (Nam));
+         Resolve (Subp, Nam);
+      end if;
+
       --  Check that a call to Current_Task does not occur in an entry body
 
       if Is_RTE (Nam, RE_Current_Task) then
@@ -9487,7 +9506,10 @@ package body Sem_Res is
 
       --  Access to subprogram types. If the operand is an access parameter,
       --  the type has a deeper accessibility that any master, and cannot
-      --  be assigned.
+      --  be assigned. We must make an exception if the conversion is part
+      --  of an assignment and the target is the return object of an extended
+      --  return statement, because in that case the accessibility check
+      --  takes place after the return.
 
       elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
                or else
@@ -9497,6 +9519,10 @@ package body Sem_Res is
          if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type
            and then Is_Entity_Name (Operand)
            and then Ekind (Entity (Operand)) = E_In_Parameter
+           and then
+             (Nkind (Parent (N)) /= N_Assignment_Statement
+               or else not Is_Entity_Name (Name (Parent (N)))
+               or else not Is_Return_Object (Entity (Name (Parent (N)))))
          then
             Error_Msg_N
               ("illegal attempt to store anonymous access to subprogram",