Skip to content

R
riscv-gcc-1
Commit fc193526 by Hristian Kirtchev Committed by Arnaud Charlet
Options

sem_ch8.adb (Analyze_Subprogram_Renaming): Alphabetize globals and move certain… 

sem_ch8.adb (Analyze_Subprogram_Renaming): Alphabetize globals and move certain variables to the "local variable" section.

2014-08-01  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch8.adb (Analyze_Subprogram_Renaming): Alphabetize
	globals and move certain variables to the "local
	variable" section. Call Build_Class_Wide_Wrapper when
	renaming a default actual subprogram with a class-wide actual.
	(Build_Class_Wide_Wrapper): New routine.
	(Check_Class_Wide_Actual): Removed.
	(Find_Renamed_Entity): Code reformatting.
	(Has_Class_Wide_Actual): Alphabetize. Change the
	logic of the predicate as the renamed name may not necessarely
	denote the correct subprogram.

From-SVN: r213467
parent 4887624e
Showing with 447 additions and 180 deletions
gcc/ada/ChangeLog
2014-08-01 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch8.adb (Analyze_Subprogram_Renaming): Alphabetize
globals and move certain variables to the "local
variable" section. Call Build_Class_Wide_Wrapper when
renaming a default actual subprogram with a class-wide actual.
(Build_Class_Wide_Wrapper): New routine.
(Check_Class_Wide_Actual): Removed.
(Find_Renamed_Entity): Code reformatting.
(Has_Class_Wide_Actual): Alphabetize. Change the
logic of the predicate as the renamed name may not necessarely
denote the correct subprogram.
2014-08-01 Eric Botcazou <ebotcazou@adacore.com> 2014-08-01 Eric Botcazou <ebotcazou@adacore.com>
* sem_ch7.adb: Fix minor oversight in condition. * sem_ch7.adb: Fix minor oversight in condition.
......
gcc/ada/sem_ch8.adb
...@@ -1812,18 +1812,51 @@ package body Sem_Ch8 is ...@@ -1812,18 +1812,51 @@ package body Sem_Ch8 is
--------------------------------- ---------------------------------
procedure Analyze_Subprogram_Renaming (N : Node_Id) is procedure Analyze_Subprogram_Renaming (N : Node_Id) is
Formal_Spec : constant Node_Id := Corresponding_Formal_Spec (N); Formal_Spec : constant Entity_Id := Corresponding_Formal_Spec (N);
Is_Actual : constant Boolean := Present (Formal_Spec); Is_Actual : constant Boolean := Present (Formal_Spec);
Inst_Node : Node_Id := Empty;
Nam : constant Node_Id := Name (N); Nam : constant Node_Id := Name (N);
New_S : Entity_Id;
Old_S : Entity_Id := Empty;
Rename_Spec : Entity_Id;
Save_AV : constant Ada_Version_Type := Ada_Version; Save_AV : constant Ada_Version_Type := Ada_Version;
Save_AVP : constant Node_Id := Ada_Version_Pragma; Save_AVP : constant Node_Id := Ada_Version_Pragma;
Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit; Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit;
Spec : constant Node_Id := Specification (N); Spec : constant Node_Id := Specification (N);
Old_S : Entity_Id := Empty;
Rename_Spec : Entity_Id;
procedure Build_Class_Wide_Wrapper
(Ren_Id : out Entity_Id;
Wrap_Id : out Entity_Id);
-- Ada 2012 (AI05-0071): A generic/instance scenario involving a formal
-- type with unknown discriminants and a generic primitive operation of
-- the said type with a box require special processing when the actual
-- is a class-wide type:
-- generic
-- type Formal_Typ (<>) is private;
-- with procedure Prim_Op (Param : Formal_Typ) is <>;
-- package Gen is ...
-- package Inst is new Gen (Actual_Typ'Class);
-- In this case the general renaming mechanism used in the prologue of
-- an instance no longer applies:
-- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op;
-- The above is replaced the following wrapper/renaming combination:
-- procedure Prim_Op (Param : Formal_Typ) is -- wrapper
-- begin
-- Prim_Op (Param); -- primitive
-- end Wrapper;
-- procedure Dummy (Param : Formal_Typ) renames Prim_Op;
-- This transformation applies only if there is no explicit visible
-- class-wide operation at the point of the instantiation. Ren_Id is
-- the entity of the renaming declaration. Wrap_Id is the entity of
-- the generated class-wide wrapper (or Any_Id).
procedure Check_Null_Exclusion procedure Check_Null_Exclusion
(Ren : Entity_Id; (Ren : Entity_Id;
Sub : Entity_Id); Sub : Entity_Id);
...@@ -1845,6 +1878,11 @@ package body Sem_Ch8 is ...@@ -1845,6 +1878,11 @@ package body Sem_Ch8 is
-- types: a callable entity freezes its profile, unless it has an -- types: a callable entity freezes its profile, unless it has an
-- incomplete untagged formal (RM 13.14(10.2/3)). -- incomplete untagged formal (RM 13.14(10.2/3)).
function Has_Class_Wide_Actual return Boolean;
-- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a
-- defaulted formal subprogram where the actual for the controlling
-- formal type is class-wide.
function Original_Subprogram (Subp : Entity_Id) return Entity_Id; function Original_Subprogram (Subp : Entity_Id) return Entity_Id;
-- Find renamed entity when the declaration is a renaming_as_body and -- Find renamed entity when the declaration is a renaming_as_body and
-- the renamed entity may itself be a renaming_as_body. Used to enforce -- the renamed entity may itself be a renaming_as_body. Used to enforce
...@@ -1852,187 +1890,405 @@ package body Sem_Ch8 is ...@@ -1852,187 +1890,405 @@ package body Sem_Ch8 is
-- before the subprogram it completes is frozen, and renaming indirectly -- before the subprogram it completes is frozen, and renaming indirectly
-- renames the subprogram itself.(Defect Report 8652/0027). -- renames the subprogram itself.(Defect Report 8652/0027).
function Check_Class_Wide_Actual return Entity_Id; ------------------------------
-- AI05-0071: In an instance, if the actual for a formal type FT with -- Build_Class_Wide_Wrapper --
-- unknown discriminants is a class-wide type CT, and the generic has ------------------------------
-- a formal subprogram with a box for a primitive operation of FT,
-- then the corresponding actual subprogram denoted by the default is a
-- class-wide operation whose body is a dispatching call. We replace the
-- generated renaming declaration:
--
-- procedure P (X : CT) renames P;
--
-- by a different renaming and a class-wide operation:
--
-- procedure Pr (X : T) renames P; -- renames primitive operation
-- procedure P (X : CT); -- class-wide operation
-- ...
-- procedure P (X : CT) is begin Pr (X); end; -- dispatching call
--
-- This rule only applies if there is no explicit visible class-wide
-- operation at the point of the instantiation.
function Has_Class_Wide_Actual return Boolean;
-- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a
-- defaulted formal subprogram when the actual for the controlling
-- formal type is class-wide.
-----------------------------
-- Check_Class_Wide_Actual --
-----------------------------
function Check_Class_Wide_Actual return Entity_Id is procedure Build_Class_Wide_Wrapper
(Ren_Id : out Entity_Id;
Wrap_Id : out Entity_Id)
is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
F : Entity_Id; function Build_Call
Formal_Type : Entity_Id; (Subp_Id : Entity_Id;
Actual_Type : Entity_Id; Params : List_Id) return Node_Id;
New_Body : Node_Id; -- Create a dispatching call to invoke routine Subp_Id with actuals
New_Decl : Node_Id; -- built from the parameter specifications of list Params.
Result : Entity_Id;
function Make_Call (Prim_Op : Entity_Id) return Node_Id; function Build_Spec (Subp_Id : Entity_Id) return Node_Id;
-- Build dispatching call for body of class-wide operation -- Create a subprogram specification based on the subprogram profile
-- of Subp_Id.
function Make_Spec return Node_Id; function Find_Primitive (Typ : Entity_Id) return Entity_Id;
-- Create subprogram specification for declaration and body of -- Find a primitive subprogram of type Typ which matches the profile
-- class-wide operation, using signature of renaming declaration. -- of the renaming declaration.
--------------- procedure Interpretation_Error (Subp_Id : Entity_Id);
-- Make_Call -- -- Emit a continuation error message suggesting subprogram Subp_Id as
--------------- -- a possible interpretation.
function Make_Call (Prim_Op : Entity_Id) return Node_Id is ----------------
Actuals : List_Id; -- Build_Call --
F : Node_Id; ----------------
function Build_Call
(Subp_Id : Entity_Id;
Params : List_Id) return Node_Id
is
Actuals : constant List_Id := New_List;
Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc);
Formal : Node_Id;
begin begin
Actuals := New_List; -- Build the actual parameters of the call
F := First (Parameter_Specifications (Specification (New_Decl)));
while Present (F) loop Formal := First (Params);
while Present (Formal) loop
Append_To (Actuals, Append_To (Actuals,
Make_Identifier (Loc, Chars (Defining_Identifier (F)))); Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
Next (F);
Next (Formal);
end loop; end loop;
if Ekind_In (Prim_Op, E_Function, E_Operator) then -- Generate:
return Make_Simple_Return_Statement (Loc, -- return Subp_Id (Actuals);
Expression =>
Make_Function_Call (Loc, if Ekind_In (Subp_Id, E_Function, E_Operator) then
Name => New_Occurrence_Of (Prim_Op, Loc), return
Parameter_Associations => Actuals)); Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name => Call_Ref,
Parameter_Associations => Actuals));
-- Generate:
-- Subp_Id (Actuals);
else else
return return
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Prim_Op, Loc), Name => Call_Ref,
Parameter_Associations => Actuals); Parameter_Associations => Actuals);
end if; end if;
end Make_Call; end Build_Call;
--------------- ----------------
-- Make_Spec -- -- Build_Spec --
--------------- ----------------
function Make_Spec return Node_Id is function Build_Spec (Subp_Id : Entity_Id) return Node_Id is
Param_Specs : constant List_Id := Copy_Parameter_List (New_S); Params : constant List_Id := Copy_Parameter_List (Subp_Id);
Spec_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars (Subp_Id));
begin begin
if Ekind (New_S) = E_Procedure then if Ekind (Formal_Spec) = E_Procedure then
return return
Make_Procedure_Specification (Loc, Make_Procedure_Specification (Loc,
Defining_Unit_Name => Defining_Unit_Name => Spec_Id,
Make_Defining_Identifier (Loc, Parameter_Specifications => Params);
Chars (Defining_Unit_Name (Spec))),
Parameter_Specifications => Param_Specs);
else else
return return
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => Defining_Unit_Name => Spec_Id,
Make_Defining_Identifier (Loc, Parameter_Specifications => Params,
Chars (Defining_Unit_Name (Spec))), Result_Definition =>
Parameter_Specifications => Param_Specs, New_Copy_Tree (Result_Definition (Spec)));
Result_Definition => end if;
New_Copy_Tree (Result_Definition (Spec))); end Build_Spec;
--------------------
-- Find_Primitive --
--------------------
function Find_Primitive (Typ : Entity_Id) return Entity_Id is
procedure Replace_Parameter_Types (Spec : Node_Id);
-- Given a specification Spec, replace all class-wide parameter
-- types with reference to type Typ.
-----------------------------
-- Replace_Parameter_Types --
-----------------------------
procedure Replace_Parameter_Types (Spec : Node_Id) is
Formal : Node_Id;
Formal_Id : Entity_Id;
Formal_Typ : Node_Id;
begin
Formal := First (Parameter_Specifications (Spec));
while Present (Formal) loop
Formal_Id := Defining_Identifier (Formal);
Formal_Typ := Parameter_Type (Formal);
-- Create a new entity for each class-wide formal to prevent
-- aliasing with the original renaming. Replace the type of
-- such a parameter with the candidate type.
if Nkind (Formal_Typ) = N_Identifier
and then Is_Class_Wide_Type (Etype (Formal_Typ))
then
Set_Defining_Identifier (Formal,
Make_Defining_Identifier (Loc, Chars (Formal_Id)));
Set_Parameter_Type (Formal, New_Occurrence_Of (Typ, Loc));
end if;
Next (Formal);
end loop;
end Replace_Parameter_Types;
-- Local variables
Alt_Ren : constant Node_Id := New_Copy_Tree (N);
Alt_Nam : constant Node_Id := Name (Alt_Ren);
Alt_Spec : constant Node_Id := Specification (Alt_Ren);
Subp_Id : Entity_Id;
-- Start of processing for Find_Primitive
begin
-- Each attempt to find a suitable primitive of a particular type
-- operates on its own copy of the original renaming. As a result
-- the original renaming is kept decoration and side-effect free.
-- Inherit the overloaded status of the renamed subprogram name
if Is_Overloaded (Nam) then
Set_Is_Overloaded (Alt_Nam);
Save_Interps (Nam, Alt_Nam);
end if; end if;
end Make_Spec;
-- Start of processing for Check_Class_Wide_Actual -- The copied renaming is hidden from visibility to prevent the
-- pollution of the enclosing context.
Set_Defining_Unit_Name (Alt_Spec, Make_Temporary (Loc, 'R'));
-- The types of all class-wide parameters must be changed to the
-- candidate type.
Replace_Parameter_Types (Alt_Spec);
-- Try to find a suitable primitive which matches the altered
-- profile of the renaming specification.
Subp_Id :=
Find_Renamed_Entity
(N => Alt_Ren,
Nam => Name (Alt_Ren),
New_S => Analyze_Subprogram_Specification (Alt_Spec),
Is_Actual => Is_Actual);
-- Do not return Any_Id if the resolion of the altered profile
-- failed as this complicates further checks on the caller side,
-- return Empty instead.
if Subp_Id = Any_Id then
return Empty;
else
return Subp_Id;
end if;
end Find_Primitive;
--------------------------
-- Interpretation_Error --
--------------------------
procedure Interpretation_Error (Subp_Id : Entity_Id) is
begin
Error_Msg_Sloc := Sloc (Subp_Id);
Error_Msg_NE
("\\possible interpretation: & defined #", Spec, Formal_Spec);
end Interpretation_Error;
-- Local variables
Actual_Typ : Entity_Id := Empty;
-- The actual class-wide type for Formal_Typ
CW_Prim_Op : Entity_Id;
-- The class-wide primitive (if any) which corresponds to the renamed
-- generic formal subprogram.
Formal_Typ : Entity_Id := Empty;
-- The generic formal type (if any) with unknown discriminants
Root_Prim_Op : Entity_Id;
-- The root type primitive (if any) which corresponds to the renamed
-- generic formal subprogram.
Body_Decl : Node_Id;
Formal : Node_Id;
Prim_Op : Entity_Id;
Spec_Decl : Node_Id;
-- Start of processing for Build_Class_Wide_Wrapper
begin begin
Result := Any_Id; -- Analyze the specification of the renaming in case the generation
Formal_Type := Empty; -- of the class-wide wrapper fails.
Actual_Type := Empty;
Ren_Id := Analyze_Subprogram_Specification (Spec);
F := First_Formal (Formal_Spec); Wrap_Id := Any_Id;
while Present (F) loop
if Has_Unknown_Discriminants (Etype (F)) -- Do not attempt to build a wrapper if the renaming is in error
and then not Is_Class_Wide_Type (Etype (F))
and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F))) if Error_Posted (Nam) then
return;
end if;
-- Analyze the renamed name, but do not resolve it. The resolution is
-- completed once a suitable primitive is found.
Analyze (Nam);
-- Step 1: Find the generic formal type with unknown discriminants
-- and its corresponding class-wide actual type from the renamed
-- generic formal subprogram.
Formal := First_Formal (Formal_Spec);
while Present (Formal) loop
if Has_Unknown_Discriminants (Etype (Formal))
and then not Is_Class_Wide_Type (Etype (Formal))
and then Is_Class_Wide_Type (Get_Instance_Of (Etype (Formal)))
then then
Formal_Type := Etype (F); Formal_Typ := Etype (Formal);
Actual_Type := Etype (Get_Instance_Of (Formal_Type)); Actual_Typ := Get_Instance_Of (Formal_Typ);
exit; exit;
end if; end if;
Next_Formal (F); Next_Formal (Formal);
end loop; end loop;
if Present (Formal_Type) then -- The specification of the generic formal subprogram should always
-- contain a formal type with unknown discriminants whose actual is
-- a class-wide type, otherwise this indicates a failure in routine
-- Has_Class_Wide_Actual.
-- Create declaration and body for class-wide operation pragma Assert (Present (Formal_Typ));
New_Decl := -- Step 2: Find the proper primitive which corresponds to the renamed
Make_Subprogram_Declaration (Loc, Specification => Make_Spec); -- generic formal subprogram.
New_Body := CW_Prim_Op := Find_Primitive (Actual_Typ);
Make_Subprogram_Body (Loc, Root_Prim_Op := Find_Primitive (Etype (Actual_Typ));
Specification => Make_Spec,
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, New_List));
-- Modify Spec and create internal name for renaming of primitive -- The class-wide actual type has two primitives which correspond to
-- operation. -- the renamed generic formal subprogram:
Set_Defining_Unit_Name (Spec, Make_Temporary (Loc, 'R')); -- with procedure Prim_Op (Param : Formal_Typ);
F := First (Parameter_Specifications (Spec));
while Present (F) loop -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited
if Nkind (Parameter_Type (F)) = N_Identifier -- procedure Prim_Op (Param : Actual_Typ'Class);
and then Is_Class_Wide_Type (Entity (Parameter_Type (F)))
-- Even though the declaration of the two primitives is legal, a call
-- to either one is ambiguous and therefore illegal.
if Present (CW_Prim_Op) and then Present (Root_Prim_Op) then
-- Deal with abstract primitives
if Is_Abstract_Subprogram (CW_Prim_Op)
or else Is_Abstract_Subprogram (Root_Prim_Op)
then
-- An abstract subprogram cannot act as a generic actual, but
-- the partial parameterization of the instance may hide the
-- true nature of the actual. Emit an error when both options
-- are abstract.
if Is_Abstract_Subprogram (CW_Prim_Op)
and then Is_Abstract_Subprogram (Root_Prim_Op)
then then
Set_Parameter_Type (F, New_Occurrence_Of (Actual_Type, Loc)); Error_Msg_NE
("abstract subprogram not allowed as generic actual",
Spec, Formal_Spec);
Interpretation_Error (CW_Prim_Op);
Interpretation_Error (Root_Prim_Op);
return;
-- Otherwise choose the non-abstract version
elsif Is_Abstract_Subprogram (Root_Prim_Op) then
Prim_Op := CW_Prim_Op;
else pragma Assert (Is_Abstract_Subprogram (CW_Prim_Op));
Prim_Op := Root_Prim_Op;
end if; end if;
Next (F);
end loop;
New_S := Analyze_Subprogram_Specification (Spec); -- If one of the candidate primitives is intrinsic, choose the
Result := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); -- other (which may also be intrinsic). Preference is given to
end if; -- the primitive of the root type.
if Result /= Any_Id then elsif Is_Intrinsic_Subprogram (CW_Prim_Op) then
Insert_Before (N, New_Decl); Prim_Op := Root_Prim_Op;
Analyze (New_Decl);
-- Add dispatching call to body of class-wide operation elsif Is_Intrinsic_Subprogram (Root_Prim_Op) then
Prim_Op := CW_Prim_Op;
Append (Make_Call (Result), elsif CW_Prim_Op = Root_Prim_Op then
Statements (Handled_Statement_Sequence (New_Body))); Prim_Op := Root_Prim_Op;
-- The generated body does not freeze. It is analyzed when the -- Otherwise there are two perfectly good candidates which satisfy
-- generated operation is frozen. This body is only needed if -- the profile of the renamed generic formal subprogram.
-- expansion is enabled.
if Expander_Active then else
Append_Freeze_Action (Defining_Entity (New_Decl), New_Body); Error_Msg_NE
("ambiguous actual for generic subprogram &",
Spec, Formal_Spec);
Interpretation_Error (CW_Prim_Op);
Interpretation_Error (Root_Prim_Op);
return;
end if; end if;
Result := Defining_Entity (New_Decl); elsif Present (CW_Prim_Op) then
Prim_Op := CW_Prim_Op;
elsif Present (Root_Prim_Op) then
Prim_Op := Root_Prim_Op;
-- Otherwise there are no candidate primitives. Let the caller
-- diagnose the error.
else
return;
end if; end if;
-- Return the class-wide operation if one was created -- Set the proper entity of the renamed generic formal subprogram
-- and reset its overloaded status now that resolution has finally
-- taken place.
Set_Entity (Nam, Prim_Op);
Set_Is_Overloaded (Nam, False);
-- Step 3: Create the declaration and the body of the wrapper, insert
-- all the pieces into the tree.
return Result; Spec_Decl :=
end Check_Class_Wide_Actual; Make_Subprogram_Declaration (Loc,
Specification => Build_Spec (Ren_Id));
Body_Decl :=
Make_Subprogram_Body (Loc,
Specification => Build_Spec (Ren_Id),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Build_Call
(Subp_Id => Prim_Op,
Params =>
Parameter_Specifications
(Specification (Spec_Decl))))));
Insert_Before_And_Analyze (N, Spec_Decl);
Wrap_Id := Defining_Entity (Spec_Decl);
-- The generated body does not freeze and must be analyzed when the
-- class-wide wrapper is frozen. The body is only needed if expansion
-- is enabled.
if Expander_Active then
Append_Freeze_Action (Wrap_Id, Body_Decl);
end if;
-- Step 4: Once the proper actual type and primitive operation are
-- known, hide the renaming declaration from visibility by giving it
-- a dummy name.
Set_Defining_Unit_Name (Spec, Make_Temporary (Loc, 'R'));
Ren_Id := Analyze_Subprogram_Specification (Spec);
end Build_Class_Wide_Wrapper;
-------------------------- --------------------------
-- Check_Null_Exclusion -- -- Check_Null_Exclusion --
...@@ -2118,7 +2374,6 @@ package body Sem_Ch8 is ...@@ -2118,7 +2374,6 @@ package body Sem_Ch8 is
if Is_Incomplete_Or_Private_Type (Etype (F)) if Is_Incomplete_Or_Private_Type (Etype (F))
and then No (Underlying_Type (Etype (F))) and then No (Underlying_Type (Etype (F)))
then then
-- Exclude generic types, or types derived from them. -- Exclude generic types, or types derived from them.
-- They will be frozen in the enclosing instance. -- They will be frozen in the enclosing instance.
...@@ -2144,28 +2399,23 @@ package body Sem_Ch8 is ...@@ -2144,28 +2399,23 @@ package body Sem_Ch8 is
--------------------------- ---------------------------
function Has_Class_Wide_Actual return Boolean is function Has_Class_Wide_Actual return Boolean is
F_Nam : Entity_Id; Formal : Entity_Id;
F_Spec : Entity_Id; Formal_Typ : Entity_Id;
begin begin
if Is_Actual if Is_Actual then
and then Nkind (Nam) in N_Has_Entity Formal := First_Formal (Formal_Spec);
and then Present (Entity (Nam)) while Present (Formal) loop
and then Is_Dispatching_Operation (Entity (Nam)) Formal_Typ := Etype (Formal);
then
F_Nam := First_Entity (Entity (Nam)); if Has_Unknown_Discriminants (Formal_Typ)
F_Spec := First_Formal (Formal_Spec); and then not Is_Class_Wide_Type (Formal_Typ)
while Present (F_Nam) and then Present (F_Spec) loop and then Is_Class_Wide_Type (Get_Instance_Of (Formal_Typ))
if Is_Controlling_Formal (F_Nam)
and then Has_Unknown_Discriminants (Etype (F_Spec))
and then not Is_Class_Wide_Type (Etype (F_Spec))
and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F_Spec)))
then then
return True; return True;
end if; end if;
Next_Entity (F_Nam); Next_Formal (Formal);
Next_Formal (F_Spec);
end loop; end loop;
end if; end if;
...@@ -2215,11 +2465,16 @@ package body Sem_Ch8 is ...@@ -2215,11 +2465,16 @@ package body Sem_Ch8 is
end if; end if;
end Original_Subprogram; end Original_Subprogram;
-- Local variables
CW_Actual : constant Boolean := Has_Class_Wide_Actual; CW_Actual : constant Boolean := Has_Class_Wide_Actual;
-- Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a -- Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a
-- defaulted formal subprogram when the actual for a related formal -- defaulted formal subprogram when the actual for a related formal
-- type is class-wide. -- type is class-wide.
Inst_Node : Node_Id := Empty;
New_S : Entity_Id;
-- Start of processing for Analyze_Subprogram_Renaming -- Start of processing for Analyze_Subprogram_Renaming
begin begin
...@@ -2344,9 +2599,8 @@ package body Sem_Ch8 is ...@@ -2344,9 +2599,8 @@ package body Sem_Ch8 is
-- Check whether the renaming is for a defaulted actual subprogram -- Check whether the renaming is for a defaulted actual subprogram
-- with a class-wide actual. -- with a class-wide actual.
if CW_Actual then if CW_Actual and then Box_Present (Inst_Node) then
New_S := Analyze_Subprogram_Specification (Spec); Build_Class_Wide_Wrapper (New_S, Old_S);
Old_S := Check_Class_Wide_Actual;
elsif Is_Entity_Name (Nam) elsif Is_Entity_Name (Nam)
and then Present (Entity (Nam)) and then Present (Entity (Nam))
...@@ -2623,8 +2877,8 @@ package body Sem_Ch8 is ...@@ -2623,8 +2877,8 @@ package body Sem_Ch8 is
Analyze_Renamed_Character (N, New_S, Present (Rename_Spec)); Analyze_Renamed_Character (N, New_S, Present (Rename_Spec));
return; return;
-- Only remaining case is where we have a non-entity name, or a -- Only remaining case is where we have a non-entity name, or a renaming
-- renaming of some other non-overloadable entity. -- of some other non-overloadable entity.
elsif not Is_Entity_Name (Nam) elsif not Is_Entity_Name (Nam)
or else not Is_Overloadable (Entity (Nam)) or else not Is_Overloadable (Entity (Nam))
...@@ -3939,7 +4193,6 @@ package body Sem_Ch8 is ...@@ -3939,7 +4193,6 @@ package body Sem_Ch8 is
else else
Pop_Scope; Pop_Scope;
end if; end if;
end End_Scope; end End_Scope;
--------------------- ---------------------
...@@ -5916,31 +6169,11 @@ package body Sem_Ch8 is ...@@ -5916,31 +6169,11 @@ package body Sem_Ch8 is
Old_S := Any_Id; Old_S := Any_Id;
Candidate_Renaming := Empty; Candidate_Renaming := Empty;
if not Is_Overloaded (Nam) then if Is_Overloaded (Nam) then
if Is_Actual and then Present (Enclosing_Instance) then
Old_S := Entity (Nam);
elsif Entity_Matches_Spec (Entity (Nam), New_S) then
Candidate_Renaming := New_S;
if Is_Visible_Operation (Entity (Nam)) then
Old_S := Entity (Nam);
end if;
elsif
Present (First_Formal (Entity (Nam)))
and then Present (First_Formal (New_S))
and then (Base_Type (Etype (First_Formal (Entity (Nam)))) =
Base_Type (Etype (First_Formal (New_S))))
then
Candidate_Renaming := Entity (Nam);
end if;
else
Get_First_Interp (Nam, Ind, It); Get_First_Interp (Nam, Ind, It);
while Present (It.Nam) loop while Present (It.Nam) loop
if Entity_Matches_Spec (It.Nam, New_S) if Entity_Matches_Spec (It.Nam, New_S)
and then Is_Visible_Operation (It.Nam) and then Is_Visible_Operation (It.Nam)
then then
if Old_S /= Any_Id then if Old_S /= Any_Id then
...@@ -6009,6 +6242,27 @@ package body Sem_Ch8 is ...@@ -6009,6 +6242,27 @@ package body Sem_Ch8 is
if Old_S /= Any_Id then if Old_S /= Any_Id then
Set_Is_Overloaded (Nam, False); Set_Is_Overloaded (Nam, False);
end if; end if;
-- Non-overloaded case
else
if Is_Actual and then Present (Enclosing_Instance) then
Old_S := Entity (Nam);
elsif Entity_Matches_Spec (Entity (Nam), New_S) then
Candidate_Renaming := New_S;
if Is_Visible_Operation (Entity (Nam)) then
Old_S := Entity (Nam);
end if;
elsif Present (First_Formal (Entity (Nam)))
and then Present (First_Formal (New_S))
and then (Base_Type (Etype (First_Formal (Entity (Nam)))) =
Base_Type (Etype (First_Formal (New_S))))
then
Candidate_Renaming := Entity (Nam);
end if;
end if; end if;
return Old_S; return Old_S;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment