X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch12.adb;h=3624385e8642393b15b8f06dff40d264243dba68;hb=362e5ece36cab6ff1252ef2a6d19d790f12b1a6c;hp=8eb0cd28e448648c43bf6056d0e7f935a2237581;hpb=ff6293ec0850332d7db6b8ef2abf8bff148549d7;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 8eb0cd28e44..3624385e864 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -23,11 +23,13 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; +with Exp_Disp; use Exp_Disp; with Fname; use Fname; with Fname.UF; use Fname.UF; with Freeze; use Freeze; @@ -52,6 +54,7 @@ with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; with Sem_Elim; use Sem_Elim; @@ -257,7 +260,7 @@ package body Sem_Ch12 is -- 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 + -- Our Ada 95 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 @@ -341,7 +344,11 @@ package body Sem_Ch12 is Def : Node_Id); -- Creates a new private type, which does not require completion + procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id); + -- Ada 2012: Creates a new incomplete type whose actual does not freeze + procedure Analyze_Generic_Formal_Part (N : Node_Id); + -- Analyze generic formal part procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id); -- Create a new access type with the given designated type @@ -394,6 +401,13 @@ package body Sem_Ch12 is -- package cannot be inlined by the front-end because front-end inlining -- requires a strict linear order of elaboration. + function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id; + -- Check if some association between formals and actuals requires to make + -- visible primitives of a tagged type, and make those primitives visible. + -- Return the list of primitives whose visibility is modified (to restore + -- their visibility later through Restore_Hidden_Primitives). If no + -- candidate is found then return No_Elist. + procedure Check_Hidden_Child_Unit (N : Node_Id; Gen_Unit : Entity_Id; @@ -438,6 +452,12 @@ package body Sem_Ch12 is -- an instantiation in the source, or the internal instantiation that -- corresponds to the actual for a formal package. + function Earlier (N1, N2 : Node_Id) return Boolean; + -- Yields True if N1 and N2 appear in the same compilation unit, + -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right + -- traversal of the tree for the unit. Used to determine the placement + -- of freeze nodes for instance bodies that may depend on other instances. + function Find_Actual_Type (Typ : Entity_Id; Gen_Type : Entity_Id) return Entity_Id; @@ -460,27 +480,17 @@ package body Sem_Ch12 is Inst : Node_Id) return Boolean; -- True if the instantiation Inst and the given freeze_node F_Node appear -- within the same declarative part, ignoring subunits, but with no inter- - -- vening subprograms or concurrent units. If true, the freeze node - -- of the instance can be placed after the freeze node of the parent, - -- which it itself an instance. + -- vening subprograms or concurrent units. Used to find the proper plave + -- for the freeze node of an instance, when the generic is declared in a + -- previous instance. If predicate is true, the freeze node of the instance + -- can be placed after the freeze node of the previous instance, Otherwise + -- it has to be placed at the end of the current declarative part. function In_Main_Context (E : Entity_Id) return Boolean; -- Check whether an instantiation is in the context of the main unit. -- Used to determine whether its body should be elaborated to allow -- 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 visibility - -- of generic formals of a generic package declared with a box or with - -- partial parametrization. - - procedure Mark_Context (Inst_Decl : Node_Id; Gen_Decl : Node_Id); - -- If the generic unit comes from a different unit, indicate that the - -- unit that contains the instance depends on the body that contains - -- the generic body. Used to determine a more precise dependency graph - -- for use by CodePeer. - procedure Set_Instance_Env (Gen_Unit : Entity_Id; Act_Unit : Entity_Id); @@ -523,11 +533,14 @@ package body Sem_Ch12 is -- of packages that are early instantiations are delayed, and their freeze -- node appears after the generic body. - procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id); - -- Insert freeze node at the end of the declarative part that includes the - -- instance node N. If N is in the visible part of an enclosing package - -- declaration, the freeze node has to be inserted at the end of the - -- private declarations, if any. + procedure Insert_Freeze_Node_For_Instance + (N : Node_Id; + F_Node : Node_Id); + -- N denotes a package or a subprogram instantiation and F_Node is the + -- associated freeze node. Insert the freeze node before the first source + -- body which follows immediately after N. If no such body is found, the + -- freeze node is inserted at the end of the declarative region which + -- contains N. procedure Freeze_Subprogram_Body (Inst_Node : Node_Id; @@ -560,6 +573,18 @@ package body Sem_Ch12 is procedure Remove_Parent (In_Body : Boolean := False); -- Reverse effect after instantiation of child is complete + procedure Install_Hidden_Primitives + (Prims_List : in out Elist_Id; + Gen_T : Entity_Id; + Act_T : Entity_Id); + -- Remove suffix 'P' from hidden primitives of Act_T to match the + -- visibility of primitives of Gen_T. The list of primitives to which + -- the suffix is removed is added to Prims_List to restore them later. + + procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id); + -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List + -- set to No_Elist. + procedure Inline_Instance_Body (N : Node_Id; Gen_Unit : Entity_Id; @@ -614,11 +639,11 @@ package body Sem_Ch12 is -- formals: the visible and private declarations themselves need not be -- created. - -- In Ada 2005, the formal package may be only partially parametrized. In - -- that case the visibility step must make visible those actuals whose + -- In Ada 2005, the formal package may be only partially parameterized. + -- 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. + -- 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; -- Test if given node is in the main unit @@ -713,6 +738,10 @@ package body Sem_Ch12 is -- before installing parents of generics, that are not visible for the -- actuals themselves. + function True_Parent (N : Node_Id) return Node_Id; + -- For a subunit, return parent of corresponding stub, else return + -- parent of node. + procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id); -- Verify that an attribute that appears as the default for a formal -- subprogram is a function or procedure with the correct profile. @@ -888,22 +917,20 @@ package body Sem_Ch12 is Formals : List_Id; F_Copy : List_Id) return List_Id is - - Actual_Types : constant Elist_Id := New_Elmt_List; - Assoc : constant List_Id := New_List; - Default_Actuals : constant Elist_Id := New_Elmt_List; - Gen_Unit : constant Entity_Id := - Defining_Entity (Parent (F_Copy)); + Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; + Assoc : constant List_Id := New_List; + Default_Actuals : constant Elist_Id := New_Elmt_List; + Gen_Unit : constant Entity_Id := + Defining_Entity (Parent (F_Copy)); Actuals : List_Id; Actual : Node_Id; - Formal : Node_Id; - Next_Formal : Node_Id; - Temp_Formal : Node_Id; Analyzed_Formal : Node_Id; + First_Named : Node_Id := Empty; + Formal : Node_Id; Match : Node_Id; Named : Node_Id; - First_Named : Node_Id := Empty; + Saved_Formal : Node_Id; Default_Formals : constant List_Id := New_List; -- If an Others_Choice is present, some of the formals may be defaulted. @@ -921,9 +948,20 @@ package body Sem_Ch12 is Num_Actuals : Int := 0; Others_Present : Boolean := False; + Others_Choice : Node_Id := Empty; -- In Ada 2005, indicates partial parametrization of a formal -- package. As usual an other association must be last in the list. + procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id); + -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance + -- cannot have a named association for it. AI05-0025 extends this rule + -- to formals of formal packages by AI05-0025, and it also applies to + -- box-initialized formals. + + function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; + -- Determine whether the parameter types and the return type of Subp + -- are fully defined at the point of instantiation. + function Matching_Actual (F : Entity_Id; A_F : Entity_Id) return Node_Id; @@ -932,7 +970,7 @@ package body Sem_Ch12 is -- are named, scan the parameter associations to find the right one. -- A_F is the corresponding entity in the analyzed generic,which is -- 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 @@ -948,6 +986,10 @@ package body Sem_Ch12 is -- associations, and add an explicit box association for F if there -- is none yet, and the default comes from an Others_Choice. + function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; + -- Determine whether Subp renames one of the subprograms defined in the + -- generated package Standard. + procedure Set_Analyzed_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 @@ -957,6 +999,96 @@ package body Sem_Ch12 is -- anonymous types, the presence a formal equality will introduce an -- implicit declaration for the corresponding inequality. + ---------------------------------------- + -- Check_Overloaded_Formal_Subprogram -- + ---------------------------------------- + + procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is + Temp_Formal : Entity_Id; + + begin + Temp_Formal := First (Formals); + while Present (Temp_Formal) loop + if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration + and then Temp_Formal /= Formal + and then + Chars (Defining_Unit_Name (Specification (Formal))) = + Chars (Defining_Unit_Name (Specification (Temp_Formal))) + then + if Present (Found_Assoc) then + Error_Msg_N + ("named association not allowed for overloaded formal", + Found_Assoc); + + else + Error_Msg_N + ("named association not allowed for overloaded formal", + Others_Choice); + end if; + + Abandon_Instantiation (Instantiation_Node); + end if; + + Next (Temp_Formal); + end loop; + end Check_Overloaded_Formal_Subprogram; + + ------------------------------- + -- Has_Fully_Defined_Profile -- + ------------------------------- + + function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is + function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; + -- Determine whethet type Typ is fully defined + + --------------------------- + -- Is_Fully_Defined_Type -- + --------------------------- + + function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is + begin + -- A private type without a full view is not fully defined + + if Is_Private_Type (Typ) + and then No (Full_View (Typ)) + then + return False; + + -- An incomplete type is never fully defined + + elsif Is_Incomplete_Type (Typ) then + return False; + + -- All other types are fully defined + + else + return True; + end if; + end Is_Fully_Defined_Type; + + -- Local declarations + + Param : Entity_Id; + + -- Start of processing for Has_Fully_Defined_Profile + + begin + -- Check the parameters + + Param := First_Formal (Subp); + while Present (Param) loop + if not Is_Fully_Defined_Type (Etype (Param)) then + return False; + end if; + + Next_Formal (Param); + end loop; + + -- Check the return type + + return Is_Fully_Defined_Type (Etype (Subp)); + end Has_Fully_Defined_Profile; + --------------------- -- Matching_Actual -- --------------------- @@ -1060,7 +1192,7 @@ package body Sem_Ch12 is -- defining identifier for it. Decl := New_Copy_Tree (F); - Id := Make_Defining_Identifier (Sloc (F_Id), Chars => Chars (F_Id)); + Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); if Nkind (F) in N_Formal_Subprogram_Declaration then Set_Defining_Unit_Name (Specification (Decl), Id); @@ -1081,6 +1213,26 @@ package body Sem_Ch12 is end if; end Process_Default; + --------------------------------- + -- Renames_Standard_Subprogram -- + --------------------------------- + + function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is + Id : Entity_Id; + + begin + Id := Alias (Subp); + while Present (Id) loop + if Scope (Id) = Standard_Standard then + return True; + end if; + + Id := Alias (Id); + end loop; + + return False; + end Renames_Standard_Subprogram; + ------------------------- -- Set_Analyzed_Formal -- ------------------------- @@ -1142,6 +1294,7 @@ package body Sem_Ch12 is while Present (Actual) loop if Nkind (Actual) = N_Others_Choice then Others_Present := True; + Others_Choice := Actual; if Present (Next (Actual)) then Error_Msg_N ("others must be last association", Actual); @@ -1190,7 +1343,7 @@ package body Sem_Ch12 is Named := First_Named; while Present (Named) loop if Nkind (Named) /= N_Others_Choice - and then No (Selector_Name (Named)) + and then No (Selector_Name (Named)) then Error_Msg_N ("invalid positional actual after named one", Named); Abandon_Instantiation (Named); @@ -1224,7 +1377,7 @@ package body Sem_Ch12 is while Present (Formal) loop Set_Analyzed_Formal; - Next_Formal := Next_Non_Pragma (Formal); + Saved_Formal := Next_Non_Pragma (Formal); case Nkind (Formal) is when N_Formal_Object_Declaration => @@ -1266,20 +1419,29 @@ package body Sem_Ch12 is Analyze (Match); Append_List (Instantiate_Type - (Formal, Match, Analyzed_Formal, Assoc), - Assoc); + (Formal, Match, Analyzed_Formal, Assoc), + Assoc); -- An instantiation is a freeze point for the actuals, - -- unless this is a rewritten formal package. + -- unless this is a rewritten formal package, or the + -- formal is an Ada 2012 formal incomplete type. + + if Nkind (I_Node) = N_Formal_Package_Declaration + or else + (Ada_Version >= Ada_2012 + and then + Ekind (Defining_Identifier (Analyzed_Formal)) = + E_Incomplete_Type) + then + null; - if Nkind (I_Node) /= N_Formal_Package_Declaration then - Append_Elmt (Entity (Match), Actual_Types); + else + Append_Elmt (Entity (Match), Actuals_To_Freeze); end if; end if; - -- A remote access-to-class-wide type must not be an - -- actual parameter for a generic formal of an access - -- type (E.2.2 (17)). + -- A remote access-to-class-wide type is not a legal actual + -- for a generic formal of an access type (E.2.2(17)). if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration and then @@ -1291,9 +1453,9 @@ package body Sem_Ch12 is when N_Formal_Subprogram_Declaration => Match := - Matching_Actual ( - Defining_Unit_Name (Specification (Formal)), - Defining_Unit_Name (Specification (Analyzed_Formal))); + Matching_Actual + (Defining_Unit_Name (Specification (Formal)), + Defining_Unit_Name (Specification (Analyzed_Formal))); -- If the formal subprogram has the same name as another -- formal subprogram of the generic, then a named @@ -1304,38 +1466,55 @@ package body Sem_Ch12 is and then Is_Named_Assoc and then Comes_From_Source (Found_Assoc) then - Temp_Formal := First (Formals); - while Present (Temp_Formal) loop - if Nkind (Temp_Formal) in - N_Formal_Subprogram_Declaration - and then Temp_Formal /= Formal - and then - Chars (Selector_Name (Found_Assoc)) = - Chars (Defining_Unit_Name - (Specification (Temp_Formal))) - then - Error_Msg_N - ("name not allowed for overloaded formal", - Found_Assoc); - Abandon_Instantiation (Instantiation_Node); - end if; - - Next (Temp_Formal); - end loop; + Check_Overloaded_Formal_Subprogram (Formal); end if; -- If there is no corresponding actual, this may be case of -- partial parametrization, or else the formal has a default -- or a box. - if No (Match) - and then Partial_Parametrization - then + if No (Match) and then Partial_Parametrization then Process_Default (Formal); + + if Nkind (I_Node) = N_Formal_Package_Declaration then + Check_Overloaded_Formal_Subprogram (Formal); + end if; + else Append_To (Assoc, Instantiate_Formal_Subprogram (Formal, Match, Analyzed_Formal)); + + -- An instantiation is a freeze point for the actuals, + -- unless this is a rewritten formal package. + + if Nkind (I_Node) /= N_Formal_Package_Declaration + and then Nkind (Match) = N_Identifier + and then Is_Subprogram (Entity (Match)) + + -- The actual subprogram may rename a routine defined + -- in Standard. Avoid freezing such renamings because + -- subprograms coming from Standard cannot be frozen. + + and then + not Renames_Standard_Subprogram (Entity (Match)) + + -- If the actual subprogram comes from a different + -- unit, it is already frozen, either by a body in + -- that unit or by the end of the declarative part + -- of the unit. This check avoids the freezing of + -- subprograms defined in Standard which are used + -- as generic actuals. + + and then In_Same_Code_Unit (Entity (Match), I_Node) + and then Has_Fully_Defined_Profile (Entity (Match)) + then + -- Mark the subprogram as having a delayed freeze + -- since this may be an out-of-order action. + + Set_Has_Delayed_Freeze (Entity (Match)); + Append_Elmt (Entity (Match), Actuals_To_Freeze); + end if; end if; -- If this is a nested generic, preserve default for later @@ -1386,7 +1565,7 @@ package body Sem_Ch12 is when N_Use_Package_Clause | N_Use_Type_Clause => if Nkind (Original_Node (I_Node)) = - N_Formal_Package_Declaration + N_Formal_Package_Declaration then Append (New_Copy_Tree (Formal), Assoc); else @@ -1399,7 +1578,7 @@ package body Sem_Ch12 is end case; - Formal := Next_Formal; + Formal := Saved_Formal; Next_Non_Pragma (Analyzed_Formal); end loop; @@ -1424,8 +1603,12 @@ package body Sem_Ch12 is ("too many actuals in generic instantiation", Instantiation_Node); end if; + -- An instantiation freezes all generic actuals. The only exceptions + -- to this are incomplete types and subprograms which are not fully + -- defined at the point of instantiation. + declare - Elmt : Elmt_Id := First_Elmt (Actual_Types); + Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); begin while Present (Elmt) loop Freeze_Before (I_Node, Node (Elmt)); @@ -1537,16 +1720,22 @@ package body Sem_Ch12 is -- static. For all scalar types we introduce an anonymous base type, with -- the same attributes. We choose the corresponding integer type to be -- Standard_Integer. + -- Here and in other similar routines, the Sloc of the generated internal + -- type must be the same as the sloc of the defining identifier of the + -- formal type declaration, to provide proper source navigation. procedure Analyze_Formal_Decimal_Fixed_Point_Type (T : Entity_Id; Def : Node_Id) is - Loc : constant Source_Ptr := Sloc (Def); - Base : constant Entity_Id := - New_Internal_Entity - (E_Decimal_Fixed_Point_Type, - Current_Scope, Sloc (Def), 'G'); + Loc : constant Source_Ptr := Sloc (Def); + + Base : constant Entity_Id := + New_Internal_Entity + (E_Decimal_Fixed_Point_Type, + Current_Scope, + Sloc (Defining_Identifier (Parent (Def))), 'G'); + Int_Base : constant Entity_Id := Standard_Integer; Delta_Val : constant Ureal := Ureal_1; Digs_Val : constant Uint := Uint_6; @@ -1686,7 +1875,9 @@ package body Sem_Ch12 is Base : constant Entity_Id := New_Internal_Entity - (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G'); + (E_Floating_Point_Type, Current_Scope, + Sloc (Defining_Identifier (Parent (Def))), 'G'); + begin Enter_Name (T); Set_Ekind (T, E_Enumeration_Subtype); @@ -1734,7 +1925,8 @@ package body Sem_Ch12 is procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is Base : constant Entity_Id := New_Internal_Entity - (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G'); + (E_Floating_Point_Type, Current_Scope, + Sloc (Defining_Identifier (Parent (Def))), 'G'); begin -- The various semantic attributes are taken from the predefined type @@ -1873,7 +2065,7 @@ package body Sem_Ch12 is -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals - if Ada_Version < Ada_05 and then Is_Limited_Type (T) then + if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then Error_Msg_N ("generic formal of mode IN must not be of limited type", N); Explain_Limited_Type (T, N); @@ -1935,6 +2127,10 @@ package body Sem_Ch12 is ("initialization not allowed for `IN OUT` formals", N); end if; end if; + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Id); + end if; end Analyze_Formal_Object_Declaration; ---------------------------------------------- @@ -1948,7 +2144,9 @@ package body Sem_Ch12 is Loc : constant Source_Ptr := Sloc (Def); Base : constant Entity_Id := New_Internal_Entity - (E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G'); + (E_Ordinary_Fixed_Point_Type, Current_Scope, + Sloc (Defining_Identifier (Parent (Def))), 'G'); + begin -- The semantic attributes are set for completeness only, their values -- will never be used, since all properties of the type are non-static. @@ -1978,11 +2176,11 @@ package body Sem_Ch12 is Check_Restriction (No_Fixed_Point, Def); end Analyze_Formal_Ordinary_Fixed_Point_Type; - ---------------------------- - -- Analyze_Formal_Package -- - ---------------------------- + ---------------------------------------- + -- Analyze_Formal_Package_Declaration -- + ---------------------------------------- - procedure Analyze_Formal_Package (N : Node_Id) is + procedure Analyze_Formal_Package_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Pack_Id : constant Entity_Id := Defining_Identifier (N); Formal : Entity_Id; @@ -1994,7 +2192,11 @@ package body Sem_Ch12 is Renaming : Node_Id; Parent_Instance : Entity_Id; Renaming_In_Par : Entity_Id; - No_Associations : Boolean := False; + Associations : Boolean := True; + + Vis_Prims_List : Elist_Id := No_Elist; + -- List of primitives made temporarily visible in the instantiation + -- to match the visibility of the formal type function Build_Local_Package return Node_Id; -- The formal package is rewritten so that its parameters are replaced @@ -2081,9 +2283,11 @@ package body Sem_Ch12 is Decls := Analyze_Associations - (Original_Node (N), - Generic_Formal_Declarations (Act_Tree), - Generic_Formal_Declarations (Gen_Decl)); + (I_Node => Original_Node (N), + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl)); + + Vis_Prims_List := Check_Hidden_Primitives (Decls); end; end if; @@ -2103,7 +2307,7 @@ package body Sem_Ch12 is return Pack_Decl; end Build_Local_Package; - -- Start of processing for Analyze_Formal_Package + -- Start of processing for Analyze_Formal_Package_Declaration begin Text_IO_Kludge (Gen_Id); @@ -2115,20 +2319,29 @@ package body Sem_Ch12 is -- Check for a formal package that is a package renaming if Present (Renamed_Object (Gen_Unit)) then + + -- Indicate that unit is used, before replacing it with renamed + -- entity for use below. + + if In_Extended_Main_Source_Unit (N) then + Set_Is_Instantiated (Gen_Unit); + Generate_Reference (Gen_Unit, N); + end if; + Gen_Unit := Renamed_Object (Gen_Unit); end if; if Ekind (Gen_Unit) /= E_Generic_Package then Error_Msg_N ("expect generic package name", Gen_Id); Restore_Env; - return; + goto Leave; elsif Gen_Unit = Current_Scope then Error_Msg_N ("generic package cannot be used as a formal package of itself", Gen_Id); Restore_Env; - return; + goto Leave; elsif In_Open_Scopes (Gen_Unit) then if Is_Compilation_Unit (Gen_Unit) @@ -2148,15 +2361,35 @@ package body Sem_Ch12 is & "within itself", Gen_Id); Restore_Env; - return; + goto Leave; end if; end if; + -- Check that name of formal package does not hide name of generic, + -- or its leading prefix. This check must be done separately because + -- the name of the generic has already been analyzed. + + declare + Gen_Name : Entity_Id; + + begin + Gen_Name := Gen_Id; + while Nkind (Gen_Name) = N_Expanded_Name loop + Gen_Name := Prefix (Gen_Name); + end loop; + + if Chars (Gen_Name) = Chars (Pack_Id) then + Error_Msg_NE + ("& is hidden within declaration of formal package", + Gen_Id, Gen_Name); + end if; + end; + if Box_Present (N) or else No (Generic_Associations (N)) or else Nkind (First (Generic_Associations (N))) = N_Others_Choice then - No_Associations := True; + Associations := False; end if; -- If there are no generic associations, the generic parameters appear @@ -2191,12 +2424,13 @@ package body Sem_Ch12 is Enter_Name (Formal); Set_Ekind (Formal, E_Variable); Set_Etype (Formal, Any_Type); + Restore_Hidden_Primitives (Vis_Prims_List); if Parent_Installed then Remove_Parent; end if; - return; + goto Leave; end; Rewrite (N, New_N); @@ -2237,26 +2471,34 @@ package body Sem_Ch12 is -- outside of the formal package. The others are still declared by a -- formal parameter declaration. - if not No_Associations then - declare - E : Entity_Id; + -- If there are no associations, the only local entity to hide is the + -- generated package renaming itself. - begin - E := First_Entity (Formal); - while Present (E) loop - exit when Ekind (E) = E_Package - and then Renamed_Entity (E) = Formal; + declare + E : Entity_Id; - if not Is_Generic_Formal (E) then - Set_Is_Hidden (E); - end if; + begin + E := First_Entity (Formal); + while Present (E) loop + if Associations + and then not Is_Generic_Formal (E) + then + Set_Is_Hidden (E); + end if; - Next_Entity (E); - end loop; - end; - end if; + if Ekind (E) = E_Package + and then Renamed_Entity (E) = Formal + then + Set_Is_Hidden (E); + exit; + end if; + + Next_Entity (E); + end loop; + end; End_Package_Scope (Formal); + Restore_Hidden_Primitives (Vis_Prims_List); if Parent_Installed then Remove_Parent; @@ -2279,7 +2521,12 @@ package body Sem_Ch12 is Set_Etype (Pack_Id, Standard_Void_Type); Set_Scope (Pack_Id, Scope (Formal)); Set_Has_Completion (Pack_Id, True); - end Analyze_Formal_Package; + + <> + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Pack_Id); + end if; + end Analyze_Formal_Package_Declaration; --------------------------------- -- Analyze_Formal_Private_Type -- @@ -2299,6 +2546,27 @@ package body Sem_Ch12 is Set_RM_Size (T, RM_Size (Standard_Integer)); end Analyze_Formal_Private_Type; + ------------------------------------ + -- Analyze_Formal_Incomplete_Type -- + ------------------------------------ + + procedure Analyze_Formal_Incomplete_Type + (T : Entity_Id; + Def : Node_Id) + is + begin + Enter_Name (T); + Set_Ekind (T, E_Incomplete_Type); + Set_Etype (T, T); + Set_Private_Dependents (T, New_Elmt_List); + + if Tagged_Present (Def) then + Set_Is_Tagged_Type (T); + Make_Class_Wide_Type (T); + Set_Direct_Primitive_Operations (T, New_Elmt_List); + end if; + end Analyze_Formal_Incomplete_Type; + ---------------------------------------- -- Analyze_Formal_Signed_Integer_Type -- ---------------------------------------- @@ -2309,7 +2577,9 @@ package body Sem_Ch12 is is Base : constant Entity_Id := New_Internal_Entity - (E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G'); + (E_Signed_Integer_Type, + Current_Scope, + Sloc (Defining_Identifier (Parent (Def))), 'G'); begin Enter_Name (T); @@ -2329,11 +2599,11 @@ package body Sem_Ch12 is Set_Parent (Base, Parent (Def)); end Analyze_Formal_Signed_Integer_Type; - ------------------------------- - -- Analyze_Formal_Subprogram -- - ------------------------------- + ------------------------------------------- + -- Analyze_Formal_Subprogram_Declaration -- + ------------------------------------------- - procedure Analyze_Formal_Subprogram (N : Node_Id) is + procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is Spec : constant Node_Id := Specification (N); Def : constant Node_Id := Default_Name (N); Nam : constant Entity_Id := Defining_Unit_Name (Spec); @@ -2346,7 +2616,7 @@ package body Sem_Ch12 is if Nkind (Nam) = N_Defining_Program_Unit_Name then Error_Msg_N ("name of formal subprogram must be a direct name", Nam); - return; + goto Leave; end if; Analyze_Subprogram_Declaration (N); @@ -2390,7 +2660,7 @@ package body Sem_Ch12 is Analyze (Prefix (Def)); Valid_Default_Attribute (Nam, Def); - return; + goto Leave; end if; -- Default name may be overloaded, in which case the interpretation @@ -2400,7 +2670,7 @@ package body Sem_Ch12 is -- can be a protected operation. if Etype (Def) = Any_Type then - return; + goto Leave; elsif Nkind (Def) = N_Selected_Component then if not Is_Overloadable (Entity (Selector_Name (Def))) then @@ -2422,7 +2692,7 @@ package body Sem_Ch12 is else Error_Msg_N ("expect valid subprogram name as default", Def); - return; + goto Leave; end if; elsif Nkind (Def) = N_Character_Literal then @@ -2435,7 +2705,7 @@ package body Sem_Ch12 is or else not Is_Overloadable (Entity (Def)) then Error_Msg_N ("expect valid subprogram name as default", Def); - return; + goto Leave; elsif not Is_Overloaded (Def) then Subp := Entity (Def); @@ -2483,7 +2753,11 @@ package body Sem_Ch12 is end; if Subp /= Any_Id then + + -- Subprogram found, generate reference to it + Set_Entity (Def, Subp); + Generate_Reference (Subp, Def); if Subp = Nam then Error_Msg_N ("premature usage of formal subprogram", Def); @@ -2497,7 +2771,13 @@ package body Sem_Ch12 is end if; end if; end if; - end Analyze_Formal_Subprogram; + + <> + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Nam); + end if; + + end Analyze_Formal_Subprogram_Declaration; ------------------------------------- -- Analyze_Formal_Type_Declaration -- @@ -2526,6 +2806,9 @@ package body Sem_Ch12 is when N_Formal_Derived_Type_Definition => Analyze_Formal_Derived_Type (N, T, Def); + when N_Formal_Incomplete_Type_Definition => + Analyze_Formal_Incomplete_Type (T, Def); + when N_Formal_Discrete_Type_Definition => Analyze_Formal_Discrete_Type (T, Def); @@ -2570,6 +2853,10 @@ package body Sem_Ch12 is end case; Set_Is_Generic_Type (T); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, T); + end if; end Analyze_Formal_Type_Declaration; ------------------------------------ @@ -2645,6 +2932,8 @@ package body Sem_Ch12 is Decl : Node_Id; begin + Check_SPARK_Restriction ("generic is not allowed", N); + -- We introduce a renaming of the enclosing package, to have a usable -- entity as the prefix of an expanded name for a local entity of the -- form Par.P.Q, where P is the generic package. This is because a local @@ -2746,6 +3035,10 @@ package body Sem_Ch12 is Check_References (Id); end if; end if; + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Id); + end if; end Analyze_Generic_Package_Declaration; -------------------------------------------- @@ -2762,6 +3055,8 @@ package body Sem_Ch12 is Typ : Entity_Id; begin + Check_SPARK_Restriction ("generic is not allowed", N); + -- Create copy of generic unit, and save for instantiation. If the unit -- is a child unit, do not copy the specifications for the parent, which -- are not part of the generic tree. @@ -2773,9 +3068,24 @@ package body Sem_Ch12 is Set_Parent_Spec (New_N, Save_Parent); Rewrite (N, New_N); + -- The aspect specifications are not attached to the tree, and must + -- be copied and attached to the generic copy explicitly. + + if Present (Aspect_Specifications (New_N)) then + declare + Aspects : constant List_Id := Aspect_Specifications (N); + begin + Set_Has_Aspects (N, False); + Move_Aspects (New_N, N); + Set_Has_Aspects (Original_Node (N), False); + Set_Aspect_Specifications (Original_Node (N), Aspects); + end; + end if; + Spec := Specification (N); Id := Defining_Entity (Spec); Generate_Definition (Id); + Set_Contract (Id, Make_Contract (Sloc (Id))); if Nkind (Id) = N_Defining_Operator_Symbol then Error_Msg_N @@ -2806,10 +3116,31 @@ package body Sem_Ch12 is if Nkind (Result_Definition (Spec)) = N_Access_Definition then Result_Type := Access_Definition (Spec, Result_Definition (Spec)); Set_Etype (Id, Result_Type); + + -- Check restriction imposed by AI05-073: a generic function + -- cannot return an abstract type or an access to such. + + -- This is a binding interpretation should it apply to earlier + -- versions of Ada as well as Ada 2012??? + + if Is_Abstract_Type (Designated_Type (Result_Type)) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N ("generic function cannot have an access result" + & " that designates an abstract type", Spec); + end if; + else Find_Type (Result_Definition (Spec)); Typ := Entity (Result_Definition (Spec)); + if Is_Abstract_Type (Typ) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N + ("generic function cannot have abstract result type", Spec); + end if; + -- If a null exclusion is imposed on the result type, then create -- a null-excluding itype (an access subtype) and use it as the -- function's Etype. @@ -2846,10 +3177,43 @@ package body Sem_Ch12 is Save_Global_References (Original_Node (N)); + -- To capture global references, analyze the expressions of aspects, + -- and propagate information to original tree. Note that in this case + -- analysis of attributes is not delayed until the freeze point. + + -- It seems very hard to recreate the proper visibility of the generic + -- subprogram at a later point because the analysis of an aspect may + -- create pragmas after the generic copies have been made ??? + + if Has_Aspects (N) then + declare + Aspect : Node_Id; + + begin + Aspect := First (Aspect_Specifications (N)); + while Present (Aspect) loop + if Get_Aspect_Id (Chars (Identifier (Aspect))) + /= Aspect_Warnings + then + Analyze (Expression (Aspect)); + end if; + Next (Aspect); + end loop; + + Aspect := First (Aspect_Specifications (Original_Node (N))); + while Present (Aspect) loop + Save_Global_References (Expression (Aspect)); + Next (Aspect); + end loop; + end; + end if; + End_Generic; End_Scope; Exit_Generic_Scope (Id); Generate_Reference_To_Formals (Id); + + List_Inherited_Pre_Post_Aspects (Id); end Analyze_Generic_Subprogram_Declaration; ----------------------------------- @@ -2879,6 +3243,9 @@ package body Sem_Ch12 is Needs_Body : Boolean; Inline_Now : Boolean := False; + Save_Style_Check : constant Boolean := Style_Check; + -- Save style check mode for restore on exit + procedure Delay_Descriptors (E : Entity_Id); -- Delay generation of subprogram descriptors for given entity @@ -2927,9 +3294,17 @@ package body Sem_Ch12 is return False; end Might_Inline_Subp; + -- Local declarations + + Vis_Prims_List : Elist_Id := No_Elist; + -- List of primitives made temporarily visible in the instantiation + -- to match the visibility of the formal type + -- Start of processing for Analyze_Package_Instantiation begin + Check_SPARK_Restriction ("generic is not allowed", N); + -- Very first thing: apply the special kludge for Text_IO processing -- in case we are instantiating one of the children of [Wide_]Text_IO. @@ -2939,6 +3314,12 @@ package body Sem_Ch12 is Instantiation_Node := N; + -- Turn off style checking in instances. If the check is enabled on the + -- generic unit, a warning in an instance would just be noise. If not + -- enabled on the generic, then a warning in an instance is just wrong. + + Style_Check := False; + -- Case of instantiation of a generic package if Nkind (N) = N_Package_Instantiation then @@ -2999,7 +3380,7 @@ package body Sem_Ch12 is if Etype (Gen_Unit) = Any_Type then Restore_Env; - return; + goto Leave; elsif Ekind (Gen_Unit) /= E_Generic_Package then @@ -3014,7 +3395,7 @@ package body Sem_Ch12 is end if; Restore_Env; - return; + goto Leave; end if; if In_Extended_Main_Source_Unit (N) then @@ -3057,7 +3438,7 @@ package body Sem_Ch12 is if In_Open_Scopes (Gen_Unit) then Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); Restore_Env; - return; + goto Leave; elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then Error_Msg_Node_2 := Current_Scope; @@ -3065,7 +3446,7 @@ package body Sem_Ch12 is ("circular Instantiation: & instantiated in &!", N, Gen_Unit); Circularity_Detected := True; Restore_Env; - return; + goto Leave; else Gen_Decl := Unit_Declaration_Node (Gen_Unit); @@ -3096,9 +3477,11 @@ package body Sem_Ch12 is Renaming_List := Analyze_Associations - (N, - Generic_Formal_Declarations (Act_Tree), - Generic_Formal_Declarations (Gen_Decl)); + (I_Node => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl)); + + Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); Set_Instance_Env (Gen_Unit, Act_Decl_Id); Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); @@ -3237,19 +3620,19 @@ package body Sem_Ch12 is or else Enclosing_Body_Present or else Present (Corresponding_Body (Gen_Decl))) and then (Is_In_Main_Unit (N) - or else Might_Inline_Subp - or else CodePeer_Mode) + or else Might_Inline_Subp) and then not Is_Actual_Pack and then not Inline_Now + and then not Alfa_Mode and then (Operating_Mode = Generate_Code - or else (Operating_Mode = Check_Semantics - and then ASIS_Mode)); + or else (Operating_Mode = Check_Semantics + and then ASIS_Mode)); -- If front_end_inlining is enabled, do not instantiate body if -- within a generic context. if (Front_End_Inlining - and then not Expander_Active) + and then not Expander_Active) or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) then Needs_Body := False; @@ -3270,10 +3653,10 @@ package body Sem_Ch12 is begin if Nkind (Decl) = N_Formal_Package_Declaration or else (Nkind (Decl) = N_Package_Declaration - and then Is_List_Member (Decl) - and then Present (Next (Decl)) - and then - Nkind (Next (Decl)) = + and then Is_List_Member (Decl) + and then Present (Next (Decl)) + and then + Nkind (Next (Decl)) = N_Formal_Package_Declaration) then Needs_Body := False; @@ -3282,15 +3665,18 @@ package body Sem_Ch12 is end if; end; - -- If we are generating the calling stubs from the instantiation of - -- a generic RCI package, we will not use the body of the generic - -- package. + -- Note that we generate the instance body even when generating + -- calling stubs for an RCI unit: it may be required e.g. if it + -- provides stream attributes for some type used in the profile of a + -- remote subprogram. If the instantiation is within the visible part + -- of the RCI, then calling stubs for any relevant subprogram will + -- be inserted immediately after the subprogram declaration, and + -- will take precedence over the subsequent (original) body. (The + -- stub and original body will be complete homographs, but this is + -- permitted in an instance). - if Distribution_Stub_Mode = Generate_Caller_Stub_Body - and then Is_Compilation_Unit (Defining_Entity (N)) - then - Needs_Body := False; - end if; + -- Could we do better and remove the original subprogram body in that + -- case??? if Needs_Body then @@ -3334,15 +3720,13 @@ package body Sem_Ch12 is Enclosing_Master := Scope (Enclosing_Master); end if; - elsif Ekind (Enclosing_Master) = E_Generic_Package then - Enclosing_Master := Scope (Enclosing_Master); - - elsif Is_Generic_Subprogram (Enclosing_Master) + elsif Is_Generic_Unit (Enclosing_Master) or else Ekind (Enclosing_Master) = E_Void then -- Cleanup actions will eventually be performed on the - -- enclosing instance, if any. Enclosing scope is void - -- in the formal part of a generic subprogram. + -- enclosing subprogram or package instance, if any. + -- Enclosing scope is void in the formal part of a + -- generic subprogram. exit Scope_Loop; @@ -3483,6 +3867,7 @@ package body Sem_Ch12 is Check_Formal_Packages (Act_Decl_Id); + Restore_Hidden_Primitives (Vis_Prims_List); Restore_Private_Views (Act_Decl_Id); Inherit_Context (Gen_Decl, N); @@ -3523,6 +3908,30 @@ package body Sem_Ch12 is Set_Defining_Identifier (N, Act_Decl_Id); end if; + Style_Check := Save_Style_Check; + + -- Check that if N is an instantiation of System.Dim_Float_IO or + -- System.Dim_Integer_IO, the formal type has a dimension system. + + if Nkind (N) = N_Package_Instantiation + and then Is_Dim_IO_Package_Instantiation (N) + then + declare + Assoc : constant Node_Id := First (Generic_Associations (N)); + begin + if not Has_Dimension_System + (Etype (Explicit_Generic_Actual_Parameter (Assoc))) + then + Error_Msg_N ("type with a dimension system expected", Assoc); + end if; + end; + end if; + + <> + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Act_Decl_Id); + end if; + exception when Instantiation_Error => if Parent_Installed then @@ -3532,6 +3941,8 @@ package body Sem_Ch12 is if Env_Installed then Restore_Env; end if; + + Style_Check := Save_Style_Check; end Analyze_Package_Instantiation; -------------------------- @@ -3548,8 +3959,7 @@ package body Sem_Ch12 is Cunit_Entity (Get_Source_Unit (Gen_Unit)); Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); Curr_Scope : Entity_Id := Empty; - Curr_Unit : constant Entity_Id := - Cunit_Entity (Current_Sem_Unit); + Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); Removed : Boolean := False; Num_Scopes : Int := 0; @@ -3843,12 +4253,12 @@ package body Sem_Ch12 is is begin if (Is_In_Main_Unit (N) - or else Is_Inlined (Subp) - or else Is_Inlined (Alias (Subp))) + or else Is_Inlined (Subp) + or else Is_Inlined (Alias (Subp))) and then (Operating_Mode = Generate_Code - or else (Operating_Mode = Check_Semantics - and then ASIS_Mode)) - and then (Expander_Active or else ASIS_Mode) + or else (Operating_Mode = Check_Semantics + and then ASIS_Mode)) + and then (Full_Expander_Active or else ASIS_Mode) and then not ABE_Is_Certain (N) and then not Is_Eliminated (Subp) then @@ -3861,6 +4271,7 @@ package body Sem_Ch12 is Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, Version => Ada_Version)); return True; + else return False; end if; @@ -3894,6 +4305,9 @@ package body Sem_Ch12 is Parent_Installed : Boolean := False; Renaming_List : List_Id; + Save_Style_Check : constant Boolean := Style_Check; + -- Save style check mode for restore on exit + procedure Analyze_Instance_And_Renamings; -- The instance must be analyzed in a context that includes the mappings -- of generic parameters into actuals. We create a package declaration @@ -3965,6 +4379,9 @@ package body Sem_Ch12 is Check_Formal_Packages (Pack_Id); Set_Is_Generic_Instance (Pack_Id, False); + -- Why do we clear Is_Generic_Instance??? We set it 20 lines + -- above??? + -- Body of the enclosing package is supplied when instantiating the -- subprogram body, after semantic analysis is completed. @@ -4049,9 +4466,17 @@ package body Sem_Ch12 is end if; end Analyze_Instance_And_Renamings; + -- Local variables + + Vis_Prims_List : Elist_Id := No_Elist; + -- List of primitives made temporarily visible in the instantiation + -- to match the visibility of the formal type + -- Start of processing for Analyze_Subprogram_Instantiation begin + Check_SPARK_Restriction ("generic is not allowed", N); + -- Very first thing: apply the special kludge for Text_IO processing -- in case we are instantiating one of the children of [Wide_]Text_IO. -- Of course such an instantiation is bogus (these are packages, not @@ -4062,6 +4487,13 @@ package body Sem_Ch12 is -- Make node global for error reporting Instantiation_Node := N; + + -- Turn off style checking in instances. If the check is enabled on the + -- generic unit, a warning in an instance would just be noise. If not + -- enabled on the generic, then a warning in an instance is just wrong. + + Style_Check := False; + Preanalyze_Actuals (N); Init_Env; @@ -4139,7 +4571,8 @@ package body Sem_Ch12 is Error_Msg_NE ("circular Instantiation: & instantiated in &!", N, Gen_Unit); Circularity_Detected := True; - return; + Restore_Hidden_Primitives (Vis_Prims_List); + goto Leave; end if; Gen_Decl := Unit_Declaration_Node (Gen_Unit); @@ -4165,9 +4598,11 @@ package body Sem_Ch12 is Renaming_List := Analyze_Associations - (N, - Generic_Formal_Declarations (Act_Tree), - Generic_Formal_Declarations (Gen_Decl)); + (I_Node => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl)); + + Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); -- The subprogram itself cannot contain a nested instance, so the -- current parent is left empty. @@ -4184,6 +4619,12 @@ package body Sem_Ch12 is Make_Subprogram_Declaration (Sloc (Act_Spec), Specification => Act_Spec); + -- The aspects have been copied previously, but they have to be + -- linked explicitly to the new subprogram declaration. Explicit + -- pre/postconditions on the instance are analyzed below, in a + -- separate step. + + Move_Aspects (Act_Tree, Act_Decl); Set_Categorization_From_Pragmas (Act_Decl); if Parent_Installed then @@ -4200,8 +4641,6 @@ package body Sem_Ch12 is -- for the compilation, we generate the instance body even if it is -- not within the main unit. - -- Any other pragmas might also be inherited ??? - if Is_Intrinsic_Subprogram (Gen_Unit) then Set_Is_Intrinsic_Subprogram (Anon_Id); Set_Is_Intrinsic_Subprogram (Act_Decl_Id); @@ -4211,17 +4650,41 @@ package body Sem_Ch12 is end if; end if; + -- Inherit convention from generic unit. Intrinsic convention, as for + -- an instance of unchecked conversion, is not inherited because an + -- explicit Ada instance has been created. + + if Has_Convention_Pragma (Gen_Unit) + and then Convention (Gen_Unit) /= Convention_Intrinsic + then + Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); + Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit)); + end if; + Generate_Definition (Act_Decl_Id); + Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id))); -- ??? needed? + Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id))); + + -- Inherit all inlining-related flags which apply to the generic in + -- the subprogram and its declaration. Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit)); Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit)); + Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); + Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); + + Set_Has_Pragma_Inline_Always + (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); + Set_Has_Pragma_Inline_Always + (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); + if not Is_Intrinsic_Subprogram (Gen_Unit) then Check_Elab_Instantiation (N); end if; if Is_Dispatching_Operation (Act_Decl_Id) - and then Ada_Version >= Ada_05 + and then Ada_Version >= Ada_2005 then declare Formal : Entity_Id; @@ -4247,8 +4710,6 @@ package body Sem_Ch12 is Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); - -- Subject to change, pending on if other pragmas are inherited ??? - Validate_Categorization_Dependency (N, Act_Decl_Id); if not Is_Intrinsic_Subprogram (Act_Decl_Id) then @@ -4291,12 +4752,20 @@ package body Sem_Ch12 is Remove_Parent; end if; + Restore_Hidden_Primitives (Vis_Prims_List); Restore_Env; Env_Installed := False; Generic_Renamings.Set_Last (0); Generic_Renamings_HTable.Reset; end if; + Style_Check := Save_Style_Check; + + <> + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Act_Decl_Id); + end if; + exception when Instantiation_Error => if Parent_Installed then @@ -4306,6 +4775,8 @@ package body Sem_Ch12 is if Env_Installed then Restore_Env; end if; + + Style_Check := Save_Style_Check; end Analyze_Subprogram_Instantiation; ------------------------- @@ -4453,7 +4924,7 @@ package body Sem_Ch12 is procedure Check_Access_Definition (N : Node_Id) is begin pragma Assert - (Ada_Version >= Ada_05 + (Ada_Version >= Ada_2005 and then Present (Access_Definition (N))); null; end Check_Access_Definition; @@ -4739,7 +5210,7 @@ package body Sem_Ch12 is -- that are attributes are rewritten as subprograms. If the -- subprogram in the formal package is defaulted, no check is -- needed. Note that this can only happen in Ada 2005 when the - -- formal package can be partially parametrized. + -- formal package can be partially parameterized. if Nkind (Unit_Declaration_Node (E1)) = N_Subprogram_Renaming_Declaration @@ -4747,6 +5218,27 @@ package body Sem_Ch12 is then null; + -- If the formal package has an "others" box association that + -- covers this formal, there is no need for a check either. + + elsif Nkind (Unit_Declaration_Node (E2)) in + N_Formal_Subprogram_Declaration + and then Box_Present (Unit_Declaration_Node (E2)) + then + null; + + -- No check needed if subprogram is a defaulted null procedure + + elsif No (Alias (E2)) + and then Ekind (E2) = E_Procedure + and then + Null_Present (Specification (Unit_Declaration_Node (E2))) + then + null; + + -- Otherwise the actual in the formal and the actual in the + -- instantiation of the formal must match, up to renamings. + else Check_Mismatch (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); @@ -4906,6 +5398,7 @@ package body Sem_Ch12 is else Check_Private_View (Subtype_Indication (Parent (E))); end if; + Set_Is_Generic_Actual_Type (E, True); Set_Is_Hidden (E, False); Set_Is_Potentially_Use_Visible (E, @@ -4994,6 +5487,63 @@ package body Sem_Ch12 is Set_Is_Hidden (E, False); end if; + if Ekind (E) = E_Constant then + + -- If the type of the actual is a private type declared in the + -- enclosing scope of the generic unit, the body of the generic + -- sees the full view of the type (because it has to appear in + -- the corresponding package body). If the type is private now, + -- exchange views to restore the proper visiblity in the instance. + + declare + Typ : constant Entity_Id := Base_Type (Etype (E)); + -- The type of the actual + + Gen_Id : Entity_Id; + -- The generic unit + + Parent_Scope : Entity_Id; + -- The enclosing scope of the generic unit + + begin + if Is_Wrapper_Package (Instance) then + Gen_Id := + Generic_Parent + (Specification + (Unit_Declaration_Node + (Related_Instance (Instance)))); + else + Gen_Id := + Generic_Parent + (Specification (Unit_Declaration_Node (Instance))); + end if; + + Parent_Scope := Scope (Gen_Id); + + -- The exchange is only needed if the generic is defined + -- within a package which is not a common ancestor of the + -- scope of the instance, and is not already in scope. + + if Is_Private_Type (Typ) + and then Scope (Typ) = Parent_Scope + and then Scope (Instance) /= Parent_Scope + and then Ekind (Parent_Scope) = E_Package + and then not Is_Child_Unit (Gen_Id) + then + Switch_View (Typ); + + -- If the type of the entity is a subtype, it may also + -- have to be made visible, together with the base type + -- of its full view, after exchange. + + if Is_Private_Type (Etype (E)) then + Switch_View (Etype (E)); + Switch_View (Base_Type (Etype (E))); + end if; + end if; + end; + end if; + Next_Entity (E); end loop; end Check_Generic_Actuals; @@ -5264,6 +5814,25 @@ package body Sem_Ch12 is then Install_Parent (Inst_Par); Parent_Installed := True; + + -- The generic unit may be the renaming of the implicit child + -- present in an instance. In that case the parent instance is + -- obtained from the name of the renamed entity. + + elsif Ekind (Entity (Gen_Id)) = E_Generic_Package + and then Present (Renamed_Entity (Entity (Gen_Id))) + and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) + then + declare + Renamed_Package : constant Node_Id := + Name (Parent (Entity (Gen_Id))); + begin + if Nkind (Renamed_Package) = N_Expanded_Name then + Inst_Par := Entity (Prefix (Renamed_Package)); + Install_Parent (Inst_Par); + Parent_Installed := True; + end if; + end; end if; end if; @@ -5507,6 +6076,49 @@ package body Sem_Ch12 is end if; end Check_Private_View; + ----------------------------- + -- Check_Hidden_Primitives -- + ----------------------------- + + function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is + Actual : Node_Id; + Gen_T : Entity_Id; + Result : Elist_Id := No_Elist; + + begin + if No (Assoc_List) then + return No_Elist; + end if; + + -- Traverse the list of associations between formals and actuals + -- searching for renamings of tagged types + + Actual := First (Assoc_List); + while Present (Actual) loop + if Nkind (Actual) = N_Subtype_Declaration then + Gen_T := Generic_Parent_Type (Actual); + + if Present (Gen_T) + and then Is_Tagged_Type (Gen_T) + then + -- Traverse the list of primitives of the actual types + -- searching for hidden primitives that are visible in the + -- corresponding generic formal; leave them visible and + -- append them to Result to restore their decoration later. + + Install_Hidden_Primitives + (Prims_List => Result, + Gen_T => Gen_T, + Act_T => Entity (Subtype_Indication (Actual))); + end if; + end if; + + Next (Actual); + end loop; + + return Result; + end Check_Hidden_Primitives; + -------------------------- -- Contains_Instance_Of -- -------------------------- @@ -5734,6 +6346,14 @@ package body Sem_Ch12 is New_N := New_Copy (N); + -- Copy aspects if present + + if Has_Aspects (N) then + Set_Has_Aspects (New_N, False); + Set_Aspect_Specifications + (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); + end if; + if Instantiating then Adjust_Instantiation_Sloc (New_N, S_Adjustment); end if; @@ -5906,12 +6526,19 @@ package body Sem_Ch12 is New_Body : Node_Id; begin + -- Make sure that, if it is a subunit of the main unit that is + -- preprocessed and if -gnateG is specified, the preprocessed + -- file will be written. + + Lib.Analysing_Subunit_Of_Main := + Lib.In_Extended_Main_Source_Unit (N); Unum := Load_Unit (Load_Name => Subunit_Name, Required => False, Subunit => True, Error_Node => N); + Lib.Analysing_Subunit_Of_Main := False; -- If the proper body is not found, a warning message will be -- emitted when analyzing the stub, or later at the point @@ -6069,8 +6696,8 @@ package body Sem_Ch12 is end if; end if; - -- Do not copy the associated node, which points to - -- the generic copy of the aggregate. + -- Do not copy the associated node, which points to the generic copy + -- of the aggregate. declare use Atree.Unchecked_Access; @@ -6084,9 +6711,9 @@ package body Sem_Ch12 is Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); end; - -- Allocators do not have an identifier denoting the access type, - -- so we must locate it through the expression to check whether - -- the views are consistent. + -- Allocators do not have an identifier denoting the access type, so we + -- must locate it through the expression to check whether the views are + -- consistent. elsif Nkind (N) = N_Allocator and then Nkind (Expression (N)) = N_Qualified_Expression @@ -6147,38 +6774,45 @@ package body Sem_Ch12 is -- Don't copy Ident or Comment pragmas, since the comment belongs to the -- generic unit, not to the instantiating unit. - elsif Nkind (N) = N_Pragma - and then Instantiating - then + elsif Nkind (N) = N_Pragma and then Instantiating then declare Prag_Id : constant Pragma_Id := Get_Pragma_Id (N); begin - if Prag_Id = Pragma_Ident - or else Prag_Id = Pragma_Comment - then + if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then New_N := Make_Null_Statement (Sloc (N)); + else Copy_Descendants; end if; end; - elsif Nkind_In (N, N_Integer_Literal, - N_Real_Literal, - N_String_Literal) - then + elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then + -- No descendant fields need traversing null; - -- For the remaining nodes, copy recursively their descendants + elsif Nkind (N) = N_String_Literal + and then Present (Etype (N)) + and then Instantiating + then + -- If the string is declared in an outer scope, the string_literal + -- subtype created for it may have the wrong scope. We force the + -- reanalysis of the constant to generate a new itype in the proper + -- context. + + Set_Etype (New_N, Empty); + Set_Analyzed (New_N, False); + + -- For the remaining nodes, copy their descendants recursively else Copy_Descendants; - if Instantiating - and then Nkind (N) = N_Subprogram_Body - then + if Instantiating and then Nkind (N) = N_Subprogram_Body then Set_Generic_Parent (Specification (New_N), N); + + -- Should preserve Corresponding_Spec??? (12.3(14)) end if; end if; @@ -6219,9 +6853,7 @@ package body Sem_Ch12 is if Renamed_Object (E1) = Pack then return True; - elsif E1 = P - or else Renamed_Object (E1) = P - then + elsif E1 = P or else Renamed_Object (E1) = P then return False; elsif Is_Actual_Of_Previous_Formal (E1) then @@ -6243,7 +6875,7 @@ package body Sem_Ch12 is Instance_Envs.Table (Instance_Envs.Last).Instantiated_Parent.Act_Id; else - Par := Current_Instantiated_Parent.Act_Id; + Par := Current_Instantiated_Parent.Act_Id; end if; if Ekind (Scop) = E_Generic_Package @@ -6304,6 +6936,181 @@ package body Sem_Ch12 is Expander_Mode_Restore; end End_Generic; + ------------- + -- Earlier -- + ------------- + + function Earlier (N1, N2 : Node_Id) return Boolean is + procedure Find_Depth (P : in out Node_Id; D : in out Integer); + -- Find distance from given node to enclosing compilation unit + + ---------------- + -- Find_Depth -- + ---------------- + + procedure Find_Depth (P : in out Node_Id; D : in out Integer) is + begin + while Present (P) + and then Nkind (P) /= N_Compilation_Unit + loop + P := True_Parent (P); + D := D + 1; + end loop; + end Find_Depth; + + -- Local declarations + + D1 : Integer := 0; + D2 : Integer := 0; + P1 : Node_Id := N1; + P2 : Node_Id := N2; + + -- Start of processing for Earlier + + begin + Find_Depth (P1, D1); + Find_Depth (P2, D2); + + if P1 /= P2 then + return False; + else + P1 := N1; + P2 := N2; + end if; + + while D1 > D2 loop + P1 := True_Parent (P1); + D1 := D1 - 1; + end loop; + + while D2 > D1 loop + P2 := True_Parent (P2); + D2 := D2 - 1; + end loop; + + -- At this point P1 and P2 are at the same distance from the root. + -- We examine their parents until we find a common declarative list. + -- If we reach the root, N1 and N2 do not descend from the same + -- declarative list (e.g. one is nested in the declarative part and + -- the other is in a block in the statement part) and the earlier + -- one is already frozen. + + while not Is_List_Member (P1) + or else not Is_List_Member (P2) + or else List_Containing (P1) /= List_Containing (P2) + loop + P1 := True_Parent (P1); + P2 := True_Parent (P2); + + if Nkind (Parent (P1)) = N_Subunit then + P1 := Corresponding_Stub (Parent (P1)); + end if; + + if Nkind (Parent (P2)) = N_Subunit then + P2 := Corresponding_Stub (Parent (P2)); + end if; + + if P1 = P2 then + return False; + end if; + end loop; + + -- Expanded code usually shares the source location of the original + -- construct it was generated for. This however may not necessarely + -- reflect the true location of the code within the tree. + + -- Before comparing the slocs of the two nodes, make sure that we are + -- working with correct source locations. Assume that P1 is to the left + -- of P2. If either one does not come from source, traverse the common + -- list heading towards the other node and locate the first source + -- statement. + + -- P1 P2 + -- ----+===+===+--------------+===+===+---- + -- expanded code expanded code + + if not Comes_From_Source (P1) then + while Present (P1) loop + + -- Neither P2 nor a source statement were located during the + -- search. If we reach the end of the list, then P1 does not + -- occur earlier than P2. + + -- ----> + -- start --- P2 ----- P1 --- end + + if No (Next (P1)) then + return False; + + -- We encounter P2 while going to the right of the list. This + -- means that P1 does indeed appear earlier. + + -- ----> + -- start --- P1 ===== P2 --- end + -- expanded code in between + + elsif P1 = P2 then + return True; + + -- No need to look any further since we have located a source + -- statement. + + elsif Comes_From_Source (P1) then + exit; + end if; + + -- Keep going right + + Next (P1); + end loop; + end if; + + if not Comes_From_Source (P2) then + while Present (P2) loop + + -- Neither P1 nor a source statement were located during the + -- search. If we reach the start of the list, then P1 does not + -- occur earlier than P2. + + -- <---- + -- start --- P2 --- P1 --- end + + if No (Prev (P2)) then + return False; + + -- We encounter P1 while going to the left of the list. This + -- means that P1 does indeed appear earlier. + + -- <---- + -- start --- P1 ===== P2 --- end + -- expanded code in between + + elsif P2 = P1 then + return True; + + -- No need to look any further since we have located a source + -- statement. + + elsif Comes_From_Source (P2) then + exit; + end if; + + -- Keep going left + + Prev (P2); + end loop; + end if; + + -- At this point either both nodes came from source or we approximated + -- their source locations through neighbouring source statements. + + if Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)) then + return True; + else + return False; + end if; + end Earlier; + ---------------------- -- Find_Actual_Type -- ---------------------- @@ -6363,126 +7170,37 @@ package body Sem_Ch12 is Gen_Body : Node_Id; Pack_Id : Entity_Id) is - F_Node : Node_Id; Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); Par : constant Entity_Id := Scope (Gen_Unit); + E_G_Id : Entity_Id; Enc_G : Entity_Id; Enc_I : Node_Id; - E_G_Id : Entity_Id; - - function Earlier (N1, N2 : Node_Id) return Boolean; - -- Yields True if N1 and N2 appear in the same compilation unit, - -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right - -- traversal of the tree for the unit. + F_Node : Node_Id; - function Enclosing_Body (N : Node_Id) return Node_Id; + function Enclosing_Package_Body (N : Node_Id) return Node_Id; -- Find innermost package body that encloses the given node, and which -- is not a compilation unit. Freeze nodes for the instance, or for its -- enclosing body, may be inserted after the enclosing_body of the - -- generic unit. + -- generic unit. Used to determine proper placement of freeze node for + -- both package and subprogram instances. function Package_Freeze_Node (B : Node_Id) return Node_Id; -- Find entity for given package body, and locate or create a freeze -- node for it. - function True_Parent (N : Node_Id) return Node_Id; - -- For a subunit, return parent of corresponding stub - - ------------- - -- Earlier -- - ------------- - - function Earlier (N1, N2 : Node_Id) return Boolean is - D1 : Integer := 0; - D2 : Integer := 0; - P1 : Node_Id := N1; - P2 : Node_Id := N2; - - procedure Find_Depth (P : in out Node_Id; D : in out Integer); - -- Find distance from given node to enclosing compilation unit - - ---------------- - -- Find_Depth -- - ---------------- - - procedure Find_Depth (P : in out Node_Id; D : in out Integer) is - begin - while Present (P) - and then Nkind (P) /= N_Compilation_Unit - loop - P := True_Parent (P); - D := D + 1; - end loop; - end Find_Depth; - - -- Start of processing for Earlier - - begin - Find_Depth (P1, D1); - Find_Depth (P2, D2); - - if P1 /= P2 then - return False; - else - P1 := N1; - P2 := N2; - end if; - - while D1 > D2 loop - P1 := True_Parent (P1); - D1 := D1 - 1; - end loop; - - while D2 > D1 loop - P2 := True_Parent (P2); - D2 := D2 - 1; - end loop; - - -- At this point P1 and P2 are at the same distance from the root. - -- We examine their parents until we find a common declarative - -- list, at which point we can establish their relative placement - -- by comparing their ultimate slocs. If we reach the root, - -- N1 and N2 do not descend from the same declarative list (e.g. - -- one is nested in the declarative part and the other is in a block - -- in the statement part) and the earlier one is already frozen. - - while not Is_List_Member (P1) - or else not Is_List_Member (P2) - or else List_Containing (P1) /= List_Containing (P2) - loop - P1 := True_Parent (P1); - P2 := True_Parent (P2); - - if Nkind (Parent (P1)) = N_Subunit then - P1 := Corresponding_Stub (Parent (P1)); - end if; - - if Nkind (Parent (P2)) = N_Subunit then - P2 := Corresponding_Stub (Parent (P2)); - end if; - - if P1 = P2 then - return False; - end if; - end loop; - - return - Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)); - end Earlier; - - -------------------- - -- Enclosing_Body -- - -------------------- + ---------------------------- + -- Enclosing_Package_Body -- + ---------------------------- - function Enclosing_Body (N : Node_Id) return Node_Id is - P : Node_Id := Parent (N); + function Enclosing_Package_Body (N : Node_Id) return Node_Id is + P : Node_Id; begin + P := Parent (N); while Present (P) and then Nkind (Parent (P)) /= N_Compilation_Unit loop if Nkind (P) = N_Package_Body then - if Nkind (Parent (P)) = N_Subunit then return Corresponding_Stub (Parent (P)); else @@ -6494,7 +7212,7 @@ package body Sem_Ch12 is end loop; return Empty; - end Enclosing_Body; + end Enclosing_Package_Body; ------------------------- -- Package_Freeze_Node -- @@ -6506,7 +7224,6 @@ package body Sem_Ch12 is begin if Nkind (B) = N_Package_Body then Id := Corresponding_Spec (B); - else pragma Assert (Nkind (B) = N_Package_Body_Stub); Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B)))); end if; @@ -6515,19 +7232,6 @@ package body Sem_Ch12 is return Freeze_Node (Id); end Package_Freeze_Node; - ----------------- - -- True_Parent -- - ----------------- - - function True_Parent (N : Node_Id) return Node_Id is - begin - if Nkind (Parent (N)) = N_Subunit then - return Parent (Corresponding_Stub (Parent (N))); - else - return Parent (N); - end if; - end True_Parent; - -- Start of processing of Freeze_Subprogram_Body begin @@ -6539,22 +7243,44 @@ package body Sem_Ch12 is -- packages. Otherwise, the freeze node is placed at the end of the -- current declarative part. - Enc_G := Enclosing_Body (Gen_Body); - Enc_I := Enclosing_Body (Inst_Node); + Enc_G := Enclosing_Package_Body (Gen_Body); + Enc_I := Enclosing_Package_Body (Inst_Node); Ensure_Freeze_Node (Pack_Id); F_Node := Freeze_Node (Pack_Id); if Is_Generic_Instance (Par) and then Present (Freeze_Node (Par)) - and then - In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) + and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) then - if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then + -- The parent was a premature instantiation. Insert freeze node at + -- the end the current declarative part. - -- The parent was a premature instantiation. Insert freeze node at - -- the end the current declarative part. - - Insert_After_Last_Decl (Inst_Node, F_Node); + if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); + + -- Handle the following case: + -- + -- package Parent_Inst is new ... + -- Parent_Inst [] + -- + -- procedure P ... -- this body freezes Parent_Inst + -- + -- package Inst is new ... + -- + -- In this particular scenario, the freeze node for Inst must be + -- inserted in the same manner as that of Parent_Inst - before the + -- next source body or at the end of the declarative list (body not + -- available). If body P did not exist and Parent_Inst was frozen + -- after Inst, either by a body following Inst or at the end of the + -- declarative region, the freeze node for Inst must be inserted + -- after that of Parent_Inst. This relation is established by + -- comparing the Slocs of Parent_Inst freeze node and Inst. + + elsif List_Containing (Get_Package_Instantiation_Node (Par)) = + List_Containing (Inst_Node) + and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node) + then + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); else Insert_After (Freeze_Node (Par), F_Node); @@ -6578,15 +7304,15 @@ package body Sem_Ch12 is In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) then -- The enclosing package may contain several instances. Rather - -- than computing the earliest point at which to insert its - -- freeze node, we place it at the end of the declarative part - -- of the parent of the generic. + -- than computing the earliest point at which to insert its freeze + -- node, we place it at the end of the declarative part of the + -- parent of the generic. - Insert_After_Last_Decl + Insert_Freeze_Node_For_Instance (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); end if; - Insert_After_Last_Decl (Inst_Node, F_Node); + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); elsif Present (Enc_G) and then Present (Enc_I) @@ -6602,12 +7328,12 @@ package body Sem_Ch12 is -- Freeze package that encloses instance, and place node after -- package that encloses generic. If enclosing package is already - -- frozen we have to assume it is at the proper place. This may be - -- a potential ABE that requires dynamic checking. Do not add a - -- freeze node if the package that encloses the generic is inside - -- the body that encloses the instance, because the freeze node - -- would be in the wrong scope. Additional contortions needed if - -- the bodies are within a subunit. + -- frozen we have to assume it is at the proper place. This may be a + -- potential ABE that requires dynamic checking. Do not add a freeze + -- node if the package that encloses the generic is inside the body + -- that encloses the instance, because the freeze node would be in + -- the wrong scope. Additional contortions needed if the bodies are + -- within a subunit. declare Enclosing_Body : Node_Id; @@ -6620,7 +7346,8 @@ package body Sem_Ch12 is end if; if Parent (List_Containing (Enc_G)) /= Enclosing_Body then - Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I)); + Insert_Freeze_Node_For_Instance + (Enc_G, Package_Freeze_Node (Enc_I)); end if; end; @@ -6632,13 +7359,13 @@ package body Sem_Ch12 is Insert_After (Enc_G, Freeze_Node (E_G_Id)); end if; - Insert_After_Last_Decl (Inst_Node, F_Node); + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); else -- If none of the above, insert freeze node at the end of the current -- declarative part. - Insert_After_Last_Decl (Inst_Node, F_Node); + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); end if; end Freeze_Subprogram_Body; @@ -6685,14 +7412,14 @@ package body Sem_Ch12 is -- investigated, and would allow this function to be significantly -- simplified. ??? - if Present (Package_Instantiation (A)) then - if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then - return Package_Instantiation (A); + Inst := Package_Instantiation (A); - elsif Nkind (Original_Node (Package_Instantiation (A))) = - N_Package_Instantiation - then - return Original_Node (Package_Instantiation (A)); + if Present (Inst) then + if Nkind (Inst) = N_Package_Instantiation then + return Inst; + + elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then + return Original_Node (Inst); end if; end if; @@ -6798,9 +7525,7 @@ package body Sem_Ch12 is -- now we depend on the user not redefining Standard itself in one of -- the parent units. - if Is_Immediately_Visible (C) - and then C /= Standard_Standard - then + if Is_Immediately_Visible (C) and then C /= Standard_Standard then Set_Is_Immediately_Visible (C, False); Append_Elmt (C, Hidden_Entities); end if; @@ -6857,6 +7582,7 @@ package body Sem_Ch12 is elsif Nkind_In (Nod, N_Subprogram_Body, N_Package_Body, + N_Package_Declaration, N_Task_Body, N_Protected_Body, N_Block_Statement) @@ -6864,7 +7590,7 @@ package body Sem_Ch12 is return False; elsif Nkind (Nod) = N_Subunit then - Nod := Corresponding_Stub (Nod); + Nod := Corresponding_Stub (Nod); elsif Nkind (Nod) = N_Compilation_Unit then return False; @@ -6907,10 +7633,9 @@ package body Sem_Ch12 is -- might produce false positives in rare cases, but guarantees -- that we produce all the instance bodies we will need. - if (Is_Entity_Name (Nam) - and then Chars (Nam) = Chars (E)) - or else (Nkind (Nam) = N_Selected_Component - and then Chars (Selector_Name (Nam)) = Chars (E)) + if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E)) + or else (Nkind (Nam) = N_Selected_Component + and then Chars (Selector_Name (Nam)) = Chars (E)) then return True; end if; @@ -6987,27 +7712,207 @@ package body Sem_Ch12 is Hidden_Entities := No_Elist; end Initialize; - ---------------------------- - -- Insert_After_Last_Decl -- - ---------------------------- + ------------------------------------- + -- Insert_Freeze_Node_For_Instance -- + ------------------------------------- + + procedure Insert_Freeze_Node_For_Instance + (N : Node_Id; + F_Node : Node_Id) + is + Inst : constant Entity_Id := Entity (F_Node); + Decl : Node_Id; + Decls : List_Id; + Par_N : Node_Id; + + function Enclosing_Body (N : Node_Id) return Node_Id; + -- Find enclosing package or subprogram body, if any. Freeze node + -- may be placed at end of current declarative list if previous + -- instance and current one have different enclosing bodies. + + function Previous_Instance (Gen : Entity_Id) return Entity_Id; + -- Find the local instance, if any, that declares the generic that is + -- being instantiated. If present, the freeze node for this instance + -- must follow the freeze node for the previous instance. + + -------------------- + -- Enclosing_Body -- + -------------------- + + function Enclosing_Body (N : Node_Id) return Node_Id is + P : Node_Id; + + begin + P := Parent (N); + while Present (P) + and then Nkind (Parent (P)) /= N_Compilation_Unit + loop + if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then + if Nkind (Parent (P)) = N_Subunit then + return Corresponding_Stub (Parent (P)); + else + return P; + end if; + end if; + + P := True_Parent (P); + end loop; + + return Empty; + end Enclosing_Body; + + ----------------------- + -- Previous_Instance -- + ----------------------- + + function Previous_Instance (Gen : Entity_Id) return Entity_Id is + S : Entity_Id; + + begin + S := Scope (Gen); + while Present (S) + and then S /= Standard_Standard + loop + if Is_Generic_Instance (S) + and then In_Same_Source_Unit (S, N) + then + return S; + end if; - procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is - L : List_Id := List_Containing (N); - P : constant Node_Id := Parent (L); + S := Scope (S); + end loop; + + return Empty; + end Previous_Instance; + + -- Start of processing for Insert_Freeze_Node_For_Instance begin if not Is_List_Member (F_Node) then - if Nkind (P) = N_Package_Specification - and then L = Visible_Declarations (P) - and then Present (Private_Declarations (P)) - and then not Is_Empty_List (Private_Declarations (P)) + Decls := List_Containing (N); + Par_N := Parent (Decls); + Decl := N; + + -- If this is a package instance, check whether the generic is + -- declared in a previous instance and the current instance is + -- not within the previous one. + + if Present (Generic_Parent (Parent (Inst))) + and then Is_In_Main_Unit (N) + then + declare + Enclosing_N : constant Node_Id := Enclosing_Body (N); + Par_I : constant Entity_Id := + Previous_Instance + (Generic_Parent (Parent (Inst))); + Scop : Entity_Id; + + begin + if Present (Par_I) + and then Earlier (N, Freeze_Node (Par_I)) + then + Scop := Scope (Inst); + + -- If the current instance is within the one that contains + -- the generic, the freeze node for the current one must + -- appear in the current declarative part. Ditto, if the + -- current instance is within another package instance or + -- within a body that does not enclose the current instance. + -- In these three cases the freeze node of the previous + -- instance is not relevant. + + while Present (Scop) + and then Scop /= Standard_Standard + loop + exit when Scop = Par_I + or else + (Is_Generic_Instance (Scop) + and then Scope_Depth (Scop) > Scope_Depth (Par_I)); + Scop := Scope (Scop); + end loop; + + -- Previous instance encloses current instance + + if Scop = Par_I then + null; + + -- If the next node is a source body we must freeze in + -- the current scope as well. + + elsif Present (Next (N)) + and then Nkind_In (Next (N), + N_Subprogram_Body, N_Package_Body) + and then Comes_From_Source (Next (N)) + then + null; + + -- Current instance is within an unrelated instance + + elsif Is_Generic_Instance (Scop) then + null; + + -- Current instance is within an unrelated body + + elsif Present (Enclosing_N) + and then Enclosing_N /= Enclosing_Body (Par_I) + then + null; + + else + Insert_After (Freeze_Node (Par_I), F_Node); + return; + end if; + end if; + end; + end if; + + -- When the instantiation occurs in a package declaration, append the + -- freeze node to the private declarations (if any). + + if Nkind (Par_N) = N_Package_Specification + and then Decls = Visible_Declarations (Par_N) + and then Present (Private_Declarations (Par_N)) + and then not Is_Empty_List (Private_Declarations (Par_N)) + then + Decls := Private_Declarations (Par_N); + Decl := First (Decls); + end if; + + -- Determine the proper freeze point of a package instantiation. We + -- adhere to the general rule of a package or subprogram body causing + -- freezing of anything before it in the same declarative region. In + -- this case, the proper freeze point of a package instantiation is + -- before the first source body which follows, or before a stub. This + -- ensures that entities coming from the instance are already frozen + -- and usable in source bodies. + + if Nkind (Par_N) /= N_Package_Declaration + and then Ekind (Inst) = E_Package + and then Is_Generic_Instance (Inst) + and then + not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst) then - L := Private_Declarations (P); + while Present (Decl) loop + if (Nkind (Decl) in N_Unit_Body + or else + Nkind (Decl) in N_Body_Stub) + and then Comes_From_Source (Decl) + then + Insert_Before (Decl, F_Node); + return; + end if; + + Next (Decl); + end loop; end if; - Insert_After (Last (L), F_Node); + -- In a package declaration, or if no previous body, insert at end + -- of list. + + Set_Sloc (F_Node, Sloc (Last (Decls))); + Insert_After (Last (Decls), F_Node); end if; - end Insert_After_Last_Decl; + end Insert_Freeze_Node_For_Instance; ------------------ -- Install_Body -- @@ -7047,9 +7952,10 @@ package body Sem_Ch12 is -------------------- function Enclosing_Subp (Id : Entity_Id) return Entity_Id is - Scop : Entity_Id := Scope (Id); + Scop : Entity_Id; begin + Scop := Scope (Id); while Scop /= Standard_Standard and then not Is_Overloadable (Scop) loop @@ -7084,9 +7990,8 @@ package body Sem_Ch12 is -- Start of processing for Install_Body begin - - -- If the body is a subunit, the freeze point is the corresponding - -- stub in the current compilation, not the subunit itself. + -- If the body is a subunit, the freeze point is the corresponding stub + -- in the current compilation, not the subunit itself. if Nkind (Parent (Gen_Body)) = N_Subunit then Orig_Body := Corresponding_Stub (Parent (Gen_Body)); @@ -7143,34 +8048,88 @@ package body Sem_Ch12 is -- generic. if In_Same_Declarative_Part (Freeze_Node (Par), N) then - Insert_After (Freeze_Node (Par), F_Node); + + -- Handle the following case: + + -- package Parent_Inst is new ... + -- Parent_Inst [] + + -- procedure P ... -- this body freezes Parent_Inst + + -- package Inst is new ... + + -- In this particular scenario, the freeze node for Inst must + -- be inserted in the same manner as that of Parent_Inst - + -- before the next source body or at the end of the declarative + -- list (body not available). If body P did not exist and + -- Parent_Inst was frozen after Inst, either by a body + -- following Inst or at the end of the declarative region, the + -- freeze node for Inst must be inserted after that of + -- Parent_Inst. This relation is established by comparing the + -- Slocs of Parent_Inst freeze node and Inst. + + if List_Containing (Get_Package_Instantiation_Node (Par)) = + List_Containing (N) + and then Sloc (Freeze_Node (Par)) < Sloc (N) + then + Insert_Freeze_Node_For_Instance (N, F_Node); + else + Insert_After (Freeze_Node (Par), F_Node); + end if; -- Freeze package enclosing instance of inner generic after -- instance of enclosing generic. - elsif Nkind (Parent (N)) = N_Package_Body + elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N)) then - declare - Enclosing : constant Entity_Id := - Corresponding_Spec (Parent (N)); + Enclosing : Entity_Id; begin - Insert_After_Last_Decl (N, F_Node); + Enclosing := Corresponding_Spec (Parent (N)); + + if No (Enclosing) then + Enclosing := Defining_Entity (Parent (N)); + end if; + + Insert_Freeze_Node_For_Instance (N, F_Node); Ensure_Freeze_Node (Enclosing); if not Is_List_Member (Freeze_Node (Enclosing)) then - Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing)); + + -- The enclosing context is a subunit, insert the freeze + -- node after the stub. + + if Nkind (Parent (Parent (N))) = N_Subunit then + Insert_Freeze_Node_For_Instance + (Corresponding_Stub (Parent (Parent (N))), + Freeze_Node (Enclosing)); + + -- The parent instance has been frozen before the body of + -- the enclosing package, insert the freeze node after + -- the body. + + elsif List_Containing (Freeze_Node (Par)) = + List_Containing (Parent (N)) + and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N)) + then + Insert_Freeze_Node_For_Instance + (Parent (N), Freeze_Node (Enclosing)); + + else + Insert_After + (Freeze_Node (Par), Freeze_Node (Enclosing)); + end if; end if; end; else - Insert_After_Last_Decl (N, F_Node); + Insert_Freeze_Node_For_Instance (N, F_Node); end if; else - Insert_After_Last_Decl (N, F_Node); + Insert_Freeze_Node_For_Instance (N, F_Node); end if; end if; @@ -7191,7 +8150,7 @@ package body Sem_Ch12 is begin E := First_Entity (Par); - -- In we are installing an instance parent, locate the formal packages + -- If we are installing an instance parent, locate the formal packages -- of its generic parent. if Is_Generic_Instance (Par) then @@ -7379,7 +8338,6 @@ package body Sem_Ch12 is -- Parent is not the name of an instantiation Install_Noninstance_Specs (Inst_Par); - exit; end if; @@ -7392,18 +8350,15 @@ package body Sem_Ch12 is if Present (First_Gen) then Append_Elmt (First_Par, Ancestors); - else Install_Noninstance_Specs (First_Par); end if; if not Is_Empty_Elmt_List (Ancestors) then Elmt := First_Elmt (Ancestors); - while Present (Elmt) loop Install_Spec (Node (Elmt)); Install_Formal_Packages (Node (Elmt)); - Next_Elmt (Elmt); end loop; end if; @@ -7413,6 +8368,138 @@ package body Sem_Ch12 is end if; end Install_Parent; + ------------------------------- + -- Install_Hidden_Primitives -- + ------------------------------- + + procedure Install_Hidden_Primitives + (Prims_List : in out Elist_Id; + Gen_T : Entity_Id; + Act_T : Entity_Id) + is + Elmt : Elmt_Id; + List : Elist_Id := No_Elist; + Prim_G_Elmt : Elmt_Id; + Prim_A_Elmt : Elmt_Id; + Prim_G : Node_Id; + Prim_A : Node_Id; + + begin + -- No action needed in case of serious errors because we cannot trust + -- in the order of primitives + + if Serious_Errors_Detected > 0 then + return; + + -- No action possible if we don't have available the list of primitive + -- operations + + elsif No (Gen_T) + or else not Is_Record_Type (Gen_T) + or else not Is_Tagged_Type (Gen_T) + or else not Is_Record_Type (Act_T) + or else not Is_Tagged_Type (Act_T) + then + return; + + -- There is no need to handle interface types since their primitives + -- cannot be hidden + + elsif Is_Interface (Gen_T) then + return; + end if; + + Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T)); + + if not Is_Class_Wide_Type (Act_T) then + Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T)); + else + Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T))); + end if; + + loop + -- Skip predefined primitives in the generic formal + + while Present (Prim_G_Elmt) + and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt)) + loop + Next_Elmt (Prim_G_Elmt); + end loop; + + -- Skip predefined primitives in the generic actual + + while Present (Prim_A_Elmt) + and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt)) + loop + Next_Elmt (Prim_A_Elmt); + end loop; + + exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt); + + Prim_G := Node (Prim_G_Elmt); + Prim_A := Node (Prim_A_Elmt); + + -- There is no need to handle interface primitives because their + -- primitives are not hidden + + exit when Present (Interface_Alias (Prim_G)); + + -- Here we install one hidden primitive + + if Chars (Prim_G) /= Chars (Prim_A) + and then Has_Suffix (Prim_A, 'P') + and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G) + then + Set_Chars (Prim_A, Chars (Prim_G)); + + if List = No_Elist then + List := New_Elmt_List; + end if; + + Append_Elmt (Prim_A, List); + end if; + + Next_Elmt (Prim_A_Elmt); + Next_Elmt (Prim_G_Elmt); + end loop; + + -- Append the elements to the list of temporarily visible primitives + -- avoiding duplicates. + + if Present (List) then + if No (Prims_List) then + Prims_List := New_Elmt_List; + end if; + + Elmt := First_Elmt (List); + while Present (Elmt) loop + Append_Unique_Elmt (Node (Elmt), Prims_List); + Next_Elmt (Elmt); + end loop; + end if; + end Install_Hidden_Primitives; + + ------------------------------- + -- Restore_Hidden_Primitives -- + ------------------------------- + + procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is + Prim_Elmt : Elmt_Id; + Prim : Node_Id; + + begin + if Prims_List /= No_Elist then + Prim_Elmt := First_Elmt (Prims_List); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + Set_Chars (Prim, Add_Suffix (Prim, 'P')); + Next_Elmt (Prim_Elmt); + end loop; + + Prims_List := No_Elist; + end if; + end Restore_Hidden_Primitives; + -------------------------------- -- Instantiate_Formal_Package -- -------------------------------- @@ -7933,9 +9020,7 @@ package body Sem_Ch12 is begin Gen_Scope := Scope (Analyzed_S); - while Present (Gen_Scope) - and then Is_Child_Unit (Gen_Scope) - loop + while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop if Scope (Subp) = Scope (Gen_Scope) then return True; end if; @@ -8116,14 +9201,12 @@ package body Sem_Ch12 is and then Present (Entity (Nam)) then if not Is_Overloaded (Nam) then - if From_Parent_Scope (Entity (Nam)) then Set_Is_Immediately_Visible (Entity (Nam), False); Set_Entity (Nam, Empty); Set_Etype (Nam, Empty); Analyze (Nam); - Set_Is_Immediately_Visible (Entity (Nam)); end if; @@ -8134,7 +9217,6 @@ package body Sem_Ch12 is begin Get_First_Interp (Nam, I, It); - while Present (It.Nam) loop if From_Parent_Scope (It.Nam) then Remove_Interp (I); @@ -8204,17 +9286,18 @@ package body Sem_Ch12 is Actual : Node_Id; Analyzed_Formal : Node_Id) return List_Id is + Gen_Obj : constant Entity_Id := Defining_Identifier (Formal); + A_Gen_Obj : constant Entity_Id := + Defining_Identifier (Analyzed_Formal); 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); Decl_Node : Node_Id; Def : Node_Id; Ftyp : Entity_Id; List : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Actual); - Orig_Ftyp : constant Entity_Id := - Etype (Defining_Identifier (Analyzed_Formal)); + Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj); Subt_Decl : Node_Id := Empty; Subt_Mark : Node_Id := Empty; @@ -8228,9 +9311,9 @@ package body Sem_Ch12 is -- Sloc for error message on missing actual - Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal))); + Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); - if Get_Instance_Of (Formal_Id) /= Formal_Id then + if Get_Instance_Of (Gen_Obj) /= Gen_Obj then Error_Msg_N ("duplicate instantiation of generic parameter", Actual); end if; @@ -8251,25 +9334,24 @@ package body Sem_Ch12 is if No (Actual) then Error_Msg_NE ("missing actual&", - Instantiation_Node, Formal_Id); + Instantiation_Node, Gen_Obj); Error_Msg_NE ("\in instantiation of & declared#", - Instantiation_Node, - Scope (Defining_Identifier (Analyzed_Formal))); + Instantiation_Node, Scope (A_Gen_Obj)); Abandon_Instantiation (Instantiation_Node); end if; if Present (Subt_Mark) then Decl_Node := Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => New_Copy (Formal_Id), + Defining_Identifier => New_Copy (Gen_Obj), Subtype_Mark => New_Copy_Tree (Subt_Mark), Name => Actual); else pragma Assert (Present (Acc_Def)); Decl_Node := Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => New_Copy (Formal_Id), + Defining_Identifier => New_Copy (Gen_Obj), Access_Definition => New_Copy_Tree (Acc_Def), Name => Actual); end if; @@ -8302,11 +9384,28 @@ package body Sem_Ch12 is end if; -- The actual has to be resolved in order to check that it is a - -- variable (due to cases such as F(1), where F returns - -- access to an array, and for overloaded prefixes). + -- variable (due to cases such as F (1), where F returns access to an + -- array, and for overloaded prefixes). + + Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); - Ftyp := - Get_Instance_Of (Etype (Defining_Identifier (Analyzed_Formal))); + -- If the type of the formal is not itself a formal, and the + -- current unit is a child unit, the formal type must be declared + -- in a parent, and must be retrieved by visibility. + + if Ftyp = Orig_Ftyp + and then Is_Generic_Unit (Scope (Ftyp)) + and then Is_Child_Unit (Scope (A_Gen_Obj)) + then + declare + Temp : constant Node_Id := + New_Copy_Tree (Subtype_Mark (Analyzed_Formal)); + begin + Set_Entity (Temp, Empty); + Find_Type (Temp); + Ftyp := Entity (Temp); + end; + end if; if Is_Private_Type (Ftyp) and then not Is_Private_Type (Etype (Actual)) @@ -8334,7 +9433,7 @@ package body Sem_Ch12 is if not Denotes_Variable (Actual) then Error_Msg_NE - ("actual for& must be a variable", Actual, Formal_Id); + ("actual for& must be a variable", Actual, Gen_Obj); elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then @@ -8342,7 +9441,7 @@ package body Sem_Ch12 is -- the type of the actual shall resolve to a specific anonymous -- access type. - if Ada_Version < Ada_05 + if Ada_Version < Ada_2005 or else Ekind (Base_Type (Ftyp)) /= E_Anonymous_Access_Type @@ -8351,7 +9450,7 @@ package body Sem_Ch12 is E_Anonymous_Access_Type then Error_Msg_NE ("type of actual does not match type of&", - Actual, Formal_Id); + Actual, Gen_Obj); end if; end if; @@ -8390,7 +9489,7 @@ package body Sem_Ch12 is Decl_Node := Make_Object_Declaration (Loc, - Defining_Identifier => New_Copy (Formal_Id), + Defining_Identifier => New_Copy (Gen_Obj), Constant_Present => True, Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => New_Copy_Tree (Def), @@ -8401,9 +9500,7 @@ package body Sem_Ch12 is -- A generic formal object of a tagged type is defined to be -- aliased so the new constant must also be treated as aliased. - if Is_Tagged_Type - (Etype (Defining_Identifier (Analyzed_Formal))) - then + if Is_Tagged_Type (Etype (A_Gen_Obj)) then Set_Aliased_Present (Decl_Node); end if; @@ -8423,11 +9520,8 @@ package body Sem_Ch12 is end if; declare - Formal_Object : constant Entity_Id := - Defining_Identifier (Analyzed_Formal); - Formal_Type : constant Entity_Id := Etype (Formal_Object); - - Typ : Entity_Id; + Formal_Type : constant Entity_Id := Etype (A_Gen_Obj); + Typ : Entity_Id; begin Typ := Get_Instance_Of (Formal_Type); @@ -8464,7 +9558,7 @@ package body Sem_Ch12 is Decl_Node := Make_Object_Declaration (Sloc (Formal), - Defining_Identifier => New_Copy (Formal_Id), + Defining_Identifier => New_Copy (Gen_Obj), Constant_Present => True, Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => New_Copy (Def), @@ -8477,14 +9571,12 @@ package body Sem_Ch12 is else Error_Msg_NE ("missing actual&", - Instantiation_Node, Formal_Id); + Instantiation_Node, Gen_Obj); Error_Msg_NE ("\in instantiation of & declared#", - Instantiation_Node, - Scope (Defining_Identifier (Analyzed_Formal))); + Instantiation_Node, Scope (A_Gen_Obj)); + + if Is_Scalar_Type (Etype (A_Gen_Obj)) then - if Is_Scalar_Type - (Etype (Defining_Identifier (Analyzed_Formal))) - then -- Create dummy constant declaration so that instance can be -- analyzed, to minimize cascaded visibility errors. @@ -8496,12 +9588,12 @@ package body Sem_Ch12 is Decl_Node := Make_Object_Declaration (Loc, - Defining_Identifier => New_Copy (Formal_Id), + Defining_Identifier => New_Copy (Gen_Obj), Constant_Present => True, Null_Exclusion_Present => Null_Exclusion_Present (Formal), Object_Definition => New_Copy (Def), Expression => - Make_Attribute_Reference (Sloc (Formal_Id), + Make_Attribute_Reference (Sloc (Gen_Obj), Attribute_Name => Name_First, Prefix => New_Copy (Def))); @@ -8527,7 +9619,7 @@ package body Sem_Ch12 is -- Otherwise, the subtype of the actual matching the formal object -- declaration shall exclude null. - if Ada_Version >= Ada_05 + if Ada_Version >= Ada_2005 and then Present (Actual_Decl) and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration, @@ -8575,6 +9667,10 @@ package body Sem_Ch12 is Par_Ent : Entity_Id := Empty; Par_Vis : Boolean := False; + Vis_Prims_List : Elist_Id := No_Elist; + -- List of primitives made temporarily visible in the instantiation + -- to match the visibility of the formal type + begin Gen_Body_Id := Corresponding_Body (Gen_Decl); @@ -8602,8 +9698,6 @@ package body Sem_Ch12 is Gen_Body_Id := Corresponding_Body (Gen_Decl); end if; - Mark_Context (Act_Decl, Gen_Decl); - -- Establish global variable for sloc adjustment and for error recovery Instantiation_Node := Inst_Node; @@ -8641,10 +9735,33 @@ package body Sem_Ch12 is Act_Body_Name := Act_Body_Id; end if; - Set_Defining_Unit_Name (Act_Body, Act_Body_Name); + Set_Defining_Unit_Name (Act_Body, Act_Body_Name); + + Set_Corresponding_Spec (Act_Body, Act_Decl_Id); + Check_Generic_Actuals (Act_Decl_Id, False); + + -- Install primitives hidden at the point of the instantiation but + -- visible when processing the generic formals + + declare + E : Entity_Id; + + begin + E := First_Entity (Act_Decl_Id); + while Present (E) loop + if Is_Type (E) + and then Is_Generic_Actual_Type (E) + and then Is_Tagged_Type (E) + then + Install_Hidden_Primitives + (Prims_List => Vis_Prims_List, + Gen_T => Generic_Parent_Type (Parent (E)), + Act_T => E); + end if; - Set_Corresponding_Spec (Act_Body, Act_Decl_Id); - Check_Generic_Actuals (Act_Decl_Id, False); + Next_Entity (E); + end loop; + end; -- If it is a child unit, make the parent instance (which is an -- instance of the parent of the generic) visible. The parent @@ -8738,6 +9855,7 @@ package body Sem_Ch12 is Set_Is_Immediately_Visible (Par_Ent, Par_Vis); end if; + Restore_Hidden_Primitives (Vis_Prims_List); Restore_Private_Views (Act_Decl_Id); -- Remove the current unit from visibility if this is an instance @@ -8886,7 +10004,6 @@ package body Sem_Ch12 is if Present (Gen_Body_Id) then Gen_Body := Unit_Declaration_Node (Gen_Body_Id); - Mark_Context (Inst_Node, Gen_Decl); if Nkind (Gen_Body) = N_Subprogram_Body_Stub then @@ -9141,9 +10258,13 @@ package body Sem_Ch12 is procedure Validate_Access_Type_Instance; procedure Validate_Derived_Type_Instance; procedure Validate_Derived_Interface_Type_Instance; + procedure Validate_Discriminated_Formal_Type; procedure Validate_Interface_Type_Instance; procedure Validate_Private_Type_Instance; - -- These procedures perform validation tests for the named case + procedure Validate_Incomplete_Type_Instance; + -- These procedures perform validation tests for the named case. + -- Validate_Discriminated_Formal_Type is shared by formal private + -- types and Ada 2012 formal incomplete types. function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean; -- Check that base types are the same and that the subtypes match @@ -9360,7 +10481,7 @@ package body Sem_Ch12 is I2 := First_Index (Act_T); for J in 1 .. Formal_Dimensions loop - -- If the indices of the actual were given by a subtype_mark, + -- If the indexes of the actual were given by a subtype_mark, -- the index was transformed into a range attribute. Retrieve -- the original type mark for checking. @@ -9549,7 +10670,7 @@ package body Sem_Ch12 is -- Ada 2005 (AI-251) - if Ada_Version >= Ada_05 + if Ada_Version >= Ada_2005 and then Is_Interface (Ancestor) then if not Interface_Present_In_Ancestor (Act_T, Ancestor) then @@ -9569,7 +10690,7 @@ package body Sem_Ch12 is -- that the formal type declaration has been rewritten as a private -- extension. - if Ada_Version >= Ada_05 + if Ada_Version >= Ada_2005 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration and then Synchronized_Present (Parent (A_Gen_T)) then @@ -9592,17 +10713,15 @@ package body Sem_Ch12 is end if; end if; - -- Perform atomic/volatile checks (RM C.6(12)) + -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1 + -- removes the second instance of the phrase "or allow pass by copy". if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then Error_Msg_N ("cannot have atomic actual type for non-atomic formal type", Actual); - elsif Is_Volatile (Act_T) - and then not Is_Volatile (Ancestor) - and then Is_By_Reference_Type (Ancestor) - then + elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then Error_Msg_N ("cannot have volatile actual type for non-volatile formal type", Actual); @@ -9951,88 +11070,38 @@ package body Sem_Ch12 is -- interface then the generic formal is not unless declared -- explicitly so. If not declared limited, the actual cannot be -- limited (see AI05-0087). - -- Disable check for now, limited interfaces implemented by - -- protected types are common, Need to update tests ??? + + -- Even though this AI is a binding interpretation, we enable the + -- check only in Ada 2012 mode, because this improper construct + -- shows up in user code and in existing B-tests. if Is_Limited_Type (Act_T) and then not Is_Limited_Type (A_Gen_T) - and then False + and then Ada_Version >= Ada_2012 then - Error_Msg_NE - ("actual for non-limited & cannot be a limited type", Actual, - Gen_T); - Explain_Limited_Type (Act_T, Actual); - Abandon_Instantiation (Actual); + if In_Instance then + null; + else + Error_Msg_NE + ("actual for non-limited & cannot be a limited type", Actual, + Gen_T); + Explain_Limited_Type (Act_T, Actual); + Abandon_Instantiation (Actual); + end if; end if; end Validate_Derived_Type_Instance; - -------------------------------------- - -- Validate_Interface_Type_Instance -- - -------------------------------------- - - procedure Validate_Interface_Type_Instance is - begin - if not Is_Interface (Act_T) then - Error_Msg_NE - ("actual for formal interface type must be an interface", - Actual, Gen_T); - - elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) - or else - Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) - or else - Is_Protected_Interface (A_Gen_T) /= - Is_Protected_Interface (Act_T) - or else - Is_Synchronized_Interface (A_Gen_T) /= - Is_Synchronized_Interface (Act_T) - then - Error_Msg_NE - ("actual for interface& does not match (RM 12.5.5(4))", - Actual, Gen_T); - end if; - end Validate_Interface_Type_Instance; - - ------------------------------------ - -- Validate_Private_Type_Instance -- - ------------------------------------ + ---------------------------------------- + -- Validate_Discriminated_Formal_Type -- + ---------------------------------------- - procedure Validate_Private_Type_Instance is + procedure Validate_Discriminated_Formal_Type is Formal_Discr : Entity_Id; Actual_Discr : Entity_Id; Formal_Subt : Entity_Id; begin - if Is_Limited_Type (Act_T) - and then not Is_Limited_Type (A_Gen_T) - then - Error_Msg_NE - ("actual for non-limited & cannot be a limited type", Actual, - Gen_T); - Explain_Limited_Type (Act_T, 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) - and then not Is_Indefinite_Subtype (A_Gen_T) - and then Ada_Version >= Ada_95 - then - Error_Msg_NE - ("actual for & must be a definite subtype", Actual, Gen_T); - - elsif not Is_Tagged_Type (Act_T) - and then Is_Tagged_Type (A_Gen_T) - then - Error_Msg_NE - ("actual for & must be a tagged type", Actual, Gen_T); - - elsif Has_Discriminants (A_Gen_T) then + if Has_Discriminants (A_Gen_T) then if not Has_Discriminants (Act_T) then Error_Msg_NE ("actual for & must have discriminants", Actual, Gen_T); @@ -10097,9 +11166,93 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; end if; + end if; + end Validate_Discriminated_Formal_Type; + + --------------------------------------- + -- Validate_Incomplete_Type_Instance -- + --------------------------------------- + + procedure Validate_Incomplete_Type_Instance is + begin + if not Is_Tagged_Type (Act_T) + and then Is_Tagged_Type (A_Gen_T) + then + Error_Msg_NE + ("actual for & must be a tagged type", Actual, Gen_T); + end if; + + Validate_Discriminated_Formal_Type; + end Validate_Incomplete_Type_Instance; + + -------------------------------------- + -- Validate_Interface_Type_Instance -- + -------------------------------------- + + procedure Validate_Interface_Type_Instance is + begin + if not Is_Interface (Act_T) then + Error_Msg_NE + ("actual for formal interface type must be an interface", + Actual, Gen_T); + + elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) + or else + Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) + or else + Is_Protected_Interface (A_Gen_T) /= + Is_Protected_Interface (Act_T) + or else + Is_Synchronized_Interface (A_Gen_T) /= + Is_Synchronized_Interface (Act_T) + then + Error_Msg_NE + ("actual for interface& does not match (RM 12.5.5(4))", + Actual, Gen_T); + end if; + end Validate_Interface_Type_Instance; + + ------------------------------------ + -- Validate_Private_Type_Instance -- + ------------------------------------ + + procedure Validate_Private_Type_Instance is + begin + if Is_Limited_Type (Act_T) + and then not Is_Limited_Type (A_Gen_T) + then + if In_Instance then + null; + else + Error_Msg_NE + ("actual for non-limited & cannot be a limited type", Actual, + Gen_T); + Explain_Limited_Type (Act_T, Actual); + Abandon_Instantiation (Actual); + end if; + + 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) + and then not Is_Indefinite_Subtype (A_Gen_T) + and then Ada_Version >= Ada_95 + then + Error_Msg_NE + ("actual for & must be a definite subtype", Actual, Gen_T); + elsif not Is_Tagged_Type (Act_T) + and then Is_Tagged_Type (A_Gen_T) + then + Error_Msg_NE + ("actual for & must be a tagged type", Actual, Gen_T); end if; + Validate_Discriminated_Formal_Type; Ancestor := Gen_T; end Validate_Private_Type_Instance; @@ -10157,7 +11310,13 @@ package body Sem_Ch12 is and then Ekind (Root_Type (Act_T)) = E_Incomplete_Type) then - if Is_Class_Wide_Type (Act_T) + -- If the formal is an incomplete type, the actual can be + -- incomplete as well. + + if Ekind (A_Gen_T) = E_Incomplete_Type then + null; + + elsif Is_Class_Wide_Type (Act_T) or else No (Full_View (Act_T)) then Error_Msg_N ("premature use of incomplete type", Actual); @@ -10180,7 +11339,14 @@ package body Sem_Ch12 is and then not Is_Derived_Type (Act_T) and then No (Full_View (Root_Type (Act_T))) then - Error_Msg_N ("premature use of private type", Actual); + -- If the formal is an incomplete type, the actual can be + -- private or incomplete as well. + + if Ekind (A_Gen_T) = E_Incomplete_Type then + null; + else + Error_Msg_N ("premature use of private type", Actual); + end if; elsif Has_Private_Component (Act_T) then Error_Msg_N @@ -10222,6 +11388,9 @@ package body Sem_Ch12 is when N_Formal_Private_Type_Definition => Validate_Private_Type_Instance; + when N_Formal_Incomplete_Type_Definition => + Validate_Incomplete_Type_Instance; + when N_Formal_Derived_Type_Definition => Validate_Derived_Type_Instance; @@ -10325,6 +11494,10 @@ package body Sem_Ch12 is -- parent, but the analyzed formal that includes the interface -- operations of all its progenitors. + -- Same treatment for formal private types, so we can check whether the + -- type is tagged limited when validating derivations in the private + -- part. (See AI05-096). + if Nkind (Def) = N_Formal_Derived_Type_Definition then if Present (Interface_List (Def)) then Set_Generic_Parent_Type (Decl_Node, A_Gen_T); @@ -10332,8 +11505,11 @@ package body Sem_Ch12 is Set_Generic_Parent_Type (Decl_Node, Ancestor); end if; - elsif Nkind (Def) = N_Formal_Private_Type_Definition then - Set_Generic_Parent_Type (Decl_Node, Ancestor); + elsif Nkind_In (Def, + N_Formal_Private_Type_Definition, + N_Formal_Incomplete_Type_Definition) + then + Set_Generic_Parent_Type (Decl_Node, A_Gen_T); end if; -- If the actual is a synchronized type that implements an interface, @@ -10378,154 +11554,6 @@ package body Sem_Ch12 is return Decl_Nodes; end Instantiate_Type; - ----------------------- - -- Is_Generic_Formal -- - ----------------------- - - function Is_Generic_Formal (E : Entity_Id) return Boolean is - Kind : Node_Kind; - begin - if No (E) then - return False; - else - Kind := Nkind (Parent (E)); - return - Nkind_In (Kind, N_Formal_Object_Declaration, - N_Formal_Package_Declaration, - 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; - - ------------------ - -- Mark_Context -- - ------------------ - - procedure Mark_Context (Inst_Decl : Node_Id; Gen_Decl : Node_Id) is - Loc : constant Source_Ptr := Sloc (Inst_Decl); - Inst_CU : constant Unit_Number_Type := Get_Code_Unit (Inst_Decl); - - -- Note that we use Get_Code_Unit to determine the position of the - -- instantiation, because it may itself appear within another instance - -- and we need to mark the context of the enclosing unit, not that of - -- the unit that contains the generic. - - Gen_CU : constant Unit_Number_Type := Get_Source_Unit (Gen_Decl); - Inst : Entity_Id; - Clause : Node_Id; - Scop : Entity_Id; - - procedure Add_Implicit_With (CU : Unit_Number_Type); - -- If a generic is instantiated in the direct or indirect context of - -- the current unit, but there is no with_clause for it in the current - -- context, add a with_clause for it to indicate that the body of the - -- generic should be examined before the current unit. - - procedure Add_Implicit_With (CU : Unit_Number_Type) is - Withn : constant Node_Id := - Make_With_Clause (Loc, - Name => New_Occurrence_Of (Cunit_Entity (CU), Loc)); - begin - Set_Implicit_With (Withn); - Set_Library_Unit (Withn, Cunit (CU)); - Set_Withed_Body (Withn, Cunit (CU)); - Prepend (Withn, Context_Items (Cunit (Inst_CU))); - end Add_Implicit_With; - - begin - -- This is only relevant when compiling for CodePeer. In what follows, - -- C is the current unit containing the instance body, and G is the - -- generic unit in that instance. - - if not CodePeer_Mode then - return; - end if; - - -- Nothing to do if G is local. - - if Inst_CU = Gen_CU then - return; - end if; - - -- If G is itself declared within an instance, indicate that the - -- generic body of that instance is also needed by C. This must be - -- done recursively. - - Scop := Scope (Defining_Entity (Gen_Decl)); - - while Is_Generic_Instance (Scop) - and then Ekind (Scop) = E_Package - loop - Mark_Context - (Inst_Decl, - Unit_Declaration_Node - (Generic_Parent - (Specification (Unit_Declaration_Node (Scop))))); - Scop := Scope (Scop); - end loop; - - -- Add references to other generic units in the context of G, because - -- they may be instantiated within G, and their bodies needed by C. - - Clause := First (Context_Items (Cunit (Gen_CU))); - - while Present (Clause) loop - if Nkind (Clause) = N_With_Clause - and then - Nkind (Unit (Library_Unit (Clause))) - = N_Generic_Package_Declaration - then - Add_Implicit_With (Get_Source_Unit (Library_Unit (Clause))); - end if; - - Next (Clause); - end loop; - - -- Now indicate that the body of G is needed by C - - Clause := First (Context_Items (Cunit (Inst_CU))); - while Present (Clause) loop - if Nkind (Clause) = N_With_Clause - and then Library_Unit (Clause) = Cunit (Gen_CU) - then - Set_Withed_Body (Clause, Cunit (Gen_CU)); - return; - end if; - - Next (Clause); - end loop; - - -- If the with-clause for G is not in the context of C, it may appear in - -- some ancestor of C. - - Inst := Cunit_Entity (Inst_CU); - while Is_Child_Unit (Inst) loop - Inst := Scope (Inst); - - Clause := - First (Context_Items (Parent (Unit_Declaration_Node (Inst)))); - while Present (Clause) loop - if Nkind (Clause) = N_With_Clause - and then Library_Unit (Clause) = Cunit (Gen_CU) - then - Set_Withed_Body (Clause, Cunit (Gen_CU)); - return; - end if; - - Next (Clause); - end loop; - end loop; - - -- If not found, G comes from an instance elsewhere in the context. Make - -- the dependence explicit in the context of C. - - Add_Implicit_With (Gen_CU); - end Mark_Context; - --------------------- -- Is_In_Main_Unit -- --------------------- @@ -11212,6 +12240,7 @@ package body Sem_Ch12 is -- stack contains the parent instances of the instantiation, followed by -- the original S. + Cur_P : Entity_Id; E : Entity_Id; P : Entity_Id; Hidden : Elmt_Id; @@ -11234,9 +12263,18 @@ package body Sem_Ch12 is Next_Entity (E); end loop; - if Is_Generic_Instance (Current_Scope) - and then P /= Current_Scope - then + -- If instantiation is declared in a block, it is the enclosing + -- scope that might be a parent instance. Note that only one + -- block can be involved, because the parent instances have + -- been installed within it. + + if Ekind (P) = E_Block then + Cur_P := Scope (P); + else + Cur_P := P; + end if; + + if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then -- We are within an instance of some sibling. Retain -- visibility of parent, for proper subsequent cleanup, and -- reinstall private declarations as well. @@ -11246,7 +12284,7 @@ package body Sem_Ch12 is end if; -- If the ultimate parent is a top-level unit recorded in - -- Instance_Parent_Unit, then reset its visibility to what is was + -- Instance_Parent_Unit, then reset its visibility to what it was -- before instantiation. (It's not clear what the purpose is of -- testing whether Scope (P) is In_Open_Scopes, but that test was -- present before the ultimate parent test was added.???) @@ -11389,11 +12427,11 @@ package body Sem_Ch12 is while Present (M) loop Typ := Node (M); - -- Subtypes of types whose views have been exchanged, and that - -- are defined within the instance, were not on the list of - -- Private_Dependents on entry to the instance, so they have to be - -- exchanged explicitly now, in order to remain consistent with the - -- view of the parent type. + -- Subtypes of types whose views have been exchanged, and that are + -- defined within the instance, were not on the Private_Dependents + -- list on entry to the instance, so they have to be exchanged + -- explicitly now, in order to remain consistent with the view of the + -- parent type. if Ekind_In (Typ, E_Private_Type, E_Limited_Private_Type, @@ -11437,11 +12475,11 @@ package body Sem_Ch12 is -- An unusual case of aliasing: the actual may also be directly -- visible in the generic, and be private there, while it is fully -- visible in the context of the instance. The internal subtype - -- is private in the instance, but has full visibility like its + -- is private in the instance but has full visibility like its -- parent in the enclosing scope. This enforces the invariant that -- the privacy status of all private dependents of a type coincide -- with that of the parent type. This can only happen when a - -- generic child unit is instantiated within sibling. + -- generic child unit is instantiated within a sibling. if Is_Private_Type (E) and then not Is_Private_Type (Etype (E)) @@ -11457,16 +12495,14 @@ package body Sem_Ch12 is -- a formal package, make its own formals private as well. The -- actual in this case is itself the renaming of an instantiation. -- If the entity is not a package renaming, it is the entity - -- created to validate formal package actuals: ignore. + -- created to validate formal package actuals: ignore it. -- If the actual is itself a formal package for the enclosing -- generic, or the actual for such a formal package, it remains -- visible on exit from the instance, and therefore nothing needs -- to be done either, except to keep it accessible. - if Is_Package - and then Renamed_Object (E) = Pack_Id - then + if Is_Package and then Renamed_Object (E) = Pack_Id then exit; elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then @@ -11640,9 +12676,11 @@ package body Sem_Ch12 is procedure Reset_Entity (N : Node_Id) is procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); - -- If the type of N2 is global to the generic unit. Save the type in - -- the generic node. - -- What does this comment mean??? + -- If the type of N2 is global to the generic unit, save the type in + -- the generic node. Just as we perform name capture for explicit + -- references within the generic, we must capture the global types + -- of local entities because they may participate in resolution in + -- the instance. function Top_Ancestor (E : Entity_Id) return Entity_Id; -- Find the ultimate ancestor of the current unit. If it is not a @@ -11720,11 +12758,26 @@ package body Sem_Ch12 is N2 := Get_Associated_Node (N); E := Entity (N2); - -- If the entity is an itype created as a subtype of an access type - -- with a null exclusion restore source entity for proper visibility. - -- The itype will be created anew in the instance. - if Present (E) then + + -- If the node is an entry call to an entry in an enclosing task, + -- it is rewritten as a selected component. No global entity to + -- preserve in this case, since the expansion will be redone in + -- the instance. + + if not Nkind_In (E, N_Defining_Identifier, + N_Defining_Character_Literal, + N_Defining_Operator_Symbol) + then + Set_Associated_Node (N, Empty); + Set_Etype (N, Empty); + return; + end if; + + -- If the entity is an itype created as a subtype of an access + -- type with a null exclusion restore source entity for proper + -- visibility. The itype will be created anew in the instance. + if Is_Itype (E) and then Ekind (E) = E_Access_Subtype and then Is_Entity_Name (N) @@ -11833,6 +12886,7 @@ package body Sem_Ch12 is Save_Entity_Descendants (N); else + Set_Is_Prefixed_Call (Parent (N)); Set_Associated_Node (N, Empty); Set_Etype (N, Empty); end if; @@ -11840,10 +12894,13 @@ package body Sem_Ch12 is -- 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. + -- captured as for other constructs. Indicate that this must + -- resolve as a call, to prevent accidental overloading in the + -- instance, if both a component and a primitive operation appear + -- as candidates. else - null; + Set_Is_Prefixed_Call (Parent (N)); end if; -- Entity is local. Reset in generic unit, so that node is resolved @@ -12339,26 +13396,6 @@ package body Sem_Ch12 is -- All other cases than aggregates else - -- For pragmas, we propagate the Enabled status for the - -- relevant pragmas to the original generic tree. This was - -- originally needed for SCO generation. It is no longer - -- needed there (since we use the Sloc value in calls to - -- Set_SCO_Pragma_Enabled), but it seems a generally good - -- idea to have this flag set properly. - - if Nkind (N) = N_Pragma - and then - (Pragma_Name (N) = Name_Assert or else - Pragma_Name (N) = Name_Check or else - Pragma_Name (N) = Name_Precondition or else - Pragma_Name (N) = Name_Postcondition) - and then Present (Associated_Node (Pragma_Identifier (N))) - then - Set_Pragma_Enabled (N, - Pragma_Enabled - (Parent (Associated_Node (Pragma_Identifier (N))))); - end if; - Save_Global_Descendant (Field1 (N)); Save_Global_Descendant (Field2 (N)); Save_Global_Descendant (Field3 (N)); @@ -12367,6 +13404,22 @@ package body Sem_Ch12 is end if; end; end if; + + -- If a node has aspects, references within their expressions must + -- be saved separately, given that they are not directly in the + -- tree. + + if Has_Aspects (N) then + declare + Aspect : Node_Id; + begin + Aspect := First (Aspect_Specifications (N)); + while Present (Aspect) loop + Save_Global_References (Expression (Aspect)); + Next (Aspect); + end loop; + end; + end if; end Save_References; -- Start of processing for Save_Global_References @@ -12509,6 +13562,19 @@ package body Sem_Ch12 is end loop; end Switch_View; + ----------------- + -- True_Parent -- + ----------------- + + function True_Parent (N : Node_Id) return Node_Id is + begin + if Nkind (Parent (N)) = N_Subunit then + return Parent (Corresponding_Stub (Parent (N))); + else + return Parent (N); + end if; + end True_Parent; + ----------------------------- -- Valid_Default_Attribute -- -----------------------------