Sy (Is_Parenthesis_Aggregate, Flag),
Sy (Is_Homogeneous_Aggregate, Flag),
Sy (Is_Enum_Array_Aggregate, Flag),
- Sm (Aggregate_Bounds, Node_Id),
+ Sm (Aggregate_Bounds_Or_Ancestor_Type, Node_Id),
Sm (Entity_Or_Associated_Node, Node_Id), -- just Associated_Node
Sm (Compile_Time_Known_Aggregate, Flag),
Sm (Expansion_Delayed, Flag),
Parent_Typ := Etype (Parent_Typ);
-- Check whether a private parent requires the use of
- -- an extension aggregate. This test does not apply in
- -- an instantiation: if the generic unit is legal so is
- -- the instance.
+ -- an extension aggregate.
if Nkind (Parent (Base_Type (Parent_Typ))) =
N_Private_Type_Declaration
or else Nkind (Parent (Base_Type (Parent_Typ))) =
N_Private_Extension_Declaration
then
- if Nkind (N) /= N_Extension_Aggregate
- and then not In_Instance
- then
+ if Nkind (N) /= N_Extension_Aggregate then
Error_Msg_NE
("type of aggregate has private ancestor&!",
N, Parent_Typ);
end if;
end Check_Actual_Type;
+ -- Local variables
+
Astype : Entity_Id;
E : Entity_Id;
Formal : Node_Id;
+ -- Start of processing for Check_Generic_Actuals
+
begin
E := First_Entity (Instance);
while Present (E) loop
Set_Associated_Node (N, New_N);
else
- if Present (Get_Associated_Node (N))
- and then Nkind (Get_Associated_Node (N)) = Nkind (N)
- then
- -- In the generic the aggregate has some composite type. If at
- -- the point of instantiation the type has a private view,
- -- install the full view (and that of its ancestors, if any).
+ -- If, in the generic, the aggregate has a global composite type
+ -- and, at the point of instantiation, the type has a private view
+ -- then install the full view.
- declare
- T : Entity_Id := Etype (Get_Associated_Node (N));
- Rt : Entity_Id;
+ declare
+ Assoc : constant Node_Id := Get_Associated_Node (N);
- begin
- if Present (T) and then Is_Private_Type (T) then
- Switch_View (T);
- end if;
+ begin
+ if Present (Assoc)
+ and then Nkind (Assoc) = Nkind (N)
+ and then Present (Etype (Assoc))
+ and then Is_Private_Type (Etype (Assoc))
+ then
+ Switch_View (Etype (Assoc));
+ end if;
+ end;
- if Present (T)
- and then Is_Tagged_Type (T)
- and then Is_Derived_Type (T)
- then
- Rt := Root_Type (T);
+ -- Moreover, for a full aggregate, if the type is a derived tagged
+ -- type and has a global ancestor, then also restore the full view
+ -- of this ancestor, and do so up to the root type.
- loop
- T := Etype (T);
+ if Nkind (N) = N_Aggregate
+ and then Present (Ancestor_Type (N))
+ then
+ declare
+ Root_Typ : constant Entity_Id :=
+ Root_Type (Ancestor_Type (N));
- if Is_Private_Type (T) then
- Switch_View (T);
- end if;
+ Typ : Entity_Id := Ancestor_Type (N);
- exit when T = Rt;
- end loop;
- end if;
+ begin
+ loop
+ if Is_Private_Type (Typ) then
+ Switch_View (Typ);
+ end if;
+
+ exit when Typ = Root_Typ;
+
+ Typ := Etype (Typ);
+ end loop;
end;
end if;
end if;
if No (N2) or else No (Typ) or else not Is_Global (Typ) then
Set_Associated_Node (N, Empty);
+ -- For a full aggregate, if the type is local but is a derived
+ -- tagged type of a global ancestor, we will need to have the
+ -- full view of this global ancestor available in the instance
+ -- in order to analyze the full aggregate.
+
+ if Present (N2)
+ and then Nkind (N2) = N_Aggregate
+ and then Present (Typ)
+ and then Is_Tagged_Type (Typ)
+ and then Is_Derived_Type (Typ)
+ then
+ declare
+ Root_Typ : constant Entity_Id := Root_Type (Typ);
+
+ Parent_Typ : Entity_Id := Typ;
+
+ begin
+ loop
+ Parent_Typ := Etype (Parent_Typ);
+
+ if Is_Global (Parent_Typ) then
+ Set_Ancestor_Type (N, Parent_Typ);
+ exit;
+ end if;
+
+ exit when Parent_Typ = Root_Typ;
+ end loop;
+ end;
+ end if;
+
-- If the aggregate is an actual in a call, it has been
-- resolved in the current context, to some local type. The
-- enclosing call may have been disambiguated by the aggregate,
Subtype_Mark => Nam,
Expression => Relocate_Node (N));
end if;
+
+ -- For a full aggregate, if the type is global and a derived
+ -- tagged type, we will also need to have the full view of its
+ -- ancestor available in the instance in order to analyze the
+ -- full aggregate.
+
+ elsif Present (N2)
+ and then Nkind (N2) = N_Aggregate
+ and then Present (Typ)
+ and then Is_Tagged_Type (Typ)
+ and then Is_Derived_Type (Typ)
+ then
+ Set_Ancestor_Type (N, Etype (Typ));
end if;
if Nkind (N) = N_Aggregate then
(N : N_Inclusive_Has_Entity; Val : Node_Id)
renames Set_Entity_Or_Associated_Node;
+ ---------------------------------------------------
+ -- Aliases for Aggregate_Bounds_Or_Ancestor_Type --
+ ---------------------------------------------------
+
+ function Aggregate_Bounds (N : Node_Id) return Node_Id
+ renames Aggregate_Bounds_Or_Ancestor_Type;
+
+ function Ancestor_Type (N : Node_Id) return Node_Id
+ renames Aggregate_Bounds_Or_Ancestor_Type;
+
+ procedure Set_Aggregate_Bounds (N : Node_Id; Val : Node_Id)
+ renames Set_Aggregate_Bounds_Or_Ancestor_Type;
+
+ procedure Set_Ancestor_Type (N : Node_Id; Val : Node_Id)
+ renames Set_Aggregate_Bounds_Or_Ancestor_Type;
+
---------------
-- Debugging --
---------------
-- is used for translation of the at end handler into a normal exception
-- handler.
+ -- Ancestor_Type
+ -- Present in record N_Aggregate nodes. Used to store the first global
+ -- ancestor of the type of the aggregate in a generic context, if any,
+ -- when the type is a derived tagged type. Otherwise Empty.
+
-- Aspect_On_Partial_View
-- Present on an N_Aspect_Specification node. For an aspect that applies
-- to a type entity, indicates whether the specification appears on the
-- Expressions (set to No_List if none or null record case)
-- Component_Associations (set to No_List if none)
-- Null_Record_Present
- -- Aggregate_Bounds
+ -- Aggregate_Bounds (array) or Ancestor_Type (record)
-- Associated_Node
-- Compile_Time_Known_Aggregate
-- Expansion_Delayed
projects / thirdparty / gcc.git / commitdiff
