-- has already established its actual subtype. This is only relevant
-- if the renamed object is an explicit dereference.
+ function Get_Object_Name (Nod : Node_Id) return Node_Id;
+ -- Obtain the name of the object from node Nod which is being renamed by
+ -- the object renaming declaration N.
+
------------------------------
-- Check_Constrained_Object --
------------------------------
null;
-- If a record is limited its size is invariant. This is the case
- -- in particular with record types with an access discirminant
+ -- in particular with record types with an access discriminant
-- that are used in iterators. This is an optimization, but it
-- also prevents typing anomalies when the prefix is further
- -- expanded. Limited types with discriminants are included.
+ -- expanded.
+ -- Note that we cannot just use the Is_Limited_Record flag because
+ -- it does not apply to records with limited components, for which
+ -- this syntactic flag is not set, but whose size is also fixed.
- elsif Is_Limited_Record (Typ)
- or else
- (Ekind (Typ) = E_Limited_Private_Type
- and then Has_Discriminants (Typ)
- and then Is_Access_Type (Etype (First_Discriminant (Typ))))
- then
+ elsif Is_Limited_Type (Typ) then
null;
else
end if;
end Check_Constrained_Object;
+ ---------------------
+ -- Get_Object_Name --
+ ---------------------
+
+ function Get_Object_Name (Nod : Node_Id) return Node_Id is
+ Obj_Nam : Node_Id;
+
+ begin
+ Obj_Nam := Nod;
+ while Present (Obj_Nam) loop
+ if Nkind_In (Obj_Nam, N_Attribute_Reference,
+ N_Explicit_Dereference,
+ N_Indexed_Component,
+ N_Slice)
+ then
+ Obj_Nam := Prefix (Obj_Nam);
+
+ elsif Nkind (Obj_Nam) = N_Selected_Component then
+ Obj_Nam := Selector_Name (Obj_Nam);
+ else
+ exit;
+ end if;
+ end loop;
+
+ return Obj_Nam;
+ end Get_Object_Name;
+
-- Start of processing for Analyze_Object_Renaming
begin
elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then
declare
- Nam_Decl : Node_Id;
- Nam_Ent : Entity_Id;
+ Nam_Ent : constant Entity_Id := Entity (Get_Object_Name (Nam));
+ Nam_Decl : constant Node_Id := Declaration_Node (Nam_Ent);
begin
- if Nkind (Nam) = N_Attribute_Reference then
- Nam_Ent := Entity (Prefix (Nam));
- else
- Nam_Ent := Entity (Nam);
- end if;
-
- Nam_Decl := Parent (Nam_Ent);
-
if Has_Null_Exclusion (N)
and then not Has_Null_Exclusion (Nam_Decl)
then
end if;
-- The entity of the renaming declaration needs to reflect whether the
- -- renamed object is volatile. Is_Volatile is set if the renamed object
- -- is volatile in the RM legality sense.
-
- Set_Is_Volatile (Id, Is_Volatile_Object (Nam));
+ -- renamed object is atomic, independent, volatile or VFA. These flags
+ -- are set on the renamed object in the RM legality sense.
- -- Also copy settings of Atomic/Independent/Volatile_Full_Access
-
- if Is_Entity_Name (Nam) then
- Set_Is_Atomic (Id, Is_Atomic (Entity (Nam)));
- Set_Is_Independent (Id, Is_Independent (Entity (Nam)));
- Set_Is_Volatile_Full_Access (Id,
- Is_Volatile_Full_Access (Entity (Nam)));
- end if;
+ Set_Is_Atomic (Id, Is_Atomic_Object (Nam));
+ Set_Is_Independent (Id, Is_Independent_Object (Nam));
+ Set_Is_Volatile (Id, Is_Volatile_Object (Nam));
+ Set_Is_Volatile_Full_Access (Id, Is_Volatile_Full_Access_Object (Nam));
-- Treat as volatile if we just set the Volatile flag
-- AI05-0225: If the renamed entity is a procedure or entry of a
-- protected object, the target object must be a variable.
- if Ekind (Scope (Old_S)) in Protected_Kind
+ if Is_Protected_Type (Scope (Old_S))
and then Ekind (New_S) = E_Procedure
and then not Is_Variable (Prefix (Nam))
then
if CW_Actual then
null;
- elsif not Is_Actual or else No (Enclosing_Instance) then
+
+ -- No need for a redundant error message if this is a nested
+ -- instance, unless the current instantiation (of a child unit)
+ -- is a compilation unit, which is not analyzed when the parent
+ -- generic is analyzed.
+
+ elsif not Is_Actual
+ or else No (Enclosing_Instance)
+ or else Is_Compilation_Unit (Current_Scope)
+ then
Check_Mode_Conformant (New_S, Old_S);
end if;
if Old_S_Ctrl_Type /= New_S_Ctrl_Type
or else No (New_S_Ctrl_Type)
then
- Error_Msg_NE
- ("actual must be dispatching subprogram for type&",
- Nam, New_S_Ctrl_Type);
+ if No (New_S_Ctrl_Type) then
+ Error_Msg_N
+ ("actual must be dispatching subprogram", Nam);
+ else
+ Error_Msg_NE
+ ("actual must be dispatching subprogram for type&",
+ Nam, New_S_Ctrl_Type);
+ end if;
else
Set_Is_Dispatching_Operation (New_S);
-- Common case for compilation unit
- elsif Defining_Entity (N => Parent (N),
- Empty_On_Errors => True) = Current_Scope
- then
+ elsif Defining_Entity (Parent (N)) = Current_Scope then
null;
else
-- If declaration appears in some other scope, it must be in some
-- parent unit when compiling a child.
- Pack := Defining_Entity (Parent (N), Empty_On_Errors => True);
+ Pack := Defining_Entity (Parent (N));
if not In_Open_Scopes (Pack) then
null;
Set_In_Use (Base_Type (T), False);
Set_Current_Use_Clause (T, Empty);
Set_Current_Use_Clause (Base_Type (T), Empty);
+
+ -- See Use_One_Type for the rationale. This is a bit on the naive
+ -- side, but should be good enough in practice.
+
+ if Is_Tagged_Type (T) then
+ Set_In_Use (Class_Wide_Type (T), False);
+ end if;
end if;
end if;
-- Package or generic package is always a simple reference
- if Ekind_In (E, E_Package, E_Generic_Package) then
+ if Is_Package_Or_Generic_Package (E) then
Generate_Reference (E, N, 'r');
-- Else see if we have a left hand side
Old_S : Entity_Id;
Inst : Entity_Id;
+ function Find_Nearer_Entity
+ (New_S : Entity_Id;
+ Old1_S : Entity_Id;
+ Old2_S : Entity_Id) return Entity_Id;
+ -- Determine whether one of Old_S1 and Old_S2 is nearer to New_S than
+ -- the other, and return it if so. Return Empty otherwise. We use this
+ -- in conjunction with Inherit_Renamed_Profile to simplify later type
+ -- disambiguation for actual subprograms in instances.
+
function Is_Visible_Operation (Op : Entity_Id) return Boolean;
-- If the renamed entity is an implicit operator, check whether it is
-- visible because its operand type is properly visible. This check
-- Determine whether a candidate subprogram is defined within the
-- enclosing instance. If yes, it has precedence over outer candidates.
+ --------------------------
+ -- Find_Nearer_Entity --
+ --------------------------
+
+ function Find_Nearer_Entity
+ (New_S : Entity_Id;
+ Old1_S : Entity_Id;
+ Old2_S : Entity_Id) return Entity_Id
+ is
+ New_F : Entity_Id;
+ Old1_F : Entity_Id;
+ Old2_F : Entity_Id;
+ Anc_T : Entity_Id;
+
+ begin
+ New_F := First_Formal (New_S);
+ Old1_F := First_Formal (Old1_S);
+ Old2_F := First_Formal (Old2_S);
+
+ -- The criterion is whether the type of the formals of one of Old1_S
+ -- and Old2_S is an ancestor subtype of the type of the corresponding
+ -- formals of New_S while the other is not (we already know that they
+ -- are all subtypes of the same base type).
+
+ -- This makes it possible to find the more correct renamed entity in
+ -- the case of a generic instantiation nested in an enclosing one for
+ -- which different formal types get the same actual type, which will
+ -- in turn make it possible for Inherit_Renamed_Profile to preserve
+ -- types on formal parameters and ultimately simplify disambiguation.
+
+ -- Consider the follow package G:
+
+ -- generic
+ -- type Item_T is private;
+ -- with function Compare (L, R: Item_T) return Boolean is <>;
+
+ -- type Bound_T is private;
+ -- with function Compare (L, R : Bound_T) return Boolean is <>;
+ -- package G is
+ -- ...
+ -- end G;
+
+ -- package body G is
+ -- package My_Inner is Inner_G (Bound_T);
+ -- ...
+ -- end G;
+
+ -- with the following package Inner_G:
+
+ -- generic
+ -- type T is private;
+ -- with function Compare (L, R: T) return Boolean is <>;
+ -- package Inner_G is
+ -- function "<" (L, R: T) return Boolean is (Compare (L, R));
+ -- end Inner_G;
+
+ -- If G is instantiated on the same actual type with a single Compare
+ -- function:
+
+ -- type T is ...
+ -- function Compare (L, R : T) return Boolean;
+ -- package My_G is new (T, T);
+
+ -- then the renaming generated for Compare in the inner instantiation
+ -- is ambiguous: it can rename either of the renamings generated for
+ -- the outer instantiation. Now if the first one is picked up, then
+ -- the subtypes of the formal parameters of the renaming will not be
+ -- preserved in Inherit_Renamed_Profile because they are subtypes of
+ -- the Bound_T formal type and not of the Item_T formal type, so we
+ -- need to arrange for the second one to be picked up instead.
+
+ while Present (New_F) loop
+ if Etype (Old1_F) /= Etype (Old2_F) then
+ Anc_T := Ancestor_Subtype (Etype (New_F));
+
+ if Etype (Old1_F) = Anc_T then
+ return Old1_S;
+ elsif Etype (Old2_F) = Anc_T then
+ return Old2_S;
+ end if;
+ end if;
+
+ Next_Formal (New_F);
+ Next_Formal (Old1_F);
+ Next_Formal (Old2_F);
+ end loop;
+
+ pragma Assert (No (Old1_F));
+ pragma Assert (No (Old2_F));
+
+ return Empty;
+ end Find_Nearer_Entity;
+
--------------------------
-- Is_Visible_Operation --
--------------------------
if Present (Inst) then
if Within (It.Nam, Inst) then
if Within (Old_S, Inst) then
-
- -- Choose the innermost subprogram, which would
- -- have hidden the outer one in the generic.
-
- if Scope_Depth (It.Nam) <
- Scope_Depth (Old_S)
- then
- return Old_S;
- else
- return It.Nam;
- end if;
+ declare
+ It_D : constant Uint := Scope_Depth (It.Nam);
+ Old_D : constant Uint := Scope_Depth (Old_S);
+ N_Ent : Entity_Id;
+ begin
+ -- Choose the innermost subprogram, which
+ -- would hide the outer one in the generic.
+
+ if Old_D > It_D then
+ return Old_S;
+ elsif It_D > Old_D then
+ return It.Nam;
+ end if;
+
+ -- Otherwise, if we can determine that one
+ -- of the entities is nearer to the renaming
+ -- than the other, choose it. If not, then
+ -- return the newer one as done historically.
+
+ N_Ent :=
+ Find_Nearer_Entity (New_S, Old_S, It.Nam);
+ if Present (N_Ent) then
+ return N_Ent;
+ else
+ return It.Nam;
+ end if;
+ end;
end if;
elsif Within (Old_S, Inst) then
- return (Old_S);
+ return Old_S;
else
return Report_Overload;
-- Set Default_Storage_Pool field of the library unit if necessary
- if Ekind_In (S, E_Package, E_Generic_Package)
+ if Is_Package_Or_Generic_Package (S)
and then
Nkind (Parent (Unit_Declaration_Node (S))) = N_Compilation_Unit
then
if Scope_Stack.Last > Scope_Stack.First then
SST.Component_Alignment_Default :=
Scope_Stack.Table
- (Scope_Stack.Last - 1). Component_Alignment_Default;
+ (Scope_Stack.Last - 1).Component_Alignment_Default;
-- Otherwise, this is the first scope being pushed on the scope
-- stack. Inherit the component alignment from the configuration
if Is_Child_Unit (S)
and then Present (E)
- and then Ekind_In (E, E_Package, E_Generic_Package)
+ and then Is_Package_Or_Generic_Package (E)
and then
Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
then
Par : constant Entity_Id := Defining_Entity (Parent (Decl));
Spec : constant Node_Id :=
Specification (Unit (Cunit (Current_Sem_Unit)));
-
+ Cur_List : constant List_Id := List_Containing (Cur_Use);
begin
if Is_Compilation_Unit (Par)
and then Par /= Cunit_Entity (Current_Sem_Unit)
- and then Parent (Cur_Use) = Spec
- and then List_Containing (Cur_Use) =
- Visible_Declarations (Spec)
then
- return;
+ if Cur_List = Context_Items (Cunit (Current_Sem_Unit))
+ or else Cur_List = Visible_Declarations (Spec)
+ then
+ return;
+ end if;
end if;
end;
end if;
then
Redundant := Clause;
Prev_Use := Cur_Use;
-
end if;
if Present (Redundant) and then Parent (Redundant) /= Prev_Use then
Set_In_Use (T);
-- If T is tagged, primitive operators on class-wide operands are
- -- also available.
+ -- also deemed available. Note that this is really necessary only
+ -- in semantics-only mode, because the primitive operators are not
+ -- fully constructed in this mode, but we do it in all modes for the
+ -- sake of uniformity, as this should not matter in practice.
if Is_Tagged_Type (T) then
Set_In_Use (Class_Wide_Type (T));
-- The package where T is declared is already used
elsif In_Use (Scope (T)) then
- Error_Msg_Sloc :=
- Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T))));
- Error_Msg_NE -- CODEFIX
- ("& is already use-visible through package use clause #??",
- Id, T);
+ -- Due to expansion of contracts we could be attempting to issue
+ -- a spurious warning - so verify there is a previous use clause.
+
+ if Current_Use_Clause (Scope (T)) /=
+ Find_Most_Prev (Current_Use_Clause (Scope (T)))
+ then
+ Error_Msg_Sloc :=
+ Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T))));
+ Error_Msg_NE -- CODEFIX
+ ("& is already use-visible through package use clause #??",
+ Id, T);
+ end if;
-- The current scope is the package where T is declared
projects / thirdparty / gcc.git / blobdiff