From 437bae3f742fc7f73ca0755a9e23c503aea872e1 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Wed, 6 Jun 2007 12:37:16 +0200 Subject: [PATCH] sem_ch12.adb (Analyze_Associations): Diagnose use of an others association in an instance. 2007-04-20 Ed Schonberg Javier Miranda * sem_ch12.adb (Analyze_Associations): Diagnose use of an others association in an instance. (Copy_Generic_Node): If the node is a string literal, no need to copy its descendants. (Is_Generic_Formal): For a formal subprogram, the declaration is the grandparent of the entity. (Analyze_Formal_Interface_Type): Transform into a full type declaration, to simplify handling of formal interfaces that derive from other formal interfaces. (Instantiate_Subprogram_Body): The defining unit name of the body of the instance should be a defining identifier. (Install_Formal_Packages): make global to the package, for use in instantiations of child units. (Analyze_Package_Instantiation): Do not attempt to set information on an enclosing master of an entry when expansion is disabled. (Instantiate_Type): If the actual is a tagged synchronized type and the generic ancestor is an interface, create a generic actual for the corresponding record. (Analyze_Formal_Derived_Interface_Type): Rewrite as a derived type declaration, to ensure that the interface list is processed correctly. (Inline_Instance_Body): If enclosing scope is an instance body, remove its entities from visibiility as well. (Pre_Analyze_Actuals): if the actual is an allocator with constraints given with a named association, analyze the expression only, not the discriminant association itself. (Reset_Entity): If the analysis of a selected component is transformed into an expanded name in the prefix of a call with parameters, do not transform the original node into an expanded name, to prevent visibility errors in the case of nested generics. (Check_Private_View): For an array type, check whether the index types may need exchanging. From-SVN: r125431 --- gcc/ada/sem_ch12.adb | 621 ++++++++++++++++++++++++++++++------------- 1 file changed, 433 insertions(+), 188 deletions(-) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index b9ceccd8bc7..d3eb0f8962f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -305,7 +305,8 @@ package body Sem_Ch12 is -- The following procedures treat other kinds of formal parameters procedure Analyze_Formal_Derived_Interface_Type - (T : Entity_Id; + (N : Node_Id; + T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Derived_Type @@ -313,6 +314,11 @@ package body Sem_Ch12 is T : Entity_Id; Def : Node_Id); + procedure Analyze_Formal_Interface_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id); + -- The following subprograms create abbreviated declarations for formal -- scalar types. We introduce an anonymous base of the proper class for -- each of them, and define the formals as constrained first subtypes of @@ -323,7 +329,6 @@ package body Sem_Ch12 is (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id); - procedure Analyze_Formal_Interface_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Ordinary_Fixed_Point_Type @@ -527,6 +532,14 @@ package body Sem_Ch12 is -- Save_Env because data-structures for visibility handling must be -- initialized before call to Check_Generic_Child_Unit. + procedure Install_Formal_Packages (Par : Entity_Id); + -- If any of the formals of the parent are formal packages with box, + -- their formal parts are visible in the parent and thus in the child + -- unit as well. Analogous to what is done in Check_Generic_Actuals + -- for the unit itself. This procedure is also used in an instance, to + -- make visible the proper entities of the actual for a formal package + -- declared with a box. + procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); -- When compiling an instance of a child unit the parent (which is -- itself an instance) is an enclosing scope that must be made @@ -561,7 +574,7 @@ package body Sem_Ch12 is (Formal : Node_Id; Actual : Node_Id; Analyzed_Formal : Node_Id; - Actual_Decls : List_Id) return Node_Id; + Actual_Decls : List_Id) return List_Id; function Instantiate_Formal_Subprogram (Formal : Node_Id; @@ -927,7 +940,9 @@ package body Sem_Ch12 is -- End of list of purely positional parameters - if No (Actual) then + if No (Actual) + or else Nkind (Actual) = N_Others_Choice + then Found_Assoc := Empty; Act := Empty; @@ -1000,26 +1015,36 @@ package body Sem_Ch12 is procedure Process_Default (F : Entity_Id) is Loc : constant Source_Ptr := Sloc (I_Node); + Decl : Node_Id; Default : Node_Id; Id : Entity_Id; begin - -- Append copy of formal declaration to associations. + -- Append copy of formal declaration to associations, and create + -- new defining identifier for it. - Append (New_Copy_Tree (F), Assoc); + Decl := New_Copy_Tree (F); - if No (Found_Assoc) then - if Nkind (F) = N_Formal_Concrete_Subprogram_Declaration then - Id := Defining_Entity (F); - else - Id := Defining_Identifier (F); - end if; + if Nkind (F) = N_Formal_Concrete_Subprogram_Declaration then + Id := + Make_Defining_Identifier (Sloc (Defining_Entity (F)), + Chars => Chars (Defining_Entity (F))); + Set_Defining_Unit_Name (Specification (Decl), Id); + else + Id := + Make_Defining_Identifier (Sloc (Defining_Entity (F)), + Chars => Chars (Defining_Identifier (F))); + Set_Defining_Identifier (Decl, Id); + end if; + + Append (Decl, Assoc); + + if No (Found_Assoc) then Default := Make_Generic_Association (Loc, - Selector_Name => - New_Occurrence_Of (Id, Loc), - Explicit_Generic_Actual_Parameter => Empty); + Selector_Name => New_Occurrence_Of (Id, Loc), + Explicit_Generic_Actual_Parameter => Empty); Set_Box_Present (Default); Append (Default, Default_Formals); end if; @@ -1092,8 +1117,28 @@ package body Sem_Ch12 is Error_Msg_N ("others must be last association", Actual); end if; - Remove (Actual); + -- This subprogram is used both for formal packages and for + -- instantiations. For the latter, associations must all be + -- explicit. + + if Nkind (I_Node) /= N_Formal_Package_Declaration + and then Comes_From_Source (I_Node) + then + Error_Msg_N + ("others association not allowed in an instance", + Actual); + end if; + + -- In any case, nothing to do after the others association + exit; + + elsif Box_Present (Actual) + and then Comes_From_Source (I_Node) + and then Nkind (I_Node) /= N_Formal_Package_Declaration + then + Error_Msg_N + ("box association not allowed in an instance", Actual); end if; Next (Actual); @@ -1104,6 +1149,7 @@ package body Sem_Ch12 is First_Named := First (Actuals); while Present (First_Named) + and then Nkind (First_Named) /= N_Others_Choice and then No (Selector_Name (First_Named)) loop Num_Actuals := Num_Actuals + 1; @@ -1113,7 +1159,9 @@ package body Sem_Ch12 is Named := First_Named; while Present (Named) loop - if No (Selector_Name (Named)) then + if Nkind (Named) /= N_Others_Choice + and then No (Selector_Name (Named)) + then Error_Msg_N ("invalid positional actual after named one", Named); Abandon_Instantiation (Named); end if; @@ -1122,7 +1170,9 @@ package body Sem_Ch12 is -- introduced for a default subprogram that turns out to be local -- to the outer instantiation. - if Present (Explicit_Generic_Actual_Parameter (Named)) then + if Nkind (Named) /= N_Others_Choice + and then Present (Explicit_Generic_Actual_Parameter (Named)) + then Num_Actuals := Num_Actuals + 1; end if; @@ -1184,9 +1234,10 @@ package body Sem_Ch12 is else Analyze (Match); - Append_To (Assoc, - Instantiate_Type - (Formal, Match, Analyzed_Formal, Assoc)); + Append_List + (Instantiate_Type + (Formal, Match, Analyzed_Formal, Assoc), + Assoc); -- An instantiation is a freeze point for the actuals, -- unless this is a rewritten formal package. @@ -1509,29 +1560,25 @@ package body Sem_Ch12 is ------------------------------------------- procedure Analyze_Formal_Derived_Interface_Type - (T : Entity_Id; + (N : Node_Id; + T : Entity_Id; Def : Node_Id) is - Ifaces_List : Elist_Id; + Loc : constant Source_Ptr := Sloc (Def); + New_N : Node_Id; begin - Enter_Name (T); - Set_Ekind (T, E_Record_Type); - Set_Etype (T, T); - Analyze (Subtype_Indication (Def)); - Analyze_Interface_Declaration (T, Def); - Make_Class_Wide_Type (T); - Analyze_List (Interface_List (Def)); - - -- Ada 2005 (AI-251): Collect the list of progenitors that are not - -- already covered by the parents. - - Collect_Abstract_Interfaces - (T => T, - Ifaces_List => Ifaces_List, - Exclude_Parent_Interfaces => True); - - Set_Abstract_Interfaces (T, Ifaces_List); + -- Rewrite as a type declaration of a derived type. This ensures that + -- the interface list and primitive operations are properly captured. + + New_N := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => T, + Type_Definition => Def); + + Rewrite (N, New_N); + Analyze (N); + Set_Is_Generic_Type (T); end Analyze_Formal_Derived_Interface_Type; --------------------------------- @@ -1695,14 +1742,23 @@ package body Sem_Ch12 is -- Analyze_Formal_Interface_Type;-- ----------------------------------- - procedure Analyze_Formal_Interface_Type (T : Entity_Id; Def : Node_Id) is + procedure Analyze_Formal_Interface_Type + (N : Node_Id; + T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (N); + New_N : Node_Id; + begin - Enter_Name (T); - Set_Ekind (T, E_Record_Type); - Set_Etype (T, T); - Analyze_Interface_Declaration (T, Def); - Make_Class_Wide_Type (T); - Set_Primitive_Operations (T, New_Elmt_List); + New_N := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => T, + Type_Definition => Def); + + Rewrite (N, New_N); + Analyze (N); + Set_Is_Generic_Type (T); end Analyze_Formal_Interface_Type; --------------------------------- @@ -2090,7 +2146,7 @@ package body Sem_Ch12 is Set_Ekind (Formal, E_Package); Set_Etype (Formal, Standard_Void_Type); Set_Inner_Instances (Formal, New_Elmt_List); - New_Scope (Formal); + Push_Scope (Formal); if Is_Child_Unit (Gen_Unit) and then Parent_Installed @@ -2449,10 +2505,10 @@ package body Sem_Ch12 is -- record declaration or a abstract type derivation. when N_Record_Definition => - Analyze_Formal_Interface_Type (T, Def); + Analyze_Formal_Interface_Type (N, T, Def); when N_Derived_Type_Definition => - Analyze_Formal_Derived_Interface_Type (T, Def); + Analyze_Formal_Derived_Interface_Type (N, T, Def); when N_Error => null; @@ -2589,7 +2645,7 @@ package body Sem_Ch12 is Enter_Name (Id); Set_Ekind (Id, E_Generic_Package); Set_Etype (Id, Standard_Void_Type); - New_Scope (Id); + Push_Scope (Id); Enter_Generic_Scope (Id); Set_Inner_Instances (Id, New_Elmt_List); @@ -2679,7 +2735,7 @@ package body Sem_Ch12 is Enter_Name (Id); Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); - New_Scope (Id); + Push_Scope (Id); Enter_Generic_Scope (Id); Set_Inner_Instances (Id, New_Elmt_List); Set_Is_Pure (Id, Is_Pure (Current_Scope)); @@ -3163,11 +3219,13 @@ package body Sem_Ch12 is Check_Forward_Instantiation (Gen_Decl); if Nkind (N) = N_Package_Instantiation then declare - Enclosing_Master : Entity_Id := Current_Scope; + Enclosing_Master : Entity_Id; begin - while Enclosing_Master /= Standard_Standard loop + -- Loop to search enclosing masters + Enclosing_Master := Current_Scope; + Scope_Loop : while Enclosing_Master /= Standard_Standard loop if Ekind (Enclosing_Master) = E_Package then if Is_Compilation_Unit (Enclosing_Master) then if In_Package_Body (Enclosing_Master) then @@ -3178,7 +3236,7 @@ package body Sem_Ch12 is (Enclosing_Master); end if; - exit; + exit Scope_Loop; else Enclosing_Master := Scope (Enclosing_Master); @@ -3194,15 +3252,19 @@ package body Sem_Ch12 is -- the enclosing instance, if any. enclosing scope -- is void in the formal part of a generic subp. - exit; + exit Scope_Loop; else if Ekind (Enclosing_Master) = E_Entry and then Ekind (Scope (Enclosing_Master)) = E_Protected_Type then - Enclosing_Master := - Protected_Body_Subprogram (Enclosing_Master); + if not Expander_Active then + exit Scope_Loop; + else + Enclosing_Master := + Protected_Body_Subprogram (Enclosing_Master); + end if; end if; Set_Delay_Cleanups (Enclosing_Master); @@ -3227,9 +3289,9 @@ package body Sem_Ch12 is end; end if; - exit; + exit Scope_Loop; end if; - end loop; + end loop Scope_Loop; end; -- Make entry in table @@ -3458,17 +3520,35 @@ package body Sem_Ch12 is -- removed previously. -- If current scope is the body of a child unit, remove context of - -- spec as well. + -- spec as well. If an enclosing scope is an instance body. the + -- context has already been removed, but the entities in the body + -- must be made invisible as well. S := Current_Scope; while Present (S) and then S /= Standard_Standard loop - exit when Is_Generic_Instance (S) - and then (In_Package_Body (S) - or else Ekind (S) = E_Procedure - or else Ekind (S) = E_Function); + if Is_Generic_Instance (S) + and then (In_Package_Body (S) + or else Ekind (S) = E_Procedure + or else Ekind (S) = E_Function) + then + -- We still have to remove the entities of the enclosing + -- instance from direct visibility. + + declare + E : Entity_Id; + begin + E := First_Entity (S); + while Present (E) loop + Set_Is_Immediately_Visible (E, False); + Next_Entity (E); + end loop; + end; + + exit; + end if; if S = Curr_Unit or else (Ekind (Curr_Unit) = E_Package_Body @@ -3514,7 +3594,7 @@ package body Sem_Ch12 is end loop; pragma Assert (Num_Inner < Num_Scopes); - New_Scope (Standard_Standard); + Push_Scope (Standard_Standard); Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; Instantiate_Package_Body ((N, Act_Decl, Expander_Active, Current_Sem_Unit), True); @@ -3538,13 +3618,13 @@ package body Sem_Ch12 is if Present (Curr_Scope) and then Is_Child_Unit (Curr_Scope) then - New_Scope (Curr_Scope); + Push_Scope (Curr_Scope); Set_Is_Immediately_Visible (Curr_Scope); -- Finally, restore inner scopes as well for J in reverse 1 .. Num_Inner loop - New_Scope (Inner_Scopes (J)); + Push_Scope (Inner_Scopes (J)); end loop; end if; @@ -3595,9 +3675,30 @@ package body Sem_Ch12 is end loop; end if; - for J in 1 .. N_Instances loop - Set_Is_Generic_Instance (Instances (J), True); - end loop; + -- Restore status of instances. If one of them is a body, make + -- its local entities visible again. + + declare + E : Entity_Id; + Inst : Entity_Id; + + begin + for J in 1 .. N_Instances loop + Inst := Instances (J); + Set_Is_Generic_Instance (Inst, True); + + if In_Package_Body (Inst) + or else Ekind (S) = E_Procedure + or else Ekind (S) = E_Function + then + E := First_Entity (Instances (J)); + while Present (E) loop + Set_Is_Immediately_Visible (E); + Next_Entity (E); + end loop; + end if; + end loop; + end; -- If generic unit is in current unit, current context is correct @@ -4970,6 +5071,17 @@ package body Sem_Ch12 is then Install_Parent (Inst_Par); Parent_Installed := True; + + elsif In_Open_Scopes (Inst_Par) then + + -- If the parent is already installed verify that the + -- actuals for its formal packages declared with a box + -- are already installed. This is necessary when the + -- child instance is a child of the parent instance. + -- In this case the parent is placed on the scope stack + -- but the formal packages are not made visible. + + Install_Formal_Packages (Inst_Par); end if; else @@ -5156,12 +5268,39 @@ package body Sem_Ch12 is then Switch_View (Designated_Type (T)); - elsif Is_Array_Type (T) - and then Is_Private_Type (Component_Type (T)) - and then not Has_Private_View (N) - and then Present (Full_View (Component_Type (T))) - then - Switch_View (Component_Type (T)); + elsif Is_Array_Type (T) then + if Is_Private_Type (Component_Type (T)) + and then not Has_Private_View (N) + and then Present (Full_View (Component_Type (T))) + then + Switch_View (Component_Type (T)); + end if; + + -- The normal exchange mechanism relies on the setting of a + -- flag on the reference in the generic. However, an additional + -- mechanism is needed for types that are not explicitly mentioned + -- in the generic, but may be needed in expanded code in the + -- instance. This includes component types of arrays and + -- designated types of access types. This processing must also + -- include the index types of arrays which we take care of here. + + declare + Indx : Node_Id; + Typ : Entity_Id; + + begin + Indx := First_Index (T); + Typ := Base_Type (Etype (Indx)); + while Present (Indx) loop + if Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Switch_View (Typ); + end if; + + Next_Index (Indx); + end loop; + end; elsif Is_Private_Type (T) and then Present (Full_View (T)) @@ -5171,10 +5310,9 @@ package body Sem_Ch12 is Switch_View (T); -- Finally, a non-private subtype may have a private base type, which - -- must be exchanged for consistency. This can happen when - -- instantiating a package body, when the scope stack is empty but in - -- fact the subtype and the base type are declared in an enclosing - -- scope. + -- must be exchanged for consistency. This can happen when a package + -- body is instantiated, when the scope stack is empty but in fact + -- the subtype and the base type are declared in an enclosing scope. -- Note that in this case we introduce an inconsistency in the view -- set, because we switch the base type BT, but there could be some @@ -5852,6 +5990,7 @@ package body Sem_Ch12 is elsif Nkind (N) = N_Integer_Literal or else Nkind (N) = N_Real_Literal + or else Nkind (N) = N_String_Literal then -- No descendant fields need traversing @@ -6780,6 +6919,42 @@ package body Sem_Ch12 is Mark_Rewrite_Insertion (Act_Body); end Install_Body; + ----------------------------- + -- Install_Formal_Packages -- + ----------------------------- + + procedure Install_Formal_Packages (Par : Entity_Id) is + E : Entity_Id; + + begin + E := First_Entity (Par); + while Present (E) loop + if Ekind (E) = E_Package + and then Nkind (Parent (E)) = N_Package_Renaming_Declaration + then + -- If this is the renaming for the parent instance, done + + if Renamed_Object (E) = Par then + exit; + + -- The visibility of a formal of an enclosing generic is + -- already correct. + + elsif Denotes_Formal_Package (E) then + null; + + elsif Present (Associated_Formal_Package (E)) + and then Box_Present (Parent (Associated_Formal_Package (E))) + then + Check_Generic_Actuals (Renamed_Object (E), True); + Set_Is_Hidden (E, False); + end if; + end if; + + Next_Entity (E); + end loop; + end Install_Formal_Packages; + -------------------- -- Install_Parent -- -------------------- @@ -6794,12 +6969,6 @@ package body Sem_Ch12 is First_Gen : Entity_Id; Elmt : Elmt_Id; - procedure Install_Formal_Packages (Par : Entity_Id); - -- If any of the formals of the parent are formal packages with box, - -- their formal parts are visible in the parent and thus in the child - -- unit as well. Analogous to what is done in Check_Generic_Actuals - -- for the unit itself. - procedure Install_Noninstance_Specs (Par : Entity_Id); -- Install the scopes of noninstance parent units ending with Par @@ -6807,42 +6976,6 @@ package body Sem_Ch12 is -- The child unit is within the declarative part of the parent, so -- the declarations within the parent are immediately visible. - ----------------------------- - -- Install_Formal_Packages -- - ----------------------------- - - procedure Install_Formal_Packages (Par : Entity_Id) is - E : Entity_Id; - - begin - E := First_Entity (Par); - while Present (E) loop - if Ekind (E) = E_Package - and then Nkind (Parent (E)) = N_Package_Renaming_Declaration - then - -- If this is the renaming for the parent instance, done - - if Renamed_Object (E) = Par then - exit; - - -- The visibility of a formal of an enclosing generic is - -- already correct. - - elsif Denotes_Formal_Package (E) then - null; - - elsif Present (Associated_Formal_Package (E)) - and then Box_Present (Parent (Associated_Formal_Package (E))) - then - Check_Generic_Actuals (Renamed_Object (E), True); - Set_Is_Hidden (E, False); - end if; - end if; - - Next_Entity (E); - end loop; - end Install_Formal_Packages; - ------------------------------- -- Install_Noninstance_Specs -- ------------------------------- @@ -6895,7 +7028,7 @@ package body Sem_Ch12 is -- parents then it should be possible to remove this -- special check. ??? - New_Scope (Par); + Push_Scope (Par); Set_Is_Immediately_Visible (Par); Install_Visible_Declarations (Par); Set_Use (Visible_Declarations (Spec)); @@ -6993,7 +7126,7 @@ package body Sem_Ch12 is end if; if not In_Body then - New_Scope (S); + Push_Scope (S); end if; end Install_Parent; @@ -7422,13 +7555,15 @@ package body Sem_Ch12 is -- renamings of the actuals supplied. declare - Gen_Decl : constant Node_Id := - Unit_Declaration_Node (Gen_Parent); - Formals : constant List_Id := - Generic_Formal_Declarations (Gen_Decl); - Actual_Ent : Entity_Id; - Formal_Node : Node_Id; - Formal_Ent : Entity_Id; + Gen_Decl : constant Node_Id := + Unit_Declaration_Node (Gen_Parent); + Formals : constant List_Id := + Generic_Formal_Declarations (Gen_Decl); + + Actual_Ent : Entity_Id; + Actual_Of_Formal : Node_Id; + Formal_Node : Node_Id; + Formal_Ent : Entity_Id; begin if Present (Formals) then @@ -7438,6 +7573,8 @@ package body Sem_Ch12 is end if; Actual_Ent := First_Entity (Actual_Pack); + Actual_Of_Formal := + First (Visible_Declarations (Specification (Analyzed_Formal))); while Present (Actual_Ent) and then Actual_Ent /= First_Private_Entity (Actual_Pack) loop @@ -7449,22 +7586,19 @@ package body Sem_Ch12 is Match_Formal_Entity (Formal_Node, Formal_Ent, Actual_Ent); + -- We iterate at the same time over the actuals of the + -- local package created for the formal, to determine + -- which one of the formals of the original generic were + -- defaulted in the formal. The corresponding actual + -- entities are visible in the enclosing instance. + if Box_Present (Formal) or else - (Present (Formal_Node) - and then Is_Generic_Formal (Formal_Ent)) + (Present (Actual_Of_Formal) + and then + Is_Generic_Formal + (Get_Formal_Entity (Actual_Of_Formal))) then - -- This may make too many formal entities visible, but - -- it's hard to build an example that exposes this - -- excess visibility. If a reference in the generic - -- resolved to a global variable then the extra - -- visibility in an instance does not affect the - -- captured entity. If the reference resolved to a - -- local entity it will resolve again in the instance. - -- Nevertheless, we should build tests to make sure - -- that hidden entities in the generic remain hidden - -- in the instance. - Set_Is_Hidden (Actual_Ent, False); Set_Is_Visible_Formal (Actual_Ent); Set_Is_Potentially_Use_Visible @@ -7473,10 +7607,15 @@ package body Sem_Ch12 is if Ekind (Actual_Ent) = E_Package then Process_Nested_Formal (Actual_Ent); end if; + + else + Set_Is_Hidden (Actual_Ent); + Set_Is_Potentially_Use_Visible (Actual_Ent, False); end if; end if; Next_Non_Pragma (Formal_Node); + Next (Actual_Of_Formal); else -- No further formals to match, but the generic part may @@ -7485,7 +7624,6 @@ package body Sem_Ch12 is Next_Entity (Actual_Ent); end if; - end loop; -- Inherited subprograms generated by formal derived types are @@ -8170,9 +8308,9 @@ package body Sem_Ch12 is -- formal object of another generic unit G, and the instantiation -- containing the actual occurs within the body of G or within the body -- of a generic unit declared within the declarative region of G, then - -- the declaration of the formal object of G shall have a null - -- exclusion. Otherwise, the subtype of the actual matching the formal - -- object declaration shall exclude null. + -- the declaration of the formal object of G must have a null exclusion. + -- Otherwise, the subtype of the actual matching the formal object + -- declaration shall exclude null. if Ada_Version >= Ada_05 and then Present (Actual_Decl) @@ -8183,8 +8321,10 @@ package body Sem_Ch12 is and then Has_Null_Exclusion (Actual_Decl) and then not Has_Null_Exclusion (Analyzed_Formal) then - Error_Msg_N ("null-exclusion required in formal object declaration", - Analyzed_Formal); + Error_Msg_Sloc := Sloc (Actual_Decl); + Error_Msg_N + ("`NOT NULL` required in formal, to match actual #", + Analyzed_Formal); end if; return List; @@ -8443,7 +8583,6 @@ package body Sem_Ch12 is Gen_Body : Node_Id; Gen_Body_Id : Node_Id; Act_Body : Node_Id; - Act_Body_Id : Entity_Id; Pack_Body : Node_Id; Prev_Formal : Entity_Id; Ret_Expr : Node_Id; @@ -8496,9 +8635,13 @@ package body Sem_Ch12 is Act_Body := Copy_Generic_Node (Original_Node (Gen_Body), Empty, Instantiating => True); - Act_Body_Id := Defining_Entity (Act_Body); - Set_Chars (Act_Body_Id, Chars (Anon_Id)); - Set_Sloc (Act_Body_Id, Sloc (Defining_Entity (Inst_Node))); + + -- Create proper defining name for the body, to correspond to + -- the one in the spec. + + Set_Defining_Unit_Name (Specification (Act_Body), + Make_Defining_Identifier + (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id))); Set_Corresponding_Spec (Act_Body, Anon_Id); Set_Has_Completion (Anon_Id); Check_Generic_Actuals (Pack_Id, False); @@ -8688,16 +8831,18 @@ package body Sem_Ch12 is (Formal : Node_Id; Actual : Node_Id; Analyzed_Formal : Node_Id; - Actual_Decls : List_Id) return Node_Id + Actual_Decls : List_Id) return List_Id is - Gen_T : constant Entity_Id := Defining_Identifier (Formal); - A_Gen_T : constant Entity_Id := Defining_Identifier (Analyzed_Formal); - Ancestor : Entity_Id := Empty; - Def : constant Node_Id := Formal_Type_Definition (Formal); - Act_T : Entity_Id; - Decl_Node : Node_Id; - Loc : Source_Ptr; - Subt : Entity_Id; + Gen_T : constant Entity_Id := Defining_Identifier (Formal); + A_Gen_T : constant Entity_Id := + Defining_Identifier (Analyzed_Formal); + Ancestor : Entity_Id := Empty; + Def : constant Node_Id := Formal_Type_Definition (Formal); + Act_T : Entity_Id; + Decl_Node : Node_Id; + Decl_Nodes : List_Id; + Loc : Source_Ptr; + Subt : Entity_Id; procedure Validate_Array_Type_Instance; procedure Validate_Access_Subprogram_Instance; @@ -8832,6 +8977,14 @@ package body Sem_Ch12 is Actual, Gen_T); Abandon_Instantiation (Actual); end if; + + -- Ada 2005: null-exclusion indicators of the two types must agree + + if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then + Error_Msg_NE + ("non null exclusion of actual and formal & do not match", + Actual, Gen_T); + end if; end Validate_Access_Type_Instance; ---------------------------------- @@ -8964,7 +9117,7 @@ package body Sem_Ch12 is -- the actual. if Present (Par) - and then not Interface_Present_In_Ancestor (Act_T, Par) + and then not Interface_Present_In_Ancestor (Act_T, Par) then Error_Msg_NE ("interface actual must include progenitor&", Actual, Par); @@ -8975,7 +9128,9 @@ package body Sem_Ch12 is Elmt := First_Elmt (Abstract_Interfaces (A_Gen_T)); while Present (Elmt) loop - if not Interface_Present_In_Ancestor (Act_T, Node (Elmt)) then + if not Interface_Present_In_Ancestor + (Act_T, Get_Instance_Of (Node (Elmt))) + then Error_Msg_NE ("interface actual must include progenitor&", Actual, Node (Elmt)); @@ -9256,7 +9411,7 @@ package body Sem_Ch12 is Is_Synchronized_Interface (Act_T) then Error_Msg_NE - ("actual for interface& does not match ('R'M 12.5.5(5))", + ("actual for interface& does not match ('R'M 12.5.5(4))", Actual, Gen_T); end if; end Validate_Interface_Type_Instance; @@ -9376,7 +9531,7 @@ package body Sem_Ch12 is begin if Get_Instance_Of (A_Gen_T) /= A_Gen_T then Error_Msg_N ("duplicate instantiation of generic type", Actual); - return Error; + return New_List (Error); elsif not Is_Entity_Name (Actual) or else not Is_Type (Entity (Actual)) @@ -9472,7 +9627,11 @@ package body Sem_Ch12 is ("actual of non-abstract formal cannot be abstract", Actual); end if; - if Is_Scalar_Type (Gen_T) then + -- A generic scalar type is a first subtype for which we generate + -- an anonymous base type. Indicate that the instance of this base + -- is the base type of the actual. + + if Is_Scalar_Type (A_Gen_T) then Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); end if; end if; @@ -9571,6 +9730,8 @@ package body Sem_Ch12 is Set_Has_Private_View (Subtype_Indication (Decl_Node)); end if; + Decl_Nodes := New_List (Decl_Node); + -- Flag actual derived types so their elaboration produces the -- appropriate renamings for the primitive operations of the ancestor. -- Flag actual for formal private types as well, to determine whether @@ -9582,7 +9743,47 @@ package body Sem_Ch12 is Set_Generic_Parent_Type (Decl_Node, Ancestor); end if; - return Decl_Node; + -- If the actual is a synchronized type that implements an interface, + -- the primitive operations are attached to the corresponding record, + -- and we have to treat it as an additional generic actual, so that its + -- primitive operations become visible in the instance. The task or + -- protected type itself does not carry primitive operations. + + if Is_Concurrent_Type (Act_T) + and then Is_Tagged_Type (Act_T) + and then Present (Corresponding_Record_Type (Act_T)) + and then Present (Ancestor) + and then Is_Interface (Ancestor) + then + declare + Corr_Rec : constant Entity_Id := + Corresponding_Record_Type (Act_T); + New_Corr : Entity_Id; + Corr_Decl : Node_Id; + + begin + New_Corr := Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + Corr_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => New_Corr, + Subtype_Indication => + New_Reference_To (Corr_Rec, Loc)); + Append_To (Decl_Nodes, Corr_Decl); + + if Ekind (Act_T) = E_Task_Type then + Set_Ekind (Subt, E_Task_Subtype); + else + Set_Ekind (Subt, E_Protected_Subtype); + end if; + + Set_Corresponding_Record_Type (Subt, Corr_Rec); + Set_Generic_Parent_Type (Corr_Decl, Ancestor); + Set_Generic_Parent_Type (Decl_Node, Empty); + end; + end if; + + return Decl_Nodes; end Instantiate_Type; ----------------------- @@ -9590,13 +9791,23 @@ package body Sem_Ch12 is ----------------------- function Is_Generic_Formal (E : Entity_Id) return Boolean is - Kind : constant Node_Kind := Nkind (Parent (E)); + Kind : Node_Kind; + begin - return - Kind = N_Formal_Object_Declaration - or else Kind = N_Formal_Package_Declaration - or else Kind in N_Formal_Subprogram_Declaration - or else Kind = N_Formal_Type_Declaration; + if No (E) then + return False; + else + Kind := Nkind (Parent (E)); + return + Kind = N_Formal_Object_Declaration + or else Kind = N_Formal_Package_Declaration + or else Kind = N_Formal_Type_Declaration + or else + (Is_Formal_Subprogram (E) + and then + Nkind (Parent (Parent (E))) in + N_Formal_Subprogram_Declaration); + end if; end Is_Generic_Formal; --------------------- @@ -9782,8 +9993,7 @@ package body Sem_Ch12 is begin Error_Msg_Unit_1 := Bname; Error_Msg_N ("this instantiation requires$!", N); - Error_Msg_Name_1 := - Get_File_Name (Bname, Subunit => False); + Error_Msg_File_1 := Get_File_Name (Bname, Subunit => False); Error_Msg_N ("\but file{ was not found!", N); raise Unrecoverable_Error; end; @@ -9959,7 +10169,26 @@ package body Sem_Ch12 is begin if Nkind (Expr) = N_Subtype_Indication then Analyze (Subtype_Mark (Expr)); - Analyze_List (Constraints (Constraint (Expr))); + + -- Analyze separately each discriminant constraint, + -- when given with a named association. + + declare + Constr : Node_Id; + + begin + Constr := First (Constraints (Constraint (Expr))); + while Present (Constr) loop + if Nkind (Constr) = N_Discriminant_Association then + Analyze (Expression (Constr)); + else + Analyze (Constr); + end if; + + Next (Constr); + end loop; + end; + else Analyze (Expr); end if; @@ -10553,17 +10782,33 @@ package body Sem_Ch12 is elsif Nkind (Parent (N)) = N_Selected_Component and then Nkind (Parent (N2)) = N_Function_Call - and then Is_Global (Entity (Name (Parent (N2)))) + and then N = Selector_Name (Parent (N)) then - Change_Selected_Component_To_Expanded_Name (Parent (N)); - Set_Associated_Node (Parent (N), Name (Parent (N2))); - Set_Global_Type (Parent (N), Name (Parent (N2))); - Save_Entity_Descendants (N); + if No (Parameter_Associations (Parent (N2))) then + if Is_Global (Entity (Name (Parent (N2)))) then + Change_Selected_Component_To_Expanded_Name (Parent (N)); + Set_Associated_Node (Parent (N), Name (Parent (N2))); + Set_Global_Type (Parent (N), Name (Parent (N2))); + Save_Entity_Descendants (N); - else - -- Entity is local. Reset in generic unit, so that node is - -- resolved anew at the point of instantiation. + else + Set_Associated_Node (N, Empty); + Set_Etype (N, Empty); + end if; + + -- In Ada 2005, X.F may be a call to a primitive operation, + -- rewritten as F (X). This rewriting will be done again in an + -- instance, so keep the original node. Global entities will be + -- captured as for other constructs. + else + null; + end if; + + -- Entity is local. Reset in generic unit, so that node is resolved + -- anew at the point of instantiation. + + else Set_Associated_Node (N, Empty); Set_Etype (N, Empty); end if; -- 2.30.2