2005-03-29 Ed Schonberg <schonberg@adacore.com>

	* sem_ch4.adb (Analyze_Selected_Component): Do not generate an actual
	subtype if code is being pre-analyzed, to prevent un-expanded
	references to protected formals, among others.
	(Analyze_Explicit_Dereference): If the overloaded prefix includes some
	interpretation that can be a call, include the result of the call as a
	possible interpretation of the dereference.

	* sem_ch5.adb (Process_Bounds): Determine type of range by
	pre-analyzing a copy of the original range, and then analyze the range
	with the expected type.

	* sem_res.adb (Check_Parameterless_Call): For an explicit dereference
	with an overloaded prefix where not all interpretations yield an
	access to subprogram, do not rewrite node as a call.
	(Resolve_Explicit_Dereference): Recognize the previous case and rewrite
	the node as a call once the context identifies the interpretation of
	the prefix whose call yields the context type.
	(Valid_Conversion): For the case of a conversion between
	local access-to-subprogram types, check subtype conformance using
	Check_Subtype_Conformant instead of Subtype_Conformant, to have a more
	detailed error message.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@97184 138bc75d-0d04-0410-961f-82ee72b054a4

2 files changed, 89 insertions, 41 deletions

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index a7931e9c0ac..88035b8a1f4 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -1197,7 +1197,7 @@ package body Sem_Ch4 is
          end if;
       end Is_Function_Type;
 
-   --  Start of processing for Analyze_Explicit_Deference
+   --  Start of processing for Analyze_Explicit_Dereference
 
    begin
       Analyze (P);
@@ -1251,8 +1251,6 @@ package body Sem_Ch4 is
             Get_Next_Interp (I, It);
          end loop;
 
-         End_Interp_List;
-
          --  Error if no interpretation of the prefix has an access type
 
          if Etype (N) = Any_Type then
@@ -1281,10 +1279,11 @@ package body Sem_Ch4 is
       then
          --  Name is a function call with no actuals, in a context that
          --  requires deproceduring (including as an actual in an enclosing
-         --  function or procedure call). We can conceive of pathological cases
+         --  function or procedure call). There are some pathological cases
          --  where the prefix might include functions that return access to
          --  subprograms and others that return a regular type. Disambiguation
-         --  of those will have to take place in Resolve. See e.g. 7117-014.
+         --  of those has to take place in Resolve.
+         --  See e.g. 7117-014 and E317-001.
 
          New_N :=
            Make_Function_Call (Loc,
@@ -1311,6 +1310,25 @@ package body Sem_Ch4 is
 
          Rewrite (N, New_N);
          Analyze (N);
+
+      elsif not Is_Function_Type
+        and then Is_Overloaded (N)
+      then
+         --  The prefix may include access to subprograms and other access
+         --  types. If the context selects the interpretation that is a call,
+         --  we cannot rewrite the node yet, but we include the result of
+         --  the call interpretation.
+
+         Get_First_Interp (N, I, It);
+         while Present (It.Nam) loop
+            if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type
+               and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type
+            then
+               Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ));
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
       end if;
 
       --  A value of remote access-to-class-wide must not be dereferenced
@@ -2652,14 +2670,20 @@ package body Sem_Ch4 is
                then
                   Set_Etype (N, Etype (Comp));
 
-               --  In all other cases, we currently build an actual subtype. It
-               --  seems likely that many of these cases can be avoided, but
-               --  right now, the front end makes direct references to the
+               --  If full analysis is not enabled, we do not generate an
+               --  actual subtype, because in the absence of expansion
+               --  reference to a formal of a protected type, for example,
+               --  will not be properly transformed, and will lead to
+               --  out-of-scope references in gigi.
+
+               --  In all other cases, we currently build an actual subtype.
+               --  It seems likely that many of these cases can be avoided,
+               --  but right now, the front end makes direct references to the
                --  bounds (e.g. in generating a length check), and if we do
                --  not make an actual subtype, we end up getting a direct
-               --  reference to a discriminant which will not do.
+               --  reference to a discriminant, which will not do.
 
-               else
+               elsif Full_Analysis then
                   Act_Decl :=
                     Build_Actual_Subtype_Of_Component (Etype (Comp), N);
                   Insert_Action (N, Act_Decl);
@@ -2681,6 +2705,11 @@ package body Sem_Ch4 is
                         Set_Etype (N, Subt);
                      end;
                   end if;
+
+               --  If Full_Analysis not enabled, just set the Etype
+
+               else
+                  Set_Etype (N, Etype (Comp));
                end if;
 
                return;
@@ -2697,17 +2726,17 @@ package body Sem_Ch4 is
          then
             return;
 
-            --  If the transformation fails, it will be necessary
-            --  to redo the analysis with all errors enabled, to indicate
-            --  candidate interpretations and reasons for each failure ???
+            --  If the transformation fails, it will be necessary to redo the
+            --  analysis with all errors enabled, to indicate candidate
+            --  interpretations and reasons for each failure ???
 
          end if;
 
       elsif Is_Private_Type (Prefix_Type) then
 
-         --  Allow access only to discriminants of the type. If the
-         --  type has no full view, gigi uses the parent type for
-         --  the components, so we do the same here.
+         --  Allow access only to discriminants of the type. If the type has
+         --  no full view, gigi uses the parent type for the components, so we
+         --  do the same here.
 
          if No (Full_View (Prefix_Type)) then
             Entity_List := Root_Type (Base_Type (Prefix_Type));
@@ -2747,11 +2776,11 @@ package body Sem_Ch4 is
       elsif Is_Concurrent_Type (Prefix_Type) then
 
          --  Prefix is concurrent type. Find visible operation with given name
-         --  For a task, this can only include entries or discriminants if
-         --  the task type is not an enclosing scope. If it is an enclosing
-         --  scope (e.g. in an inner task) then all entities are visible, but
-         --  the prefix must denote the enclosing scope, i.e. can only be
-         --  a direct name or an expanded name.
+         --  For a task, this can only include entries or discriminants if the
+         --  task type is not an enclosing scope. If it is an enclosing scope
+         --  (e.g. in an inner task) then all entities are visible, but the
+         --  prefix must denote the enclosing scope, i.e. can only be a direct
+         --  name or an expanded name.
 
          Set_Etype (Sel,  Any_Type);
          In_Scope := In_Open_Scopes (Prefix_Type);
@@ -2780,8 +2809,8 @@ package body Sem_Ch4 is
                   Set_Original_Discriminant (Sel, Comp);
                end if;
 
-               --  For access type case, introduce explicit deference for
-               --  more uniform treatment of entry calls.
+               --  For access type case, introduce explicit deference for more
+               --  uniform treatment of entry calls.
 
                if Is_Access_Type (Etype (Name)) then
                   Insert_Explicit_Dereference (Name);
@@ -2809,8 +2838,8 @@ package body Sem_Ch4 is
 
       if Etype (N) = Any_Type then
 
-         --  If the prefix is a single concurrent object, use its name in
-         --  the error message, rather than that of its anonymous type.
+         --  If the prefix is a single concurrent object, use its name in the
+         --  error message, rather than that of its anonymous type.
 
          if Is_Concurrent_Type (Prefix_Type)
            and then Is_Internal_Name (Chars (Prefix_Type))
@@ -2828,7 +2857,7 @@ package body Sem_Ch4 is
            and then Prefix_Type /= Etype (Prefix_Type)
            and then Is_Record_Type (Etype (Prefix_Type))
          then
-            --  If this is a derived formal type, the parent may have a
+            --  If this is a derived formal type, the parent may have
             --  different visibility at this point. Try for an inherited
             --  component before reporting an error.
 
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 3f16dca9396..163365fc46a 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -1112,7 +1112,9 @@ package body Sem_Ch5 is
       --  If the iteration is given by a range, create temporaries and
       --  assignment statements block to capture the bounds and perform
       --  required finalization actions in case a bound includes a function
-      --  call that uses the temporary stack.
+      --  call that uses the temporary stack. We first pre-analyze a copy of
+      --  the range in order to determine the expected type, and analyze
+      --  and resolve the original bounds.
 
       procedure Check_Controlled_Array_Attribute (DS : Node_Id);
       --  If the bounds are given by a 'Range reference on a function call
@@ -1126,13 +1128,16 @@ package body Sem_Ch5 is
 
       procedure Process_Bounds (R : Node_Id) is
          Loc          : constant Source_Ptr := Sloc (N);
+         R_Copy       : constant Node_Id := New_Copy_Tree (R);
          Lo           : constant Node_Id := Low_Bound  (R);
          Hi           : constant Node_Id := High_Bound (R);
          New_Lo_Bound : Node_Id := Empty;
          New_Hi_Bound : Node_Id := Empty;
-         Typ          : constant Entity_Id := Etype (R);
+         Typ          : Entity_Id;
 
-         function One_Bound (Bound : Node_Id) return Node_Id;
+         function One_Bound
+           (Original_Bound : Node_Id;
+            Analyzed_Bound : Node_Id) return Node_Id;
          --  Create one declaration followed by one assignment statement
          --  to capture the value of bound. We create a separate assignment
          --  in order to force the creation of a block in case the bound
@@ -1142,7 +1147,10 @@ package body Sem_Ch5 is
          -- One_Bound --
          ---------------
 
-         function One_Bound (Bound : Node_Id) return Node_Id is
+         function One_Bound
+           (Original_Bound : Node_Id;
+            Analyzed_Bound : Node_Id) return Node_Id
+         is
             Assign   : Node_Id;
             Id       : Entity_Id;
             Decl     : Node_Id;
@@ -1156,11 +1164,17 @@ package body Sem_Ch5 is
             --  part of the call to Make_Index (literal bounds may need to
             --  be resolved to type Integer).
 
-            if Nkind (Bound) = N_Integer_Literal
-              or else Is_Entity_Name (Bound)
-              or else Analyzed (Bound)
+            if Analyzed (Original_Bound) then
+               return Original_Bound;
+
+            elsif Nkind (Analyzed_Bound) = N_Integer_Literal
+              or else Is_Entity_Name (Analyzed_Bound)
             then
-               return Bound;
+               Analyze_And_Resolve (Original_Bound, Typ);
+               return Original_Bound;
+
+            else
+               Analyze_And_Resolve (Original_Bound, Typ);
             end if;
 
             Id :=
@@ -1188,26 +1202,32 @@ package body Sem_Ch5 is
             Assign :=
               Make_Assignment_Statement (Loc,
                 Name        => New_Occurrence_Of (Id, Loc),
-                Expression  => Relocate_Node (Bound));
+                Expression  => Relocate_Node (Original_Bound));
 
-            Save_Interps (Bound, Expression (Assign));
             Insert_Before (Parent (N), Assign);
             Analyze (Assign);
 
-            Rewrite (Bound, New_Occurrence_Of (Id, Loc));
+            Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
 
             if Nkind (Assign) = N_Assignment_Statement then
                return Expression (Assign);
             else
-               return Bound;
+               return Original_Bound;
             end if;
          end One_Bound;
 
       --  Start of processing for Process_Bounds
 
       begin
-         New_Lo_Bound := One_Bound (Lo);
-         New_Hi_Bound := One_Bound (Hi);
+         --  Determine expected type of range by analyzing separate copy.
+
+         Set_Parent (R_Copy, Parent (R));
+         Pre_Analyze_And_Resolve (R_Copy);
+         Typ := Etype (R_Copy);
+         Set_Etype (R, Typ);
+
+         New_Lo_Bound := One_Bound (Lo, Low_Bound  (R_Copy));
+         New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy));
 
          --  Propagate staticness to loop range itself, in case the
          --  corresponding subtype is static.
@@ -1332,7 +1352,6 @@ package body Sem_Ch5 is
                   if Nkind (DS) = N_Range
                     and then Expander_Active
                   then
-                     Pre_Analyze_And_Resolve (DS);
                      Process_Bounds (DS);
                   else
                      Analyze (DS);