diff options
Diffstat (limited to 'gcc/ada/sem_ch7.adb')
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 174 |
1 files changed, 63 insertions, 111 deletions
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 6d9a1db..3ff2001 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2020, 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- -- @@ -47,7 +47,6 @@ with Nmake; use Nmake; with Nlists; use Nlists; with Opt; use Opt; with Output; use Output; -with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; @@ -463,29 +462,44 @@ package body Sem_Ch7 is -- Exceptions, objects and renamings do not need to be public -- if they are not followed by a construct which can reference - -- and export them. Likewise for subprograms but we work harder + -- and export them. + + elsif Nkind (Decl) in N_Exception_Declaration + | N_Object_Declaration + | N_Object_Renaming_Declaration + then + Decl_Id := Defining_Entity (Decl); + + if not In_Nested_Instance + and then not Is_Imported (Decl_Id) + and then not Is_Exported (Decl_Id) + and then No (Interface_Name (Decl_Id)) + and then not Has_Referencer_Of_Non_Subprograms + then + Set_Is_Public (Decl_Id, False); + end if; + + -- Likewise for subprograms and renamings, but we work harder -- for them to see whether they are referenced on an individual -- basis by looking into the table of referenced subprograms. - -- But we cannot say anything for entities declared in nested - -- instances because instantiations are not done yet so the - -- bodies are not visible and could contain references to them. - elsif Nkind_In (Decl, N_Exception_Declaration, - N_Object_Declaration, - N_Object_Renaming_Declaration, - N_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration) + + elsif Nkind (Decl) in N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration then Decl_Id := Defining_Entity (Decl); - if not In_Nested_Instance + -- We cannot say anything for subprograms declared in nested + -- instances because instantiations are not done yet so the + -- bodies are not visible and could contain references to + -- them, except if we still have no subprograms at all which + -- are referenced by an inlined body. + + if (not In_Nested_Instance + or else not Subprogram_Table.Get_First) and then not Is_Imported (Decl_Id) and then not Is_Exported (Decl_Id) and then No (Interface_Name (Decl_Id)) - and then - ((Nkind (Decl) /= N_Subprogram_Declaration - and then not Has_Referencer_Of_Non_Subprograms) - or else (Nkind (Decl) = N_Subprogram_Declaration - and then not Subprogram_Table.Get (Decl_Id))) + and then not Subprogram_Table.Get (Decl_Id) then Set_Is_Public (Decl_Id, False); end if; @@ -956,6 +970,15 @@ package body Sem_Ch7 is ("\value Off was set for SPARK_Mode on & #", N, Spec_Id); end if; + -- SPARK_Mode Off could complete no SPARK_Mode in a generic, either + -- as specified in source code, or because SPARK_Mode On is ignored + -- in an instance where the context is SPARK_Mode Off/Auto. + + elsif Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = Off + and then (Is_Generic_Unit (Spec_Id) or else In_Instance) + then + null; + else Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id)); Error_Msg_N ("incorrect application of SPARK_Mode#", N); @@ -1073,9 +1096,13 @@ package body Sem_Ch7 is -- unit, especially subprograms. -- This is done only for top-level library packages or child units as - -- the algorithm does a top-down traversal of the package body. + -- the algorithm does a top-down traversal of the package body. This is + -- also done for instances because instantiations are still pending by + -- the time the enclosing package body is analyzed. - if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) + if (Scope (Spec_Id) = Standard_Standard + or else Is_Child_Unit (Spec_Id) + or else Is_Generic_Instance (Spec_Id)) and then not Is_Generic_Unit (Spec_Id) then Hide_Public_Entities (Declarations (N)); @@ -1262,10 +1289,6 @@ package body Sem_Ch7 is -- private_with_clauses, and remove them at the end of the nested -- package. - procedure Check_One_Tagged_Type_Or_Extension_At_Most; - -- Issue an error in SPARK mode if a package specification contains - -- more than one tagged type or type extension. - procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); -- Clears constant indications (Never_Set_In_Source, Constant_Value, and -- Is_True_Constant) on all variables that are entities of Id, and on @@ -1292,58 +1315,6 @@ package body Sem_Ch7 is -- private part rather than being done in Sem_Ch12.Install_Parent -- (which is where the parents' visible declarations are installed). - ------------------------------------------------ - -- Check_One_Tagged_Type_Or_Extension_At_Most -- - ------------------------------------------------ - - procedure Check_One_Tagged_Type_Or_Extension_At_Most is - Previous : Node_Id; - - procedure Check_Decls (Decls : List_Id); - -- Check that either Previous is Empty and Decls does not contain - -- more than one tagged type or type extension, or Previous is - -- already set and Decls contains no tagged type or type extension. - - ----------------- - -- Check_Decls -- - ----------------- - - procedure Check_Decls (Decls : List_Id) is - Decl : Node_Id; - - begin - Decl := First (Decls); - while Present (Decl) loop - if Nkind (Decl) = N_Full_Type_Declaration - and then Is_Tagged_Type (Defining_Identifier (Decl)) - then - if No (Previous) then - Previous := Decl; - - else - Error_Msg_Sloc := Sloc (Previous); - Check_SPARK_05_Restriction - ("at most one tagged type or type extension allowed", - "\\ previous declaration#", - Decl); - end if; - end if; - - Next (Decl); - end loop; - end Check_Decls; - - -- Start of processing for Check_One_Tagged_Type_Or_Extension_At_Most - - begin - Previous := Empty; - Check_Decls (Vis_Decls); - - if Present (Priv_Decls) then - Check_Decls (Priv_Decls); - end if; - end Check_One_Tagged_Type_Or_Extension_At_Most; - --------------------- -- Clear_Constants -- --------------------- @@ -1399,8 +1370,8 @@ package body Sem_Ch7 is then Generate_Reference (Id, Scope (Id), 'k', False); - elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body, - N_Subunit) + elsif Nkind (Unit (Cunit (Main_Unit))) not in + N_Subprogram_Body | N_Subunit then -- If current unit is an ancestor of main unit, generate a -- reference to its own parent. @@ -1466,8 +1437,8 @@ package body Sem_Ch7 is -- prevents cascaded errors when routines defined only for type -- entities are called with non-type entities. - if Nkind_In (Decl, N_Incomplete_Type_Declaration, - N_Private_Type_Declaration) + if Nkind (Decl) in N_Incomplete_Type_Declaration + | N_Private_Type_Declaration and then Is_Type (Defining_Identifier (Decl)) and then Has_Discriminants (Defining_Identifier (Decl)) and then Present (Full_View (Defining_Identifier (Decl))) @@ -1501,8 +1472,8 @@ package body Sem_Ch7 is while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop Inst_Node := Get_Unit_Instantiation_Node (Inst_Par); - if Nkind_In (Inst_Node, N_Package_Instantiation, - N_Formal_Package_Declaration) + if Nkind (Inst_Node) in + N_Package_Instantiation | N_Formal_Package_Declaration and then Nkind (Name (Inst_Node)) = N_Expanded_Name then Inst_Par := Entity (Prefix (Name (Inst_Node))); @@ -1880,11 +1851,6 @@ package body Sem_Ch7 is Clear_Constants (Id, First_Private_Entity (Id)); end if; - -- Issue an error in SPARK mode if a package specification contains - -- more than one tagged type or type extension. - - Check_One_Tagged_Type_Or_Extension_At_Most; - -- Output relevant information as to why the package requires a body. -- Do not consider generated packages as this exposes internal symbols -- and leads to confusing messages. @@ -2428,7 +2394,7 @@ package body Sem_Ch7 is -- defined in the associated package, subject to at least one Part_Of -- constituent. - if Ekind_In (P, E_Generic_Package, E_Package) then + if Is_Package_Or_Generic_Package (P) then declare States : constant Elist_Id := Abstract_States (P); State_Elmt : Elmt_Id; @@ -2674,7 +2640,7 @@ package body Sem_Ch7 is -- implicit completion at some point. elsif (Is_Overloadable (Id) - and then not Ekind_In (Id, E_Enumeration_Literal, E_Operator) + and then Ekind (Id) not in E_Enumeration_Literal | E_Operator and then not Is_Abstract_Subprogram (Id) and then not Has_Completion (Id) and then Comes_From_Source (Parent (Id))) @@ -2691,7 +2657,7 @@ package body Sem_Ch7 is and then not Is_Generic_Type (Id)) or else - (Ekind_In (Id, E_Task_Type, E_Protected_Type) + (Ekind (Id) in E_Task_Type | E_Protected_Type and then not Has_Completion (Id)) or else @@ -2792,34 +2758,20 @@ package body Sem_Ch7 is Set_Freeze_Node (Priv, Freeze_Node (Full)); -- Propagate Default_Initial_Condition-related attributes from the - -- base type of the full view to the full view and vice versa. This - -- may seem strange, but is necessary depending on which type - -- triggered the generation of the DIC procedure body. As a result, - -- both the full view and its base type carry the same DIC-related - -- information. - - Propagate_DIC_Attributes (Full, From_Typ => Full_Base); - Propagate_DIC_Attributes (Full_Base, From_Typ => Full); - - -- Propagate Default_Initial_Condition-related attributes from the -- full view to the private view. Propagate_DIC_Attributes (Priv, From_Typ => Full); - -- Propagate invariant-related attributes from the base type of the - -- full view to the full view and vice versa. This may seem strange, - -- but is necessary depending on which type triggered the generation - -- of the invariant procedure body. As a result, both the full view - -- and its base type carry the same invariant-related information. - - Propagate_Invariant_Attributes (Full, From_Typ => Full_Base); - Propagate_Invariant_Attributes (Full_Base, From_Typ => Full); - -- Propagate invariant-related attributes from the full view to the -- private view. Propagate_Invariant_Attributes (Priv, From_Typ => Full); + -- Propagate predicate-related attributes from the full view to the + -- private view. + + Propagate_Predicate_Attributes (Priv, From_Typ => Full); + if Is_Tagged_Type (Priv) and then Is_Tagged_Type (Full) and then not Error_Posted (Full) @@ -3007,7 +2959,7 @@ package body Sem_Ch7 is Check_Conventions (Id); end if; - if Ekind_In (Id, E_Private_Type, E_Limited_Private_Type) + if Ekind (Id) in E_Private_Type | E_Limited_Private_Type and then No (Full_View (Id)) and then not Is_Generic_Type (Id) and then not Is_Derived_Type (Id) @@ -3322,7 +3274,7 @@ package body Sem_Ch7 is -- performed if the caller requests this behavior. if Do_Abstract_States - and then Ekind_In (Pack_Id, E_Generic_Package, E_Package) + and then Is_Package_Or_Generic_Package (Pack_Id) and then Has_Non_Null_Abstract_State (Pack_Id) and then Requires_Body then @@ -3380,7 +3332,7 @@ package body Sem_Ch7 is -- provided). If Ignore_Abstract_State is True, we don't do this check -- (so we can use Unit_Requires_Body to check for some other reason). - elsif Ekind_In (Pack_Id, E_Generic_Package, E_Package) + elsif Is_Package_Or_Generic_Package (Pack_Id) and then Present (Abstract_States (Pack_Id)) and then not Is_Null_State (Node (First_Elmt (Abstract_States (Pack_Id)))) |