Skip to content

R
riscv-gcc-1
Commit 097fdf65 by Ed Schonberg Committed by Arnaud Charlet
Options

sem_ch12.ads, [...] (Save_References): If node is an operator that has been constant-folded... 

2006-10-31  Ed Schonberg  <schonberg@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>
        
        * sem_ch12.ads, sem_ch12.adb (Save_References): If node is an operator
	that has been constant-folded, preserve information of original tree,
	for ASIS uses.
	(Analyze_Formal_Derived_Type): Set the limited present flag of the newly
	generated private extension declaration if the formal derived type is
	synchronized. Carry synchronized present over to the generated private
	extension.
	(Validate_Derived_Type_Instance): Ensure that the actual of a
	synchronized formal derived type is a synchronized tagged type.
	(Instantiate_Formal_Package): When creating the instantiation used to
	validate the actual package of a formal declared without a box, check
	whether the formal itself depends on a prior actual.
	(Instantiate_Formal_Subprogram): Create new entities for the defining
	identifiers of the formals in the renaming declaration, for ASIS use.
	(Instantiate_Formal_Subprogram, Instantiate_Formal_Type): When creating
	a renaming declaration or a subtype declaration for an actual in an
	instance, capture location information of declaration in generic, for
	ASIS use.
	(Instantiate_Formal_Package): Add comments on needed additional tests.
	AI-317 (partial parametrization) is fully implemented.
	(Validate_Private_Type_Instance): Add check for actual which
	must have preelaborable initialization
	Use new // insertion for some continuation messages
	(Analyze_Formal_Object_Declaration): Change usage of Expression to
	Default_Expression. Add type retrieval when the declaration has an
	access definition. Update premature usage of incomplete type check.
	(Check_Access_Definition): New subsidiary routine. Check whether the
	current compilation version is Ada 05 and the supplied node has an
	access definition.
	(Instantiate object): Alphabetize local variables. Handle the creation
	of new renaming declarations with respect to the kind of definition
	used - either an access definition or a subtype mark. Guard against
	unnecessary error message in the context of anonymous access types after
	they have been resolved. Add check for required null exclusion in a
	formal object declaration.
	(Switch_View): A private subtype of a non-private type needs to be
	switched (the base type can have been switched without its private
	dependents because of the last branch of Check_Private_View.
	(Check_Private_View): Do not recompute Base_Type (T), instead use cached
	value from BT.
	(Instantiate_Type): Emit an error message whenever a class-wide type of
	a tagged incomplete type is used as a generic actual.
	(Find_Actual_Type): Extend routine to handle a component type in a child
	unit that is imported from a formal package in a parent.
	(Validate_Derived_Type_Instance): Check that analyzed formal and actual
	agree on constrainedness, rather than checking against ultimate ancestor
	(Instantiate_Subprogram_Body): Create a cross-reference link to the
	generic body, for navigation purposes.

From-SVN: r118300
parent 6109adeb
Showing with 835 additions and 190 deletions
gcc/ada/sem_ch12.adb
...@@ -78,13 +78,13 @@ package body Sem_Ch12 is ...@@ -78,13 +78,13 @@ package body Sem_Ch12 is
---------------------------------------------------------- ----------------------------------------------------------
-- Implementation of Generic Analysis and Instantiation -- -- Implementation of Generic Analysis and Instantiation --
----------------------------------------------------------- ----------------------------------------------------------
-- GNAT implements generics by macro expansion. No attempt is made to -- GNAT implements generics by macro expansion. No attempt is made to share
-- share generic instantiations (for now). Analysis of a generic definition -- generic instantiations (for now). Analysis of a generic definition does
-- does not perform any expansion action, but the expander must be called -- not perform any expansion action, but the expander must be called on the
-- on the tree for each instantiation, because the expansion may of course -- tree for each instantiation, because the expansion may of course depend
-- depend on the generic actuals. All of this is best achieved as follows: -- on the generic actuals. All of this is best achieved as follows:
-- --
-- a) Semantic analysis of a generic unit is performed on a copy of the -- a) Semantic analysis of a generic unit is performed on a copy of the
-- tree for the generic unit. All tree modifications that follow analysis -- tree for the generic unit. All tree modifications that follow analysis
...@@ -93,7 +93,7 @@ package body Sem_Ch12 is ...@@ -93,7 +93,7 @@ package body Sem_Ch12 is
-- the generic, and propagate them to each instance (recall that name -- the generic, and propagate them to each instance (recall that name
-- resolution is done on the generic declaration: generics are not really -- resolution is done on the generic declaration: generics are not really
-- macros!). This is summarized in the following diagram: -- macros!). This is summarized in the following diagram:
--
-- .-----------. .----------. -- .-----------. .----------.
-- | semantic |<--------------| generic | -- | semantic |<--------------| generic |
-- | copy | | unit | -- | copy | | unit |
...@@ -108,13 +108,13 @@ package body Sem_Ch12 is ...@@ -108,13 +108,13 @@ package body Sem_Ch12 is
-- |__| | | -- |__| | |
-- |__| instance | -- |__| instance |
-- |__________| -- |__________|
--
-- b) Each instantiation copies the original tree, and inserts into it a -- b) Each instantiation copies the original tree, and inserts into it a
-- series of declarations that describe the mapping between generic formals -- series of declarations that describe the mapping between generic formals
-- and actuals. For example, a generic In OUT parameter is an object -- and actuals. For example, a generic In OUT parameter is an object
-- renaming of the corresponing actual, etc. Generic IN parameters are -- renaming of the corresponing actual, etc. Generic IN parameters are
-- constant declarations. -- constant declarations.
--
-- c) In order to give the right visibility for these renamings, we use -- c) In order to give the right visibility for these renamings, we use
-- a different scheme for package and subprogram instantiations. For -- a different scheme for package and subprogram instantiations. For
-- packages, the list of renamings is inserted into the package -- packages, the list of renamings is inserted into the package
...@@ -154,16 +154,16 @@ package body Sem_Ch12 is ...@@ -154,16 +154,16 @@ package body Sem_Ch12 is
-- Visibility within nested generic units requires special handling. -- Visibility within nested generic units requires special handling.
-- Consider the following scheme: -- Consider the following scheme:
--
-- type Global is ... -- outside of generic unit. -- type Global is ... -- outside of generic unit.
-- generic ... -- generic ...
-- package Outer is -- package Outer is
-- ... -- ...
-- type Semi_Global is ... -- global to inner. -- type Semi_Global is ... -- global to inner.
--
-- generic ... -- 1 -- generic ... -- 1
-- procedure inner (X1 : Global; X2 : Semi_Global); -- procedure inner (X1 : Global; X2 : Semi_Global);
--
-- procedure in2 is new inner (...); -- 4 -- procedure in2 is new inner (...); -- 4
-- end Outer; -- end Outer;
...@@ -221,31 +221,78 @@ package body Sem_Ch12 is ...@@ -221,31 +221,78 @@ package body Sem_Ch12 is
-- Detection of Instantiation Circularities -- -- Detection of Instantiation Circularities --
---------------------------------------------- ----------------------------------------------
-- If we have a chain of instantiations that is circular, this is a -- If we have a chain of instantiations that is circular, this is static
-- static error which must be detected at compile time. The detection -- error which must be detected at compile time. The detection of these
-- of these circularities is carried out at the point that we insert -- circularities is carried out at the point that we insert a generic
-- a generic instance spec or body. If there is a circularity, then -- instance spec or body. If there is a circularity, then the analysis of
-- the analysis of the offending spec or body will eventually result -- the offending spec or body will eventually result in trying to load the
-- in trying to load the same unit again, and we detect this problem -- same unit again, and we detect this problem as we analyze the package
-- as we analyze the package instantiation for the second time. -- instantiation for the second time.
-- At least in some cases after we have detected the circularity, we -- At least in some cases after we have detected the circularity, we get
-- get into trouble if we try to keep going. The following flag is -- into trouble if we try to keep going. The following flag is set if a
-- set if a circularity is detected, and used to abandon compilation -- circularity is detected, and used to abandon compilation after the
-- after the messages have been posted. -- messages have been posted.
Circularity_Detected : Boolean := False; Circularity_Detected : Boolean := False;
-- This should really be reset on encountering a new main unit, but in -- This should really be reset on encountering a new main unit, but in
-- practice we are not using multiple main units so it is not critical. -- practice we are not using multiple main units so it is not critical.
-------------------------------------------------
-- Formal packages and partial parametrization --
-------------------------------------------------
-- When compiling a generic, a formal package is a local instantiation. If
-- declared with a box, its generic formals are visible in the enclosing
-- generic. If declared with a partial list of actuals, those actuals that
-- are defaulted (covered by an Others clause, or given an explicit box
-- initialization) are also visible in the enclosing generic, while those
-- that have a corresponding actual are not.
-- In our source model of instantiation, the same visibility must be
-- present in the spec and body of an instance: the names of the formals
-- that are defaulted must be made visible within the instance, and made
-- invisible (hidden) after the instantiation is complete, so that they
-- are not accessible outside of the instance.
-- In a generic, a formal package is treated like a special instantiation.
-- Our Ada95 compiler handled formals with and without box in different
-- ways. With partial parametrization, we use a single model for both.
-- We create a package declaration that consists of the specification of
-- the generic package, and a set of declarations that map the actuals
-- into local renamings, just as we do for bona fide instantiations. For
-- defaulted parameters and formals with a box, we copy directly the
-- declarations of the formal into this local package. The result is a
-- a package whose visible declarations may include generic formals. This
-- package is only used for type checking and visibility analysis, and
-- never reaches the back-end, so it can freely violate the placement
-- rules for generic formal declarations.
-- The list of declarations (renamings and copies of formals) is built
-- by Analyze_Associations, just as for regular instantiations.
-- At the point of instantiation, conformance checking must be applied only
-- to those parameters that were specified in the formal. We perform this
-- checking by creating another internal instantiation, this one including
-- only the renamings and the formals (the rest of the package spec is not
-- relevant to conformance checking). We can then traverse two lists: the
-- list of actuals in the instance that corresponds to the formal package,
-- and the list of actuals produced for this bogus instantiation. We apply
-- the conformance rules to those actuals that are not defaulted (i.e.
-- which still appear as generic formals.
-- When we compile an instance body we must make the right parameters
-- visible again. The predicate Is_Generic_Formal indicates which of the
-- formals should have its Is_Hidden flag reset.
----------------------- -----------------------
-- Local subprograms -- -- Local subprograms --
----------------------- -----------------------
procedure Abandon_Instantiation (N : Node_Id); procedure Abandon_Instantiation (N : Node_Id);
pragma No_Return (Abandon_Instantiation); pragma No_Return (Abandon_Instantiation);
-- Posts an error message "instantiation abandoned" at the indicated -- Posts an error message "instantiation abandoned" at the indicated node
-- node and then raises the exception Instantiation_Error to do it. -- and then raises the exception Instantiation_Error to do it.
procedure Analyze_Formal_Array_Type procedure Analyze_Formal_Array_Type
(T : in out Entity_Id; (T : in out Entity_Id;
...@@ -286,12 +333,12 @@ package body Sem_Ch12 is ...@@ -286,12 +333,12 @@ package body Sem_Ch12 is
(N : Node_Id; (N : Node_Id;
T : Entity_Id; T : Entity_Id;
Def : Node_Id); Def : Node_Id);
-- This needs comments??? -- Creates a new private type, which does not require completion
procedure Analyze_Generic_Formal_Part (N : Node_Id); procedure Analyze_Generic_Formal_Part (N : Node_Id);
procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
-- This needs comments ??? -- Create a new access type with the given designated type
function Analyze_Associations function Analyze_Associations
(I_Node : Node_Id; (I_Node : Node_Id;
...@@ -321,6 +368,10 @@ package body Sem_Ch12 is ...@@ -321,6 +368,10 @@ package body Sem_Ch12 is
-- nodes or subprogram body and declaration nodes depending on the case). -- nodes or subprogram body and declaration nodes depending on the case).
-- On return, the node N has been rewritten with the actual body. -- On return, the node N has been rewritten with the actual body.
procedure Check_Access_Definition (N : Node_Id);
-- Subsidiary routine to null exclusion processing. Perform an assertion
-- check on Ada version and the presence of an access definition in N.
procedure Check_Formal_Packages (P_Id : Entity_Id); procedure Check_Formal_Packages (P_Id : Entity_Id);
-- Apply the following to all formal packages in generic associations -- Apply the following to all formal packages in generic associations
...@@ -345,16 +396,6 @@ package body Sem_Ch12 is ...@@ -345,16 +396,6 @@ package body Sem_Ch12 is
-- instance, we need to make an explicit test that it is not hidden by -- instance, we need to make an explicit test that it is not hidden by
-- a child instance of the same name and parent. -- a child instance of the same name and parent.
procedure Check_Private_View (N : Node_Id);
-- Check whether the type of a generic entity has a different view between
-- the point of generic analysis and the point of instantiation. If the
-- view has changed, then at the point of instantiation we restore the
-- correct view to perform semantic analysis of the instance, and reset
-- the current view after instantiation. The processing is driven by the
-- current private status of the type of the node, and Has_Private_View,
-- a flag that is set at the point of generic compilation. If view and
-- flag are inconsistent then the type is updated appropriately.
procedure Check_Generic_Actuals procedure Check_Generic_Actuals
(Instance : Entity_Id; (Instance : Entity_Id;
Is_Formal_Box : Boolean); Is_Formal_Box : Boolean);
...@@ -393,8 +434,14 @@ package body Sem_Ch12 is ...@@ -393,8 +434,14 @@ package body Sem_Ch12 is
-- When validating the actual types of a child instance, check whether -- When validating the actual types of a child instance, check whether
-- the formal is a formal type of the parent unit, and retrieve the current -- the formal is a formal type of the parent unit, and retrieve the current
-- actual for it. Typ is the entity in the analyzed formal type declaration -- actual for it. Typ is the entity in the analyzed formal type declaration
-- (component or index type of an array type) and Gen_Scope is the scope of -- (component or index type of an array type, or designated type of an
-- the analyzed formal array type. -- access formal) and Gen_Scope is the scope of the analyzed formal array
-- or access type. The desired actual may be a formal of a parent, or may
-- be declared in a formal package of a parent. In both cases it is a
-- generic actual type because it appears within a visible instance.
-- Ambiguities may still arise if two homonyms are declared in two formal
-- packages, and the prefix of the formal type may be needed to resolve
-- the ambiguity in the instance ???
function In_Same_Declarative_Part function In_Same_Declarative_Part
(F_Node : Node_Id; (F_Node : Node_Id;
...@@ -410,6 +457,12 @@ package body Sem_Ch12 is ...@@ -410,6 +457,12 @@ package body Sem_Ch12 is
-- Used to determine whether its body should be elaborated to allow -- Used to determine whether its body should be elaborated to allow
-- front-end inlining. -- front-end inlining.
function Is_Generic_Formal (E : Entity_Id) return Boolean;
-- Utility to determine whether a given entity is declared by means of
-- of a formal parameter declaration. Used to set properly the visiblity
-- of generic formals of a generic package declared with a box or with
-- partial parametrization.
procedure Set_Instance_Env procedure Set_Instance_Env
(Gen_Unit : Entity_Id; (Gen_Unit : Entity_Id;
Act_Unit : Entity_Id); Act_Unit : Entity_Id);
...@@ -531,6 +584,15 @@ package body Sem_Ch12 is ...@@ -531,6 +584,15 @@ package body Sem_Ch12 is
-- apply these rules is to repeat the instantiation of the formal package -- apply these rules is to repeat the instantiation of the formal package
-- in the context of the enclosing instance, and compare the generic -- in the context of the enclosing instance, and compare the generic
-- associations of this instantiation with those of the actual package. -- associations of this instantiation with those of the actual package.
-- This internal instantiation only needs to contain the renamings of the
-- formals: the visible and private declarations themselves need not be
-- created.
-- In Ada2005, the formal package may be only partially parametrized. In
-- that case the visibility step must make visible those actuals whose
-- corresponding formals were given with a box. A final complication
-- involves inherited operations from formal derived types, which must be
-- visible if the type is.
function Is_In_Main_Unit (N : Node_Id) return Boolean; function Is_In_Main_Unit (N : Node_Id) return Boolean;
-- Test if given node is in the main unit -- Test if given node is in the main unit
...@@ -768,7 +830,7 @@ package body Sem_Ch12 is ...@@ -768,7 +830,7 @@ package body Sem_Ch12 is
procedure Abandon_Instantiation (N : Node_Id) is procedure Abandon_Instantiation (N : Node_Id) is
begin begin
Error_Msg_N ("instantiation abandoned!", N); Error_Msg_N ("\instantiation abandoned!", N);
raise Instantiation_Error; raise Instantiation_Error;
end Abandon_Instantiation; end Abandon_Instantiation;
...@@ -783,7 +845,7 @@ package body Sem_Ch12 is ...@@ -783,7 +845,7 @@ package body Sem_Ch12 is
is is
Actual_Types : constant Elist_Id := New_Elmt_List; Actual_Types : constant Elist_Id := New_Elmt_List;
Assoc : constant List_Id := New_List; Assoc : constant List_Id := New_List;
Defaults : constant Elist_Id := New_Elmt_List; Default_Actuals : constant Elist_Id := New_Elmt_List;
Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy)); Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy));
Actuals : List_Id; Actuals : List_Id;
Actual : Node_Id; Actual : Node_Id;
...@@ -794,11 +856,26 @@ package body Sem_Ch12 is ...@@ -794,11 +856,26 @@ package body Sem_Ch12 is
Match : Node_Id; Match : Node_Id;
Named : Node_Id; Named : Node_Id;
First_Named : Node_Id := Empty; First_Named : Node_Id := Empty;
Default_Formals : constant List_Id := New_List;
-- If an Other_Choice is present, some of the formals may be defaulted.
-- To simplify the treatement of visibility in an instance, we introduce
-- individual defaults for each such formal. These defaults are
-- appended to the list of associations and replace the Others_Choice.
Found_Assoc : Node_Id; Found_Assoc : Node_Id;
-- Association for the current formal being match. Empty if there are
-- no remaining actuals, or if there is no named association with the
-- name of the formal.
Is_Named_Assoc : Boolean; Is_Named_Assoc : Boolean;
Num_Matched : Int := 0; Num_Matched : Int := 0;
Num_Actuals : Int := 0; Num_Actuals : Int := 0;
Others_Present : Boolean := False;
-- In Ada 2005, indicates partial parametrization of of a formal
-- package. As usual an others association must be last in the list.
function Matching_Actual function Matching_Actual
(F : Entity_Id; (F : Entity_Id;
A_F : Entity_Id) return Node_Id; A_F : Entity_Id) return Node_Id;
...@@ -808,6 +885,21 @@ package body Sem_Ch12 is ...@@ -808,6 +885,21 @@ package body Sem_Ch12 is
-- A_F is the corresponding entity in the analyzed generic,which is -- A_F is the corresponding entity in the analyzed generic,which is
-- placed on the selector name for ASIS use. -- placed on the selector name for ASIS use.
-- In Ada 2005, a named association may be given with a box, in which
-- case Matching_Actual sets Found_Assoc to the generic association,
-- but return Empty for the actual itself. In this case the code below
-- creates a corresponding declaration for the formal.
function Partial_Parametrization return Boolean;
-- Ada 2005: if no match is found for a given formal, check if the
-- association for it includes a box, or whether the associations
-- include an Others clause.
procedure Process_Default (F : Entity_Id);
-- Add a copy of the declaration of generic formal F to the list of
-- associations, and add an explicit box association for F if there
-- is none yet, and the default comes from an Others_Choice.
procedure Set_Analyzed_Formal; procedure Set_Analyzed_Formal;
-- Find the node in the generic copy that corresponds to a given formal. -- Find the node in the generic copy that corresponds to a given formal.
-- The semantic information on this node is used to perform legality -- The semantic information on this node is used to perform legality
...@@ -825,8 +917,8 @@ package body Sem_Ch12 is ...@@ -825,8 +917,8 @@ package body Sem_Ch12 is
(F : Entity_Id; (F : Entity_Id;
A_F : Entity_Id) return Node_Id A_F : Entity_Id) return Node_Id
is is
Found : Node_Id;
Prev : Node_Id; Prev : Node_Id;
Act : Node_Id;
begin begin
Is_Named_Assoc := False; Is_Named_Assoc := False;
...@@ -834,13 +926,14 @@ package body Sem_Ch12 is ...@@ -834,13 +926,14 @@ package body Sem_Ch12 is
-- End of list of purely positional parameters -- End of list of purely positional parameters
if No (Actual) then if No (Actual) then
Found := Empty; Found_Assoc := Empty;
Act := Empty;
-- Case of positional parameter corresponding to current formal -- Case of positional parameter corresponding to current formal
elsif No (Selector_Name (Actual)) then elsif No (Selector_Name (Actual)) then
Found := Explicit_Generic_Actual_Parameter (Actual);
Found_Assoc := Actual; Found_Assoc := Actual;
Act := Explicit_Generic_Actual_Parameter (Actual);
Num_Matched := Num_Matched + 1; Num_Matched := Num_Matched + 1;
Next (Actual); Next (Actual);
...@@ -849,16 +942,17 @@ package body Sem_Ch12 is ...@@ -849,16 +942,17 @@ package body Sem_Ch12 is
else else
Is_Named_Assoc := True; Is_Named_Assoc := True;
Found := Empty; Found_Assoc := Empty;
Act := Empty;
Prev := Empty; Prev := Empty;
while Present (Actual) loop while Present (Actual) loop
if Chars (Selector_Name (Actual)) = Chars (F) then if Chars (Selector_Name (Actual)) = Chars (F) then
Found := Explicit_Generic_Actual_Parameter (Actual);
Set_Entity (Selector_Name (Actual), A_F); Set_Entity (Selector_Name (Actual), A_F);
Set_Etype (Selector_Name (Actual), Etype (A_F)); Set_Etype (Selector_Name (Actual), Etype (A_F));
Generate_Reference (A_F, Selector_Name (Actual)); Generate_Reference (A_F, Selector_Name (Actual));
Found_Assoc := Actual; Found_Assoc := Actual;
Act := Explicit_Generic_Actual_Parameter (Actual);
Num_Matched := Num_Matched + 1; Num_Matched := Num_Matched + 1;
exit; exit;
end if; end if;
...@@ -885,9 +979,41 @@ package body Sem_Ch12 is ...@@ -885,9 +979,41 @@ package body Sem_Ch12 is
Actual := First_Named; Actual := First_Named;
end if; end if;
return Found; return Act;
end Matching_Actual; end Matching_Actual;
-----------------------------
-- Partial_Parametrization --
-----------------------------
function Partial_Parametrization return Boolean is
begin
return Others_Present
or else (Present (Found_Assoc) and then Box_Present (Found_Assoc));
end Partial_Parametrization;
---------------------
-- Process_Default --
---------------------
procedure Process_Default (F : Entity_Id) is
Loc : constant Source_Ptr := Sloc (I_Node);
Default : Node_Id;
begin
Append (Copy_Generic_Node (F, Empty, True), Assoc);
if No (Found_Assoc) then
Default :=
Make_Generic_Association (Loc,
Selector_Name =>
New_Occurrence_Of (Defining_Identifier (F), Loc),
Explicit_Generic_Actual_Parameter => Empty);
Set_Box_Present (Default);
Append (Default, Default_Formals);
end if;
end Process_Default;
------------------------- -------------------------
-- Set_Analyzed_Formal -- -- Set_Analyzed_Formal --
------------------------- -------------------------
...@@ -912,7 +1038,9 @@ package body Sem_Ch12 is ...@@ -912,7 +1038,9 @@ package body Sem_Ch12 is
exit when exit when
Kind = N_Formal_Package_Declaration Kind = N_Formal_Package_Declaration
or else or else
Kind = N_Generic_Package_Declaration; Kind = N_Generic_Package_Declaration
or else
Kind = N_Package_Declaration;
when N_Use_Package_Clause | N_Use_Type_Clause => exit; when N_Use_Package_Clause | N_Use_Type_Clause => exit;
...@@ -933,20 +1061,37 @@ package body Sem_Ch12 is ...@@ -933,20 +1061,37 @@ package body Sem_Ch12 is
Next (Analyzed_Formal); Next (Analyzed_Formal);
end loop; end loop;
end Set_Analyzed_Formal; end Set_Analyzed_Formal;
-- Start of processing for Analyze_Associations -- Start of processing for Analyze_Associations
begin begin
-- If named associations are present, save the first named association
-- (it may of course be Empty) to facilitate subsequent name search.
Actuals := Generic_Associations (I_Node); Actuals := Generic_Associations (I_Node);
if Present (Actuals) then if Present (Actuals) then
First_Named := First (Actuals);
-- check for an Others choice, indicating a partial parametrization
-- for a formal package.
Actual := First (Actuals);
while Present (Actual) loop
if Nkind (Actual) = N_Others_Choice then
Others_Present := True;
if Present (Next (Actual)) then
Error_Msg_N ("others must be last association", Actual);
end if;
Remove (Actual);
exit;
end if;
Next (Actual);
end loop;
-- If named associations are present, save first named association
-- (it may of course be Empty) to facilitate subsequent name search.
First_Named := First (Actuals);
while Present (First_Named) while Present (First_Named)
and then No (Selector_Name (First_Named)) and then No (Selector_Name (First_Named))
loop loop
...@@ -997,9 +1142,13 @@ package body Sem_Ch12 is ...@@ -997,9 +1142,13 @@ package body Sem_Ch12 is
Defining_Identifier (Formal), Defining_Identifier (Formal),
Defining_Identifier (Analyzed_Formal)); Defining_Identifier (Analyzed_Formal));
if No (Match) and then Partial_Parametrization then
Process_Default (Formal);
else
Append_List Append_List
(Instantiate_Object (Formal, Match, Analyzed_Formal), (Instantiate_Object (Formal, Match, Analyzed_Formal),
Assoc); Assoc);
end if;
when N_Formal_Type_Declaration => when N_Formal_Type_Declaration =>
Match := Match :=
...@@ -1008,13 +1157,19 @@ package body Sem_Ch12 is ...@@ -1008,13 +1157,19 @@ package body Sem_Ch12 is
Defining_Identifier (Analyzed_Formal)); Defining_Identifier (Analyzed_Formal));
if No (Match) then if No (Match) then
if Partial_Parametrization then
Process_Default (Formal);
else
Error_Msg_Sloc := Sloc (Gen_Unit); Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE Error_Msg_NE
("missing actual&", ("missing actual&",
Instantiation_Node, Defining_Identifier (Formal)); Instantiation_Node,
Defining_Identifier (Formal));
Error_Msg_NE ("\in instantiation of & declared#", Error_Msg_NE ("\in instantiation of & declared#",
Instantiation_Node, Gen_Unit); Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node); Abandon_Instantiation (Instantiation_Node);
end if;
else else
Analyze (Match); Analyze (Match);
...@@ -1082,12 +1237,15 @@ package body Sem_Ch12 is ...@@ -1082,12 +1237,15 @@ package body Sem_Ch12 is
Instantiate_Formal_Subprogram Instantiate_Formal_Subprogram
(Formal, Match, Analyzed_Formal)); (Formal, Match, Analyzed_Formal));
if No (Match) if No (Match) then
and then Box_Present (Formal) if Partial_Parametrization then
then Process_Default (Formal);
elsif Box_Present (Formal) then
Append_Elmt Append_Elmt
(Defining_Unit_Name (Specification (Last (Assoc))), (Defining_Unit_Name (Specification (Last (Assoc))),
Defaults); Default_Actuals);
end if;
end if; end if;
when N_Formal_Package_Declaration => when N_Formal_Package_Declaration =>
...@@ -1097,6 +1255,10 @@ package body Sem_Ch12 is ...@@ -1097,6 +1255,10 @@ package body Sem_Ch12 is
Defining_Identifier (Original_Node (Analyzed_Formal))); Defining_Identifier (Original_Node (Analyzed_Formal)));
if No (Match) then if No (Match) then
if Partial_Parametrization then
Process_Default (Formal);
else
Error_Msg_Sloc := Sloc (Gen_Unit); Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE Error_Msg_NE
("missing actual&", ("missing actual&",
...@@ -1105,6 +1267,7 @@ package body Sem_Ch12 is ...@@ -1105,6 +1267,7 @@ package body Sem_Ch12 is
Instantiation_Node, Gen_Unit); Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node); Abandon_Instantiation (Instantiation_Node);
end if;
else else
Analyze (Match); Analyze (Match);
...@@ -1114,15 +1277,21 @@ package body Sem_Ch12 is ...@@ -1114,15 +1277,21 @@ package body Sem_Ch12 is
Assoc); Assoc);
end if; end if;
-- For use type and use package appearing in the context -- For use type and use package appearing in the generic
-- clause, we have already copied them, so we can just -- part, we have already copied them, so we can just
-- move them where they belong (we mustn't recopy them -- move them where they belong (we mustn't recopy them
-- since this would mess up the Sloc values). -- since this would mess up the Sloc values).
when N_Use_Package_Clause | when N_Use_Package_Clause |
N_Use_Type_Clause => N_Use_Type_Clause =>
if Nkind (Original_Node (I_Node)) =
N_Formal_Package_Declaration
then
Append (New_Copy_Tree (Formal), Assoc);
else
Remove (Formal); Remove (Formal);
Append (Formal, Assoc); Append (Formal, Assoc);
end if;
when others => when others =>
raise Program_Error; raise Program_Error;
...@@ -1174,7 +1343,7 @@ package body Sem_Ch12 is ...@@ -1174,7 +1343,7 @@ package body Sem_Ch12 is
New_D : Node_Id; New_D : Node_Id;
begin begin
Elmt := First_Elmt (Defaults); Elmt := First_Elmt (Default_Actuals);
while Present (Elmt) loop while Present (Elmt) loop
if No (Actuals) then if No (Actuals) then
Actuals := New_List; Actuals := New_List;
...@@ -1193,6 +1362,14 @@ package body Sem_Ch12 is ...@@ -1193,6 +1362,14 @@ package body Sem_Ch12 is
end loop; end loop;
end; end;
-- If this is a formal package. normalize the parameter list by
-- adding explicit box asssociations for the formals that are covered
-- by an Others_Choice.
if not Is_Empty_List (Default_Formals) then
Append_List (Default_Formals, Formals);
end if;
return Assoc; return Assoc;
end Analyze_Associations; end Analyze_Associations;
...@@ -1314,6 +1491,8 @@ package body Sem_Ch12 is ...@@ -1314,6 +1491,8 @@ package body Sem_Ch12 is
(T : Entity_Id; (T : Entity_Id;
Def : Node_Id) Def : Node_Id)
is is
Ifaces_List : Elist_Id;
begin begin
Enter_Name (T); Enter_Name (T);
Set_Ekind (T, E_Record_Type); Set_Ekind (T, E_Record_Type);
...@@ -1321,9 +1500,17 @@ package body Sem_Ch12 is ...@@ -1321,9 +1500,17 @@ package body Sem_Ch12 is
Analyze (Subtype_Indication (Def)); Analyze (Subtype_Indication (Def));
Analyze_Interface_Declaration (T, Def); Analyze_Interface_Declaration (T, Def);
Make_Class_Wide_Type (T); Make_Class_Wide_Type (T);
Set_Primitive_Operations (T, New_Elmt_List);
Analyze_List (Interface_List (Def)); Analyze_List (Interface_List (Def));
Collect_Interfaces (Def, T);
-- 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);
end Analyze_Formal_Derived_Interface_Type; end Analyze_Formal_Derived_Interface_Type;
--------------------------------- ---------------------------------
...@@ -1348,10 +1535,12 @@ package body Sem_Ch12 is ...@@ -1348,10 +1535,12 @@ package body Sem_Ch12 is
Defining_Identifier => T, Defining_Identifier => T,
Discriminant_Specifications => Discriminant_Specifications (N), Discriminant_Specifications => Discriminant_Specifications (N),
Unknown_Discriminants_Present => Unk_Disc, Unknown_Discriminants_Present => Unk_Disc,
Subtype_Indication => Subtype_Mark (Def)); Subtype_Indication => Subtype_Mark (Def),
Interface_List => Interface_List (Def));
Set_Abstract_Present (New_N, Abstract_Present (Def)); Set_Abstract_Present (New_N, Abstract_Present (Def));
Set_Limited_Present (New_N, Limited_Present (Def)); Set_Limited_Present (New_N, Limited_Present (Def));
Set_Synchronized_Present (New_N, Synchronized_Present (Def));
else else
New_N := New_N :=
...@@ -1516,7 +1705,7 @@ package body Sem_Ch12 is ...@@ -1516,7 +1705,7 @@ package body Sem_Ch12 is
--------------------------------------- ---------------------------------------
procedure Analyze_Formal_Object_Declaration (N : Node_Id) is procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
E : constant Node_Id := Expression (N); E : constant Node_Id := Default_Expression (N);
Id : constant Node_Id := Defining_Identifier (N); Id : constant Node_Id := Defining_Identifier (N);
K : Entity_Kind; K : Entity_Kind;
T : Node_Id; T : Node_Id;
...@@ -1537,11 +1726,33 @@ package body Sem_Ch12 is ...@@ -1537,11 +1726,33 @@ package body Sem_Ch12 is
K := E_Generic_In_Parameter; K := E_Generic_In_Parameter;
end if; end if;
if Present (Subtype_Mark (N)) then
Find_Type (Subtype_Mark (N)); Find_Type (Subtype_Mark (N));
T := Entity (Subtype_Mark (N)); T := Entity (Subtype_Mark (N));
-- Ada 2005 (AI-423): Formal object with an access definition
else
Check_Access_Definition (N);
T := Access_Definition
(Related_Nod => N,
N => Access_Definition (N));
end if;
if Ekind (T) = E_Incomplete_Type then if Ekind (T) = E_Incomplete_Type then
Error_Msg_N ("premature usage of incomplete type", Subtype_Mark (N)); declare
Error_Node : Node_Id;
begin
if Present (Subtype_Mark (N)) then
Error_Node := Subtype_Mark (N);
else
Check_Access_Definition (N);
Error_Node := Access_Definition (N);
end if;
Error_Msg_N ("premature usage of incomplete type", Error_Node);
end;
end if; end if;
if K = E_Generic_In_Parameter then if K = E_Generic_In_Parameter then
...@@ -1666,6 +1877,110 @@ package body Sem_Ch12 is ...@@ -1666,6 +1877,110 @@ package body Sem_Ch12 is
Renaming : Node_Id; Renaming : Node_Id;
Parent_Instance : Entity_Id; Parent_Instance : Entity_Id;
Renaming_In_Par : Entity_Id; Renaming_In_Par : Entity_Id;
No_Associations : Boolean := False;
function Build_Local_Package return Node_Id;
-- The formal package is rewritten so that its parameters are replaced
-- with corresponding declarations. For parameters with bona fide
-- associations these declarations are created by Analyze_Associations
-- as for aa regular instantiation. For boxed parameters, we preserve
-- the formal declarations and analyze them, in order to introduce
-- entities of the right kind in the environment of the formal.
-------------------------
-- Build_Local_Package --
-------------------------
function Build_Local_Package return Node_Id is
Decls : List_Id;
Pack_Decl : Node_Id;
begin
-- Within the formal, the name of the generic package is a renaming
-- of the formal (as for a regular instantiation).
Pack_Decl :=
Make_Package_Declaration (Loc,
Specification =>
Copy_Generic_Node
(Specification (Original_Node (Gen_Decl)),
Empty, Instantiating => True));
Renaming := Make_Package_Renaming_Declaration (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
Name => New_Occurrence_Of (Formal, Loc));
if Nkind (Gen_Id) = N_Identifier
and then Chars (Gen_Id) = Chars (Pack_Id)
then
Error_Msg_NE
("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
end if;
-- If the formal is declared with a box, or with an others choice,
-- create corresponding declarations for all entities in the formal
-- part, so that names with the proper types are available in the
-- specification of the formal package.
if No_Associations then
declare
Formal_Decl : Node_Id;
begin
-- TBA : for a formal package, need to recurse
Decls := New_List;
Formal_Decl :=
First
(Generic_Formal_Declarations (Original_Node (Gen_Decl)));
while Present (Formal_Decl) loop
Append_To
(Decls, Copy_Generic_Node (Formal_Decl, Empty, True));
Next (Formal_Decl);
end loop;
end;
-- If generic associations are present, use Analyze_Associations to
-- create the proper renaming declarations.
else
declare
Act_Tree : constant Node_Id :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty,
Instantiating => True);
begin
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
Instantiation_Node := N;
Decls :=
Analyze_Associations
(Original_Node (N),
Generic_Formal_Declarations (Act_Tree),
Generic_Formal_Declarations (Gen_Decl));
end;
end if;
Append (Renaming, To => Decls);
-- Add generated declarations ahead of local declarations in
-- the package.
if No (Visible_Declarations (Specification (Pack_Decl))) then
Set_Visible_Declarations (Specification (Pack_Decl), Decls);
else
Insert_List_Before
(First (Visible_Declarations (Specification (Pack_Decl))),
Decls);
end if;
return Pack_Decl;
end Build_Local_Package;
-- Start of processing for Analyze_Formal_Package
begin begin
Text_IO_Kludge (Gen_Id); Text_IO_Kludge (Gen_Id);
...@@ -1714,18 +2029,13 @@ package body Sem_Ch12 is ...@@ -1714,18 +2029,13 @@ package body Sem_Ch12 is
end if; end if;
end if; end if;
-- The formal package is treated like a regular instance, but only if Box_Present (N)
-- the specification needs to be instantiated, to make entities visible. or else No (Generic_Associations (N))
or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
if not Box_Present (N) then then
Hidden_Entities := New_Elmt_List; No_Associations := True;
Analyze_Package_Instantiation (N);
if Parent_Installed then
Remove_Parent;
end if; end if;
else
-- If there are no generic associations, the generic parameters -- If there are no generic associations, the generic parameters
-- appear as local entities and are instantiated like them. We copy -- appear as local entities and are instantiated like them. We copy
-- the generic package declaration as if it were an instantiation, -- the generic package declaration as if it were an instantiation,
...@@ -1742,34 +2052,22 @@ package body Sem_Ch12 is ...@@ -1742,34 +2052,22 @@ package body Sem_Ch12 is
Formal := New_Copy (Pack_Id); Formal := New_Copy (Pack_Id);
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
New_N := -- Make local generic without formals. The formals will be replaced
Copy_Generic_Node -- with internal declarations..
(Original_Node (Gen_Decl), Empty, Instantiating => True);
New_N := Build_Local_Package;
Rewrite (N, New_N); Rewrite (N, New_N);
Set_Defining_Unit_Name (Specification (New_N), Formal); Set_Defining_Unit_Name (Specification (New_N), Formal);
Set_Generic_Parent (Specification (N), Gen_Unit); Set_Generic_Parent (Specification (N), Gen_Unit);
Set_Instance_Env (Gen_Unit, Formal); Set_Instance_Env (Gen_Unit, Formal);
Set_Is_Generic_Instance (Formal);
Enter_Name (Formal); Enter_Name (Formal);
Set_Ekind (Formal, E_Generic_Package); Set_Ekind (Formal, E_Package);
Set_Etype (Formal, Standard_Void_Type); Set_Etype (Formal, Standard_Void_Type);
Set_Inner_Instances (Formal, New_Elmt_List); Set_Inner_Instances (Formal, New_Elmt_List);
New_Scope (Formal); New_Scope (Formal);
-- Within the formal, the name of the generic package is a renaming
-- of the formal (as for a regular instantiation).
Renaming := Make_Package_Renaming_Declaration (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
Name => New_Reference_To (Formal, Loc));
if Present (Visible_Declarations (Specification (N))) then
Prepend (Renaming, To => Visible_Declarations (Specification (N)));
elsif Present (Private_Declarations (Specification (N))) then
Prepend (Renaming, To => Private_Declarations (Specification (N)));
end if;
if Is_Child_Unit (Gen_Unit) if Is_Child_Unit (Gen_Unit)
and then Parent_Installed and then Parent_Installed
then then
...@@ -1790,8 +2088,31 @@ package body Sem_Ch12 is ...@@ -1790,8 +2088,31 @@ package body Sem_Ch12 is
Append_Entity (Renaming_In_Par, Parent_Instance); Append_Entity (Renaming_In_Par, Parent_Instance);
end if; end if;
Analyze_Generic_Formal_Part (N);
Analyze (Specification (N)); Analyze (Specification (N));
-- The formals for which associations are provided are not visible
-- outside of the formal package. The others are still declared by
-- a formal parameter declaration.
if not No_Associations then
declare
E : Entity_Id;
begin
E := First_Entity (Formal);
while Present (E) loop
exit when Ekind (E) = E_Package
and then Renamed_Entity (E) = Formal;
if not Is_Generic_Formal (E) then
Set_Is_Hidden (E);
end if;
Next_Entity (E);
end loop;
end;
end if;
End_Package_Scope (Formal); End_Package_Scope (Formal);
if Parent_Installed then if Parent_Installed then
...@@ -1807,14 +2128,15 @@ package body Sem_Ch12 is ...@@ -1807,14 +2128,15 @@ package body Sem_Ch12 is
-- A generic formal package is an instance, and can be used as -- A generic formal package is an instance, and can be used as
-- an actual for an inner instance. -- an actual for an inner instance.
Set_Ekind (Formal, E_Package);
Set_Has_Completion (Formal, True); Set_Has_Completion (Formal, True);
-- Add semantic information to the original defining identifier.
-- for ASIS use.
Set_Ekind (Pack_Id, E_Package); Set_Ekind (Pack_Id, E_Package);
Set_Etype (Pack_Id, Standard_Void_Type); Set_Etype (Pack_Id, Standard_Void_Type);
Set_Scope (Pack_Id, Scope (Formal)); Set_Scope (Pack_Id, Scope (Formal));
Set_Has_Completion (Pack_Id, True); Set_Has_Completion (Pack_Id, True);
end if;
end Analyze_Formal_Package; end Analyze_Formal_Package;
--------------------------------- ---------------------------------
...@@ -2374,10 +2696,6 @@ package body Sem_Ch12 is ...@@ -2374,10 +2696,6 @@ package body Sem_Ch12 is
-- Analyze_Package_Instantiation -- -- Analyze_Package_Instantiation --
----------------------------------- -----------------------------------
-- Note: this procedure is also used for formal package declarations, in
-- which case the argument N is an N_Formal_Package_Declaration node.
-- This should really be noted in the spec! ???
procedure Analyze_Package_Instantiation (N : Node_Id) is procedure Analyze_Package_Instantiation (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Gen_Id : constant Node_Id := Name (N); Gen_Id : constant Node_Id := Name (N);
...@@ -2925,9 +3243,6 @@ package body Sem_Ch12 is ...@@ -2925,9 +3243,6 @@ package body Sem_Ch12 is
end if; end if;
end if; end if;
-- There is a problem with inlining here
-- More comments needed??? what problem
Set_Unit (Parent (N), Act_Decl); Set_Unit (Parent (N), Act_Decl);
Set_Parent_Spec (Act_Decl, Parent_Spec (N)); Set_Parent_Spec (Act_Decl, Parent_Spec (N));
Set_Package_Instantiation (Act_Decl_Id, N); Set_Package_Instantiation (Act_Decl_Id, N);
...@@ -3852,6 +4167,18 @@ package body Sem_Ch12 is ...@@ -3852,6 +4167,18 @@ package body Sem_Ch12 is
Build_Elaboration_Entity (Decl_Cunit, New_Main); Build_Elaboration_Entity (Decl_Cunit, New_Main);
end Build_Instance_Compilation_Unit_Nodes; end Build_Instance_Compilation_Unit_Nodes;
-----------------------------
-- Check_Access_Definition --
-----------------------------
procedure Check_Access_Definition (N : Node_Id) is
begin
pragma Assert
(Ada_Version >= Ada_05
and then Present (Access_Definition (N)));
null;
end Check_Access_Definition;
----------------------------------- -----------------------------------
-- Check_Formal_Package_Instance -- -- Check_Formal_Package_Instance --
----------------------------------- -----------------------------------
...@@ -3892,8 +4219,19 @@ package body Sem_Ch12 is ...@@ -3892,8 +4219,19 @@ package body Sem_Ch12 is
-------------------- --------------------
procedure Check_Mismatch (B : Boolean) is procedure Check_Mismatch (B : Boolean) is
Kind : constant Node_Kind := Nkind (Parent (E2));
begin begin
if B then if Kind = N_Formal_Type_Declaration then
return;
elsif Kind = N_Formal_Object_Declaration
or else Kind in N_Formal_Subprogram_Declaration
or else Kind = N_Formal_Package_Declaration
then
null;
elsif B then
Error_Msg_NE Error_Msg_NE
("actual for & in actual instance does not match formal", ("actual for & in actual instance does not match formal",
Parent (Actual_Pack), E1); Parent (Actual_Pack), E1);
...@@ -3990,6 +4328,9 @@ package body Sem_Ch12 is ...@@ -3990,6 +4328,9 @@ package body Sem_Ch12 is
-- Itypes generated for other parameters need not be checked, -- Itypes generated for other parameters need not be checked,
-- the check will be performed on the parameters themselves. -- the check will be performed on the parameters themselves.
-- If E2 is a formal type declaration, it is a defaulted
-- parameter and needs no checking.
if not Is_Itype (E1) if not Is_Itype (E1)
and then not Is_Itype (E2) and then not Is_Itype (E2)
then then
...@@ -4086,7 +4427,8 @@ package body Sem_Ch12 is ...@@ -4086,7 +4427,8 @@ package body Sem_Ch12 is
elsif Is_Overloadable (E1) then elsif Is_Overloadable (E1) then
-- Verify that the names of the entities match. -- Verify that the names of the entities match.
-- What if actual is an attribute ??? -- Note that actuals that are attributes are rewritten
-- as subprograms.
Check_Mismatch Check_Mismatch
(Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
...@@ -4128,6 +4470,12 @@ package body Sem_Ch12 is ...@@ -4128,6 +4470,12 @@ package body Sem_Ch12 is
elsif not Box_Present (Parent (Associated_Formal_Package (E))) then elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
Formal_P := Next_Entity (E); Formal_P := Next_Entity (E);
Check_Formal_Package_Instance (Formal_P, E); Check_Formal_Package_Instance (Formal_P, E);
-- After checking, remove the internal validating package. It
-- is only needed for semantic checks, and as it may contain
-- generic formal declarations it should not reach gigi.
Remove (Unit_Declaration_Node (Formal_P));
end if; end if;
end if; end if;
...@@ -4287,9 +4635,14 @@ package body Sem_Ch12 is ...@@ -4287,9 +4635,14 @@ package body Sem_Ch12 is
elsif Denotes_Formal_Package (E) then elsif Denotes_Formal_Package (E) then
null; null;
elsif Present (Associated_Formal_Package (E)) then elsif Present (Associated_Formal_Package (E))
and then not Is_Generic_Formal (E)
then
if Box_Present (Parent (Associated_Formal_Package (E))) then if Box_Present (Parent (Associated_Formal_Package (E))) then
Check_Generic_Actuals (Renamed_Object (E), True); Check_Generic_Actuals (Renamed_Object (E), True);
else
Check_Generic_Actuals (Renamed_Object (E), False);
end if; end if;
Set_Is_Hidden (E, False); Set_Is_Hidden (E, False);
...@@ -4301,8 +4654,13 @@ package body Sem_Ch12 is ...@@ -4301,8 +4654,13 @@ package body Sem_Ch12 is
elsif Is_Wrapper_Package (Instance) then elsif Is_Wrapper_Package (Instance) then
Set_Is_Hidden (E, False); Set_Is_Hidden (E, False);
else -- If the formal package is declared with a box, or if the formal
Set_Is_Hidden (E, not Is_Formal_Box); -- parameter is defaulted, it is visible in the body.
elsif Is_Formal_Box
or else Is_Visible_Formal (E)
then
Set_Is_Hidden (E, False);
end if; end if;
Next_Entity (E); Next_Entity (E);
...@@ -4743,15 +5101,21 @@ package body Sem_Ch12 is ...@@ -4743,15 +5101,21 @@ package body Sem_Ch12 is
then then
Switch_View (T); Switch_View (T);
-- Finally, a non-private subtype may have a private base type, -- Finally, a non-private subtype may have a private base type, which
-- which must be exchanged for consistency. This can happen when -- must be exchanged for consistency. This can happen when
-- instantiating a package body, when the scope stack is empty -- instantiating a package body, when the scope stack is empty but in
-- but in fact the subtype and the base type are declared in an -- fact the subtype and the base type are declared in an enclosing
-- enclosing scope. -- 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
-- private dependent subtypes of BT which remain unswitched. Such
-- subtypes might need to be switched at a later point (see specific
-- provision for that case in Switch_View).
elsif not Is_Private_Type (T) elsif not Is_Private_Type (T)
and then not Has_Private_View (N) and then not Has_Private_View (N)
and then Is_Private_Type (Base_Type (T)) and then Is_Private_Type (BT)
and then Present (Full_View (BT)) and then Present (Full_View (BT))
and then not Is_Generic_Type (BT) and then not Is_Generic_Type (BT)
and then not In_Open_Scopes (BT) and then not In_Open_Scopes (BT)
...@@ -5465,7 +5829,9 @@ package body Sem_Ch12 is ...@@ -5465,7 +5829,9 @@ package body Sem_Ch12 is
then then
return True; return True;
elsif Nkind (Parent (Pack)) = N_Formal_Package_Declaration then elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) =
N_Formal_Package_Declaration
then
return True; return True;
elsif No (Par) then elsif No (Par) then
...@@ -5482,6 +5848,7 @@ package body Sem_Ch12 is ...@@ -5482,6 +5848,7 @@ package body Sem_Ch12 is
or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
then then
null; null;
elsif Renamed_Object (E) = Par then elsif Renamed_Object (E) = Par then
return False; return False;
...@@ -5535,6 +5902,9 @@ package body Sem_Ch12 is ...@@ -5535,6 +5902,9 @@ package body Sem_Ch12 is
while Present (T) loop while Present (T) loop
if In_Open_Scopes (Scope (T)) then if In_Open_Scopes (Scope (T)) then
return T; return T;
elsif Is_Generic_Actual_Type (T) then
return T;
end if; end if;
T := Homonym (T); T := Homonym (T);
...@@ -5898,7 +6268,7 @@ package body Sem_Ch12 is ...@@ -5898,7 +6268,7 @@ package body Sem_Ch12 is
return Unit (Parent (Decl)); return Unit (Parent (Decl));
end if; end if;
elsif Nkind (Decl) = N_Generic_Package_Declaration elsif Nkind (Decl) = N_Package_Declaration
and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration
then then
return Original_Node (Decl); return Original_Node (Decl);
...@@ -6874,6 +7244,7 @@ package body Sem_Ch12 is ...@@ -6874,6 +7244,7 @@ package body Sem_Ch12 is
Ent := First_Entity (Formal); Ent := First_Entity (Formal);
while Present (Ent) loop while Present (Ent) loop
Set_Is_Hidden (Ent, False); Set_Is_Hidden (Ent, False);
Set_Is_Visible_Formal (Ent);
Set_Is_Potentially_Use_Visible Set_Is_Potentially_Use_Visible
(Ent, Is_Potentially_Use_Visible (Formal)); (Ent, Is_Potentially_Use_Visible (Formal));
...@@ -6969,7 +7340,12 @@ package body Sem_Ch12 is ...@@ -6969,7 +7340,12 @@ package body Sem_Ch12 is
-- handle checking of actual parameter associations for later -- handle checking of actual parameter associations for later
-- formals that depend on actuals declared in the formal package. -- formals that depend on actuals declared in the formal package.
if Box_Present (Formal) then -- In Ada 2005, partial parametrization requires that we make
-- visible the actuals corresponding to formals that were defaulted
-- in the formal package. There formals are identified because they
-- remain formal generics within the formal package, rather than
-- being renamings of the actuals supplied.
declare declare
Gen_Decl : constant Node_Id := Gen_Decl : constant Node_Id :=
Unit_Declaration_Node (Gen_Parent); Unit_Declaration_Node (Gen_Parent);
...@@ -6987,18 +7363,9 @@ package body Sem_Ch12 is ...@@ -6987,18 +7363,9 @@ package body Sem_Ch12 is
end if; end if;
Actual_Ent := First_Entity (Actual_Pack); Actual_Ent := First_Entity (Actual_Pack);
while Present (Actual_Ent) while Present (Actual_Ent)
and then Actual_Ent /= First_Private_Entity (Actual_Pack) and then Actual_Ent /= First_Private_Entity (Actual_Pack)
loop loop
Set_Is_Hidden (Actual_Ent, False);
Set_Is_Potentially_Use_Visible
(Actual_Ent, In_Use (Actual_Pack));
if Ekind (Actual_Ent) = E_Package then
Process_Nested_Formal (Actual_Ent);
end if;
if Present (Formal_Node) then if Present (Formal_Node) then
Formal_Ent := Get_Formal_Entity (Formal_Node); Formal_Ent := Get_Formal_Entity (Formal_Node);
...@@ -7006,6 +7373,32 @@ package body Sem_Ch12 is ...@@ -7006,6 +7373,32 @@ package body Sem_Ch12 is
Find_Matching_Actual (Formal_Node, Actual_Ent); Find_Matching_Actual (Formal_Node, Actual_Ent);
Match_Formal_Entity Match_Formal_Entity
(Formal_Node, Formal_Ent, Actual_Ent); (Formal_Node, Formal_Ent, Actual_Ent);
if Box_Present (Formal)
or else
(Present (Formal_Node)
and then Is_Generic_Formal (Formal_Ent))
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
(Actual_Ent, In_Use (Actual_Pack));
if Ekind (Actual_Ent) = E_Package then
Process_Nested_Formal (Actual_Ent);
end if;
end if;
end if; end if;
Next_Non_Pragma (Formal_Node); Next_Non_Pragma (Formal_Node);
...@@ -7019,14 +7412,42 @@ package body Sem_Ch12 is ...@@ -7019,14 +7412,42 @@ package body Sem_Ch12 is
end if; end if;
end loop; end loop;
-- Inherited subprograms generated by formal derived types are
-- also visible if the types are.
Actual_Ent := First_Entity (Actual_Pack);
while Present (Actual_Ent)
and then Actual_Ent /= First_Private_Entity (Actual_Pack)
loop
if Is_Overloadable (Actual_Ent)
and then
Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration
and then
not Is_Hidden (Defining_Identifier (Parent (Actual_Ent)))
then
Set_Is_Hidden (Actual_Ent, False);
Set_Is_Potentially_Use_Visible
(Actual_Ent, In_Use (Actual_Pack));
end if;
Next_Entity (Actual_Ent);
end loop;
end; end;
-- If the formal is not declared with a box, reanalyze it as -- If the formal is not declared with a box, reanalyze it as
-- an instantiation, to verify the matching rules of 12.7. The -- an abbreviated instantiation, to verify the matching rules
-- actual checks are performed after the generic associations -- of 12.7. The actual checks are performed after the generic
-- been analyzed. -- associations have been analyzed, to guarantee the same
-- visibility for this instantiation and for the actuals.
else
-- In Ada 2005, the generic associations for the formal can include
-- defaulted parameters. These are ignored during check. This
-- internal instantiation is removed from the tree after conformance
-- checking, because it contains formal declarations for those
-- defaulted parameters, and those should not reach the back-end.
if not Box_Present (Formal) then
declare declare
I_Pack : constant Entity_Id := I_Pack : constant Entity_Id :=
Make_Defining_Identifier (Sloc (Actual), Make_Defining_Identifier (Sloc (Actual),
...@@ -7038,7 +7459,9 @@ package body Sem_Ch12 is ...@@ -7038,7 +7459,9 @@ package body Sem_Ch12 is
Append_To (Decls, Append_To (Decls,
Make_Package_Instantiation (Sloc (Actual), Make_Package_Instantiation (Sloc (Actual),
Defining_Unit_Name => I_Pack, Defining_Unit_Name => I_Pack,
Name => New_Occurrence_Of (Gen_Parent, Sloc (Actual)), Name =>
New_Occurrence_Of
(Get_Instance_Of (Gen_Parent), Sloc (Actual)),
Generic_Associations => Generic_Associations =>
Generic_Associations (Formal))); Generic_Associations (Formal)));
end; end;
...@@ -7057,7 +7480,7 @@ package body Sem_Ch12 is ...@@ -7057,7 +7480,7 @@ package body Sem_Ch12 is
Actual : Node_Id; Actual : Node_Id;
Analyzed_Formal : Node_Id) return Node_Id Analyzed_Formal : Node_Id) return Node_Id
is is
Loc : Source_Ptr := Sloc (Instantiation_Node); Loc : Source_Ptr;
Formal_Sub : constant Entity_Id := Formal_Sub : constant Entity_Id :=
Defining_Unit_Name (Specification (Formal)); Defining_Unit_Name (Specification (Formal));
Analyzed_S : constant Entity_Id := Analyzed_S : constant Entity_Id :=
...@@ -7136,11 +7559,34 @@ package body Sem_Ch12 is ...@@ -7136,11 +7559,34 @@ package body Sem_Ch12 is
begin begin
New_Spec := New_Copy_Tree (Specification (Formal)); New_Spec := New_Copy_Tree (Specification (Formal));
-- The tree copy has created the proper instantiation sloc for the
-- new specification. Use this location for all other constructed
-- declarations.
Loc := Sloc (Defining_Unit_Name (New_Spec));
-- Create new entity for the actual (New_Copy_Tree does not) -- Create new entity for the actual (New_Copy_Tree does not)
Set_Defining_Unit_Name Set_Defining_Unit_Name
(New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub))); (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
-- Create new entities for the each of the formals in the
-- specification of the renaming declaration built for the actual.
if Present (Parameter_Specifications (New_Spec)) then
declare
F : Node_Id;
begin
F := First (Parameter_Specifications (New_Spec));
while Present (F) loop
Set_Defining_Identifier (F,
Make_Defining_Identifier (Loc,
Chars => Chars (Defining_Identifier (F))));
Next (F);
end loop;
end;
end if;
-- Find entity of actual. If the actual is an attribute reference, it -- Find entity of actual. If the actual is an attribute reference, it
-- cannot be resolved here (its formal is missing) but is handled -- cannot be resolved here (its formal is missing) but is handled
-- instead in Attribute_Renaming. If the actual is overloaded, it is -- instead in Attribute_Renaming. If the actual is overloaded, it is
...@@ -7332,18 +7778,28 @@ package body Sem_Ch12 is ...@@ -7332,18 +7778,28 @@ package body Sem_Ch12 is
Actual : Node_Id; Actual : Node_Id;
Analyzed_Formal : Node_Id) return List_Id Analyzed_Formal : Node_Id) return List_Id
is is
Acc_Def : Node_Id := Empty;
Act_Assoc : constant Node_Id := Parent (Actual);
Actual_Decl : Node_Id := Empty;
Formal_Id : constant Entity_Id := Defining_Identifier (Formal); Formal_Id : constant Entity_Id := Defining_Identifier (Formal);
Type_Id : constant Node_Id := Subtype_Mark (Formal); Decl_Node : Node_Id;
Def : Node_Id;
Ftyp : Entity_Id;
List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Actual); Loc : constant Source_Ptr := Sloc (Actual);
Act_Assoc : constant Node_Id := Parent (Actual);
Orig_Ftyp : constant Entity_Id := Orig_Ftyp : constant Entity_Id :=
Etype (Defining_Identifier (Analyzed_Formal)); Etype (Defining_Identifier (Analyzed_Formal));
List : constant List_Id := New_List;
Ftyp : Entity_Id;
Decl_Node : Node_Id;
Subt_Decl : Node_Id := Empty; Subt_Decl : Node_Id := Empty;
Subt_Mark : Node_Id := Empty;
begin begin
if Present (Subtype_Mark (Formal)) then
Subt_Mark := Subtype_Mark (Formal);
else
Check_Access_Definition (Formal);
Acc_Def := Access_Definition (Formal);
end if;
-- Sloc for error message on missing actual -- Sloc for error message on missing actual
Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal))); Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal)));
...@@ -7377,12 +7833,21 @@ package body Sem_Ch12 is ...@@ -7377,12 +7833,21 @@ package body Sem_Ch12 is
Abandon_Instantiation (Instantiation_Node); Abandon_Instantiation (Instantiation_Node);
end if; end if;
if Present (Subt_Mark) then
Decl_Node := Decl_Node :=
Make_Object_Renaming_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => New_Copy (Formal_Id), Defining_Identifier => New_Copy (Formal_Id),
Subtype_Mark => New_Copy_Tree (Type_Id), Subtype_Mark => New_Copy_Tree (Subt_Mark),
Name => Actual); Name => Actual);
else pragma Assert (Present (Acc_Def));
Decl_Node :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => New_Copy (Formal_Id),
Access_Definition => New_Copy_Tree (Acc_Def),
Name => Actual);
end if;
Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
-- The analysis of the actual may produce insert_action nodes, so -- The analysis of the actual may produce insert_action nodes, so
...@@ -7447,9 +7912,22 @@ package body Sem_Ch12 is ...@@ -7447,9 +7912,22 @@ package body Sem_Ch12 is
("actual for& must be a variable", Actual, Formal_Id); ("actual for& must be a variable", Actual, Formal_Id);
elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
Error_Msg_NE (
"type of actual does not match type of&", Actual, Formal_Id);
-- Ada 2005 (AI-423): For a generic formal object of mode in
-- out, the type of the actual shall resolve to a specific
-- anonymous access type.
if Ada_Version < Ada_05
or else
Ekind (Base_Type (Ftyp)) /=
E_Anonymous_Access_Type
or else
Ekind (Base_Type (Etype (Actual))) /=
E_Anonymous_Access_Type
then
Error_Msg_NE ("type of actual does not match type of&",
Actual, Formal_Id);
end if;
end if; end if;
Note_Possible_Modification (Actual); Note_Possible_Modification (Actual);
...@@ -7475,16 +7953,22 @@ package body Sem_Ch12 is ...@@ -7475,16 +7953,22 @@ package body Sem_Ch12 is
-- OUT not present -- OUT not present
else else
-- The instantiation of a generic formal in-parameter -- The instantiation of a generic formal in-parameter is a
-- is a constant declaration. The actual is the expression for -- constant declaration. The actual is the expression for
-- that declaration. -- that declaration.
if Present (Actual) then if Present (Actual) then
if Present (Subt_Mark) then
Def := Subt_Mark;
else pragma Assert (Present (Acc_Def));
Def := Acc_Def;
end if;
Decl_Node := Make_Object_Declaration (Loc, Decl_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => New_Copy (Formal_Id), Defining_Identifier => New_Copy (Formal_Id),
Constant_Present => True, Constant_Present => True,
Object_Definition => New_Copy_Tree (Type_Id), Object_Definition => New_Copy_Tree (Def),
Expression => Actual); Expression => Actual);
Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
...@@ -7532,16 +8016,23 @@ package body Sem_Ch12 is ...@@ -7532,16 +8016,23 @@ package body Sem_Ch12 is
end if; end if;
end; end;
elsif Present (Expression (Formal)) then elsif Present (Default_Expression (Formal)) then
-- Use default to construct declaration -- Use default to construct declaration
if Present (Subt_Mark) then
Def := Subt_Mark;
else pragma Assert (Present (Acc_Def));
Def := Acc_Def;
end if;
Decl_Node := Decl_Node :=
Make_Object_Declaration (Sloc (Formal), Make_Object_Declaration (Sloc (Formal),
Defining_Identifier => New_Copy (Formal_Id), Defining_Identifier => New_Copy (Formal_Id),
Constant_Present => True, Constant_Present => True,
Object_Definition => New_Copy (Type_Id), Object_Definition => New_Copy (Def),
Expression => New_Copy_Tree (Expression (Formal))); Expression => New_Copy_Tree (Default_Expression
(Formal)));
Append (Decl_Node, List); Append (Decl_Node, List);
Set_Analyzed (Expression (Decl_Node), False); Set_Analyzed (Expression (Decl_Node), False);
...@@ -7560,15 +8051,21 @@ package body Sem_Ch12 is ...@@ -7560,15 +8051,21 @@ package body Sem_Ch12 is
-- Create dummy constant declaration so that instance can -- Create dummy constant declaration so that instance can
-- be analyzed, to minimize cascaded visibility errors. -- be analyzed, to minimize cascaded visibility errors.
if Present (Subt_Mark) then
Def := Subt_Mark;
else pragma Assert (Present (Acc_Def));
Def := Acc_Def;
end if;
Decl_Node := Decl_Node :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => New_Copy (Formal_Id), Defining_Identifier => New_Copy (Formal_Id),
Constant_Present => True, Constant_Present => True,
Object_Definition => New_Copy (Type_Id), Object_Definition => New_Copy (Def),
Expression => Expression =>
Make_Attribute_Reference (Sloc (Formal_Id), Make_Attribute_Reference (Sloc (Formal_Id),
Attribute_Name => Name_First, Attribute_Name => Name_First,
Prefix => New_Copy (Type_Id))); Prefix => New_Copy (Def)));
Append (Decl_Node, List); Append (Decl_Node, List);
...@@ -7576,7 +8073,33 @@ package body Sem_Ch12 is ...@@ -7576,7 +8073,33 @@ package body Sem_Ch12 is
Abandon_Instantiation (Instantiation_Node); Abandon_Instantiation (Instantiation_Node);
end if; end if;
end if; end if;
end if;
if Nkind (Actual) in N_Has_Entity then
Actual_Decl := Parent (Entity (Actual));
end if;
-- Ada 2005 (AI-423): For a formal object declaration with a null
-- exclusion or an access definition that has a null exclusion: If
-- the actual matching the formal object declaration denotes a generic
-- 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.
if Ada_Version >= Ada_05
and then Present (Actual_Decl)
and then
(Nkind (Actual_Decl) = N_Formal_Object_Declaration
or else Nkind (Actual_Decl) = N_Object_Declaration)
and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
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);
end if; end if;
return List; return List;
...@@ -7897,6 +8420,14 @@ package body Sem_Ch12 is ...@@ -7897,6 +8420,14 @@ package body Sem_Ch12 is
Set_Has_Completion (Anon_Id); Set_Has_Completion (Anon_Id);
Check_Generic_Actuals (Pack_Id, False); Check_Generic_Actuals (Pack_Id, False);
-- Generate a reference to link the visible subprogram instance to
-- the the generic body, which for navigation purposes is the only
-- available source for the instance.
Generate_Reference
(Related_Instance (Pack_Id),
Gen_Body_Id, 'b', Set_Ref => False, Force => True);
-- If it is a child unit, make the parent instance (which is an -- If it is a child unit, make the parent instance (which is an
-- instance of the parent of the generic) visible. The parent -- instance of the parent of the generic) visible. The parent
-- instance is the prefix of the name of the generic unit. -- instance is the prefix of the name of the generic unit.
...@@ -8074,13 +8605,14 @@ package body Sem_Ch12 is ...@@ -8074,13 +8605,14 @@ package body Sem_Ch12 is
Analyzed_Formal : Node_Id; Analyzed_Formal : Node_Id;
Actual_Decls : List_Id) return Node_Id Actual_Decls : List_Id) return Node_Id
is is
Loc : constant Source_Ptr := Sloc (Actual);
Gen_T : constant Entity_Id := Defining_Identifier (Formal); Gen_T : constant Entity_Id := Defining_Identifier (Formal);
A_Gen_T : constant Entity_Id := Defining_Identifier (Analyzed_Formal); A_Gen_T : constant Entity_Id := Defining_Identifier (Analyzed_Formal);
Ancestor : Entity_Id := Empty; Ancestor : Entity_Id := Empty;
Def : constant Node_Id := Formal_Type_Definition (Formal); Def : constant Node_Id := Formal_Type_Definition (Formal);
Act_T : Entity_Id; Act_T : Entity_Id;
Decl_Node : Node_Id; Decl_Node : Node_Id;
Loc : Source_Ptr;
Subt : Entity_Id;
procedure Validate_Array_Type_Instance; procedure Validate_Array_Type_Instance;
procedure Validate_Access_Subprogram_Instance; procedure Validate_Access_Subprogram_Instance;
...@@ -8470,6 +9002,33 @@ package body Sem_Ch12 is ...@@ -8470,6 +9002,33 @@ package body Sem_Ch12 is
Abandon_Instantiation (Actual); Abandon_Instantiation (Actual);
end if; end if;
-- Ada 2005 (AI-443): Synchronized formal derived type ckecks. Note
-- that the formal type declaration has been rewritten as a private
-- extension.
if Ada_Version >= Ada_05
and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration
and then Synchronized_Present (Parent (A_Gen_T))
then
-- The actual must be a synchronized tagged type
if not Is_Tagged_Type (Act_T) then
Error_Msg_N
("actual of synchronized type must be tagged", Actual);
Abandon_Instantiation (Actual);
elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Parent (Act_T))) =
N_Derived_Type_Definition
and then not Synchronized_Present (Type_Definition
(Parent (Act_T)))
then
Error_Msg_N
("actual of synchronized type must be synchronized", Actual);
Abandon_Instantiation (Actual);
end if;
end if;
-- Perform atomic/volatile checks (RM C.6(12)) -- Perform atomic/volatile checks (RM C.6(12))
if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
...@@ -8508,11 +9067,15 @@ package body Sem_Ch12 is ...@@ -8508,11 +9067,15 @@ package body Sem_Ch12 is
Abandon_Instantiation (Actual); Abandon_Instantiation (Actual);
end if; end if;
-- Ancestor is unconstrained -- Ancestor is unconstrained, Check if generic formal and
-- actual agree on constrainedness. The check only applies
-- to array types and discriminated types.
elsif Is_Constrained (Act_T) then elsif Is_Constrained (Act_T) then
if Ekind (Ancestor) = E_Access_Type if Ekind (Ancestor) = E_Access_Type
or else Is_Composite_Type (Ancestor) or else
(not Is_Constrained (A_Gen_T)
and then Is_Composite_Type (A_Gen_T))
then then
Error_Msg_N Error_Msg_N
("actual subtype must be unconstrained", Actual); ("actual subtype must be unconstrained", Actual);
...@@ -8633,6 +9196,13 @@ package body Sem_Ch12 is ...@@ -8633,6 +9196,13 @@ package body Sem_Ch12 is
Explain_Limited_Type (Act_T, Actual); Explain_Limited_Type (Act_T, Actual);
Abandon_Instantiation (Actual); Abandon_Instantiation (Actual);
elsif Known_To_Have_Preelab_Init (A_Gen_T)
and then not Has_Preelaborable_Initialization (Act_T)
then
Error_Msg_NE
("actual for & must have preelaborable initialization", Actual,
Gen_T);
elsif Is_Indefinite_Subtype (Act_T) elsif Is_Indefinite_Subtype (Act_T)
and then not Is_Indefinite_Subtype (A_Gen_T) and then not Is_Indefinite_Subtype (A_Gen_T)
and then Ada_Version >= Ada_95 and then Ada_Version >= Ada_95
...@@ -8764,8 +9334,14 @@ package body Sem_Ch12 is ...@@ -8764,8 +9334,14 @@ package body Sem_Ch12 is
-- Deal with error of using incomplete type as generic actual -- Deal with error of using incomplete type as generic actual
if Ekind (Act_T) = E_Incomplete_Type then if Ekind (Act_T) = E_Incomplete_Type
if No (Underlying_Type (Act_T)) then or else (Is_Class_Wide_Type (Act_T)
and then
Ekind (Root_Type (Act_T)) = E_Incomplete_Type)
then
if Is_Class_Wide_Type (Act_T)
or else No (Underlying_Type (Act_T))
then
Error_Msg_N ("premature use of incomplete type", Actual); Error_Msg_N ("premature use of incomplete type", Actual);
Abandon_Instantiation (Actual); Abandon_Instantiation (Actual);
else else
...@@ -8890,9 +9466,16 @@ package body Sem_Ch12 is ...@@ -8890,9 +9466,16 @@ package body Sem_Ch12 is
end case; end case;
Subt := New_Copy (Gen_T);
-- Use adjusted sloc of subtype name as the location for other
-- nodes in the subtype declaration.
Loc := Sloc (Subt);
Decl_Node := Decl_Node :=
Make_Subtype_Declaration (Loc, Make_Subtype_Declaration (Loc,
Defining_Identifier => New_Copy (Gen_T), Defining_Identifier => Subt,
Subtype_Indication => New_Reference_To (Act_T, Loc)); Subtype_Indication => New_Reference_To (Act_T, Loc));
if Is_Private_Type (Act_T) then if Is_Private_Type (Act_T) then
...@@ -8918,6 +9501,20 @@ package body Sem_Ch12 is ...@@ -8918,6 +9501,20 @@ package body Sem_Ch12 is
return Decl_Node; return Decl_Node;
end Instantiate_Type; end Instantiate_Type;
-----------------------
-- Is_Generic_Formal --
-----------------------
function Is_Generic_Formal (E : Entity_Id) return Boolean is
Kind : constant Node_Kind := Nkind (Parent (E));
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;
end Is_Generic_Formal;
--------------------- ---------------------
-- Is_In_Main_Unit -- -- Is_In_Main_Unit --
--------------------- ---------------------
...@@ -9248,19 +9845,19 @@ package body Sem_Ch12 is ...@@ -9248,19 +9845,19 @@ package body Sem_Ch12 is
begin begin
Assoc := First (Generic_Associations (N)); Assoc := First (Generic_Associations (N));
while Present (Assoc) loop while Present (Assoc) loop
if Nkind (Assoc) /= N_Others_Choice then
Act := Explicit_Generic_Actual_Parameter (Assoc); Act := Explicit_Generic_Actual_Parameter (Assoc);
-- Within a nested instantiation, a defaulted actual is an -- Within a nested instantiation, a defaulted actual is an empty
-- empty association, so nothing to analyze. If the actual for -- association, so nothing to analyze. If the subprogram actual
-- a subprogram is an attribute, analyze prefix only, because -- isan attribute, analyze prefix only, because actual is not a
-- actual is not a complete attribute reference. -- complete attribute reference.
-- If actual is an allocator, analyze expression only. The full -- If actual is an allocator, analyze expression only. The full
-- analysis can generate code, and if the instance is a compilation -- analysis can generate code, and if instance is a compilation
-- unit we have to wait until the package instance is installed to -- unit we have to wait until the package instance is installed
-- have a proper place to insert this code. -- to have a proper place to insert this code.
-- String literals may be operators, but at this point we do not -- String literals may be operators, but at this point we do not
-- know whether the actual is a formal subprogram or a string. -- know whether the actual is a formal subprogram or a string.
...@@ -9294,6 +9891,7 @@ package body Sem_Ch12 is ...@@ -9294,6 +9891,7 @@ package body Sem_Ch12 is
if Errs /= Serious_Errors_Detected then if Errs /= Serious_Errors_Detected then
Abandon_Instantiation (Act); Abandon_Instantiation (Act);
end if; end if;
end if;
Next (Assoc); Next (Assoc);
end loop; end loop;
...@@ -9428,17 +10026,16 @@ package body Sem_Ch12 is ...@@ -9428,17 +10026,16 @@ package body Sem_Ch12 is
procedure Restore_Nested_Formal (Formal : Entity_Id) is procedure Restore_Nested_Formal (Formal : Entity_Id) is
Ent : Entity_Id; Ent : Entity_Id;
begin begin
if Present (Renamed_Object (Formal)) if Present (Renamed_Object (Formal))
and then Denotes_Formal_Package (Renamed_Object (Formal), True) and then Denotes_Formal_Package (Renamed_Object (Formal), True)
then then
return; return;
elsif Present (Associated_Formal_Package (Formal)) elsif Present (Associated_Formal_Package (Formal)) then
and then Box_Present (Parent (Associated_Formal_Package (Formal)))
then
Ent := First_Entity (Formal);
Ent := First_Entity (Formal);
while Present (Ent) loop while Present (Ent) loop
exit when Ekind (Ent) = E_Package exit when Ekind (Ent) = E_Package
and then Renamed_Entity (Ent) = Renamed_Entity (Formal); and then Renamed_Entity (Ent) = Renamed_Entity (Formal);
...@@ -9457,6 +10054,8 @@ package body Sem_Ch12 is ...@@ -9457,6 +10054,8 @@ package body Sem_Ch12 is
end if; end if;
end Restore_Nested_Formal; end Restore_Nested_Formal;
-- Start of processing for Restore_Private_Views
begin begin
M := First_Elmt (Exchanged_Views); M := First_Elmt (Exchanged_Views);
while Present (M) loop while Present (M) loop
...@@ -9473,7 +10072,6 @@ package body Sem_Ch12 is ...@@ -9473,7 +10072,6 @@ package body Sem_Ch12 is
or else Ekind (Typ) = E_Record_Type_With_Private or else Ekind (Typ) = E_Record_Type_With_Private
then then
Dep_Elmt := First_Elmt (Private_Dependents (Typ)); Dep_Elmt := First_Elmt (Private_Dependents (Typ));
while Present (Dep_Elmt) loop while Present (Dep_Elmt) loop
Dep_Typ := Node (Dep_Elmt); Dep_Typ := Node (Dep_Elmt);
...@@ -9500,7 +10098,6 @@ package body Sem_Ch12 is ...@@ -9500,7 +10098,6 @@ package body Sem_Ch12 is
-- types into subtypes of the actuals again. -- types into subtypes of the actuals again.
E := First_Entity (Pack_Id); E := First_Entity (Pack_Id);
while Present (E) loop while Present (E) loop
Set_Is_Hidden (E, True); Set_Is_Hidden (E, True);
...@@ -10152,19 +10749,39 @@ package body Sem_Ch12 is ...@@ -10152,19 +10749,39 @@ package body Sem_Ch12 is
or else Nkind (N2) = N_Real_Literal or else Nkind (N2) = N_Real_Literal
or else Nkind (N2) = N_String_Literal or else Nkind (N2) = N_String_Literal
then then
-- Operation was constant-folded, perform the same if Present (Original_Node (N2))
-- replacement in generic. and then Nkind (Original_Node (N2)) = Nkind (N)
then
-- Operation was constant-folded. Whenever possible,
-- recover semantic information from unfolded node,
-- for ASIS use.
Set_Associated_Node (N, Original_Node (N2));
if Nkind (N) = N_Op_Concat then
Set_Is_Component_Left_Opnd (N,
Is_Component_Left_Opnd (Get_Associated_Node (N)));
Set_Is_Component_Right_Opnd (N,
Is_Component_Right_Opnd (Get_Associated_Node (N)));
end if;
Reset_Entity (N);
else
-- If original node is already modified, propagate
-- constant-folding to template.
Rewrite (N, New_Copy (N2)); Rewrite (N, New_Copy (N2));
Set_Analyzed (N, False); Set_Analyzed (N, False);
end if;
elsif Nkind (N2) = N_Identifier elsif Nkind (N2) = N_Identifier
and then Ekind (Entity (N2)) = E_Enumeration_Literal and then Ekind (Entity (N2)) = E_Enumeration_Literal
then then
-- Same if call was folded into a literal, but in this -- Same if call was folded into a literal, but in this case
-- case retain the entity to avoid spurious ambiguities -- retain the entity to avoid spurious ambiguities if id is
-- if id is overloaded at the point of instantiation or -- overloaded at the point of instantiation or inlining.
-- inlining.
Rewrite (N, New_Copy (N2)); Rewrite (N, New_Copy (N2));
Set_Analyzed (N, False); Set_Analyzed (N, False);
...@@ -10181,9 +10798,9 @@ package body Sem_Ch12 is ...@@ -10181,9 +10798,9 @@ package body Sem_Ch12 is
elsif Nkind (N) = N_Identifier then elsif Nkind (N) = N_Identifier then
if Nkind (N) = Nkind (Get_Associated_Node (N)) then if Nkind (N) = Nkind (Get_Associated_Node (N)) then
-- If this is a discriminant reference, always save it. -- If this is a discriminant reference, always save it. It is
-- It is used in the instance to find the corresponding -- used in the instance to find the corresponding discriminant
-- discriminant positionally rather than by name. -- positionally rather than by name.
Set_Original_Discriminant Set_Original_Discriminant
(N, Original_Discriminant (Get_Associated_Node (N))); (N, Original_Discriminant (Get_Associated_Node (N)));
...@@ -10195,8 +10812,8 @@ package body Sem_Ch12 is ...@@ -10195,8 +10812,8 @@ package body Sem_Ch12 is
if Nkind (N2) = N_Function_Call then if Nkind (N2) = N_Function_Call then
E := Entity (Name (N2)); E := Entity (Name (N2));
-- Name resolves to a call to parameterless function. -- Name resolves to a call to parameterless function. If
-- If original entity is global, mark node as resolved. -- original entity is global, mark node as resolved.
if Present (E) if Present (E)
and then Is_Global (E) and then Is_Global (E)
...@@ -10208,16 +10825,25 @@ package body Sem_Ch12 is ...@@ -10208,16 +10825,25 @@ package body Sem_Ch12 is
end if; end if;
elsif elsif
Nkind (N2) = N_Integer_Literal or else (Nkind (N2) = N_Integer_Literal
Nkind (N2) = N_Real_Literal or else or else
Nkind (N2) = N_String_Literal Nkind (N2) = N_Real_Literal)
and then Is_Entity_Name (Original_Node (N2))
then then
-- Name resolves to named number that is constant-folded, -- Name resolves to named number that is constant-folded,
-- or to string literal from concatenation. -- We must preserve the original name for ASIS use, and
-- Perform the same replacement in generic. -- undo the constant-folding, which will be repeated in
-- each instance.
Set_Associated_Node (N, Original_Node (N2));
Reset_Entity (N);
elsif Nkind (N2) = N_String_Literal then
-- Name resolves to string literal. Perform the same
-- replacement in generic.
Rewrite (N, New_Copy (N2)); Rewrite (N, New_Copy (N2));
Set_Analyzed (N, False);
elsif Nkind (N2) = N_Explicit_Dereference then elsif Nkind (N2) = N_Explicit_Dereference then
...@@ -10474,9 +11100,14 @@ package body Sem_Ch12 is ...@@ -10474,9 +11100,14 @@ package body Sem_Ch12 is
begin begin
-- T may be private but its base type may have been exchanged through -- T may be private but its base type may have been exchanged through
-- some other occurrence, in which case there is nothing to switch. -- some other occurrence, in which case there is nothing to switch
-- besides T itself. Note that a private dependent subtype of a private
-- type might not have been switched even if the base type has been,
-- because of the last branch of Check_Private_View (see comment there).
if not Is_Private_Type (BT) then if not Is_Private_Type (BT) then
Prepend_Elmt (Full_View (T), Exchanged_Views);
Exchange_Declarations (T);
return; return;
end if; end if;
......
gcc/ada/sem_ch12.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -126,4 +126,18 @@ package Sem_Ch12 is ...@@ -126,4 +126,18 @@ package Sem_Ch12 is
procedure Initialize; procedure Initialize;
-- Initializes internal data structures -- Initializes internal data structures
procedure Check_Private_View (N : Node_Id);
-- Check whether the type of a generic entity has a different view between
-- the point of generic analysis and the point of instantiation. If the
-- view has changed, then at the point of instantiation we restore the
-- correct view to perform semantic analysis of the instance, and reset
-- the current view after instantiation. The processing is driven by the
-- current private status of the type of the node, and Has_Private_View,
-- a flag that is set at the point of generic compilation. If view and
-- flag are inconsistent then the type is updated appropriately.
--
-- This subprogram is used in Check_Generic_Actuals and Copy_Generic_Node,
-- and is exported here for the purpose of front-end inlining (see Exp_Ch6.
-- Expand_Inlined_Call.Process_Formals).
end Sem_Ch12; end Sem_Ch12;
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