diff options
Diffstat (limited to 'gcc/ada/sem_ch12.adb')
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 270 |
1 files changed, 235 insertions, 35 deletions
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index ec270f3ad19..223703d2a43 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -839,6 +839,10 @@ package body Sem_Ch12 is -- entity is marked as having a limited_view actual when some actual is -- a limited view. This is used to place the instance body properly. + procedure Provide_Completing_Bodies (N : Node_Id); + -- Generate completing bodies for all subprograms found within package or + -- subprogram declaration N. + procedure Remove_Parent (In_Body : Boolean := False); -- Reverse effect after instantiation of child is complete @@ -1903,7 +1907,8 @@ package body Sem_Ch12 is -- body. Explicit_Freeze_Check : declare - Actual : constant Entity_Id := Entity (Match); + Actual : constant Entity_Id := Entity (Match); + Gen_Par : Entity_Id; Needs_Freezing : Boolean; S : Entity_Id; @@ -1912,7 +1917,11 @@ package body Sem_Ch12 is -- The actual may be an instantiation of a unit -- declared in a previous instantiation. If that -- one is also in the current compilation, it must - -- itself be frozen before the actual. + -- itself be frozen before the actual. The actual + -- may be an instantiation of a generic child unit, + -- in which case the same applies to the instance + -- of the parent which must be frozen before the + -- actual. -- Should this itself be recursive ??? -------------------------- @@ -1920,30 +1929,72 @@ package body Sem_Ch12 is -------------------------- procedure Check_Generic_Parent is - Par : Entity_Id; + Inst : constant Node_Id := + Next (Unit_Declaration_Node (Actual)); + Par : Entity_Id; begin - if Nkind (Parent (Actual)) = - N_Package_Specification + Par := Empty; + + if Nkind (Parent (Actual)) = N_Package_Specification then Par := Scope (Generic_Parent (Parent (Actual))); - if Is_Generic_Instance (Par) - and then Scope (Par) = Current_Scope - and then - (No (Freeze_Node (Par)) - or else - not Is_List_Member (Freeze_Node (Par))) + if Is_Generic_Instance (Par) then + null; + + -- If the actual is a child generic unit, check + -- whether the instantiation of the parent is + -- also local and must also be frozen now. We + -- must retrieve the instance node to locate the + -- parent instance if any. + + elsif Ekind (Par) = E_Generic_Package + and then Is_Child_Unit (Gen_Par) + and then Ekind (Scope (Gen_Par)) = + E_Generic_Package then - Set_Has_Delayed_Freeze (Par); - Append_Elmt (Par, Actuals_To_Freeze); + if Nkind (Inst) = N_Package_Instantiation + and then Nkind (Name (Inst)) = + N_Expanded_Name + then + -- Retrieve entity of parent instance + + Par := Entity (Prefix (Name (Inst))); + end if; + + else + Par := Empty; end if; end if; + + if Present (Par) + and then Is_Generic_Instance (Par) + and then Scope (Par) = Current_Scope + and then + (No (Freeze_Node (Par)) + or else + not Is_List_Member (Freeze_Node (Par))) + then + Set_Has_Delayed_Freeze (Par); + Append_Elmt (Par, Actuals_To_Freeze); + end if; end Check_Generic_Parent; -- Start of processing for Explicit_Freeze_Check begin + if Present (Renamed_Entity (Actual)) then + Gen_Par := + Generic_Parent (Specification + (Unit_Declaration_Node + (Renamed_Entity (Actual)))); + else + Gen_Par := + Generic_Parent (Specification + (Unit_Declaration_Node (Actual))); + end if; + if not Expander_Active or else not Has_Completion (Actual) or else not In_Same_Source_Unit (I_Node, Actual) @@ -1986,12 +2037,13 @@ package body Sem_Ch12 is -- that it is the instance that must be frozen. if Nkind (Parent (Actual)) = - N_Package_Renaming_Declaration + N_Package_Renaming_Declaration then Set_Has_Delayed_Freeze (Renamed_Entity (Actual)); Append_Elmt - (Renamed_Entity (Actual), Actuals_To_Freeze); + (Renamed_Entity (Actual), + Actuals_To_Freeze); else Set_Has_Delayed_Freeze (Actual); Append_Elmt (Actual, Actuals_To_Freeze); @@ -3496,6 +3548,14 @@ package body Sem_Ch12 is Set_SPARK_Pragma_Inherited (Id); Set_SPARK_Aux_Pragma_Inherited (Id); + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => Id, + Checks => True); + -- Analyze aspects now, so that generated pragmas appear in the -- declarations before building and analyzing the generic copy. @@ -3624,7 +3684,7 @@ package body Sem_Ch12 is Create_Generic_Contract (N); Spec := Specification (N); - Id := Defining_Entity (Spec); + Id := Defining_Entity (Spec); Generate_Definition (Id); if Nkind (Id) = N_Defining_Operator_Symbol then @@ -3651,14 +3711,27 @@ package body Sem_Ch12 is Analyze_Generic_Formal_Part (N); - Formals := Parameter_Specifications (Spec); - if Nkind (Spec) = N_Function_Specification then Set_Ekind (Id, E_Generic_Function); else Set_Ekind (Id, E_Generic_Procedure); end if; + -- Set SPARK_Mode from context + + Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Id); + + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => Id, + Checks => True); + + Formals := Parameter_Specifications (Spec); + if Present (Formals) then Process_Formals (Formals, Spec); end if; @@ -3854,6 +3927,16 @@ package body Sem_Ch12 is -- Start of processing for Analyze_Package_Instantiation begin + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => N, + Checks => True, + Level => True, + Modes => True); + Check_SPARK_05_Restriction ("generic is not allowed", N); -- Very first thing: check for Text_IO special unit in case we are @@ -4516,19 +4599,26 @@ package body Sem_Ch12 is Analyze (Act_Decl); Set_Unit (Parent (N), N); Set_Body_Required (Parent (N), False); + end if; - -- We never need elaboration checks on instantiations, since by - -- definition, the body instantiation is elaborated at the same - -- time as the spec instantiation. + -- Save the scenario for later examination by the ABE Processing + -- phase. - Set_Suppress_Elaboration_Warnings (Act_Decl_Id); - Set_Kill_Elaboration_Checks (Act_Decl_Id); - end if; + Record_Elaboration_Scenario (N); + + -- The instantiation results in a guaranteed ABE - Check_Elab_Instantiation (N); + if Is_Known_Guaranteed_ABE (N) and then Needs_Body then + + -- Do not instantiate the corresponding body because gigi cannot + -- handle certain types of premature instantiations. - if ABE_Is_Certain (N) and then Needs_Body then Pending_Instantiations.Decrement_Last; + + -- Create completing bodies for all subprogram declarations since + -- their real bodies will not be instantiated. + + Provide_Completing_Bodies (Instance_Spec (N)); end if; Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); @@ -5010,7 +5100,7 @@ package body Sem_Ch12 is -- No point in inlining if ABE is inevitable - and then not ABE_Is_Certain (N) + and then not Is_Known_Guaranteed_ABE (N) -- Or if subprogram is eliminated @@ -5196,12 +5286,7 @@ package body Sem_Ch12 is Check_Eliminated (Act_Decl_Id); Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); - -- In compilation unit case, kill elaboration checks on the - -- instantiation, since they are never needed -- the body is - -- instantiated at the same point as the spec. - if Nkind (Parent (N)) = N_Compilation_Unit then - Set_Suppress_Elaboration_Warnings (Act_Decl_Id); Set_Kill_Elaboration_Checks (Act_Decl_Id); Set_Is_Compilation_Unit (Anon_Id); @@ -5292,6 +5377,16 @@ package body Sem_Ch12 is -- Start of processing for Analyze_Subprogram_Instantiation begin + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => N, + Checks => True, + Level => True, + Modes => True); + Check_SPARK_05_Restriction ("generic is not allowed", N); -- Very first thing: check for special Text_IO unit in case we are @@ -5544,8 +5639,17 @@ package body Sem_Ch12 is Set_Ignore_SPARK_Mode_Pragmas (Anon_Id); end if; - if not Is_Intrinsic_Subprogram (Gen_Unit) then - Check_Elab_Instantiation (N); + -- Save the scenario for later examination by the ABE Processing + -- phase. + + Record_Elaboration_Scenario (N); + + -- The instantiation results in a guaranteed ABE. Create a completing + -- body for the subprogram declaration because the real body will not + -- be instantiated. + + if Is_Known_Guaranteed_ABE (N) then + Provide_Completing_Bodies (Instance_Spec (N)); end if; if Is_Dispatching_Operation (Act_Decl_Id) @@ -8515,7 +8619,7 @@ package body Sem_Ch12 is -- The parent was a premature instantiation. Insert freeze node at -- the end the current declarative part. - if ABE_Is_Certain (Get_Unit_Instantiation_Node (Par)) then + if Is_Known_Guaranteed_ABE (Get_Unit_Instantiation_Node (Par)) then Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); -- Handle the following case: @@ -13945,6 +14049,102 @@ package body Sem_Ch12 is end if; end Preanalyze_Actuals; + ------------------------------- + -- Provide_Completing_Bodies -- + ------------------------------- + + procedure Provide_Completing_Bodies (N : Node_Id) is + procedure Build_Completing_Body (Subp_Decl : Node_Id); + -- Generate the completing body for subprogram declaration Subp_Decl + + procedure Provide_Completing_Bodies_In (Decls : List_Id); + -- Generating completing bodies for all subprograms found in declarative + -- list Decls. + + --------------------------- + -- Build_Completing_Body -- + --------------------------- + + procedure Build_Completing_Body (Subp_Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Subp_Decl); + Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); + Spec : Node_Id; + + begin + -- Nothing to do if the subprogram already has a completing body + + if Present (Corresponding_Body (Subp_Decl)) then + return; + + -- Mark the function as having a valid return statement even though + -- the body contains a single raise statement. + + elsif Ekind (Subp_Id) = E_Function then + Set_Return_Present (Subp_Id); + end if; + + -- Clone the specification to obtain new entities and reset the only + -- semantic field. + + Spec := Copy_Subprogram_Spec (Specification (Subp_Decl)); + Set_Generic_Parent (Spec, Empty); + + -- Generate: + -- function Func ... return ... is + -- <or> + -- procedure Proc ... is + -- begin + -- raise Program_Error with "access before elaboration"; + -- edn Proc; + + Insert_After_And_Analyze (Subp_Decl, + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration))))); + end Build_Completing_Body; + + ---------------------------------- + -- Provide_Completing_Bodies_In -- + ---------------------------------- + + procedure Provide_Completing_Bodies_In (Decls : List_Id) is + Decl : Node_Id; + + begin + if Present (Decls) then + Decl := First (Decls); + while Present (Decl) loop + Provide_Completing_Bodies (Decl); + Next (Decl); + end loop; + end if; + end Provide_Completing_Bodies_In; + + -- Local variables + + Spec : Node_Id; + + -- Start of processing for Provide_Completing_Bodies + + begin + if Nkind (N) = N_Package_Declaration then + Spec := Specification (N); + + Push_Scope (Defining_Entity (N)); + Provide_Completing_Bodies_In (Visible_Declarations (Spec)); + Provide_Completing_Bodies_In (Private_Declarations (Spec)); + Pop_Scope; + + elsif Nkind (N) = N_Subprogram_Declaration then + Build_Completing_Body (N); + end if; + end Provide_Completing_Bodies; + ------------------- -- Remove_Parent -- ------------------- |