-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- The following procedures treat other kinds of formal parameters
procedure Analyze_Formal_Derived_Interface_Type
- (T : Entity_Id;
+ (N : Node_Id;
+ T : Entity_Id;
Def : Node_Id);
procedure Analyze_Formal_Derived_Type
T : Entity_Id;
Def : Node_Id);
+ procedure Analyze_Formal_Interface_Type
+ (N : Node_Id;
+ T : Entity_Id;
+ Def : Node_Id);
+
-- The following subprograms create abbreviated declarations for formal
-- scalar types. We introduce an anonymous base of the proper class for
-- each of them, and define the formals as constrained first subtypes of
(T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id);
- procedure Analyze_Formal_Interface_Type (T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id);
procedure Analyze_Formal_Ordinary_Fixed_Point_Type
-- Save_Env because data-structures for visibility handling must be
-- initialized before call to Check_Generic_Child_Unit.
+ procedure Install_Formal_Packages (Par : Entity_Id);
+ -- If any of the formals of the parent are formal packages with box,
+ -- their formal parts are visible in the parent and thus in the child
+ -- unit as well. Analogous to what is done in Check_Generic_Actuals
+ -- for the unit itself. This procedure is also used in an instance, to
+ -- make visible the proper entities of the actual for a formal package
+ -- declared with a box.
+
procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
-- When compiling an instance of a child unit the parent (which is
-- itself an instance) is an enclosing scope that must be made
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id;
- Actual_Decls : List_Id) return Node_Id;
+ Actual_Decls : List_Id) return List_Id;
function Instantiate_Formal_Subprogram
(Formal : Node_Id;
-- End of list of purely positional parameters
- if No (Actual) then
+ if No (Actual)
+ or else Nkind (Actual) = N_Others_Choice
+ then
Found_Assoc := Empty;
Act := Empty;
procedure Process_Default (F : Entity_Id) is
Loc : constant Source_Ptr := Sloc (I_Node);
+ Decl : Node_Id;
Default : Node_Id;
Id : Entity_Id;
begin
- -- Append copy of formal declaration to associations.
+ -- Append copy of formal declaration to associations, and create
+ -- new defining identifier for it.
- Append (New_Copy_Tree (F), Assoc);
+ Decl := New_Copy_Tree (F);
- if No (Found_Assoc) then
- if Nkind (F) = N_Formal_Concrete_Subprogram_Declaration then
- Id := Defining_Entity (F);
- else
- Id := Defining_Identifier (F);
- end if;
+ if Nkind (F) = N_Formal_Concrete_Subprogram_Declaration then
+ Id :=
+ Make_Defining_Identifier (Sloc (Defining_Entity (F)),
+ Chars => Chars (Defining_Entity (F)));
+ Set_Defining_Unit_Name (Specification (Decl), Id);
+ else
+ Id :=
+ Make_Defining_Identifier (Sloc (Defining_Entity (F)),
+ Chars => Chars (Defining_Identifier (F)));
+ Set_Defining_Identifier (Decl, Id);
+ end if;
+
+ Append (Decl, Assoc);
+
+ if No (Found_Assoc) then
Default :=
Make_Generic_Association (Loc,
- Selector_Name =>
- New_Occurrence_Of (Id, Loc),
- Explicit_Generic_Actual_Parameter => Empty);
+ Selector_Name => New_Occurrence_Of (Id, Loc),
+ Explicit_Generic_Actual_Parameter => Empty);
Set_Box_Present (Default);
Append (Default, Default_Formals);
end if;
Error_Msg_N ("others must be last association", Actual);
end if;
- Remove (Actual);
+ -- This subprogram is used both for formal packages and for
+ -- instantiations. For the latter, associations must all be
+ -- explicit.
+
+ if Nkind (I_Node) /= N_Formal_Package_Declaration
+ and then Comes_From_Source (I_Node)
+ then
+ Error_Msg_N
+ ("others association not allowed in an instance",
+ Actual);
+ end if;
+
+ -- In any case, nothing to do after the others association
+
exit;
+
+ elsif Box_Present (Actual)
+ and then Comes_From_Source (I_Node)
+ and then Nkind (I_Node) /= N_Formal_Package_Declaration
+ then
+ Error_Msg_N
+ ("box association not allowed in an instance", Actual);
end if;
Next (Actual);
First_Named := First (Actuals);
while Present (First_Named)
+ and then Nkind (First_Named) /= N_Others_Choice
and then No (Selector_Name (First_Named))
loop
Num_Actuals := Num_Actuals + 1;
Named := First_Named;
while Present (Named) loop
- if No (Selector_Name (Named)) then
+ if Nkind (Named) /= N_Others_Choice
+ and then No (Selector_Name (Named))
+ then
Error_Msg_N ("invalid positional actual after named one", Named);
Abandon_Instantiation (Named);
end if;
-- introduced for a default subprogram that turns out to be local
-- to the outer instantiation.
- if Present (Explicit_Generic_Actual_Parameter (Named)) then
+ if Nkind (Named) /= N_Others_Choice
+ and then Present (Explicit_Generic_Actual_Parameter (Named))
+ then
Num_Actuals := Num_Actuals + 1;
end if;
else
Analyze (Match);
- Append_To (Assoc,
- Instantiate_Type
- (Formal, Match, Analyzed_Formal, Assoc));
+ Append_List
+ (Instantiate_Type
+ (Formal, Match, Analyzed_Formal, Assoc),
+ Assoc);
-- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package.
-------------------------------------------
procedure Analyze_Formal_Derived_Interface_Type
- (T : Entity_Id;
+ (N : Node_Id;
+ T : Entity_Id;
Def : Node_Id)
is
- Ifaces_List : Elist_Id;
+ Loc : constant Source_Ptr := Sloc (Def);
+ New_N : Node_Id;
begin
- Enter_Name (T);
- Set_Ekind (T, E_Record_Type);
- Set_Etype (T, T);
- Analyze (Subtype_Indication (Def));
- Analyze_Interface_Declaration (T, Def);
- Make_Class_Wide_Type (T);
- Analyze_List (Interface_List (Def));
-
- -- Ada 2005 (AI-251): Collect the list of progenitors that are not
- -- already covered by the parents.
-
- Collect_Abstract_Interfaces
- (T => T,
- Ifaces_List => Ifaces_List,
- Exclude_Parent_Interfaces => True);
-
- Set_Abstract_Interfaces (T, Ifaces_List);
+ -- Rewrite as a type declaration of a derived type. This ensures that
+ -- the interface list and primitive operations are properly captured.
+
+ New_N :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => T,
+ Type_Definition => Def);
+
+ Rewrite (N, New_N);
+ Analyze (N);
+ Set_Is_Generic_Type (T);
end Analyze_Formal_Derived_Interface_Type;
---------------------------------
-- Analyze_Formal_Interface_Type;--
-----------------------------------
- procedure Analyze_Formal_Interface_Type (T : Entity_Id; Def : Node_Id) is
+ procedure Analyze_Formal_Interface_Type
+ (N : Node_Id;
+ T : Entity_Id;
+ Def : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ New_N : Node_Id;
+
begin
- Enter_Name (T);
- Set_Ekind (T, E_Record_Type);
- Set_Etype (T, T);
- Analyze_Interface_Declaration (T, Def);
- Make_Class_Wide_Type (T);
- Set_Primitive_Operations (T, New_Elmt_List);
+ New_N :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => T,
+ Type_Definition => Def);
+
+ Rewrite (N, New_N);
+ Analyze (N);
+ Set_Is_Generic_Type (T);
end Analyze_Formal_Interface_Type;
---------------------------------
Set_Ekind (Formal, E_Package);
Set_Etype (Formal, Standard_Void_Type);
Set_Inner_Instances (Formal, New_Elmt_List);
- New_Scope (Formal);
+ Push_Scope (Formal);
if Is_Child_Unit (Gen_Unit)
and then Parent_Installed
-- record declaration or a abstract type derivation.
when N_Record_Definition =>
- Analyze_Formal_Interface_Type (T, Def);
+ Analyze_Formal_Interface_Type (N, T, Def);
when N_Derived_Type_Definition =>
- Analyze_Formal_Derived_Interface_Type (T, Def);
+ Analyze_Formal_Derived_Interface_Type (N, T, Def);
when N_Error =>
null;
Enter_Name (Id);
Set_Ekind (Id, E_Generic_Package);
Set_Etype (Id, Standard_Void_Type);
- New_Scope (Id);
+ Push_Scope (Id);
Enter_Generic_Scope (Id);
Set_Inner_Instances (Id, New_Elmt_List);
Enter_Name (Id);
Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
- New_Scope (Id);
+ Push_Scope (Id);
Enter_Generic_Scope (Id);
Set_Inner_Instances (Id, New_Elmt_List);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
Check_Forward_Instantiation (Gen_Decl);
if Nkind (N) = N_Package_Instantiation then
declare
- Enclosing_Master : Entity_Id := Current_Scope;
+ Enclosing_Master : Entity_Id;
begin
- while Enclosing_Master /= Standard_Standard loop
+ -- Loop to search enclosing masters
+ Enclosing_Master := Current_Scope;
+ Scope_Loop : while Enclosing_Master /= Standard_Standard loop
if Ekind (Enclosing_Master) = E_Package then
if Is_Compilation_Unit (Enclosing_Master) then
if In_Package_Body (Enclosing_Master) then
(Enclosing_Master);
end if;
- exit;
+ exit Scope_Loop;
else
Enclosing_Master := Scope (Enclosing_Master);
-- the enclosing instance, if any. enclosing scope
-- is void in the formal part of a generic subp.
- exit;
+ exit Scope_Loop;
else
if Ekind (Enclosing_Master) = E_Entry
and then
Ekind (Scope (Enclosing_Master)) = E_Protected_Type
then
- Enclosing_Master :=
- Protected_Body_Subprogram (Enclosing_Master);
+ if not Expander_Active then
+ exit Scope_Loop;
+ else
+ Enclosing_Master :=
+ Protected_Body_Subprogram (Enclosing_Master);
+ end if;
end if;
Set_Delay_Cleanups (Enclosing_Master);
end;
end if;
- exit;
+ exit Scope_Loop;
end if;
- end loop;
+ end loop Scope_Loop;
end;
-- Make entry in table
-- removed previously.
-- If current scope is the body of a child unit, remove context of
- -- spec as well.
+ -- spec as well. If an enclosing scope is an instance body. the
+ -- context has already been removed, but the entities in the body
+ -- must be made invisible as well.
S := Current_Scope;
while Present (S)
and then S /= Standard_Standard
loop
- exit when Is_Generic_Instance (S)
- and then (In_Package_Body (S)
- or else Ekind (S) = E_Procedure
- or else Ekind (S) = E_Function);
+ if Is_Generic_Instance (S)
+ and then (In_Package_Body (S)
+ or else Ekind (S) = E_Procedure
+ or else Ekind (S) = E_Function)
+ then
+ -- We still have to remove the entities of the enclosing
+ -- instance from direct visibility.
+
+ declare
+ E : Entity_Id;
+ begin
+ E := First_Entity (S);
+ while Present (E) loop
+ Set_Is_Immediately_Visible (E, False);
+ Next_Entity (E);
+ end loop;
+ end;
+
+ exit;
+ end if;
if S = Curr_Unit
or else (Ekind (Curr_Unit) = E_Package_Body
end loop;
pragma Assert (Num_Inner < Num_Scopes);
- New_Scope (Standard_Standard);
+ Push_Scope (Standard_Standard);
Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
Instantiate_Package_Body
((N, Act_Decl, Expander_Active, Current_Sem_Unit), True);
if Present (Curr_Scope)
and then Is_Child_Unit (Curr_Scope)
then
- New_Scope (Curr_Scope);
+ Push_Scope (Curr_Scope);
Set_Is_Immediately_Visible (Curr_Scope);
-- Finally, restore inner scopes as well
for J in reverse 1 .. Num_Inner loop
- New_Scope (Inner_Scopes (J));
+ Push_Scope (Inner_Scopes (J));
end loop;
end if;
end loop;
end if;
- for J in 1 .. N_Instances loop
- Set_Is_Generic_Instance (Instances (J), True);
- end loop;
+ -- Restore status of instances. If one of them is a body, make
+ -- its local entities visible again.
+
+ declare
+ E : Entity_Id;
+ Inst : Entity_Id;
+
+ begin
+ for J in 1 .. N_Instances loop
+ Inst := Instances (J);
+ Set_Is_Generic_Instance (Inst, True);
+
+ if In_Package_Body (Inst)
+ or else Ekind (S) = E_Procedure
+ or else Ekind (S) = E_Function
+ then
+ E := First_Entity (Instances (J));
+ while Present (E) loop
+ Set_Is_Immediately_Visible (E);
+ Next_Entity (E);
+ end loop;
+ end if;
+ end loop;
+ end;
-- If generic unit is in current unit, current context is correct
then
Install_Parent (Inst_Par);
Parent_Installed := True;
+
+ elsif In_Open_Scopes (Inst_Par) then
+
+ -- If the parent is already installed verify that the
+ -- actuals for its formal packages declared with a box
+ -- are already installed. This is necessary when the
+ -- child instance is a child of the parent instance.
+ -- In this case the parent is placed on the scope stack
+ -- but the formal packages are not made visible.
+
+ Install_Formal_Packages (Inst_Par);
end if;
else
then
Switch_View (Designated_Type (T));
- elsif Is_Array_Type (T)
- and then Is_Private_Type (Component_Type (T))
- and then not Has_Private_View (N)
- and then Present (Full_View (Component_Type (T)))
- then
- Switch_View (Component_Type (T));
+ elsif Is_Array_Type (T) then
+ if Is_Private_Type (Component_Type (T))
+ and then not Has_Private_View (N)
+ and then Present (Full_View (Component_Type (T)))
+ then
+ Switch_View (Component_Type (T));
+ end if;
+
+ -- The normal exchange mechanism relies on the setting of a
+ -- flag on the reference in the generic. However, an additional
+ -- mechanism is needed for types that are not explicitly mentioned
+ -- in the generic, but may be needed in expanded code in the
+ -- instance. This includes component types of arrays and
+ -- designated types of access types. This processing must also
+ -- include the index types of arrays which we take care of here.
+
+ declare
+ Indx : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ Indx := First_Index (T);
+ Typ := Base_Type (Etype (Indx));
+ while Present (Indx) loop
+ if Is_Private_Type (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Switch_View (Typ);
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end;
elsif Is_Private_Type (T)
and then Present (Full_View (T))
Switch_View (T);
-- Finally, a non-private subtype may have a private base type, which
- -- must be exchanged for consistency. This can happen when
- -- instantiating a package body, when the scope stack is empty but in
- -- fact the subtype and the base type are declared in an enclosing
- -- scope.
+ -- must be exchanged for consistency. This can happen when a package
+ -- body is instantiated, when the scope stack is empty but in fact
+ -- the subtype and the base type are declared in an enclosing scope.
-- Note that in this case we introduce an inconsistency in the view
-- set, because we switch the base type BT, but there could be some
elsif Nkind (N) = N_Integer_Literal
or else Nkind (N) = N_Real_Literal
+ or else Nkind (N) = N_String_Literal
then
-- No descendant fields need traversing
Mark_Rewrite_Insertion (Act_Body);
end Install_Body;
+ -----------------------------
+ -- Install_Formal_Packages --
+ -----------------------------
+
+ procedure Install_Formal_Packages (Par : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Par);
+ while Present (E) loop
+ if Ekind (E) = E_Package
+ and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
+ then
+ -- If this is the renaming for the parent instance, done
+
+ if Renamed_Object (E) = Par then
+ exit;
+
+ -- The visibility of a formal of an enclosing generic is
+ -- already correct.
+
+ elsif Denotes_Formal_Package (E) then
+ null;
+
+ elsif Present (Associated_Formal_Package (E))
+ and then Box_Present (Parent (Associated_Formal_Package (E)))
+ then
+ Check_Generic_Actuals (Renamed_Object (E), True);
+ Set_Is_Hidden (E, False);
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Install_Formal_Packages;
+
--------------------
-- Install_Parent --
--------------------
First_Gen : Entity_Id;
Elmt : Elmt_Id;
- procedure Install_Formal_Packages (Par : Entity_Id);
- -- If any of the formals of the parent are formal packages with box,
- -- their formal parts are visible in the parent and thus in the child
- -- unit as well. Analogous to what is done in Check_Generic_Actuals
- -- for the unit itself.
-
procedure Install_Noninstance_Specs (Par : Entity_Id);
-- Install the scopes of noninstance parent units ending with Par
-- The child unit is within the declarative part of the parent, so
-- the declarations within the parent are immediately visible.
- -----------------------------
- -- Install_Formal_Packages --
- -----------------------------
-
- procedure Install_Formal_Packages (Par : Entity_Id) is
- E : Entity_Id;
-
- begin
- E := First_Entity (Par);
- while Present (E) loop
- if Ekind (E) = E_Package
- and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
- then
- -- If this is the renaming for the parent instance, done
-
- if Renamed_Object (E) = Par then
- exit;
-
- -- The visibility of a formal of an enclosing generic is
- -- already correct.
-
- elsif Denotes_Formal_Package (E) then
- null;
-
- elsif Present (Associated_Formal_Package (E))
- and then Box_Present (Parent (Associated_Formal_Package (E)))
- then
- Check_Generic_Actuals (Renamed_Object (E), True);
- Set_Is_Hidden (E, False);
- end if;
- end if;
-
- Next_Entity (E);
- end loop;
- end Install_Formal_Packages;
-
-------------------------------
-- Install_Noninstance_Specs --
-------------------------------
-- parents then it should be possible to remove this
-- special check. ???
- New_Scope (Par);
+ Push_Scope (Par);
Set_Is_Immediately_Visible (Par);
Install_Visible_Declarations (Par);
Set_Use (Visible_Declarations (Spec));
end if;
if not In_Body then
- New_Scope (S);
+ Push_Scope (S);
end if;
end Install_Parent;
-- renamings of the actuals supplied.
declare
- Gen_Decl : constant Node_Id :=
- Unit_Declaration_Node (Gen_Parent);
- Formals : constant List_Id :=
- Generic_Formal_Declarations (Gen_Decl);
- Actual_Ent : Entity_Id;
- Formal_Node : Node_Id;
- Formal_Ent : Entity_Id;
+ Gen_Decl : constant Node_Id :=
+ Unit_Declaration_Node (Gen_Parent);
+ Formals : constant List_Id :=
+ Generic_Formal_Declarations (Gen_Decl);
+
+ Actual_Ent : Entity_Id;
+ Actual_Of_Formal : Node_Id;
+ Formal_Node : Node_Id;
+ Formal_Ent : Entity_Id;
begin
if Present (Formals) then
end if;
Actual_Ent := First_Entity (Actual_Pack);
+ Actual_Of_Formal :=
+ First (Visible_Declarations (Specification (Analyzed_Formal)));
while Present (Actual_Ent)
and then Actual_Ent /= First_Private_Entity (Actual_Pack)
loop
Match_Formal_Entity
(Formal_Node, Formal_Ent, Actual_Ent);
+ -- We iterate at the same time over the actuals of the
+ -- local package created for the formal, to determine
+ -- which one of the formals of the original generic were
+ -- defaulted in the formal. The corresponding actual
+ -- entities are visible in the enclosing instance.
+
if Box_Present (Formal)
or else
- (Present (Formal_Node)
- and then Is_Generic_Formal (Formal_Ent))
+ (Present (Actual_Of_Formal)
+ and then
+ Is_Generic_Formal
+ (Get_Formal_Entity (Actual_Of_Formal)))
then
- -- This may make too many formal entities visible, but
- -- it's hard to build an example that exposes this
- -- excess visibility. If a reference in the generic
- -- resolved to a global variable then the extra
- -- visibility in an instance does not affect the
- -- captured entity. If the reference resolved to a
- -- local entity it will resolve again in the instance.
- -- Nevertheless, we should build tests to make sure
- -- that hidden entities in the generic remain hidden
- -- in the instance.
-
Set_Is_Hidden (Actual_Ent, False);
Set_Is_Visible_Formal (Actual_Ent);
Set_Is_Potentially_Use_Visible
if Ekind (Actual_Ent) = E_Package then
Process_Nested_Formal (Actual_Ent);
end if;
+
+ else
+ Set_Is_Hidden (Actual_Ent);
+ Set_Is_Potentially_Use_Visible (Actual_Ent, False);
end if;
end if;
Next_Non_Pragma (Formal_Node);
+ Next (Actual_Of_Formal);
else
-- No further formals to match, but the generic part may
Next_Entity (Actual_Ent);
end if;
-
end loop;
-- Inherited subprograms generated by formal derived types are
-- formal object of another generic unit G, and the instantiation
-- containing the actual occurs within the body of G or within the body
-- of a generic unit declared within the declarative region of G, then
- -- the declaration of the formal object of G shall have a null
- -- exclusion. Otherwise, the subtype of the actual matching the formal
- -- object declaration shall exclude null.
+ -- the declaration of the formal object of G must have a null exclusion.
+ -- Otherwise, the subtype of the actual matching the formal object
+ -- declaration shall exclude null.
if Ada_Version >= Ada_05
and then Present (Actual_Decl)
and then Has_Null_Exclusion (Actual_Decl)
and then not Has_Null_Exclusion (Analyzed_Formal)
then
- Error_Msg_N ("null-exclusion required in formal object declaration",
- Analyzed_Formal);
+ Error_Msg_Sloc := Sloc (Actual_Decl);
+ Error_Msg_N
+ ("`NOT NULL` required in formal, to match actual #",
+ Analyzed_Formal);
end if;
return List;
Gen_Body : Node_Id;
Gen_Body_Id : Node_Id;
Act_Body : Node_Id;
- Act_Body_Id : Entity_Id;
Pack_Body : Node_Id;
Prev_Formal : Entity_Id;
Ret_Expr : Node_Id;
Act_Body :=
Copy_Generic_Node
(Original_Node (Gen_Body), Empty, Instantiating => True);
- Act_Body_Id := Defining_Entity (Act_Body);
- Set_Chars (Act_Body_Id, Chars (Anon_Id));
- Set_Sloc (Act_Body_Id, Sloc (Defining_Entity (Inst_Node)));
+
+ -- Create proper defining name for the body, to correspond to
+ -- the one in the spec.
+
+ Set_Defining_Unit_Name (Specification (Act_Body),
+ Make_Defining_Identifier
+ (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id)));
Set_Corresponding_Spec (Act_Body, Anon_Id);
Set_Has_Completion (Anon_Id);
Check_Generic_Actuals (Pack_Id, False);
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id;
- Actual_Decls : List_Id) return Node_Id
+ Actual_Decls : List_Id) return List_Id
is
- Gen_T : constant Entity_Id := Defining_Identifier (Formal);
- A_Gen_T : constant Entity_Id := Defining_Identifier (Analyzed_Formal);
- Ancestor : Entity_Id := Empty;
- Def : constant Node_Id := Formal_Type_Definition (Formal);
- Act_T : Entity_Id;
- Decl_Node : Node_Id;
- Loc : Source_Ptr;
- Subt : Entity_Id;
+ Gen_T : constant Entity_Id := Defining_Identifier (Formal);
+ A_Gen_T : constant Entity_Id :=
+ Defining_Identifier (Analyzed_Formal);
+ Ancestor : Entity_Id := Empty;
+ Def : constant Node_Id := Formal_Type_Definition (Formal);
+ Act_T : Entity_Id;
+ Decl_Node : Node_Id;
+ Decl_Nodes : List_Id;
+ Loc : Source_Ptr;
+ Subt : Entity_Id;
procedure Validate_Array_Type_Instance;
procedure Validate_Access_Subprogram_Instance;
Actual, Gen_T);
Abandon_Instantiation (Actual);
end if;
+
+ -- Ada 2005: null-exclusion indicators of the two types must agree
+
+ if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then
+ Error_Msg_NE
+ ("non null exclusion of actual and formal & do not match",
+ Actual, Gen_T);
+ end if;
end Validate_Access_Type_Instance;
----------------------------------
-- the actual.
if Present (Par)
- and then not Interface_Present_In_Ancestor (Act_T, Par)
+ and then not Interface_Present_In_Ancestor (Act_T, Par)
then
Error_Msg_NE
("interface actual must include progenitor&", Actual, Par);
Elmt := First_Elmt (Abstract_Interfaces (A_Gen_T));
while Present (Elmt) loop
- if not Interface_Present_In_Ancestor (Act_T, Node (Elmt)) then
+ if not Interface_Present_In_Ancestor
+ (Act_T, Get_Instance_Of (Node (Elmt)))
+ then
Error_Msg_NE
("interface actual must include progenitor&",
Actual, Node (Elmt));
Is_Synchronized_Interface (Act_T)
then
Error_Msg_NE
- ("actual for interface& does not match ('R'M 12.5.5(5))",
+ ("actual for interface& does not match ('R'M 12.5.5(4))",
Actual, Gen_T);
end if;
end Validate_Interface_Type_Instance;
begin
if Get_Instance_Of (A_Gen_T) /= A_Gen_T then
Error_Msg_N ("duplicate instantiation of generic type", Actual);
- return Error;
+ return New_List (Error);
elsif not Is_Entity_Name (Actual)
or else not Is_Type (Entity (Actual))
("actual of non-abstract formal cannot be abstract", Actual);
end if;
- if Is_Scalar_Type (Gen_T) then
+ -- A generic scalar type is a first subtype for which we generate
+ -- an anonymous base type. Indicate that the instance of this base
+ -- is the base type of the actual.
+
+ if Is_Scalar_Type (A_Gen_T) then
Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T));
end if;
end if;
Set_Has_Private_View (Subtype_Indication (Decl_Node));
end if;
+ Decl_Nodes := New_List (Decl_Node);
+
-- Flag actual derived types so their elaboration produces the
-- appropriate renamings for the primitive operations of the ancestor.
-- Flag actual for formal private types as well, to determine whether
Set_Generic_Parent_Type (Decl_Node, Ancestor);
end if;
- return Decl_Node;
+ -- If the actual is a synchronized type that implements an interface,
+ -- the primitive operations are attached to the corresponding record,
+ -- and we have to treat it as an additional generic actual, so that its
+ -- primitive operations become visible in the instance. The task or
+ -- protected type itself does not carry primitive operations.
+
+ if Is_Concurrent_Type (Act_T)
+ and then Is_Tagged_Type (Act_T)
+ and then Present (Corresponding_Record_Type (Act_T))
+ and then Present (Ancestor)
+ and then Is_Interface (Ancestor)
+ then
+ declare
+ Corr_Rec : constant Entity_Id :=
+ Corresponding_Record_Type (Act_T);
+ New_Corr : Entity_Id;
+ Corr_Decl : Node_Id;
+
+ begin
+ New_Corr := Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('S'));
+ Corr_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => New_Corr,
+ Subtype_Indication =>
+ New_Reference_To (Corr_Rec, Loc));
+ Append_To (Decl_Nodes, Corr_Decl);
+
+ if Ekind (Act_T) = E_Task_Type then
+ Set_Ekind (Subt, E_Task_Subtype);
+ else
+ Set_Ekind (Subt, E_Protected_Subtype);
+ end if;
+
+ Set_Corresponding_Record_Type (Subt, Corr_Rec);
+ Set_Generic_Parent_Type (Corr_Decl, Ancestor);
+ Set_Generic_Parent_Type (Decl_Node, Empty);
+ end;
+ end if;
+
+ return Decl_Nodes;
end Instantiate_Type;
-----------------------
-----------------------
function Is_Generic_Formal (E : Entity_Id) return Boolean is
- Kind : constant Node_Kind := Nkind (Parent (E));
+ Kind : Node_Kind;
+
begin
- return
- Kind = N_Formal_Object_Declaration
- or else Kind = N_Formal_Package_Declaration
- or else Kind in N_Formal_Subprogram_Declaration
- or else Kind = N_Formal_Type_Declaration;
+ if No (E) then
+ return False;
+ else
+ Kind := Nkind (Parent (E));
+ return
+ Kind = N_Formal_Object_Declaration
+ or else Kind = N_Formal_Package_Declaration
+ or else Kind = N_Formal_Type_Declaration
+ or else
+ (Is_Formal_Subprogram (E)
+ and then
+ Nkind (Parent (Parent (E))) in
+ N_Formal_Subprogram_Declaration);
+ end if;
end Is_Generic_Formal;
---------------------
begin
Error_Msg_Unit_1 := Bname;
Error_Msg_N ("this instantiation requires$!", N);
- Error_Msg_Name_1 :=
- Get_File_Name (Bname, Subunit => False);
+ Error_Msg_File_1 := Get_File_Name (Bname, Subunit => False);
Error_Msg_N ("\but file{ was not found!", N);
raise Unrecoverable_Error;
end;
begin
if Nkind (Expr) = N_Subtype_Indication then
Analyze (Subtype_Mark (Expr));
- Analyze_List (Constraints (Constraint (Expr)));
+
+ -- Analyze separately each discriminant constraint,
+ -- when given with a named association.
+
+ declare
+ Constr : Node_Id;
+
+ begin
+ Constr := First (Constraints (Constraint (Expr)));
+ while Present (Constr) loop
+ if Nkind (Constr) = N_Discriminant_Association then
+ Analyze (Expression (Constr));
+ else
+ Analyze (Constr);
+ end if;
+
+ Next (Constr);
+ end loop;
+ end;
+
else
Analyze (Expr);
end if;
elsif Nkind (Parent (N)) = N_Selected_Component
and then Nkind (Parent (N2)) = N_Function_Call
- and then Is_Global (Entity (Name (Parent (N2))))
+ and then N = Selector_Name (Parent (N))
then
- Change_Selected_Component_To_Expanded_Name (Parent (N));
- Set_Associated_Node (Parent (N), Name (Parent (N2)));
- Set_Global_Type (Parent (N), Name (Parent (N2)));
- Save_Entity_Descendants (N);
+ if No (Parameter_Associations (Parent (N2))) then
+ if Is_Global (Entity (Name (Parent (N2)))) then
+ Change_Selected_Component_To_Expanded_Name (Parent (N));
+ Set_Associated_Node (Parent (N), Name (Parent (N2)));
+ Set_Global_Type (Parent (N), Name (Parent (N2)));
+ Save_Entity_Descendants (N);
- else
- -- Entity is local. Reset in generic unit, so that node is
- -- resolved anew at the point of instantiation.
+ else
+ Set_Associated_Node (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+
+ -- In Ada 2005, X.F may be a call to a primitive operation,
+ -- rewritten as F (X). This rewriting will be done again in an
+ -- instance, so keep the original node. Global entities will be
+ -- captured as for other constructs.
+ else
+ null;
+ end if;
+
+ -- Entity is local. Reset in generic unit, so that node is resolved
+ -- anew at the point of instantiation.
+
+ else
Set_Associated_Node (N, Empty);
Set_Etype (N, Empty);
end if;
OSDN Git Service
