From: Ed Schonberg Date: Wed, 26 Mar 2008 07:41:53 +0000 (+0100) Subject: sem_ch10.adb (Analyze_Compilation_Unit): if a unit in the context is a generic subpro... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=9b91e15091b8d490e742ec04d8f1813c27f9cc13;p=gcc.git sem_ch10.adb (Analyze_Compilation_Unit): if a unit in the context is a generic subprogram that is imported... 2008-03-26 Ed Schonberg * sem_ch10.adb (Analyze_Compilation_Unit): if a unit in the context is a generic subprogram that is imported, do not attempt to compile non-existent body. * sem_ch12.adb (Instantiate_Subprogram_Body): if the generic is imported, do not generate a raise_program_error for the non-existent body. (Pre_Analyze_Actuals): If an error is detected during pre-analysis, perform minimal name resolution on the generic to avoid spurious warnings. (Find_Actual_Type): the designated type of the actual in a child unit may be declared in a parent unit without being an actual. From-SVN: r133575 --- diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index cc8fcb39063..665c1efb861 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -387,9 +387,9 @@ package body Sem_Ch10 is elsif Nkind (Cont_Item) = N_Pragma and then - (Chars (Cont_Item) = Name_Elaborate + (Pragma_Name (Cont_Item) = Name_Elaborate or else - Chars (Cont_Item) = Name_Elaborate_All) + Pragma_Name (Cont_Item) = Name_Elaborate_All) and then not Used_Type_Or_Elab then Prag_Unit := @@ -759,7 +759,7 @@ package body Sem_Ch10 is Set_Acts_As_Spec (N, False); Set_Is_Child_Unit (Defining_Entity (Unit_Node)); - Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit))); + Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit))); Set_Comes_From_Source_Default (SCS); end; end if; @@ -910,7 +910,6 @@ package body Sem_Ch10 is Add_Stub_Constructs (N); end if; - end if; -- Remove unit from visibility, so that environment is clean for @@ -1005,8 +1004,13 @@ package body Sem_Ch10 is then Nam := Entity (Name (Item)); + -- Compile generic subprogram, unless it is intrinsic or + -- imported so no body is required, or generic package body + -- if the package spec requires a body. + if (Is_Generic_Subprogram (Nam) - and then not Is_Intrinsic_Subprogram (Nam)) + and then not Is_Intrinsic_Subprogram (Nam) + and then not Is_Imported (Nam)) or else (Ekind (Nam) = E_Generic_Package and then Unit_Requires_Body (Nam)) then @@ -1237,7 +1241,7 @@ package body Sem_Ch10 is Item := First (Context_Items (N)); while Present (Item) and then Nkind (Item) = N_Pragma - and then Chars (Item) in Configuration_Pragma_Names + and then Pragma_Name (Item) in Configuration_Pragma_Names loop Analyze (Item); Next (Item); @@ -1732,7 +1736,6 @@ package body Sem_Ch10 is else Optional_Subunit; end if; - end Analyze_Proper_Body; ---------------------------------- @@ -2693,20 +2696,21 @@ package body Sem_Ch10 is begin New_Nodes_OK := New_Nodes_OK + 1; Withn := - Make_With_Clause (Loc, Name => Build_Unit_Name (Nam)); + Make_With_Clause (Loc, + Name => Build_Unit_Name (Nam)); P := Parent (Unit_Declaration_Node (Ent)); - Set_Library_Unit (Withn, P); - Set_Corresponding_Spec (Withn, Ent); - Set_First_Name (Withn, True); - Set_Implicit_With (Withn, True); + Set_Library_Unit (Withn, P); + Set_Corresponding_Spec (Withn, Ent); + Set_First_Name (Withn, True); + Set_Implicit_With (Withn, True); -- If the unit is a package declaration, a private_with_clause on a -- child unit implies that the implicit with on the parent is also -- private. if Nkind (Unit (N)) = N_Package_Declaration then - Set_Private_Present (Withn, Private_Present (Item)); + Set_Private_Present (Withn, Private_Present (Item)); end if; Prepend (Withn, Context_Items (N)); @@ -2729,13 +2733,10 @@ package body Sem_Ch10 is if Nkind (Unit) = N_Package_Body and then Nkind (Original_Node (Unit)) = N_Package_Instantiation then - return - Defining_Entity - (Specification (Instance_Spec (Original_Node (Unit)))); - + return Defining_Entity + (Specification (Instance_Spec (Original_Node (Unit)))); elsif Nkind (Unit) = N_Package_Instantiation then return Defining_Entity (Specification (Instance_Spec (Unit))); - else return Defining_Entity (Unit); end if; @@ -2890,7 +2891,6 @@ package body Sem_Ch10 is end if; Install_Limited_Context_Clauses (N); - end Install_Context; ----------------------------- @@ -2913,7 +2913,7 @@ package body Sem_Ch10 is Item := First (Context_Items (N)); while Present (Item) and then Nkind (Item) = N_Pragma - and then Chars (Item) in Configuration_Pragma_Names + and then Pragma_Name (Item) in Configuration_Pragma_Names loop Next (Item); end loop; @@ -3713,6 +3713,7 @@ package body Sem_Ch10 is Item : Node_Id; Id : Entity_Id; Prev : Entity_Id; + begin -- Iterate over explicit with clauses, and check whether the scope of -- each entity is an ancestor of the current unit, in which case it is @@ -3950,8 +3951,8 @@ package body Sem_Ch10 is while Present (Item) loop if Nkind (Item) = N_With_Clause and then not Limited_Present (Item) - and then Nkind (Unit (Library_Unit (Item))) - = N_Package_Declaration + and then Nkind (Unit (Library_Unit (Item))) = + N_Package_Declaration then Decl := First (Visible_Declarations @@ -4599,13 +4600,13 @@ package body Sem_Ch10 is Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); P : constant Entity_Id := Cunit_Entity (Unum); - Spec : Node_Id; -- To denote a package specification - Lim_Typ : Entity_Id; -- To denote shadow entities - Comp_Typ : Entity_Id; -- To denote real entities + Spec : Node_Id; -- To denote a package specification + Lim_Typ : Entity_Id; -- To denote shadow entities + Comp_Typ : Entity_Id; -- To denote real entities - Lim_Header : Entity_Id; -- Package entity - Last_Lim_E : Entity_Id := Empty; -- Last limited entity built - Last_Pub_Lim_E : Entity_Id; -- To set the first private entity + Lim_Header : Entity_Id; -- Package entity + Last_Lim_E : Entity_Id := Empty; -- Last limited entity built + Last_Pub_Lim_E : Entity_Id; -- To set the first private entity procedure Decorate_Incomplete_Type (E : Entity_Id; @@ -4805,8 +4806,8 @@ package body Sem_Ch10 is Set_Non_Limited_View (Lim_Typ, Comp_Typ); - elsif Nkind (Decl) = N_Private_Type_Declaration - or else Nkind (Decl) = N_Incomplete_Type_Declaration + elsif Nkind_In (Decl, N_Private_Type_Declaration, + N_Incomplete_Type_Declaration) then Comp_Typ := Defining_Identifier (Decl); @@ -4879,7 +4880,7 @@ package body Sem_Ch10 is Decorate_Package_Specification (Lim_Typ); Set_Scope (Lim_Typ, Scope); - Set_Chars (Lim_Typ, Chars (Comp_Typ)); + Set_Chars (Lim_Typ, Chars (Comp_Typ)); Set_Parent (Lim_Typ, Parent (Comp_Typ)); Set_From_With_Type (Lim_Typ); @@ -4958,8 +4959,9 @@ package body Sem_Ch10 is -- Build the header of the limited_view - Lim_Header := Make_Defining_Identifier (Sloc (N), - Chars => New_Internal_Name (Id_Char => 'Z')); + Lim_Header := + Make_Defining_Identifier (Sloc (N), + Chars => New_Internal_Name (Id_Char => 'Z')); Set_Ekind (Lim_Header, E_Package); Set_Is_Internal (Lim_Header); Set_Limited_View (P, Lim_Header); @@ -5410,7 +5412,6 @@ package body Sem_Ch10 is if Nkind (Item) = N_With_Clause and then Private_Present (Item) then - -- If private_with_clause is redundant, remove it from -- context, as a small optimization to subsequent handling -- of private_with clauses in other nested packages.. @@ -5418,7 +5419,6 @@ package body Sem_Ch10 is if In_Regular_With_Clause (Entity (Name (Item))) then declare Nxt : constant Node_Id := Next (Item); - begin Remove (Item); Item := Nxt; @@ -5451,7 +5451,6 @@ package body Sem_Ch10 is P : constant Entity_Id := Scope (Unit_Name); begin - if Debug_Flag_I then Write_Str ("remove unit "); Write_Name (Chars (Unit_Name)); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 4a830603f12..a2019a6e427 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -434,15 +434,17 @@ package body Sem_Ch12 is function Find_Actual_Type (Typ : Entity_Id; - Gen_Scope : Entity_Id) return Entity_Id; + Gen_Type : Entity_Id) return Entity_Id; -- When validating the actual types of a child instance, check whether -- the formal is a formal type of the parent unit, and retrieve the current -- actual for it. Typ is the entity in the analyzed formal type declaration -- (component or index type of an array type, or designated type of an - -- access formal) and Gen_Scope is the scope of the analyzed formal array + -- access formal) and Gen_Type is the enclosing analyzed formal array -- or access type. The desired actual may be a formal of a parent, or may -- be declared in a formal package of a parent. In both cases it is a -- generic actual type because it appears within a visible instance. + -- Finally, it may be declared in a parent unit without being a formal + -- of that unit, in which case it must be retrieved by visibility. -- Ambiguities may still arise if two homonyms are declared in two formal -- packages, and the prefix of the formal type may be needed to resolve -- the ambiguity in the instance ??? @@ -1066,6 +1068,7 @@ package body Sem_Ch12 is procedure Set_Analyzed_Formal is Kind : Node_Kind; + begin while Present (Analyzed_Formal) loop Kind := Nkind (Analyzed_Formal); @@ -1081,12 +1084,9 @@ package body Sem_Ch12 is (Defining_Unit_Name (Specification (Analyzed_Formal))); when N_Formal_Package_Declaration => - exit when - Kind = N_Formal_Package_Declaration - or else - Kind = N_Generic_Package_Declaration - or else - Kind = N_Package_Declaration; + exit when Nkind_In (Kind, N_Formal_Package_Declaration, + N_Generic_Package_Declaration, + N_Package_Declaration); when N_Use_Package_Clause | N_Use_Type_Clause => exit; @@ -1097,10 +1097,10 @@ package body Sem_Ch12 is exit when Kind not in N_Formal_Subprogram_Declaration - and then Kind /= N_Subprogram_Declaration - and then Kind /= N_Freeze_Entity - and then Kind /= N_Null_Statement - and then Kind /= N_Itype_Reference + and then not Nkind_In (Kind, N_Subprogram_Declaration, + N_Freeze_Entity, + N_Null_Statement, + N_Itype_Reference) and then Chars (Defining_Identifier (Formal)) = Chars (Defining_Identifier (Analyzed_Formal)); end case; @@ -1123,6 +1123,7 @@ package body Sem_Ch12 is while Present (Actual) loop if Nkind (Actual) = N_Others_Choice then Others_Present := True; + if Present (Next (Actual)) then Error_Msg_N ("others must be last association", Actual); end if; @@ -1181,7 +1182,7 @@ package body Sem_Ch12 is -- to the outer instantiation. if Nkind (Named) /= N_Others_Choice - and then Present (Explicit_Generic_Actual_Parameter (Named)) + and then Present (Explicit_Generic_Actual_Parameter (Named)) then Num_Actuals := Num_Actuals + 1; end if; @@ -1474,9 +1475,9 @@ package body Sem_Ch12 is if Nkind (Def) = N_Constrained_Array_Definition then DSS := First (Discrete_Subtype_Definitions (Def)); while Present (DSS) loop - if Nkind (DSS) = N_Subtype_Indication - or else Nkind (DSS) = N_Range - or else Nkind (DSS) = N_Attribute_Reference + if Nkind_In (DSS, N_Subtype_Indication, + N_Range, + N_Attribute_Reference) then Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); end if; @@ -1499,8 +1500,8 @@ package body Sem_Ch12 is elsif Is_Internal (Component_Type (T)) and then Present (Subtype_Indication (Component_Definition (Def))) and then Nkind (Original_Node - (Subtype_Indication (Component_Definition (Def)))) - = N_Subtype_Indication + (Subtype_Indication (Component_Definition (Def)))) = + N_Subtype_Indication then Error_Msg_N ("in a formal, a subtype indication can only be " @@ -2377,7 +2378,6 @@ package body Sem_Ch12 is end if; elsif Nkind (Def) = N_Indexed_Component then - if Nkind (Prefix (Def)) /= N_Selected_Component then Error_Msg_N ("expect valid subprogram name as default", Def); return; @@ -3124,7 +3124,7 @@ package body Sem_Ch12 is Inline_Now := True; -- In configurable_run_time mode we force the inlining of - -- predefined subprogram marked Inline_Always, to minimize + -- predefined subprograms marked Inline_Always, to minimize -- the use of the run-time library. elsif Is_Predefined_File_Name @@ -3194,10 +3194,11 @@ 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)) = N_Formal_Package_Declaration) + and then Is_List_Member (Decl) + and then Present (Next (Decl)) + and then + Nkind (Next (Decl)) = + N_Formal_Package_Declaration) then Needs_Body := False; end if; @@ -3825,7 +3826,7 @@ package body Sem_Ch12 is Set_Instance_Spec (N, Pack_Decl); Set_Is_Generic_Instance (Pack_Id); - Set_Needs_Debug_Info (Pack_Id); + Set_Debug_Info_Needed (Pack_Id); -- Case of not a compilation unit @@ -3875,7 +3876,7 @@ package body Sem_Ch12 is end if; Set_Is_Generic_Instance (Anon_Id); - Set_Needs_Debug_Info (Anon_Id); + Set_Debug_Info_Needed (Anon_Id); Act_Decl_Id := New_Copy (Anon_Id); Set_Parent (Act_Decl_Id, Parent (Anon_Id)); @@ -4207,15 +4208,15 @@ package body Sem_Ch12 is ------------------------- function Get_Associated_Node (N : Node_Id) return Node_Id is - Assoc : Node_Id := Associated_Node (N); + Assoc : Node_Id; begin + Assoc := Associated_Node (N); + if Nkind (Assoc) /= Nkind (N) then return Assoc; - elsif Nkind (Assoc) = N_Aggregate - or else Nkind (Assoc) = N_Extension_Aggregate - then + elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then return Assoc; else @@ -4235,15 +4236,11 @@ package body Sem_Ch12 is if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) and then Present (Associated_Node (Assoc)) - and then (Nkind (Associated_Node (Assoc)) = N_Function_Call - or else - Nkind (Associated_Node (Assoc)) = N_Explicit_Dereference - or else - Nkind (Associated_Node (Assoc)) = N_Integer_Literal - or else - Nkind (Associated_Node (Assoc)) = N_Real_Literal - or else - Nkind (Associated_Node (Assoc)) = N_String_Literal) + and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, + N_Explicit_Dereference, + N_Integer_Literal, + N_Real_Literal, + N_String_Literal)) then Assoc := Associated_Node (Assoc); end if; @@ -4396,9 +4393,9 @@ package body Sem_Ch12 is if Kind = N_Formal_Type_Declaration then return; - elsif Kind = N_Formal_Object_Declaration + elsif Nkind_In (Kind, N_Formal_Object_Declaration, + N_Formal_Package_Declaration) or else Kind in N_Formal_Subprogram_Declaration - or else Kind = N_Formal_Package_Declaration then null; @@ -5625,10 +5622,10 @@ package body Sem_Ch12 is -- Special casing for identifiers and other entity names and operators - elsif Nkind (New_N) = N_Identifier - or else Nkind (New_N) = N_Character_Literal - or else Nkind (New_N) = N_Expanded_Name - or else Nkind (New_N) = N_Operator_Symbol + elsif Nkind_In (New_N, N_Identifier, + N_Character_Literal, + N_Expanded_Name, + N_Operator_Symbol) or else Nkind (New_N) in N_Op then if not Instantiating then @@ -5673,20 +5670,19 @@ package body Sem_Ch12 is elsif No (Ent) or else - not (Nkind (Ent) = N_Defining_Identifier - or else - Nkind (Ent) = N_Defining_Character_Literal - or else - Nkind (Ent) = N_Defining_Operator_Symbol) + not Nkind_In (Ent, N_Defining_Identifier, + N_Defining_Character_Literal, + N_Defining_Operator_Symbol) or else No (Scope (Ent)) or else (Scope (Ent) = Current_Instantiated_Parent.Gen_Id and then not Is_Child_Unit (Ent)) - or else (Scope_Depth (Scope (Ent)) > + or else + (Scope_Depth (Scope (Ent)) > Scope_Depth (Current_Instantiated_Parent.Gen_Id) - and then - Get_Source_Unit (Ent) = - Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) + and then + Get_Source_Unit (Ent) = + Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) then Set_Associated_Node (New_N, Empty); end if; @@ -5702,6 +5698,7 @@ package body Sem_Ch12 is declare Assoc : constant Node_Id := Get_Associated_Node (N); + begin if Present (Assoc) then if Nkind (Assoc) = Nkind (N) then @@ -5711,9 +5708,9 @@ package body Sem_Ch12 is elsif Nkind (Assoc) = N_Function_Call then Set_Entity (New_N, Entity (Name (Assoc))); - elsif (Nkind (Assoc) = N_Defining_Identifier - or else Nkind (Assoc) = N_Defining_Character_Literal - or else Nkind (Assoc) = N_Defining_Operator_Symbol) + elsif Nkind_In (Assoc, N_Defining_Identifier, + N_Defining_Character_Literal, + N_Defining_Operator_Symbol) and then Expander_Active then -- Inlining case: we are copying a tree that contains @@ -5902,9 +5899,7 @@ package body Sem_Ch12 is Set_Assignment_OK (Name (New_N), True); end if; - elsif Nkind (N) = N_Aggregate - or else Nkind (N) = N_Extension_Aggregate - then + elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then if not Instantiating then Set_Associated_Node (N, New_N); @@ -6029,22 +6024,20 @@ package body Sem_Ch12 is and then Instantiating then declare - Prag_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N)); - + Prag_Id : constant Pragma_Id := Get_Pragma_Id (N); begin 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 (N) = N_Integer_Literal - or else Nkind (N) = N_Real_Literal - or else Nkind (N) = N_String_Literal + elsif Nkind_In (N, N_Integer_Literal, + N_Real_Literal, + N_String_Literal) then -- No descendant fields need traversing @@ -6145,20 +6138,34 @@ package body Sem_Ch12 is ---------------------- function Find_Actual_Type - (Typ : Entity_Id; - Gen_Scope : Entity_Id) return Entity_Id + (Typ : Entity_Id; + Gen_Type : Entity_Id) return Entity_Id is - T : Entity_Id; + Gen_Scope : constant Entity_Id := Scope (Gen_Type); + T : Entity_Id; begin + -- Special processing only applies to child units + if not Is_Child_Unit (Gen_Scope) then return Get_Instance_Of (Typ); + -- If designated or component type is itself a formal of the child unit, + -- its instance is available. + + elsif Scope (Typ) = Gen_Scope then + return Get_Instance_Of (Typ); + + -- If the array or access type is not declared in the parent unit, + -- no special processing needed. + elsif not Is_Generic_Type (Typ) - or else Scope (Typ) = Gen_Scope + and then Scope (Gen_Scope) /= Scope (Typ) then return Get_Instance_Of (Typ); + -- Otherwise, retrieve designated or component type by visibility + else T := Current_Entity (Typ); while Present (T) loop @@ -6397,7 +6404,7 @@ package body Sem_Ch12 is or else (Nkind (Enc_I) = N_Package_Body and then - In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) + 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 @@ -6511,8 +6518,8 @@ package body Sem_Ch12 is if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then return Package_Instantiation (A); - elsif Nkind (Original_Node (Package_Instantiation (A))) - = N_Package_Instantiation + elsif Nkind (Original_Node (Package_Instantiation (A))) = + N_Package_Instantiation then return Original_Node (Package_Instantiation (A)); end if; @@ -6554,8 +6561,8 @@ package body Sem_Ch12 is else Inst := Next (Decl); - while Nkind (Inst) /= N_Package_Instantiation - and then Nkind (Inst) /= N_Formal_Package_Declaration + while not Nkind_In (Inst, N_Package_Instantiation, + N_Formal_Package_Declaration) loop Next (Inst); end loop; @@ -6677,11 +6684,11 @@ package body Sem_Ch12 is if Nod = Decls then return True; - elsif Nkind (Nod) = N_Subprogram_Body - or else Nkind (Nod) = N_Package_Body - or else Nkind (Nod) = N_Task_Body - or else Nkind (Nod) = N_Protected_Body - or else Nkind (Nod) = N_Block_Statement + elsif Nkind_In (Nod, N_Subprogram_Body, + N_Package_Body, + N_Task_Body, + N_Protected_Body, + N_Block_Statement) then return False; @@ -6690,6 +6697,7 @@ package body Sem_Ch12 is elsif Nkind (Nod) = N_Compilation_Unit then return False; + else Nod := Parent (Nod); end if; @@ -6728,7 +6736,7 @@ 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 (Nkind (Nam) = N_Identifier + 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)) @@ -6895,6 +6903,7 @@ 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. @@ -6919,8 +6928,8 @@ package body Sem_Ch12 is Must_Delay := (Gen_Unit = Act_Unit - and then ((Nkind (Gen_Unit) = N_Package_Declaration) - or else Nkind (Gen_Unit) = N_Generic_Package_Declaration + and then (Nkind_In (Gen_Unit, N_Package_Declaration, + N_Generic_Package_Declaration) or else (Gen_Unit = Body_Unit and then True_Sloc (N) < Sloc (Orig_Body))) and then Is_In_Main_Unit (Gen_Unit) @@ -7827,10 +7836,10 @@ package body Sem_Ch12 is end if; if (Present (Act_E) and then Is_Overloadable (Act_E)) - or else Nkind (Act) = N_Attribute_Reference - or else Nkind (Act) = N_Indexed_Component - or else Nkind (Act) = N_Character_Literal - or else Nkind (Act) = N_Explicit_Dereference + or else Nkind_In (Act, N_Attribute_Reference, + N_Indexed_Component, + N_Character_Literal, + N_Explicit_Dereference) then return; end if; @@ -7900,10 +7909,10 @@ package body Sem_Ch12 is Nam := Actual; elsif Present (Default_Name (Formal)) then - if Nkind (Default_Name (Formal)) /= N_Attribute_Reference - and then Nkind (Default_Name (Formal)) /= N_Selected_Component - and then Nkind (Default_Name (Formal)) /= N_Indexed_Component - and then Nkind (Default_Name (Formal)) /= N_Character_Literal + if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, + N_Selected_Component, + N_Indexed_Component, + N_Character_Literal) and then Present (Entity (Default_Name (Formal))) then Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); @@ -8297,7 +8306,7 @@ package body Sem_Ch12 is -- a child unit. if Nkind (Actual) = N_Aggregate then - Pre_Analyze_And_Resolve (Actual, Typ); + Pre_Analyze_And_Resolve (Actual, Typ); end if; if Is_Limited_Type (Typ) @@ -8385,8 +8394,8 @@ package body Sem_Ch12 is if Ada_Version >= Ada_05 and then Present (Actual_Decl) and then - (Nkind (Actual_Decl) = N_Formal_Object_Declaration - or else Nkind (Actual_Decl) = N_Object_Declaration) + Nkind_In (Actual_Decl, N_Formal_Object_Declaration, + N_Object_Declaration) and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration and then Has_Null_Exclusion (Actual_Decl) and then not Has_Null_Exclusion (Analyzed_Formal) @@ -8685,8 +8694,24 @@ package body Sem_Ch12 is Scope_Suppress := Body_Info.Scope_Suppress; if No (Gen_Body_Id) then - Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl)); - Gen_Body_Id := Corresponding_Body (Gen_Decl); + + -- For imported generic subprogram, no body to compile, complete + -- the spec entity appropriately. + + if Is_Imported (Gen_Unit) then + Set_Is_Imported (Anon_Id); + Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit)); + Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit)); + Set_Convention (Anon_Id, Convention (Gen_Unit)); + Set_Has_Completion (Anon_Id); + return; + + -- For other cases, commpile the body + + else + Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl)); + Gen_Body_Id := Corresponding_Body (Gen_Decl); + end if; end if; Instantiation_Node := Inst_Node; @@ -9011,8 +9036,8 @@ package body Sem_Ch12 is procedure Validate_Access_Type_Instance is Desig_Type : constant Entity_Id := - Find_Actual_Type - (Designated_Type (A_Gen_T), Scope (A_Gen_T)); + Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); + Desig_Act : Entity_Id; begin if not Is_Access_Type (Act_T) then @@ -9046,9 +9071,19 @@ package body Sem_Ch12 is -- by an access type declaration (and not by a subtype declaration) -- must match. - if not Subtypes_Match - (Desig_Type, Designated_Type (Base_Type (Act_T))) + Desig_Act := Designated_Type (Base_Type (Act_T)); + + -- The designated type may have been introduced through a limited_ + -- with clause, in which case retrieve the non-limited view. + + if Ekind (Desig_Act) = E_Incomplete_Type + and then From_With_Type (Desig_Act) then + Desig_Act := Available_View (Desig_Act); + end if; + + if not Subtypes_Match + (Desig_Type, Desig_Act) then Error_Msg_NE ("designated type of actual does not match that of formal &", Actual, Gen_T); @@ -9155,7 +9190,7 @@ package body Sem_Ch12 is end if; if not Subtypes_Match - (Find_Actual_Type (Etype (I1), Scope (A_Gen_T)), T2) + (Find_Actual_Type (Etype (I1), A_Gen_T), T2) then Error_Msg_NE ("index types of actual do not match those of formal &", @@ -9167,9 +9202,9 @@ package body Sem_Ch12 is Next_Index (I2); end loop; - if not Subtypes_Match ( - Find_Actual_Type (Component_Type (A_Gen_T), Scope (A_Gen_T)), - Component_Type (Act_T)) + if not Subtypes_Match + (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), + Component_Type (Act_T)) then Error_Msg_NE ("component subtype of actual does not match that of formal &", @@ -9184,7 +9219,6 @@ package body Sem_Ch12 is ("actual must have aliased components to match formal type &", Actual, Gen_T); end if; - end Validate_Array_Type_Instance; ----------------------------------------------- @@ -10151,9 +10185,9 @@ package body Sem_Ch12 is 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 + Nkind_In (Kind, N_Formal_Object_Declaration, + N_Formal_Package_Declaration, + N_Formal_Type_Declaration) or else (Is_Formal_Subprogram (E) and then @@ -10670,6 +10704,20 @@ package body Sem_Ch12 is end if; if Errs /= Serious_Errors_Detected then + + -- Do a minimal analysis of the generic, to prevent spurious + -- warnings complaining about the generic being unreferenced, + -- before abandoning the instantiation. + + Analyze (Name (N)); + + if Is_Entity_Name (Name (N)) + and then Etype (Name (N)) /= Any_Type + then + Generate_Reference (Entity (Name (N)), Name (N)); + Set_Is_Instantiated (Entity (Name (N))); + end if; + Abandon_Instantiation (Act); end if; end if; @@ -10772,12 +10820,12 @@ package body Sem_Ch12 is Restore_Private_Views (Empty); end if; - Current_Instantiated_Parent := Saved.Instantiated_Parent; - Exchanged_Views := Saved.Exchanged_Views; - Hidden_Entities := Saved.Hidden_Entities; - Current_Sem_Unit := Saved.Current_Sem_Unit; - Parent_Unit_Visible := Saved.Parent_Unit_Visible; - Instance_Parent_Unit := Saved.Instance_Parent_Unit; + Current_Instantiated_Parent := Saved.Instantiated_Parent; + Exchanged_Views := Saved.Exchanged_Views; + Hidden_Entities := Saved.Hidden_Entities; + Current_Sem_Unit := Saved.Current_Sem_Unit; + Parent_Unit_Visible := Saved.Parent_Unit_Visible; + Instance_Parent_Unit := Saved.Instance_Parent_Unit; Restore_Opt_Config_Switches (Saved.Switches); @@ -10816,7 +10864,6 @@ package body Sem_Ch12 is return; elsif Present (Associated_Formal_Package (Formal)) then - Ent := First_Entity (Formal); while Present (Ent) loop exit when Ekind (Ent) = E_Package @@ -10890,8 +10937,8 @@ 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 + -- visible in the context of the instance. The internal subtype + -- 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 @@ -10915,8 +10962,8 @@ package body Sem_Ch12 is -- 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. + -- 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 @@ -11033,7 +11080,7 @@ package body Sem_Ch12 is --------------- function Is_Global (E : Entity_Id) return Boolean is - Se : Entity_Id := Scope (E); + Se : Entity_Id; function Is_Instance_Node (Decl : Node_Id) return Boolean; -- Determine whether the parent node of a reference to a child unit @@ -11064,13 +11111,15 @@ package body Sem_Ch12 is elsif Is_Child_Unit (E) and then (Is_Instance_Node (Parent (N2)) - or else (Nkind (Parent (N2)) = N_Expanded_Name - and then N2 = Selector_Name (Parent (N2)) - and then Is_Instance_Node (Parent (Parent (N2))))) + or else (Nkind (Parent (N2)) = N_Expanded_Name + and then N2 = Selector_Name (Parent (N2)) + and then + Is_Instance_Node (Parent (Parent (N2))))) then return True; else + Se := Scope (E); while Se /= Gen_Scope loop if Se = Standard_Standard then return True; @@ -11153,9 +11202,10 @@ package body Sem_Ch12 is ------------------ function Top_Ancestor (E : Entity_Id) return Entity_Id is - Par : Entity_Id := E; + Par : Entity_Id; begin + Par := E; while Is_Child_Unit (Par) loop Par := Scope (Par); end loop; @@ -11241,8 +11291,7 @@ package body Sem_Ch12 is -- its value. Otherwise the folding will happen in any instantiation, elsif Nkind (Parent (N)) = N_Selected_Component - and then (Nkind (Parent (N2)) = N_Integer_Literal - or else Nkind (Parent (N2)) = N_Real_Literal) + and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) then if Present (Entity (Original_Node (Parent (N2)))) and then Is_Global (Entity (Original_Node (Parent (N2)))) @@ -11504,9 +11553,7 @@ package body Sem_Ch12 is if N = Empty then null; - elsif Nkind (N) = N_Character_Literal - or else Nkind (N) = N_Operator_Symbol - then + elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then if Nkind (N) = Nkind (Get_Associated_Node (N)) then Reset_Entity (N); @@ -11545,9 +11592,9 @@ package body Sem_Ch12 is Set_Etype (N, Empty); end if; - elsif Nkind (N2) = N_Integer_Literal - or else Nkind (N2) = N_Real_Literal - or else Nkind (N2) = N_String_Literal + elsif Nkind_In (N2, N_Integer_Literal, + N_Real_Literal, + N_String_Literal) then if Present (Original_Node (N2)) and then Nkind (Original_Node (N2)) = Nkind (N) @@ -11588,8 +11635,7 @@ package body Sem_Ch12 is end if; end if; - -- Complete the check on operands, if node has not been - -- constant-folded. + -- Complete operands check if node has not been constant-folded if Nkind (N) in N_Op then Save_Entity_Descendants (N); @@ -11624,10 +11670,7 @@ package body Sem_Ch12 is Set_Etype (N, Empty); end if; - elsif - (Nkind (N2) = N_Integer_Literal - or else - Nkind (N2) = N_Real_Literal) + elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) and then Is_Entity_Name (Original_Node (N2)) then -- Name resolves to named number that is constant-folded, @@ -11712,10 +11755,7 @@ package body Sem_Ch12 is -- traversal, so it needs direct access to node fields. begin - if Nkind (N) = N_Aggregate - or else - Nkind (N) = N_Extension_Aggregate - then + if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then N2 := Get_Associated_Node (N); if No (N2) then @@ -11723,10 +11763,10 @@ package body Sem_Ch12 is else Typ := Etype (N2); - -- In an instance within a generic, use the name of - -- the actual and not the original generic parameter. - -- If the actual is global in the current generic it - -- must be preserved for its instantiation. + -- In an instance within a generic, use the name of the + -- actual and not the original generic parameter. If the + -- actual is global in the current generic it must be + -- preserved for its instantiation. if Nkind (Parent (Typ)) = N_Subtype_Declaration and then @@ -11759,8 +11799,8 @@ package body Sem_Ch12 is if Nkind (N2) = Nkind (N) and then - (Nkind (Parent (N2)) = N_Procedure_Call_Statement - or else Nkind (Parent (N2)) = N_Function_Call) + Nkind_In (Parent (N2), N_Procedure_Call_Statement, + N_Function_Call) and then Comes_From_Source (Typ) then if Is_Immediately_Visible (Scope (Typ)) then