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);