Skip to content

R
riscv-gcc-1
Commit 437bae3f by Ed Schonberg Committed by Arnaud Charlet
Options

sem_ch12.adb (Analyze_Associations): Diagnose use of an others association in an instance. 

2007-04-20  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_ch12.adb (Analyze_Associations): Diagnose use of an others
	association in an instance.
	(Copy_Generic_Node): If the node is a string literal, no need to copy
	its descendants.
	(Is_Generic_Formal): For a formal subprogram, the declaration is the
	grandparent of the entity.
	(Analyze_Formal_Interface_Type): Transform into a full type declaration,
	to simplify handling of formal interfaces that derive from other formal
	interfaces.
	(Instantiate_Subprogram_Body): The defining unit name of the body of
	the instance should be a defining identifier.
	(Install_Formal_Packages): make global to the package, for use in
	instantiations of child units.
	(Analyze_Package_Instantiation): Do not attempt to set information on an
	enclosing master of an entry when expansion is disabled.
	(Instantiate_Type): If the actual is a tagged synchronized type and the
	generic ancestor is an interface, create a generic actual for the
	corresponding record.
	(Analyze_Formal_Derived_Interface_Type): Rewrite as a derived type
	declaration, to ensure that the interface list is processed correctly.
	(Inline_Instance_Body): If enclosing scope is an instance body, remove
	its entities from visibiility as well.
	(Pre_Analyze_Actuals): if the actual is an allocator with  constraints
	given with a named association, analyze the expression only, not the
	discriminant association itself.
	(Reset_Entity): If the analysis of a selected component is transformed
	into an expanded name in the prefix of a call with parameters, do not
	transform the original node into an expanded name, to prevent visibility
	errors in the case of nested generics.
	(Check_Private_View): For an array type, check whether the index types
	may need exchanging.

From-SVN: r125431
parent f35b24e9
Showing with 433 additions and 188 deletions
gcc/ada/sem_ch12.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -305,7 +305,8 @@ package body Sem_Ch12 is
-- 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
......@@ -313,6 +314,11 @@ package body Sem_Ch12 is
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
......@@ -323,7 +329,6 @@ package body Sem_Ch12 is
(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
......@@ -527,6 +532,14 @@ package body Sem_Ch12 is
-- 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
......@@ -561,7 +574,7 @@ package body Sem_Ch12 is
(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;
......@@ -927,7 +940,9 @@ package body Sem_Ch12 is
-- 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;
......@@ -1000,26 +1015,36 @@ package body Sem_Ch12 is
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;
......@@ -1092,8 +1117,28 @@ package body Sem_Ch12 is
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);
......@@ -1104,6 +1149,7 @@ package body Sem_Ch12 is
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;
......@@ -1113,7 +1159,9 @@ package body Sem_Ch12 is
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;
......@@ -1122,7 +1170,9 @@ package body Sem_Ch12 is
-- 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;
......@@ -1184,9 +1234,10 @@ package body Sem_Ch12 is
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.
......@@ -1509,29 +1560,25 @@ package body Sem_Ch12 is
-------------------------------------------
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;
---------------------------------
......@@ -1695,14 +1742,23 @@ package body Sem_Ch12 is
-- 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;
---------------------------------
......@@ -2090,7 +2146,7 @@ package body Sem_Ch12 is
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
......@@ -2449,10 +2505,10 @@ package body Sem_Ch12 is
-- 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;
......@@ -2589,7 +2645,7 @@ package body Sem_Ch12 is
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);
......@@ -2679,7 +2735,7 @@ package body Sem_Ch12 is
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));
......@@ -3163,11 +3219,13 @@ package body Sem_Ch12 is
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
......@@ -3178,7 +3236,7 @@ package body Sem_Ch12 is
(Enclosing_Master);
end if;
exit;
exit Scope_Loop;
else
Enclosing_Master := Scope (Enclosing_Master);
......@@ -3194,15 +3252,19 @@ package body Sem_Ch12 is
-- 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);
......@@ -3227,9 +3289,9 @@ package body Sem_Ch12 is
end;
end if;
exit;
exit Scope_Loop;
end if;
end loop;
end loop Scope_Loop;
end;
-- Make entry in table
......@@ -3458,17 +3520,35 @@ package body Sem_Ch12 is
-- 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
......@@ -3514,7 +3594,7 @@ package body Sem_Ch12 is
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);
......@@ -3538,13 +3618,13 @@ package body Sem_Ch12 is
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;
......@@ -3595,9 +3675,30 @@ package body Sem_Ch12 is
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
......@@ -4970,6 +5071,17 @@ package body Sem_Ch12 is
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
......@@ -5156,12 +5268,39 @@ package body Sem_Ch12 is
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))
......@@ -5171,10 +5310,9 @@ package body Sem_Ch12 is
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
......@@ -5852,6 +5990,7 @@ package body Sem_Ch12 is
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
......@@ -6780,6 +6919,42 @@ package body Sem_Ch12 is
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 --
--------------------
......@@ -6794,12 +6969,6 @@ package body Sem_Ch12 is
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
......@@ -6807,42 +6976,6 @@ package body Sem_Ch12 is
-- 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 --
-------------------------------
......@@ -6895,7 +7028,7 @@ package body Sem_Ch12 is
-- 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));
......@@ -6993,7 +7126,7 @@ package body Sem_Ch12 is
end if;
if not In_Body then
New_Scope (S);
Push_Scope (S);
end if;
end Install_Parent;
......@@ -7422,13 +7555,15 @@ package body Sem_Ch12 is
-- 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
......@@ -7438,6 +7573,8 @@ package body Sem_Ch12 is
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
......@@ -7449,22 +7586,19 @@ package body Sem_Ch12 is
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
......@@ -7473,10 +7607,15 @@ package body Sem_Ch12 is
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
......@@ -7485,7 +7624,6 @@ package body Sem_Ch12 is
Next_Entity (Actual_Ent);
end if;
end loop;
-- Inherited subprograms generated by formal derived types are
......@@ -8170,9 +8308,9 @@ package body Sem_Ch12 is
-- 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)
......@@ -8183,8 +8321,10 @@ package body Sem_Ch12 is
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;
......@@ -8443,7 +8583,6 @@ package body Sem_Ch12 is
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;
......@@ -8496,9 +8635,13 @@ package body Sem_Ch12 is
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);
......@@ -8688,16 +8831,18 @@ package body Sem_Ch12 is
(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;
......@@ -8832,6 +8977,14 @@ package body Sem_Ch12 is
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;
----------------------------------
......@@ -8964,7 +9117,7 @@ package body Sem_Ch12 is
-- 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);
......@@ -8975,7 +9128,9 @@ package body Sem_Ch12 is
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));
......@@ -9256,7 +9411,7 @@ package body Sem_Ch12 is
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;
......@@ -9376,7 +9531,7 @@ package body Sem_Ch12 is
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))
......@@ -9472,7 +9627,11 @@ package body Sem_Ch12 is
("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;
......@@ -9571,6 +9730,8 @@ package body Sem_Ch12 is
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
......@@ -9582,7 +9743,47 @@ package body Sem_Ch12 is
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;
-----------------------
......@@ -9590,13 +9791,23 @@ package body Sem_Ch12 is
-----------------------
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;
---------------------
......@@ -9782,8 +9993,7 @@ package body Sem_Ch12 is
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;
......@@ -9959,7 +10169,26 @@ package body Sem_Ch12 is
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;
......@@ -10553,17 +10782,33 @@ package body Sem_Ch12 is
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;
......
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