| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ C H 6 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2019, 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- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Aspects; use Aspects; |
| with Atree; use Atree; |
| with Checks; use Checks; |
| with Contracts; use Contracts; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Expander; use Expander; |
| with Exp_Ch6; use Exp_Ch6; |
| with Exp_Ch7; use Exp_Ch7; |
| with Exp_Ch9; use Exp_Ch9; |
| with Exp_Dbug; use Exp_Dbug; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Freeze; use Freeze; |
| with Ghost; use Ghost; |
| with Inline; use Inline; |
| with Itypes; use Itypes; |
| with Lib.Xref; use Lib.Xref; |
| with Layout; use Layout; |
| with Namet; use Namet; |
| with Lib; use Lib; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Output; use Output; |
| with Restrict; use Restrict; |
| with Rident; use Rident; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Cat; use Sem_Cat; |
| with Sem_Ch3; use Sem_Ch3; |
| with Sem_Ch4; use Sem_Ch4; |
| with Sem_Ch5; use Sem_Ch5; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Ch9; use Sem_Ch9; |
| with Sem_Ch10; use Sem_Ch10; |
| with Sem_Ch12; use Sem_Ch12; |
| with Sem_Ch13; use Sem_Ch13; |
| with Sem_Dim; use Sem_Dim; |
| with Sem_Disp; use Sem_Disp; |
| with Sem_Dist; use Sem_Dist; |
| with Sem_Elim; use Sem_Elim; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Mech; use Sem_Mech; |
| with Sem_Prag; use Sem_Prag; |
| with Sem_Res; use Sem_Res; |
| with Sem_Util; use Sem_Util; |
| with Sem_Type; use Sem_Type; |
| with Sem_Warn; use Sem_Warn; |
| with Sinput; use Sinput; |
| with Stand; use Stand; |
| with Sinfo; use Sinfo; |
| with Sinfo.CN; use Sinfo.CN; |
| with Snames; use Snames; |
| with Stringt; use Stringt; |
| with Style; |
| with Stylesw; use Stylesw; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| with Urealp; use Urealp; |
| with Validsw; use Validsw; |
| |
| package body Sem_Ch6 is |
| |
| May_Hide_Profile : Boolean := False; |
| -- This flag is used to indicate that two formals in two subprograms being |
| -- checked for conformance differ only in that one is an access parameter |
| -- while the other is of a general access type with the same designated |
| -- type. In this case, if the rest of the signatures match, a call to |
| -- either subprogram may be ambiguous, which is worth a warning. The flag |
| -- is set in Compatible_Types, and the warning emitted in |
| -- New_Overloaded_Entity. |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Analyze_Function_Return (N : Node_Id); |
| -- Subsidiary to Analyze_Return_Statement. Called when the return statement |
| -- applies to a [generic] function. |
| |
| procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id); |
| -- Analyze a generic subprogram body. N is the body to be analyzed, and |
| -- Gen_Id is the defining entity Id for the corresponding spec. |
| |
| procedure Analyze_Null_Procedure |
| (N : Node_Id; |
| Is_Completion : out Boolean); |
| -- A null procedure can be a declaration or (Ada 2012) a completion |
| |
| procedure Analyze_Return_Statement (N : Node_Id); |
| -- Common processing for simple and extended return statements |
| |
| procedure Analyze_Return_Type (N : Node_Id); |
| -- Subsidiary to Process_Formals: analyze subtype mark in function |
| -- specification in a context where the formals are visible and hide |
| -- outer homographs. |
| |
| procedure Analyze_Subprogram_Body_Helper (N : Node_Id); |
| -- Does all the real work of Analyze_Subprogram_Body. This is split out so |
| -- that we can use RETURN but not skip the debug output at the end. |
| |
| function Can_Override_Operator (Subp : Entity_Id) return Boolean; |
| -- Returns true if Subp can override a predefined operator. |
| |
| procedure Check_Conformance |
| (New_Id : Entity_Id; |
| Old_Id : Entity_Id; |
| Ctype : Conformance_Type; |
| Errmsg : Boolean; |
| Conforms : out Boolean; |
| Err_Loc : Node_Id := Empty; |
| Get_Inst : Boolean := False; |
| Skip_Controlling_Formals : Boolean := False); |
| -- Given two entities, this procedure checks that the profiles associated |
| -- with these entities meet the conformance criterion given by the third |
| -- parameter. If they conform, Conforms is set True and control returns |
| -- to the caller. If they do not conform, Conforms is set to False, and |
| -- in addition, if Errmsg is True on the call, proper messages are output |
| -- to complain about the conformance failure. If Err_Loc is non_Empty |
| -- the error messages are placed on Err_Loc, if Err_Loc is empty, then |
| -- error messages are placed on the appropriate part of the construct |
| -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance |
| -- against a formal access-to-subprogram type so Get_Instance_Of must |
| -- be called. |
| |
| procedure Check_Limited_Return |
| (N : Node_Id; |
| Expr : Node_Id; |
| R_Type : Entity_Id); |
| -- Check the appropriate (Ada 95 or Ada 2005) rules for returning limited |
| -- types. Used only for simple return statements. Expr is the expression |
| -- returned. |
| |
| procedure Check_Subprogram_Order (N : Node_Id); |
| -- N is the N_Subprogram_Body node for a subprogram. This routine applies |
| -- the alpha ordering rule for N if this ordering requirement applicable. |
| |
| procedure Check_Returns |
| (HSS : Node_Id; |
| Mode : Character; |
| Err : out Boolean; |
| Proc : Entity_Id := Empty); |
| -- Called to check for missing return statements in a function body, or for |
| -- returns present in a procedure body which has No_Return set. HSS is the |
| -- handled statement sequence for the subprogram body. This procedure |
| -- checks all flow paths to make sure they either have return (Mode = 'F', |
| -- used for functions) or do not have a return (Mode = 'P', used for |
| -- No_Return procedures). The flag Err is set if there are any control |
| -- paths not explicitly terminated by a return in the function case, and is |
| -- True otherwise. Proc is the entity for the procedure case and is used |
| -- in posting the warning message. |
| |
| procedure Check_Untagged_Equality (Eq_Op : Entity_Id); |
| -- In Ada 2012, a primitive equality operator on an untagged record type |
| -- must appear before the type is frozen, and have the same visibility as |
| -- that of the type. This procedure checks that this rule is met, and |
| -- otherwise emits an error on the subprogram declaration and a warning |
| -- on the earlier freeze point if it is easy to locate. In Ada 2012 mode, |
| -- this routine outputs errors (or warnings if -gnatd.E is set). In earlier |
| -- versions of Ada, warnings are output if Warn_On_Ada_2012_Incompatibility |
| -- is set, otherwise the call has no effect. |
| |
| procedure Enter_Overloaded_Entity (S : Entity_Id); |
| -- This procedure makes S, a new overloaded entity, into the first visible |
| -- entity with that name. |
| |
| function Is_Non_Overriding_Operation |
| (Prev_E : Entity_Id; |
| New_E : Entity_Id) return Boolean; |
| -- Enforce the rule given in 12.3(18): a private operation in an instance |
| -- overrides an inherited operation only if the corresponding operation |
| -- was overriding in the generic. This needs to be checked for primitive |
| -- operations of types derived (in the generic unit) from formal private |
| -- or formal derived types. |
| |
| procedure Make_Inequality_Operator (S : Entity_Id); |
| -- Create the declaration for an inequality operator that is implicitly |
| -- created by a user-defined equality operator that yields a boolean. |
| |
| procedure Preanalyze_Formal_Expression (N : Node_Id; T : Entity_Id); |
| -- Preanalysis of default expressions of subprogram formals. N is the |
| -- expression to be analyzed and T is the expected type. |
| |
| procedure Set_Formal_Validity (Formal_Id : Entity_Id); |
| -- Formal_Id is an formal parameter entity. This procedure deals with |
| -- setting the proper validity status for this entity, which depends on |
| -- the kind of parameter and the validity checking mode. |
| |
| --------------------------------------------- |
| -- Analyze_Abstract_Subprogram_Declaration -- |
| --------------------------------------------- |
| |
| procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is |
| Scop : constant Entity_Id := Current_Scope; |
| Subp_Id : constant Entity_Id := |
| Analyze_Subprogram_Specification (Specification (N)); |
| |
| begin |
| Check_SPARK_05_Restriction ("abstract subprogram is not allowed", N); |
| |
| Generate_Definition (Subp_Id); |
| |
| -- Set the SPARK mode from the current context (may be overwritten later |
| -- with explicit pragma). |
| |
| Set_SPARK_Pragma (Subp_Id, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (Subp_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 => Subp_Id, |
| Checks => True, |
| Warnings => True); |
| |
| Set_Is_Abstract_Subprogram (Subp_Id); |
| New_Overloaded_Entity (Subp_Id); |
| Check_Delayed_Subprogram (Subp_Id); |
| |
| Set_Categorization_From_Scope (Subp_Id, Scop); |
| |
| if Ekind (Scope (Subp_Id)) = E_Protected_Type then |
| Error_Msg_N ("abstract subprogram not allowed in protected type", N); |
| |
| -- Issue a warning if the abstract subprogram is neither a dispatching |
| -- operation nor an operation that overrides an inherited subprogram or |
| -- predefined operator, since this most likely indicates a mistake. |
| |
| elsif Warn_On_Redundant_Constructs |
| and then not Is_Dispatching_Operation (Subp_Id) |
| and then not Present (Overridden_Operation (Subp_Id)) |
| and then (not Is_Operator_Symbol_Name (Chars (Subp_Id)) |
| or else Scop /= Scope (Etype (First_Formal (Subp_Id)))) |
| then |
| Error_Msg_N |
| ("abstract subprogram is not dispatching or overriding?r?", N); |
| end if; |
| |
| Generate_Reference_To_Formals (Subp_Id); |
| Check_Eliminated (Subp_Id); |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Subp_Id); |
| end if; |
| end Analyze_Abstract_Subprogram_Declaration; |
| |
| --------------------------------- |
| -- Analyze_Expression_Function -- |
| --------------------------------- |
| |
| procedure Analyze_Expression_Function (N : Node_Id) is |
| Expr : constant Node_Id := Expression (N); |
| Loc : constant Source_Ptr := Sloc (N); |
| LocX : constant Source_Ptr := Sloc (Expr); |
| Spec : constant Node_Id := Specification (N); |
| |
| -- Local variables |
| |
| Asp : Node_Id; |
| New_Body : Node_Id; |
| New_Spec : Node_Id; |
| Orig_N : Node_Id; |
| Ret : Node_Id; |
| |
| Def_Id : Entity_Id := Empty; |
| Prev : Entity_Id; |
| -- If the expression is a completion, Prev is the entity whose |
| -- declaration is completed. Def_Id is needed to analyze the spec. |
| |
| -- Start of processing for Analyze_Expression_Function |
| |
| begin |
| -- This is one of the occasions on which we transform the tree during |
| -- semantic analysis. If this is a completion, transform the expression |
| -- function into an equivalent subprogram body, and analyze it. |
| |
| -- Expression functions are inlined unconditionally. The back-end will |
| -- determine whether this is possible. |
| |
| Inline_Processing_Required := True; |
| |
| -- Create a specification for the generated body. This must be done |
| -- prior to the analysis of the initial declaration. |
| |
| New_Spec := Copy_Subprogram_Spec (Spec); |
| Prev := Current_Entity_In_Scope (Defining_Entity (Spec)); |
| |
| -- If there are previous overloadable entities with the same name, |
| -- check whether any of them is completed by the expression function. |
| -- In a generic context a formal subprogram has no completion. |
| |
| if Present (Prev) |
| and then Is_Overloadable (Prev) |
| and then not Is_Formal_Subprogram (Prev) |
| then |
| Def_Id := Analyze_Subprogram_Specification (Spec); |
| Prev := Find_Corresponding_Spec (N); |
| |
| -- The previous entity may be an expression function as well, in |
| -- which case the redeclaration is illegal. |
| |
| if Present (Prev) |
| and then Nkind (Original_Node (Unit_Declaration_Node (Prev))) = |
| N_Expression_Function |
| then |
| Error_Msg_Sloc := Sloc (Prev); |
| Error_Msg_N ("& conflicts with declaration#", Def_Id); |
| return; |
| end if; |
| end if; |
| |
| Ret := Make_Simple_Return_Statement (LocX, Expr); |
| |
| New_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => New_Spec, |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (LocX, |
| Statements => New_List (Ret))); |
| Set_Was_Expression_Function (New_Body); |
| |
| -- If the expression completes a generic subprogram, we must create a |
| -- separate node for the body, because at instantiation the original |
| -- node of the generic copy must be a generic subprogram body, and |
| -- cannot be a expression function. Otherwise we just rewrite the |
| -- expression with the non-generic body. |
| |
| if Present (Prev) and then Ekind (Prev) = E_Generic_Function then |
| Insert_After (N, New_Body); |
| |
| -- Propagate any aspects or pragmas that apply to the expression |
| -- function to the proper body when the expression function acts |
| -- as a completion. |
| |
| if Has_Aspects (N) then |
| Move_Aspects (N, To => New_Body); |
| end if; |
| |
| Relocate_Pragmas_To_Body (New_Body); |
| |
| Rewrite (N, Make_Null_Statement (Loc)); |
| Set_Has_Completion (Prev, False); |
| Analyze (N); |
| Analyze (New_Body); |
| Set_Is_Inlined (Prev); |
| |
| -- If the expression function is a completion, the previous declaration |
| -- must come from source. We know already that it appears in the current |
| -- scope. The entity itself may be internally created if within a body |
| -- to be inlined. |
| |
| elsif Present (Prev) |
| and then Is_Overloadable (Prev) |
| and then not Is_Formal_Subprogram (Prev) |
| and then Comes_From_Source (Parent (Prev)) |
| then |
| Set_Has_Completion (Prev, False); |
| Set_Is_Inlined (Prev); |
| |
| -- AI12-0103: Expression functions that are a completion freeze their |
| -- expression but don't freeze anything else (unlike regular bodies). |
| |
| -- Note that we cannot defer this freezing to the analysis of the |
| -- expression itself, because a freeze node might appear in a nested |
| -- scope, leading to an elaboration order issue in gigi. |
| -- As elsewhere, we do not emit freeze nodes within a generic unit. |
| |
| if not Inside_A_Generic then |
| Freeze_Expr_Types |
| (Def_Id => Def_Id, |
| Typ => Etype (Def_Id), |
| Expr => Expr, |
| N => N); |
| end if; |
| |
| -- For navigation purposes, indicate that the function is a body |
| |
| Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True); |
| Rewrite (N, New_Body); |
| |
| -- Remove any existing aspects from the original node because the act |
| -- of rewriting causes the list to be shared between the two nodes. |
| |
| Orig_N := Original_Node (N); |
| Remove_Aspects (Orig_N); |
| |
| -- Propagate any pragmas that apply to expression function to the |
| -- proper body when the expression function acts as a completion. |
| -- Aspects are automatically transfered because of node rewriting. |
| |
| Relocate_Pragmas_To_Body (N); |
| Analyze (N); |
| |
| -- Once the aspects of the generated body have been analyzed, create |
| -- a copy for ASIS purposes and associate it with the original node. |
| |
| if Has_Aspects (N) then |
| Set_Aspect_Specifications (Orig_N, |
| New_Copy_List_Tree (Aspect_Specifications (N))); |
| end if; |
| |
| -- Prev is the previous entity with the same name, but it is can |
| -- be an unrelated spec that is not completed by the expression |
| -- function. In that case the relevant entity is the one in the body. |
| -- Not clear that the backend can inline it in this case ??? |
| |
| if Has_Completion (Prev) then |
| |
| -- The formals of the expression function are body formals, |
| -- and do not appear in the ali file, which will only contain |
| -- references to the formals of the original subprogram spec. |
| |
| declare |
| F1 : Entity_Id; |
| F2 : Entity_Id; |
| |
| begin |
| F1 := First_Formal (Def_Id); |
| F2 := First_Formal (Prev); |
| |
| while Present (F1) loop |
| Set_Spec_Entity (F1, F2); |
| Next_Formal (F1); |
| Next_Formal (F2); |
| end loop; |
| end; |
| |
| else |
| Set_Is_Inlined (Defining_Entity (New_Body)); |
| end if; |
| |
| -- If this is not a completion, create both a declaration and a body, so |
| -- that the expression can be inlined whenever possible. |
| |
| else |
| -- An expression function that is not a completion is not a |
| -- subprogram declaration, and thus cannot appear in a protected |
| -- definition. |
| |
| if Nkind (Parent (N)) = N_Protected_Definition then |
| Error_Msg_N |
| ("an expression function is not a legal protected operation", N); |
| end if; |
| |
| Rewrite (N, Make_Subprogram_Declaration (Loc, Specification => Spec)); |
| |
| -- Remove any existing aspects from the original node because the act |
| -- of rewriting causes the list to be shared between the two nodes. |
| |
| Orig_N := Original_Node (N); |
| Remove_Aspects (Orig_N); |
| |
| Analyze (N); |
| |
| -- Once the aspects of the generated spec have been analyzed, create |
| -- a copy for ASIS purposes and associate it with the original node. |
| |
| if Has_Aspects (N) then |
| Set_Aspect_Specifications (Orig_N, |
| New_Copy_List_Tree (Aspect_Specifications (N))); |
| end if; |
| |
| -- If aspect SPARK_Mode was specified on the body, it needs to be |
| -- repeated both on the generated spec and the body. |
| |
| Asp := Find_Aspect (Defining_Unit_Name (Spec), Aspect_SPARK_Mode); |
| |
| if Present (Asp) then |
| Asp := New_Copy_Tree (Asp); |
| Set_Analyzed (Asp, False); |
| Set_Aspect_Specifications (New_Body, New_List (Asp)); |
| end if; |
| |
| Def_Id := Defining_Entity (N); |
| Set_Is_Inlined (Def_Id); |
| |
| -- Establish the linkages between the spec and the body. These are |
| -- used when the expression function acts as the prefix of attribute |
| -- 'Access in order to freeze the original expression which has been |
| -- moved to the generated body. |
| |
| Set_Corresponding_Body (N, Defining_Entity (New_Body)); |
| Set_Corresponding_Spec (New_Body, Def_Id); |
| |
| -- Within a generic preanalyze the original expression for name |
| -- capture. The body is also generated but plays no role in |
| -- this because it is not part of the original source. |
| |
| if Inside_A_Generic then |
| Set_Has_Completion (Def_Id); |
| Push_Scope (Def_Id); |
| Install_Formals (Def_Id); |
| Preanalyze_Spec_Expression (Expr, Etype (Def_Id)); |
| End_Scope; |
| end if; |
| |
| -- To prevent premature freeze action, insert the new body at the end |
| -- of the current declarations, or at the end of the package spec. |
| -- However, resolve usage names now, to prevent spurious visibility |
| -- on later entities. Note that the function can now be called in |
| -- the current declarative part, which will appear to be prior to |
| -- the presence of the body in the code. There are nevertheless no |
| -- order of elaboration issues because all name resolution has taken |
| -- place at the point of declaration. |
| |
| declare |
| Decls : List_Id := List_Containing (N); |
| Expr : constant Node_Id := Expression (Ret); |
| Par : constant Node_Id := Parent (Decls); |
| Typ : constant Entity_Id := Etype (Def_Id); |
| |
| begin |
| -- If this is a wrapper created for in an instance for a formal |
| -- subprogram, insert body after declaration, to be analyzed when |
| -- the enclosing instance is analyzed. |
| |
| if GNATprove_Mode |
| and then Is_Generic_Actual_Subprogram (Def_Id) |
| then |
| Insert_After (N, New_Body); |
| |
| else |
| if Nkind (Par) = N_Package_Specification |
| and then Decls = Visible_Declarations (Par) |
| and then Present (Private_Declarations (Par)) |
| and then not Is_Empty_List (Private_Declarations (Par)) |
| then |
| Decls := Private_Declarations (Par); |
| end if; |
| |
| Insert_After (Last (Decls), New_Body); |
| |
| -- Preanalyze the expression if not already done above |
| |
| if not Inside_A_Generic then |
| Push_Scope (Def_Id); |
| Install_Formals (Def_Id); |
| Preanalyze_Formal_Expression (Expr, Typ); |
| Check_Limited_Return (Original_Node (N), Expr, Typ); |
| End_Scope; |
| end if; |
| end if; |
| end; |
| end if; |
| |
| -- Check incorrect use of dynamically tagged expression. This doesn't |
| -- fall out automatically when analyzing the generated function body, |
| -- because Check_Dynamically_Tagged_Expression deliberately ignores |
| -- nodes that don't come from source. |
| |
| if Present (Def_Id) |
| and then Nkind (Def_Id) in N_Has_Etype |
| and then Is_Tagged_Type (Etype (Def_Id)) |
| then |
| Check_Dynamically_Tagged_Expression |
| (Expr => Expr, |
| Typ => Etype (Def_Id), |
| Related_Nod => Original_Node (N)); |
| end if; |
| |
| -- We must enforce checks for unreferenced formals in our newly |
| -- generated function, so we propagate the referenced flag from the |
| -- original spec to the new spec as well as setting Comes_From_Source. |
| |
| if Present (Parameter_Specifications (New_Spec)) then |
| declare |
| Form_New_Def : Entity_Id; |
| Form_New_Spec : Entity_Id; |
| Form_Old_Def : Entity_Id; |
| Form_Old_Spec : Entity_Id; |
| |
| begin |
| Form_New_Spec := First (Parameter_Specifications (New_Spec)); |
| Form_Old_Spec := First (Parameter_Specifications (Spec)); |
| |
| while Present (Form_New_Spec) and then Present (Form_Old_Spec) loop |
| Form_New_Def := Defining_Identifier (Form_New_Spec); |
| Form_Old_Def := Defining_Identifier (Form_Old_Spec); |
| |
| Set_Comes_From_Source (Form_New_Def, True); |
| |
| -- Because of the usefulness of unreferenced controlling |
| -- formals we exempt them from unreferenced warnings by marking |
| -- them as always referenced. |
| |
| Set_Referenced (Form_Old_Def, |
| (Is_Formal (Form_Old_Def) |
| and then Is_Controlling_Formal (Form_Old_Def)) |
| or else Referenced (Form_Old_Def)); |
| |
| Next (Form_New_Spec); |
| Next (Form_Old_Spec); |
| end loop; |
| end; |
| end if; |
| end Analyze_Expression_Function; |
| |
| ---------------------------------------- |
| -- Analyze_Extended_Return_Statement -- |
| ---------------------------------------- |
| |
| procedure Analyze_Extended_Return_Statement (N : Node_Id) is |
| begin |
| Check_Compiler_Unit ("extended return statement", N); |
| Analyze_Return_Statement (N); |
| end Analyze_Extended_Return_Statement; |
| |
| ---------------------------- |
| -- Analyze_Function_Call -- |
| ---------------------------- |
| |
| procedure Analyze_Function_Call (N : Node_Id) is |
| Actuals : constant List_Id := Parameter_Associations (N); |
| Func_Nam : constant Node_Id := Name (N); |
| Actual : Node_Id; |
| |
| begin |
| Analyze (Func_Nam); |
| |
| -- A call of the form A.B (X) may be an Ada 2005 call, which is |
| -- rewritten as B (A, X). If the rewriting is successful, the call |
| -- has been analyzed and we just return. |
| |
| if Nkind (Func_Nam) = N_Selected_Component |
| and then Name (N) /= Func_Nam |
| and then Is_Rewrite_Substitution (N) |
| and then Present (Etype (N)) |
| then |
| return; |
| end if; |
| |
| -- If error analyzing name, then set Any_Type as result type and return |
| |
| if Etype (Func_Nam) = Any_Type then |
| Set_Etype (N, Any_Type); |
| return; |
| end if; |
| |
| -- Otherwise analyze the parameters |
| |
| if Present (Actuals) then |
| Actual := First (Actuals); |
| while Present (Actual) loop |
| Analyze (Actual); |
| Check_Parameterless_Call (Actual); |
| Next (Actual); |
| end loop; |
| end if; |
| |
| Analyze_Call (N); |
| end Analyze_Function_Call; |
| |
| ----------------------------- |
| -- Analyze_Function_Return -- |
| ----------------------------- |
| |
| procedure Analyze_Function_Return (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Stm_Entity : constant Entity_Id := Return_Statement_Entity (N); |
| Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity); |
| |
| R_Type : constant Entity_Id := Etype (Scope_Id); |
| -- Function result subtype |
| |
| procedure Check_Aggregate_Accessibility (Aggr : Node_Id); |
| -- Apply legality rule of 6.5 (5.8) to the access discriminants of an |
| -- aggregate in a return statement. |
| |
| procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); |
| -- Check that the return_subtype_indication properly matches the result |
| -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). |
| |
| ----------------------------------- |
| -- Check_Aggregate_Accessibility -- |
| ----------------------------------- |
| |
| procedure Check_Aggregate_Accessibility (Aggr : Node_Id) is |
| Typ : constant Entity_Id := Etype (Aggr); |
| Assoc : Node_Id; |
| Discr : Entity_Id; |
| Expr : Node_Id; |
| Obj : Node_Id; |
| |
| begin |
| if Is_Record_Type (Typ) and then Has_Discriminants (Typ) then |
| Discr := First_Discriminant (Typ); |
| Assoc := First (Component_Associations (Aggr)); |
| while Present (Discr) loop |
| if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then |
| Expr := Expression (Assoc); |
| |
| if Nkind (Expr) = N_Attribute_Reference |
| and then Attribute_Name (Expr) /= Name_Unrestricted_Access |
| then |
| Obj := Prefix (Expr); |
| while Nkind_In (Obj, N_Indexed_Component, |
| N_Selected_Component) |
| loop |
| Obj := Prefix (Obj); |
| end loop; |
| |
| -- Do not check aliased formals or function calls. A |
| -- run-time check may still be needed ??? |
| |
| if Is_Entity_Name (Obj) |
| and then Comes_From_Source (Obj) |
| then |
| if Is_Formal (Entity (Obj)) |
| and then Is_Aliased (Entity (Obj)) |
| then |
| null; |
| |
| elsif Object_Access_Level (Obj) > |
| Scope_Depth (Scope (Scope_Id)) |
| then |
| Error_Msg_N |
| ("access discriminant in return aggregate would " |
| & "be a dangling reference", Obj); |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| Next_Discriminant (Discr); |
| end loop; |
| end if; |
| end Check_Aggregate_Accessibility; |
| |
| ------------------------------------- |
| -- Check_Return_Subtype_Indication -- |
| ------------------------------------- |
| |
| procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is |
| Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); |
| |
| R_Stm_Type : constant Entity_Id := Etype (Return_Obj); |
| -- Subtype given in the extended return statement (must match R_Type) |
| |
| Subtype_Ind : constant Node_Id := |
| Object_Definition (Original_Node (Obj_Decl)); |
| |
| procedure Error_No_Match (N : Node_Id); |
| -- Output error messages for case where types do not statically |
| -- match. N is the location for the messages. |
| |
| -------------------- |
| -- Error_No_Match -- |
| -------------------- |
| |
| procedure Error_No_Match (N : Node_Id) is |
| begin |
| Error_Msg_N |
| ("subtype must statically match function result subtype", N); |
| |
| if not Predicates_Match (R_Stm_Type, R_Type) then |
| Error_Msg_Node_2 := R_Type; |
| Error_Msg_NE |
| ("\predicate of& does not match predicate of&", |
| N, R_Stm_Type); |
| end if; |
| end Error_No_Match; |
| |
| -- Start of processing for Check_Return_Subtype_Indication |
| |
| begin |
| -- First, avoid cascaded errors |
| |
| if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then |
| return; |
| end if; |
| |
| -- "return access T" case; check that the return statement also has |
| -- "access T", and that the subtypes statically match: |
| -- if this is an access to subprogram the signatures must match. |
| |
| if Is_Anonymous_Access_Type (R_Type) then |
| if Is_Anonymous_Access_Type (R_Stm_Type) then |
| if Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type |
| then |
| if Base_Type (Designated_Type (R_Stm_Type)) /= |
| Base_Type (Designated_Type (R_Type)) |
| or else not Subtypes_Statically_Match (R_Stm_Type, R_Type) |
| then |
| Error_No_Match (Subtype_Mark (Subtype_Ind)); |
| end if; |
| |
| else |
| -- For two anonymous access to subprogram types, the types |
| -- themselves must be type conformant. |
| |
| if not Conforming_Types |
| (R_Stm_Type, R_Type, Fully_Conformant) |
| then |
| Error_No_Match (Subtype_Ind); |
| end if; |
| end if; |
| |
| else |
| Error_Msg_N ("must use anonymous access type", Subtype_Ind); |
| end if; |
| |
| -- If the return object is of an anonymous access type, then report |
| -- an error if the function's result type is not also anonymous. |
| |
| elsif Is_Anonymous_Access_Type (R_Stm_Type) then |
| pragma Assert (not Is_Anonymous_Access_Type (R_Type)); |
| Error_Msg_N |
| ("anonymous access not allowed for function with named access " |
| & "result", Subtype_Ind); |
| |
| -- Subtype indication case: check that the return object's type is |
| -- covered by the result type, and that the subtypes statically match |
| -- when the result subtype is constrained. Also handle record types |
| -- with unknown discriminants for which we have built the underlying |
| -- record view. Coverage is needed to allow specific-type return |
| -- objects when the result type is class-wide (see AI05-32). |
| |
| elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type)) |
| or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type)) |
| and then |
| Covers |
| (Base_Type (R_Type), |
| Underlying_Record_View (Base_Type (R_Stm_Type)))) |
| then |
| -- A null exclusion may be present on the return type, on the |
| -- function specification, on the object declaration or on the |
| -- subtype itself. |
| |
| if Is_Access_Type (R_Type) |
| and then |
| (Can_Never_Be_Null (R_Type) |
| or else Null_Exclusion_Present (Parent (Scope_Id))) /= |
| Can_Never_Be_Null (R_Stm_Type) |
| then |
| Error_No_Match (Subtype_Ind); |
| end if; |
| |
| -- AI05-103: for elementary types, subtypes must statically match |
| |
| if Is_Constrained (R_Type) or else Is_Access_Type (R_Type) then |
| if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then |
| Error_No_Match (Subtype_Ind); |
| end if; |
| end if; |
| |
| -- All remaining cases are illegal |
| |
| -- Note: previous versions of this subprogram allowed the return |
| -- value to be the ancestor of the return type if the return type |
| -- was a null extension. This was plainly incorrect. |
| |
| else |
| Error_Msg_N |
| ("wrong type for return_subtype_indication", Subtype_Ind); |
| end if; |
| end Check_Return_Subtype_Indication; |
| |
| --------------------- |
| -- Local Variables -- |
| --------------------- |
| |
| Expr : Node_Id; |
| Obj_Decl : Node_Id := Empty; |
| |
| -- Start of processing for Analyze_Function_Return |
| |
| begin |
| Set_Return_Present (Scope_Id); |
| |
| if Nkind (N) = N_Simple_Return_Statement then |
| Expr := Expression (N); |
| |
| -- Guard against a malformed expression. The parser may have tried to |
| -- recover but the node is not analyzable. |
| |
| if Nkind (Expr) = N_Error then |
| Set_Etype (Expr, Any_Type); |
| Expander_Mode_Save_And_Set (False); |
| return; |
| |
| else |
| -- The resolution of a controlled [extension] aggregate associated |
| -- with a return statement creates a temporary which needs to be |
| -- finalized on function exit. Wrap the return statement inside a |
| -- block so that the finalization machinery can detect this case. |
| -- This early expansion is done only when the return statement is |
| -- not part of a handled sequence of statements. |
| |
| if Nkind_In (Expr, N_Aggregate, |
| N_Extension_Aggregate) |
| and then Needs_Finalization (R_Type) |
| and then Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements |
| then |
| Rewrite (N, |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Relocate_Node (N))))); |
| |
| Analyze (N); |
| return; |
| end if; |
| |
| Analyze (Expr); |
| |
| -- Ada 2005 (AI-251): If the type of the returned object is |
| -- an access to an interface type then we add an implicit type |
| -- conversion to force the displacement of the "this" pointer to |
| -- reference the secondary dispatch table. We cannot delay the |
| -- generation of this implicit conversion until the expansion |
| -- because in this case the type resolution changes the decoration |
| -- of the expression node to match R_Type; by contrast, if the |
| -- returned object is a class-wide interface type then it is too |
| -- early to generate here the implicit conversion since the return |
| -- statement may be rewritten by the expander into an extended |
| -- return statement whose expansion takes care of adding the |
| -- implicit type conversion to displace the pointer to the object. |
| |
| if Expander_Active |
| and then Serious_Errors_Detected = 0 |
| and then Is_Access_Type (R_Type) |
| and then not Nkind_In (Expr, N_Null, N_Raise_Expression) |
| and then Is_Interface (Designated_Type (R_Type)) |
| and then Is_Progenitor (Designated_Type (R_Type), |
| Designated_Type (Etype (Expr))) |
| then |
| Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr))); |
| Analyze (Expr); |
| end if; |
| |
| Resolve (Expr, R_Type); |
| Check_Limited_Return (N, Expr, R_Type); |
| |
| if Present (Expr) and then Nkind (Expr) = N_Aggregate then |
| Check_Aggregate_Accessibility (Expr); |
| end if; |
| end if; |
| |
| -- RETURN only allowed in SPARK as the last statement in function |
| |
| if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements |
| and then |
| (Nkind (Parent (Parent (N))) /= N_Subprogram_Body |
| or else Present (Next (N))) |
| then |
| Check_SPARK_05_Restriction |
| ("RETURN should be the last statement in function", N); |
| end if; |
| |
| else |
| Check_SPARK_05_Restriction ("extended RETURN is not allowed", N); |
| Obj_Decl := Last (Return_Object_Declarations (N)); |
| |
| -- Analyze parts specific to extended_return_statement: |
| |
| declare |
| Has_Aliased : constant Boolean := Aliased_Present (Obj_Decl); |
| HSS : constant Node_Id := Handled_Statement_Sequence (N); |
| |
| begin |
| Expr := Expression (Obj_Decl); |
| |
| -- Note: The check for OK_For_Limited_Init will happen in |
| -- Analyze_Object_Declaration; we treat it as a normal |
| -- object declaration. |
| |
| Set_Is_Return_Object (Defining_Identifier (Obj_Decl)); |
| Analyze (Obj_Decl); |
| |
| Check_Return_Subtype_Indication (Obj_Decl); |
| |
| if Present (HSS) then |
| Analyze (HSS); |
| |
| if Present (Exception_Handlers (HSS)) then |
| |
| -- ???Has_Nested_Block_With_Handler needs to be set. |
| -- Probably by creating an actual N_Block_Statement. |
| -- Probably in Expand. |
| |
| null; |
| end if; |
| end if; |
| |
| -- Mark the return object as referenced, since the return is an |
| -- implicit reference of the object. |
| |
| Set_Referenced (Defining_Identifier (Obj_Decl)); |
| |
| Check_References (Stm_Entity); |
| |
| -- Check RM 6.5 (5.9/3) |
| |
| if Has_Aliased then |
| if Ada_Version < Ada_2012 then |
| |
| -- Shouldn't this test Warn_On_Ada_2012_Compatibility ??? |
| -- Can it really happen (extended return???) |
| |
| Error_Msg_N |
| ("aliased only allowed for limited return objects " |
| & "in Ada 2012??", N); |
| |
| elsif not Is_Limited_View (R_Type) then |
| Error_Msg_N |
| ("aliased only allowed for limited return objects", N); |
| end if; |
| end if; |
| end; |
| end if; |
| |
| -- Case of Expr present |
| |
| if Present (Expr) then |
| |
| -- Defend against previous errors |
| |
| if Nkind (Expr) = N_Empty |
| or else No (Etype (Expr)) |
| then |
| return; |
| end if; |
| |
| -- Apply constraint check. Note that this is done before the implicit |
| -- conversion of the expression done for anonymous access types to |
| -- ensure correct generation of the null-excluding check associated |
| -- with null-excluding expressions found in return statements. |
| |
| Apply_Constraint_Check (Expr, R_Type); |
| |
| -- The return value is converted to the return type of the function, |
| -- which implies a predicate check if the return type is predicated. |
| -- We do not apply the check to a case expression because it will |
| -- be expanded into a series of return statements, each of which |
| -- will receive a predicate check. |
| |
| if Nkind (Expr) /= N_Case_Expression then |
| Apply_Predicate_Check (Expr, R_Type); |
| end if; |
| |
| -- Ada 2005 (AI-318-02): When the result type is an anonymous access |
| -- type, apply an implicit conversion of the expression to that type |
| -- to force appropriate static and run-time accessibility checks. |
| |
| if Ada_Version >= Ada_2005 |
| and then Ekind (R_Type) = E_Anonymous_Access_Type |
| then |
| Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr))); |
| Analyze_And_Resolve (Expr, R_Type); |
| |
| -- If this is a local anonymous access to subprogram, the |
| -- accessibility check can be applied statically. The return is |
| -- illegal if the access type of the return expression is declared |
| -- inside of the subprogram (except if it is the subtype indication |
| -- of an extended return statement). |
| |
| elsif Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type then |
| if not Comes_From_Source (Current_Scope) |
| or else Ekind (Current_Scope) = E_Return_Statement |
| then |
| null; |
| |
| elsif |
| Scope_Depth (Scope (Etype (Expr))) >= Scope_Depth (Scope_Id) |
| then |
| Error_Msg_N ("cannot return local access to subprogram", N); |
| end if; |
| |
| -- The expression cannot be of a formal incomplete type |
| |
| elsif Ekind (Etype (Expr)) = E_Incomplete_Type |
| and then Is_Generic_Type (Etype (Expr)) |
| then |
| Error_Msg_N |
| ("cannot return expression of a formal incomplete type", N); |
| end if; |
| |
| -- If the result type is class-wide, then check that the return |
| -- expression's type is not declared at a deeper level than the |
| -- function (RM05-6.5(5.6/2)). |
| |
| if Ada_Version >= Ada_2005 |
| and then Is_Class_Wide_Type (R_Type) |
| then |
| if Type_Access_Level (Etype (Expr)) > |
| Subprogram_Access_Level (Scope_Id) |
| then |
| Error_Msg_N |
| ("level of return expression type is deeper than " |
| & "class-wide function!", Expr); |
| end if; |
| end if; |
| |
| -- Check incorrect use of dynamically tagged expression |
| |
| if Is_Tagged_Type (R_Type) then |
| Check_Dynamically_Tagged_Expression |
| (Expr => Expr, |
| Typ => R_Type, |
| Related_Nod => N); |
| end if; |
| |
| -- ??? A real run-time accessibility check is needed in cases |
| -- involving dereferences of access parameters. For now we just |
| -- check the static cases. |
| |
| if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) |
| and then Is_Limited_View (Etype (Scope_Id)) |
| and then Object_Access_Level (Expr) > |
| Subprogram_Access_Level (Scope_Id) |
| then |
| -- Suppress the message in a generic, where the rewriting |
| -- is irrelevant. |
| |
| if Inside_A_Generic then |
| null; |
| |
| else |
| Rewrite (N, |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Accessibility_Check_Failed)); |
| Analyze (N); |
| |
| Error_Msg_Warn := SPARK_Mode /= On; |
| Error_Msg_N ("cannot return a local value by reference<<", N); |
| Error_Msg_NE ("\& [<<", N, Standard_Program_Error); |
| end if; |
| end if; |
| |
| if Known_Null (Expr) |
| and then Nkind (Parent (Scope_Id)) = N_Function_Specification |
| and then Null_Exclusion_Present (Parent (Scope_Id)) |
| then |
| Apply_Compile_Time_Constraint_Error |
| (N => Expr, |
| Msg => "(Ada 2005) null not allowed for " |
| & "null-excluding return??", |
| Reason => CE_Null_Not_Allowed); |
| end if; |
| |
| -- RM 6.5 (5.4/3): accessibility checks also apply if the return object |
| -- has no initializing expression. |
| |
| elsif Ada_Version > Ada_2005 and then Is_Class_Wide_Type (R_Type) then |
| if Type_Access_Level (Etype (Defining_Identifier (Obj_Decl))) > |
| Subprogram_Access_Level (Scope_Id) |
| then |
| Error_Msg_N |
| ("level of return expression type is deeper than " |
| & "class-wide function!", Obj_Decl); |
| end if; |
| end if; |
| end Analyze_Function_Return; |
| |
| ------------------------------------- |
| -- Analyze_Generic_Subprogram_Body -- |
| ------------------------------------- |
| |
| procedure Analyze_Generic_Subprogram_Body |
| (N : Node_Id; |
| Gen_Id : Entity_Id) |
| is |
| Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id); |
| Kind : constant Entity_Kind := Ekind (Gen_Id); |
| Body_Id : Entity_Id; |
| New_N : Node_Id; |
| Spec : Node_Id; |
| |
| begin |
| -- Copy body and disable expansion while analyzing the generic For a |
| -- stub, do not copy the stub (which would load the proper body), this |
| -- will be done when the proper body is analyzed. |
| |
| if Nkind (N) /= N_Subprogram_Body_Stub then |
| New_N := Copy_Generic_Node (N, Empty, Instantiating => False); |
| Rewrite (N, New_N); |
| |
| -- Once the contents of the generic copy and the template are |
| -- swapped, do the same for their respective aspect specifications. |
| |
| Exchange_Aspects (N, New_N); |
| |
| -- Collect all contract-related source pragmas found within the |
| -- template and attach them to the contract of the subprogram body. |
| -- This contract is used in the capture of global references within |
| -- annotations. |
| |
| Create_Generic_Contract (N); |
| |
| Start_Generic; |
| end if; |
| |
| Spec := Specification (N); |
| |
| -- Within the body of the generic, the subprogram is callable, and |
| -- behaves like the corresponding non-generic unit. |
| |
| Body_Id := Defining_Entity (Spec); |
| |
| if Kind = E_Generic_Procedure |
| and then Nkind (Spec) /= N_Procedure_Specification |
| then |
| Error_Msg_N ("invalid body for generic procedure ", Body_Id); |
| return; |
| |
| elsif Kind = E_Generic_Function |
| and then Nkind (Spec) /= N_Function_Specification |
| then |
| Error_Msg_N ("invalid body for generic function ", Body_Id); |
| return; |
| end if; |
| |
| Set_Corresponding_Body (Gen_Decl, Body_Id); |
| |
| if Has_Completion (Gen_Id) |
| and then Nkind (Parent (N)) /= N_Subunit |
| then |
| Error_Msg_N ("duplicate generic body", N); |
| return; |
| else |
| Set_Has_Completion (Gen_Id); |
| end if; |
| |
| if Nkind (N) = N_Subprogram_Body_Stub then |
| Set_Ekind (Defining_Entity (Specification (N)), Kind); |
| else |
| Set_Corresponding_Spec (N, Gen_Id); |
| end if; |
| |
| if Nkind (Parent (N)) = N_Compilation_Unit then |
| Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N)); |
| end if; |
| |
| -- Make generic parameters immediately visible in the body. They are |
| -- needed to process the formals declarations. Then make the formals |
| -- visible in a separate step. |
| |
| Push_Scope (Gen_Id); |
| |
| declare |
| E : Entity_Id; |
| First_Ent : Entity_Id; |
| |
| begin |
| First_Ent := First_Entity (Gen_Id); |
| |
| E := First_Ent; |
| while Present (E) and then not Is_Formal (E) loop |
| Install_Entity (E); |
| Next_Entity (E); |
| end loop; |
| |
| Set_Use (Generic_Formal_Declarations (Gen_Decl)); |
| |
| -- Now generic formals are visible, and the specification can be |
| -- analyzed, for subsequent conformance check. |
| |
| Body_Id := Analyze_Subprogram_Specification (Spec); |
| |
| -- Make formal parameters visible |
| |
| if Present (E) then |
| |
| -- E is the first formal parameter, we loop through the formals |
| -- installing them so that they will be visible. |
| |
| Set_First_Entity (Gen_Id, E); |
| while Present (E) loop |
| Install_Entity (E); |
| Next_Formal (E); |
| end loop; |
| end if; |
| |
| -- Visible generic entity is callable within its own body |
| |
| Set_Ekind (Gen_Id, Ekind (Body_Id)); |
| Set_Ekind (Body_Id, E_Subprogram_Body); |
| Set_Convention (Body_Id, Convention (Gen_Id)); |
| Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id)); |
| Set_Scope (Body_Id, Scope (Gen_Id)); |
| |
| Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id); |
| |
| if Nkind (N) = N_Subprogram_Body_Stub then |
| |
| -- No body to analyze, so restore state of generic unit |
| |
| Set_Ekind (Gen_Id, Kind); |
| Set_Ekind (Body_Id, Kind); |
| |
| if Present (First_Ent) then |
| Set_First_Entity (Gen_Id, First_Ent); |
| end if; |
| |
| End_Scope; |
| return; |
| end if; |
| |
| -- If this is a compilation unit, it must be made visible explicitly, |
| -- because the compilation of the declaration, unlike other library |
| -- unit declarations, does not. If it is not a unit, the following |
| -- is redundant but harmless. |
| |
| Set_Is_Immediately_Visible (Gen_Id); |
| Reference_Body_Formals (Gen_Id, Body_Id); |
| |
| if Is_Child_Unit (Gen_Id) then |
| Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False); |
| end if; |
| |
| Set_Actual_Subtypes (N, Current_Scope); |
| |
| Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (Body_Id); |
| |
| -- Analyze any aspect specifications that appear on the generic |
| -- subprogram body. |
| |
| if Has_Aspects (N) then |
| Analyze_Aspects_On_Subprogram_Body_Or_Stub (N); |
| end if; |
| |
| Analyze_Declarations (Declarations (N)); |
| Check_Completion; |
| |
| -- Process the contract of the subprogram body after all declarations |
| -- have been analyzed. This ensures that any contract-related pragmas |
| -- are available through the N_Contract node of the body. |
| |
| Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id); |
| |
| Analyze (Handled_Statement_Sequence (N)); |
| Save_Global_References (Original_Node (N)); |
| |
| -- Prior to exiting the scope, include generic formals again (if any |
| -- are present) in the set of local entities. |
| |
| if Present (First_Ent) then |
| Set_First_Entity (Gen_Id, First_Ent); |
| end if; |
| |
| Check_References (Gen_Id); |
| end; |
| |
| Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope); |
| Update_Use_Clause_Chain; |
| Validate_Categorization_Dependency (N, Gen_Id); |
| End_Scope; |
| Check_Subprogram_Order (N); |
| |
| -- Outside of its body, unit is generic again |
| |
| Set_Ekind (Gen_Id, Kind); |
| Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False); |
| |
| if Style_Check then |
| Style.Check_Identifier (Body_Id, Gen_Id); |
| end if; |
| |
| End_Generic; |
| end Analyze_Generic_Subprogram_Body; |
| |
| ---------------------------- |
| -- Analyze_Null_Procedure -- |
| ---------------------------- |
| |
| -- WARNING: This routine manages Ghost regions. Return statements must be |
| -- replaced by gotos that jump to the end of the routine and restore the |
| -- Ghost mode. |
| |
| procedure Analyze_Null_Procedure |
| (N : Node_Id; |
| Is_Completion : out Boolean) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Spec : constant Node_Id := Specification (N); |
| |
| Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; |
| Saved_IGR : constant Node_Id := Ignored_Ghost_Region; |
| Saved_ISMP : constant Boolean := |
| Ignore_SPARK_Mode_Pragmas_In_Instance; |
| -- Save the Ghost and SPARK mode-related data to restore on exit |
| |
| Designator : Entity_Id; |
| Form : Node_Id; |
| Null_Body : Node_Id := Empty; |
| Null_Stmt : Node_Id := Null_Statement (Spec); |
| Prev : Entity_Id; |
| |
| begin |
| Prev := Current_Entity_In_Scope (Defining_Entity (Spec)); |
| |
| -- A null procedure is Ghost when it is stand-alone and is subject to |
| -- pragma Ghost, or when the corresponding spec is Ghost. Set the mode |
| -- now, to ensure that any nodes generated during analysis and expansion |
| -- are properly marked as Ghost. |
| |
| if Present (Prev) then |
| Mark_And_Set_Ghost_Body (N, Prev); |
| end if; |
| |
| -- Capture the profile of the null procedure before analysis, for |
| -- expansion at the freeze point and at each point of call. The body is |
| -- used if the procedure has preconditions, or if it is a completion. In |
| -- the first case the body is analyzed at the freeze point, in the other |
| -- it replaces the null procedure declaration. |
| |
| -- For a null procedure that comes from source, a NULL statement is |
| -- provided by the parser, which carries the source location of the |
| -- NULL keyword, and has Comes_From_Source set. For a null procedure |
| -- from expansion, create one now. |
| |
| if No (Null_Stmt) then |
| Null_Stmt := Make_Null_Statement (Loc); |
| end if; |
| |
| Null_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => New_Copy_Tree (Spec), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Null_Stmt))); |
| |
| -- Create new entities for body and formals |
| |
| Set_Defining_Unit_Name (Specification (Null_Body), |
| Make_Defining_Identifier |
| (Sloc (Defining_Entity (N)), |
| Chars (Defining_Entity (N)))); |
| |
| Form := First (Parameter_Specifications (Specification (Null_Body))); |
| while Present (Form) loop |
| Set_Defining_Identifier (Form, |
| Make_Defining_Identifier |
| (Sloc (Defining_Identifier (Form)), |
| Chars (Defining_Identifier (Form)))); |
| Next (Form); |
| end loop; |
| |
| -- Determine whether the null procedure may be a completion of a generic |
| -- suprogram, in which case we use the new null body as the completion |
| -- and set minimal semantic information on the original declaration, |
| -- which is rewritten as a null statement. |
| |
| if Present (Prev) and then Is_Generic_Subprogram (Prev) then |
| Insert_Before (N, Null_Body); |
| Set_Ekind (Defining_Entity (N), Ekind (Prev)); |
| |
| Rewrite (N, Make_Null_Statement (Loc)); |
| Analyze_Generic_Subprogram_Body (Null_Body, Prev); |
| Is_Completion := True; |
| |
| goto Leave; |
| |
| else |
| -- Resolve the types of the formals now, because the freeze point may |
| -- appear in a different context, e.g. an instantiation. |
| |
| Form := First (Parameter_Specifications (Specification (Null_Body))); |
| while Present (Form) loop |
| if Nkind (Parameter_Type (Form)) /= N_Access_Definition then |
| Find_Type (Parameter_Type (Form)); |
| |
| elsif No (Access_To_Subprogram_Definition |
| (Parameter_Type (Form))) |
| then |
| Find_Type (Subtype_Mark (Parameter_Type (Form))); |
| |
| -- The case of a null procedure with a formal that is an |
| -- access-to-subprogram type, and that is used as an actual |
| -- in an instantiation is left to the enthusiastic reader. |
| |
| else |
| null; |
| end if; |
| |
| Next (Form); |
| end loop; |
| end if; |
| |
| -- If there are previous overloadable entities with the same name, check |
| -- whether any of them is completed by the null procedure. |
| |
| if Present (Prev) and then Is_Overloadable (Prev) then |
| Designator := Analyze_Subprogram_Specification (Spec); |
| Prev := Find_Corresponding_Spec (N); |
| end if; |
| |
| if No (Prev) or else not Comes_From_Source (Prev) then |
| Designator := Analyze_Subprogram_Specification (Spec); |
| Set_Has_Completion (Designator); |
| |
| -- Signal to caller that this is a procedure declaration |
| |
| Is_Completion := False; |
| |
| -- Null procedures are always inlined, but generic formal subprograms |
| -- which appear as such in the internal instance of formal packages, |
| -- need no completion and are not marked Inline. |
| |
| if Expander_Active |
| and then Nkind (N) /= N_Formal_Concrete_Subprogram_Declaration |
| then |
| Set_Corresponding_Body (N, Defining_Entity (Null_Body)); |
| Set_Body_To_Inline (N, Null_Body); |
| Set_Is_Inlined (Designator); |
| end if; |
| |
| else |
| -- The null procedure is a completion. We unconditionally rewrite |
| -- this as a null body (even if expansion is not active), because |
| -- there are various error checks that are applied on this body |
| -- when it is analyzed (e.g. correct aspect placement). |
| |
| if Has_Completion (Prev) then |
| Error_Msg_Sloc := Sloc (Prev); |
| Error_Msg_NE ("duplicate body for & declared#", N, Prev); |
| end if; |
| |
| Check_Previous_Null_Procedure (N, Prev); |
| |
| Is_Completion := True; |
| Rewrite (N, Null_Body); |
| Analyze (N); |
| end if; |
| |
| <<Leave>> |
| Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; |
| Restore_Ghost_Region (Saved_GM, Saved_IGR); |
| end Analyze_Null_Procedure; |
| |
| ----------------------------- |
| -- Analyze_Operator_Symbol -- |
| ----------------------------- |
| |
| -- An operator symbol such as "+" or "and" may appear in context where the |
| -- literal denotes an entity name, such as "+"(x, y) or in context when it |
| -- is just a string, as in (conjunction = "or"). In these cases the parser |
| -- generates this node, and the semantics does the disambiguation. Other |
| -- such case are actuals in an instantiation, the generic unit in an |
| -- instantiation, and pragma arguments. |
| |
| procedure Analyze_Operator_Symbol (N : Node_Id) is |
| Par : constant Node_Id := Parent (N); |
| |
| begin |
| if (Nkind (Par) = N_Function_Call and then N = Name (Par)) |
| or else Nkind (Par) = N_Function_Instantiation |
| or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par)) |
| or else (Nkind (Par) = N_Pragma_Argument_Association |
| and then not Is_Pragma_String_Literal (Par)) |
| or else Nkind (Par) = N_Subprogram_Renaming_Declaration |
| or else (Nkind (Par) = N_Attribute_Reference |
| and then Attribute_Name (Par) /= Name_Value) |
| then |
| Find_Direct_Name (N); |
| |
| else |
| Change_Operator_Symbol_To_String_Literal (N); |
| Analyze (N); |
| end if; |
| end Analyze_Operator_Symbol; |
| |
| ----------------------------------- |
| -- Analyze_Parameter_Association -- |
| ----------------------------------- |
| |
| procedure Analyze_Parameter_Association (N : Node_Id) is |
| begin |
| Analyze (Explicit_Actual_Parameter (N)); |
| end Analyze_Parameter_Association; |
| |
| ---------------------------- |
| -- Analyze_Procedure_Call -- |
| ---------------------------- |
| |
| -- WARNING: This routine manages Ghost regions. Return statements must be |
| -- replaced by gotos that jump to the end of the routine and restore the |
| -- Ghost mode. |
| |
| procedure Analyze_Procedure_Call (N : Node_Id) is |
| procedure Analyze_Call_And_Resolve; |
| -- Do Analyze and Resolve calls for procedure call. At the end, check |
| -- for illegal order dependence. |
| -- ??? where is the check for illegal order dependencies? |
| |
| ------------------------------ |
| -- Analyze_Call_And_Resolve -- |
| ------------------------------ |
| |
| procedure Analyze_Call_And_Resolve is |
| begin |
| if Nkind (N) = N_Procedure_Call_Statement then |
| Analyze_Call (N); |
| Resolve (N, Standard_Void_Type); |
| else |
| Analyze (N); |
| end if; |
| end Analyze_Call_And_Resolve; |
| |
| -- Local variables |
| |
| Actuals : constant List_Id := Parameter_Associations (N); |
| Loc : constant Source_Ptr := Sloc (N); |
| P : constant Node_Id := Name (N); |
| |
| Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; |
| Saved_IGR : constant Node_Id := Ignored_Ghost_Region; |
| -- Save the Ghost-related attributes to restore on exit |
| |
| Actual : Node_Id; |
| New_N : Node_Id; |
| |
| -- Start of processing for Analyze_Procedure_Call |
| |
| begin |
| -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote |
| -- a procedure call or an entry call. The prefix may denote an access |
| -- to subprogram type, in which case an implicit dereference applies. |
| -- If the prefix is an indexed component (without implicit dereference) |
| -- then the construct denotes a call to a member of an entire family. |
| -- If the prefix is a simple name, it may still denote a call to a |
| -- parameterless member of an entry family. Resolution of these various |
| -- interpretations is delicate. |
| |
| -- Do not analyze machine code statements to avoid rejecting them in |
| -- CodePeer mode. |
| |
| if CodePeer_Mode and then Nkind (P) = N_Qualified_Expression then |
| Set_Etype (P, Standard_Void_Type); |
| else |
| Analyze (P); |
| end if; |
| |
| -- If this is a call of the form Obj.Op, the call may have been analyzed |
| -- and possibly rewritten into a block, in which case we are done. |
| |
| if Analyzed (N) then |
| return; |
| |
| -- If there is an error analyzing the name (which may have been |
| -- rewritten if the original call was in prefix notation) then error |
| -- has been emitted already, mark node and return. |
| |
| elsif Error_Posted (N) or else Etype (Name (N)) = Any_Type then |
| Set_Etype (N, Any_Type); |
| return; |
| end if; |
| |
| -- A procedure call is Ghost when its name denotes a Ghost procedure. |
| -- Set the mode now to ensure that any nodes generated during analysis |
| -- and expansion are properly marked as Ghost. |
| |
| Mark_And_Set_Ghost_Procedure_Call (N); |
| |
| -- Otherwise analyze the parameters |
| |
| if Present (Actuals) then |
| Actual := First (Actuals); |
| |
| while Present (Actual) loop |
| Analyze (Actual); |
| Check_Parameterless_Call (Actual); |
| Next (Actual); |
| end loop; |
| end if; |
| |
| -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls |
| |
| if Nkind (P) = N_Attribute_Reference |
| and then Nam_In (Attribute_Name (P), Name_Elab_Spec, |
| Name_Elab_Body, |
| Name_Elab_Subp_Body) |
| then |
| if Present (Actuals) then |
| Error_Msg_N |
| ("no parameters allowed for this call", First (Actuals)); |
| goto Leave; |
| end if; |
| |
| Set_Etype (N, Standard_Void_Type); |
| Set_Analyzed (N); |
| |
| elsif Is_Entity_Name (P) |
| and then Is_Record_Type (Etype (Entity (P))) |
| and then Remote_AST_I_Dereference (P) |
| then |
| goto Leave; |
| |
| elsif Is_Entity_Name (P) |
| and then Ekind (Entity (P)) /= E_Entry_Family |
| then |
| if Is_Access_Type (Etype (P)) |
| and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type |
| and then No (Actuals) |
| and then Comes_From_Source (N) |
| then |
| Error_Msg_N ("missing explicit dereference in call", N); |
| end if; |
| |
| Analyze_Call_And_Resolve; |
| |
| -- If the prefix is the simple name of an entry family, this is a |
| -- parameterless call from within the task body itself. |
| |
| elsif Is_Entity_Name (P) |
| and then Nkind (P) = N_Identifier |
| and then Ekind (Entity (P)) = E_Entry_Family |
| and then Present (Actuals) |
| and then No (Next (First (Actuals))) |
| then |
| -- Can be call to parameterless entry family. What appears to be the |
| -- sole argument is in fact the entry index. Rewrite prefix of node |
| -- accordingly. Source representation is unchanged by this |
| -- transformation. |
| |
| New_N := |
| Make_Indexed_Component (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc), |
| Selector_Name => New_Occurrence_Of (Entity (P), Loc)), |
| Expressions => Actuals); |
| Set_Name (N, New_N); |
| Set_Etype (New_N, Standard_Void_Type); |
| Set_Parameter_Associations (N, No_List); |
| Analyze_Call_And_Resolve; |
| |
| elsif Nkind (P) = N_Explicit_Dereference then |
| if Ekind (Etype (P)) = E_Subprogram_Type then |
| Analyze_Call_And_Resolve; |
| else |
| Error_Msg_N ("expect access to procedure in call", P); |
| end if; |
| |
| -- The name can be a selected component or an indexed component that |
| -- yields an access to subprogram. Such a prefix is legal if the call |
| -- has parameter associations. |
| |
| elsif Is_Access_Type (Etype (P)) |
| and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type |
| then |
| if Present (Actuals) then |
| Analyze_Call_And_Resolve; |
| else |
| Error_Msg_N ("missing explicit dereference in call ", N); |
| end if; |
| |
| -- If not an access to subprogram, then the prefix must resolve to the |
| -- name of an entry, entry family, or protected operation. |
| |
| -- For the case of a simple entry call, P is a selected component where |
| -- the prefix is the task and the selector name is the entry. A call to |
| -- a protected procedure will have the same syntax. If the protected |
| -- object contains overloaded operations, the entity may appear as a |
| -- function, the context will select the operation whose type is Void. |
| |
| elsif Nkind (P) = N_Selected_Component |
| and then Ekind_In (Entity (Selector_Name (P)), E_Entry, |
| E_Function, |
| E_Procedure) |
| then |
| -- When front-end inlining is enabled, as with SPARK_Mode, a call |
| -- in prefix notation may still be missing its controlling argument, |
| -- so perform the transformation now. |
| |
| if SPARK_Mode = On and then In_Inlined_Body then |
| declare |
| Subp : constant Entity_Id := Entity (Selector_Name (P)); |
| Typ : constant Entity_Id := Etype (Prefix (P)); |
| |
| begin |
| if Is_Tagged_Type (Typ) |
| and then Present (First_Formal (Subp)) |
| and then (Etype (First_Formal (Subp)) = Typ |
| or else |
| Class_Wide_Type (Etype (First_Formal (Subp))) = Typ) |
| and then Try_Object_Operation (P) |
| then |
| return; |
| |
| else |
| Analyze_Call_And_Resolve; |
| end if; |
| end; |
| |
| else |
| Analyze_Call_And_Resolve; |
| end if; |
| |
| elsif Nkind (P) = N_Selected_Component |
| and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family |
| and then Present (Actuals) |
| and then No (Next (First (Actuals))) |
| then |
| -- Can be call to parameterless entry family. What appears to be the |
| -- sole argument is in fact the entry index. Rewrite prefix of node |
| -- accordingly. Source representation is unchanged by this |
| -- transformation. |
| |
| New_N := |
| Make_Indexed_Component (Loc, |
| Prefix => New_Copy (P), |
| Expressions => Actuals); |
| Set_Name (N, New_N); |
| Set_Etype (New_N, Standard_Void_Type); |
| Set_Parameter_Associations (N, No_List); |
| Analyze_Call_And_Resolve; |
| |
| -- For the case of a reference to an element of an entry family, P is |
| -- an indexed component whose prefix is a selected component (task and |
| -- entry family), and whose index is the entry family index. |
| |
| elsif Nkind (P) = N_Indexed_Component |
| and then Nkind (Prefix (P)) = N_Selected_Component |
| and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family |
| then |
| Analyze_Call_And_Resolve; |
| |
| -- If the prefix is the name of an entry family, it is a call from |
| -- within the task body itself. |
| |
| elsif Nkind (P) = N_Indexed_Component |
| and then Nkind (Prefix (P)) = N_Identifier |
| and then Ekind (Entity (Prefix (P))) = E_Entry_Family |
| then |
| New_N := |
| Make_Selected_Component (Loc, |
| Prefix => |
| New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc), |
| Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc)); |
| Rewrite (Prefix (P), New_N); |
| Analyze (P); |
| Analyze_Call_And_Resolve; |
| |
| -- In Ada 2012. a qualified expression is a name, but it cannot be a |
| -- procedure name, so the construct can only be a qualified expression. |
| |
| elsif Nkind (P) = N_Qualified_Expression |
| and then Ada_Version >= Ada_2012 |
| then |
| Rewrite (N, Make_Code_Statement (Loc, Expression => P)); |
| Analyze (N); |
| |
| -- Anything else is an error |
| |
| else |
| Error_Msg_N ("invalid procedure or entry call", N); |
| end if; |
| |
| <<Leave>> |
| Restore_Ghost_Region (Saved_GM, Saved_IGR); |
| end Analyze_Procedure_Call; |
| |
| ------------------------------ |
| -- Analyze_Return_Statement -- |
| ------------------------------ |
| |
| procedure Analyze_Return_Statement (N : Node_Id) is |
| pragma Assert (Nkind_In (N, N_Extended_Return_Statement, |
| N_Simple_Return_Statement)); |
| |
| Returns_Object : constant Boolean := |
| Nkind (N) = N_Extended_Return_Statement |
| or else |
| (Nkind (N) = N_Simple_Return_Statement |
| and then Present (Expression (N))); |
| -- True if we're returning something; that is, "return <expression>;" |
| -- or "return Result : T [:= ...]". False for "return;". Used for error |
| -- checking: If Returns_Object is True, N should apply to a function |
| -- body; otherwise N should apply to a procedure body, entry body, |
| -- accept statement, or extended return statement. |
| |
| function Find_What_It_Applies_To return Entity_Id; |
| -- Find the entity representing the innermost enclosing body, accept |
| -- statement, or extended return statement. If the result is a callable |
| -- construct or extended return statement, then this will be the value |
| -- of the Return_Applies_To attribute. Otherwise, the program is |
| -- illegal. See RM-6.5(4/2). |
| |
| ----------------------------- |
| -- Find_What_It_Applies_To -- |
| ----------------------------- |
| |
| function Find_What_It_Applies_To return Entity_Id is |
| Result : Entity_Id := Empty; |
| |
| begin |
| -- Loop outward through the Scope_Stack, skipping blocks, loops, |
| -- and postconditions. |
| |
| for J in reverse 0 .. Scope_Stack.Last loop |
| Result := Scope_Stack.Table (J).Entity; |
| exit when not Ekind_In (Result, E_Block, E_Loop) |
| and then Chars (Result) /= Name_uPostconditions; |
| end loop; |
| |
| pragma Assert (Present (Result)); |
| return Result; |
| end Find_What_It_Applies_To; |
| |
| -- Local declarations |
| |
| Scope_Id : constant Entity_Id := Find_What_It_Applies_To; |
| Kind : constant Entity_Kind := Ekind (Scope_Id); |
| Loc : constant Source_Ptr := Sloc (N); |
| Stm_Entity : constant Entity_Id := |
| New_Internal_Entity |
| (E_Return_Statement, Current_Scope, Loc, 'R'); |
| |
| -- Start of processing for Analyze_Return_Statement |
| |
| begin |
| Set_Return_Statement_Entity (N, Stm_Entity); |
| |
| Set_Etype (Stm_Entity, Standard_Void_Type); |
| Set_Return_Applies_To (Stm_Entity, Scope_Id); |
| |
| -- Place Return entity on scope stack, to simplify enforcement of 6.5 |
| -- (4/2): an inner return statement will apply to this extended return. |
| |
| if Nkind (N) = N_Extended_Return_Statement then |
| Push_Scope (Stm_Entity); |
| end if; |
| |
| -- Check that pragma No_Return is obeyed. Don't complain about the |
| -- implicitly-generated return that is placed at the end. |
| |
| if No_Return (Scope_Id) and then Comes_From_Source (N) then |
| Error_Msg_N ("RETURN statement not allowed (No_Return)", N); |
| end if; |
| |
| -- Warn on any unassigned OUT parameters if in procedure |
| |
| if Ekind (Scope_Id) = E_Procedure then |
| Warn_On_Unassigned_Out_Parameter (N, Scope_Id); |
| end if; |
| |
| -- Check that functions return objects, and other things do not |
| |
| if Kind = E_Function or else Kind = E_Generic_Function then |
| if not Returns_Object then |
| Error_Msg_N ("missing expression in return from function", N); |
| end if; |
| |
| elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then |
| if Returns_Object then |
| Error_Msg_N ("procedure cannot return value (use function)", N); |
| end if; |
| |
| elsif Kind = E_Entry or else Kind = E_Entry_Family then |
| if Returns_Object then |
| if Is_Protected_Type (Scope (Scope_Id)) then |
| Error_Msg_N ("entry body cannot return value", N); |
| else |
| Error_Msg_N ("accept statement cannot return value", N); |
| end if; |
| end if; |
| |
| elsif Kind = E_Return_Statement then |
| |
| -- We are nested within another return statement, which must be an |
| -- extended_return_statement. |
| |
| if Returns_Object then |
| if Nkind (N) = N_Extended_Return_Statement then |
| Error_Msg_N |
| ("extended return statement cannot be nested (use `RETURN;`)", |
| N); |
| |
| -- Case of a simple return statement with a value inside extended |
| -- return statement. |
| |
| else |
| Error_Msg_N |
| ("return nested in extended return statement cannot return " |
| & "value (use `RETURN;`)", N); |
| end if; |
| end if; |
| |
| else |
| Error_Msg_N ("illegal context for return statement", N); |
| end if; |
| |
| if Ekind_In (Kind, E_Function, E_Generic_Function) then |
| Analyze_Function_Return (N); |
| |
| elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then |
| Set_Return_Present (Scope_Id); |
| end if; |
| |
| if Nkind (N) = N_Extended_Return_Statement then |
| End_Scope; |
| end if; |
| |
| Kill_Current_Values (Last_Assignment_Only => True); |
| Check_Unreachable_Code (N); |
| |
| Analyze_Dimension (N); |
| end Analyze_Return_Statement; |
| |
| ------------------------------------- |
| -- Analyze_Simple_Return_Statement -- |
| ------------------------------------- |
| |
| procedure Analyze_Simple_Return_Statement (N : Node_Id) is |
| begin |
| if Present (Expression (N)) then |
| Mark_Coextensions (N, Expression (N)); |
| end if; |
| |
| Analyze_Return_Statement (N); |
| end Analyze_Simple_Return_Statement; |
| |
| ------------------------- |
| -- Analyze_Return_Type -- |
| ------------------------- |
| |
| procedure Analyze_Return_Type (N : Node_Id) is |
| Designator : constant Entity_Id := Defining_Entity (N); |
| Typ : Entity_Id := Empty; |
| |
| begin |
| -- Normal case where result definition does not indicate an error |
| |
| if Result_Definition (N) /= Error then |
| if Nkind (Result_Definition (N)) = N_Access_Definition then |
| Check_SPARK_05_Restriction |
| ("access result is not allowed", Result_Definition (N)); |
| |
| -- Ada 2005 (AI-254): Handle anonymous access to subprograms |
| |
| declare |
| AD : constant Node_Id := |
| Access_To_Subprogram_Definition (Result_Definition (N)); |
| begin |
| if Present (AD) and then Protected_Present (AD) then |
| Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N); |
| else |
| Typ := Access_Definition (N, Result_Definition (N)); |
| end if; |
| end; |
| |
| Set_Parent (Typ, Result_Definition (N)); |
| Set_Is_Local_Anonymous_Access (Typ); |
| Set_Etype (Designator, Typ); |
| |
| -- Ada 2005 (AI-231): Ensure proper usage of null exclusion |
| |
| Null_Exclusion_Static_Checks (N); |
| |
| -- Subtype_Mark case |
| |
| else |
| Find_Type (Result_Definition (N)); |
| Typ := Entity (Result_Definition (N)); |
| Set_Etype (Designator, Typ); |
| |
| -- Unconstrained array as result is not allowed in SPARK |
| |
| if Is_Array_Type (Typ) and then not Is_Constrained (Typ) then |
| Check_SPARK_05_Restriction |
| ("returning an unconstrained array is not allowed", |
| Result_Definition (N)); |
| end if; |
| |
| -- Ada 2005 (AI-231): Ensure proper usage of null exclusion |
| |
| Null_Exclusion_Static_Checks (N); |
| |
| -- 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. Note that the null exclusion checks are done |
| -- right before this, because they don't get applied to types that |
| -- do not come from source. |
| |
| if Is_Access_Type (Typ) and then Null_Exclusion_Present (N) then |
| Set_Etype (Designator, |
| Create_Null_Excluding_Itype |
| (T => Typ, |
| Related_Nod => N, |
| Scope_Id => Scope (Current_Scope))); |
| |
| -- The new subtype must be elaborated before use because |
| -- it is visible outside of the function. However its base |
| -- type may not be frozen yet, so the reference that will |
| -- force elaboration must be attached to the freezing of |
| -- the base type. |
| |
| -- If the return specification appears on a proper body, |
| -- the subtype will have been created already on the spec. |
| |
| if Is_Frozen (Typ) then |
| if Nkind (Parent (N)) = N_Subprogram_Body |
| and then Nkind (Parent (Parent (N))) = N_Subunit |
| then |
| null; |
| else |
| Build_Itype_Reference (Etype (Designator), Parent (N)); |
| end if; |
| |
| else |
| Ensure_Freeze_Node (Typ); |
| |
| declare |
| IR : constant Node_Id := Make_Itype_Reference (Sloc (N)); |
| begin |
| Set_Itype (IR, Etype (Designator)); |
| Append_Freeze_Actions (Typ, New_List (IR)); |
| end; |
| end if; |
| |
| else |
| Set_Etype (Designator, Typ); |
| end if; |
| |
| if Ekind (Typ) = E_Incomplete_Type |
| or else (Is_Class_Wide_Type (Typ) |
| and then Ekind (Root_Type (Typ)) = E_Incomplete_Type) |
| then |
| -- AI05-0151: Tagged incomplete types are allowed in all formal |
| -- parts. Untagged incomplete types are not allowed in bodies. |
| -- As a consequence, limited views cannot appear in a basic |
| -- declaration that is itself within a body, because there is |
| -- no point at which the non-limited view will become visible. |
| |
| if Ada_Version >= Ada_2012 then |
| if From_Limited_With (Typ) and then In_Package_Body then |
| Error_Msg_NE |
| ("invalid use of incomplete type&", |
| Result_Definition (N), Typ); |
| |
| -- The return type of a subprogram body cannot be of a |
| -- formal incomplete type. |
| |
| elsif Is_Generic_Type (Typ) |
| and then Nkind (Parent (N)) = N_Subprogram_Body |
| then |
| Error_Msg_N |
| ("return type cannot be a formal incomplete type", |
| Result_Definition (N)); |
| |
| elsif Is_Class_Wide_Type (Typ) |
| and then Is_Generic_Type (Root_Type (Typ)) |
| and then Nkind (Parent (N)) = N_Subprogram_Body |
| then |
| Error_Msg_N |
| ("return type cannot be a formal incomplete type", |
| Result_Definition (N)); |
| |
| elsif Is_Tagged_Type (Typ) then |
| null; |
| |
| -- Use is legal in a thunk generated for an operation |
| -- inherited from a progenitor. |
| |
| elsif Is_Thunk (Designator) |
| and then Present (Non_Limited_View (Typ)) |
| then |
| null; |
| |
| elsif Nkind (Parent (N)) = N_Subprogram_Body |
| or else Nkind_In (Parent (Parent (N)), N_Accept_Statement, |
| N_Entry_Body) |
| then |
| Error_Msg_NE |
| ("invalid use of untagged incomplete type&", |
| Designator, Typ); |
| end if; |
| |
| -- The type must be completed in the current package. This |
| -- is checked at the end of the package declaration when |
| -- Taft-amendment types are identified. If the return type |
| -- is class-wide, there is no required check, the type can |
| -- be a bona fide TAT. |
| |
| if Ekind (Scope (Current_Scope)) = E_Package |
| and then In_Private_Part (Scope (Current_Scope)) |
| and then not Is_Class_Wide_Type (Typ) |
| then |
| Append_Elmt (Designator, Private_Dependents (Typ)); |
| end if; |
| |
| else |
| Error_Msg_NE |
| ("invalid use of incomplete type&", Designator, Typ); |
| end if; |
| end if; |
| end if; |
| |
| -- Case where result definition does indicate an error |
| |
| else |
| Set_Etype (Designator, Any_Type); |
| end if; |
| end Analyze_Return_Type; |
| |
| ----------------------------- |
| -- Analyze_Subprogram_Body -- |
| ----------------------------- |
| |
| procedure Analyze_Subprogram_Body (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Body_Spec : constant Node_Id := Specification (N); |
| Body_Id : constant Entity_Id := Defining_Entity (Body_Spec); |
| |
| begin |
| if Debug_Flag_C then |
| Write_Str ("==> subprogram body "); |
| Write_Name (Chars (Body_Id)); |
| Write_Str (" from "); |
| Write_Location (Loc); |
| Write_Eol; |
| Indent; |
| end if; |
| |
| Trace_Scope (N, Body_Id, " Analyze subprogram: "); |
| |
| -- The real work is split out into the helper, so it can do "return;" |
| -- without skipping the debug output: |
| |
| Analyze_Subprogram_Body_Helper (N); |
| |
| if Debug_Flag_C then |
| Outdent; |
| Write_Str ("<== subprogram body "); |
| Write_Name (Chars (Body_Id)); |
| Write_Str (" from "); |
| Write_Location (Loc); |
| Write_Eol; |
| end if; |
| end Analyze_Subprogram_Body; |
| |
| ------------------------------------ |
| -- Analyze_Subprogram_Body_Helper -- |
| ------------------------------------ |
| |
| -- This procedure is called for regular subprogram bodies, generic bodies, |
| -- and for subprogram stubs of both kinds. In the case of stubs, only the |
| -- specification matters, and is used to create a proper declaration for |
| -- the subprogram, or to perform conformance checks. |
| |
| -- WARNING: This routine manages Ghost regions. Return statements must be |
| -- replaced by gotos that jump to the end of the routine and restore the |
| -- Ghost mode. |
| |
| procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is |
| Body_Spec : Node_Id := Specification (N); |
| Body_Id : Entity_Id := Defining_Entity (Body_Spec); |
| Loc : constant Source_Ptr := Sloc (N); |
| Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); |
| |
| Conformant : Boolean; |
| Desig_View : Entity_Id := Empty; |
| Exch_Views : Elist_Id := No_Elist; |
| HSS : Node_Id; |
| Mask_Types : Elist_Id := No_Elist; |
| Prot_Typ : Entity_Id := Empty; |
| Spec_Decl : Node_Id := Empty; |
| Spec_Id : Entity_Id; |
| |
| Last_Real_Spec_Entity : Entity_Id := Empty; |
| -- When we analyze a separate spec, the entity chain ends up containing |
| -- the formals, as well as any itypes generated during analysis of the |
| -- default expressions for parameters, or the arguments of associated |
| -- precondition/postcondition pragmas (which are analyzed in the context |
| -- of the spec since they have visibility on formals). |
| -- |
| -- These entities belong with the spec and not the body. However we do |
| -- the analysis of the body in the context of the spec (again to obtain |
| -- visibility to the formals), and all the entities generated during |
| -- this analysis end up also chained to the entity chain of the spec. |
| -- But they really belong to the body, and there is circuitry to move |
| -- them from the spec to the body. |
| -- |
| -- However, when we do this move, we don't want to move the real spec |
| -- entities (first para above) to the body. The Last_Real_Spec_Entity |
| -- variable points to the last real spec entity, so we only move those |
| -- chained beyond that point. It is initialized to Empty to deal with |
| -- the case where there is no separate spec. |
| |
| function Body_Has_Contract return Boolean; |
| -- Check whether unanalyzed body has an aspect or pragma that may |
| -- generate a SPARK contract. |
| |
| function Body_Has_SPARK_Mode_On return Boolean; |
| -- Check whether SPARK_Mode On applies to the subprogram body, either |
| -- because it is specified directly on the body, or because it is |
| -- inherited from the enclosing subprogram or package. |
| |
| procedure Build_Subprogram_Declaration; |
| -- Create a matching subprogram declaration for subprogram body N |
| |
| procedure Check_Anonymous_Return; |
| -- Ada 2005: if a function returns an access type that denotes a task, |
| -- or a type that contains tasks, we must create a master entity for |
| -- the anonymous type, which typically will be used in an allocator |
| -- in the body of the function. |
| |
| procedure Check_Inline_Pragma (Spec : in out Node_Id); |
| -- Look ahead to recognize a pragma that may appear after the body. |
| -- If there is a previous spec, check that it appears in the same |
| -- declarative part. If the pragma is Inline_Always, perform inlining |
| -- unconditionally, otherwise only if Front_End_Inlining is requested. |
| -- If the body acts as a spec, and inlining is required, we create a |
| -- subprogram declaration for it, in order to attach the body to inline. |
| -- If pragma does not appear after the body, check whether there is |
| -- an inline pragma before any local declarations. |
| |
| procedure Check_Missing_Return; |
| -- Checks for a function with a no return statements, and also performs |
| -- the warning checks implemented by Check_Returns. In formal mode, also |
| -- verify that a function ends with a RETURN and that a procedure does |
| -- not contain any RETURN. |
| |
| function Disambiguate_Spec return Entity_Id; |
| -- When a primitive is declared between the private view and the full |
| -- view of a concurrent type which implements an interface, a special |
| -- mechanism is used to find the corresponding spec of the primitive |
| -- body. |
| |
| function Exchange_Limited_Views (Subp_Id : Entity_Id) return Elist_Id; |
| -- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains |
| -- incomplete types coming from a limited context and replace their |
| -- limited views with the non-limited ones. Return the list of changes |
| -- to be used to undo the transformation. |
| |
| function Is_Private_Concurrent_Primitive |
| (Subp_Id : Entity_Id) return Boolean; |
| -- Determine whether subprogram Subp_Id is a primitive of a concurrent |
| -- type that implements an interface and has a private view. |
| |
| function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id; |
| -- N is the body generated for an expression function that is not a |
| -- completion and Spec_Id the defining entity of its spec. Mark all |
| -- the not-yet-frozen types referenced by the simple return statement |
| -- of the function as formally frozen. |
| |
| procedure Restore_Limited_Views (Restore_List : Elist_Id); |
| -- Undo the transformation done by Exchange_Limited_Views. |
| |
| procedure Set_Trivial_Subprogram (N : Node_Id); |
| -- Sets the Is_Trivial_Subprogram flag in both spec and body of the |
| -- subprogram whose body is being analyzed. N is the statement node |
| -- causing the flag to be set, if the following statement is a return |
| -- of an entity, we mark the entity as set in source to suppress any |
| -- warning on the stylized use of function stubs with a dummy return. |
| |
| procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id); |
| -- Undo the transformation done by Mask_Unfrozen_Types |
| |
| procedure Verify_Overriding_Indicator; |
| -- If there was a previous spec, the entity has been entered in the |
| -- current scope previously. If the body itself carries an overriding |
| -- indicator, check that it is consistent with the known status of the |
| -- entity. |
| |
| ----------------------- |
| -- Body_Has_Contract -- |
| ----------------------- |
| |
| function Body_Has_Contract return Boolean is |
| Decls : constant List_Id := Declarations (N); |
| Item : Node_Id; |
| |
| begin |
| -- Check for aspects that may generate a contract |
| |
| if Present (Aspect_Specifications (N)) then |
| Item := First (Aspect_Specifications (N)); |
| while Present (Item) loop |
| if Is_Subprogram_Contract_Annotation (Item) then |
| return True; |
| end if; |
| |
| Next (Item); |
| end loop; |
| end if; |
| |
| -- Check for pragmas that may generate a contract |
| |
| if Present (Decls) then |
| Item := First (Decls); |
| while Present (Item) loop |
| if Nkind (Item) = N_Pragma |
| and then Is_Subprogram_Contract_Annotation (Item) |
| then |
| return True; |
| end if; |
| |
| Next (Item); |
| end loop; |
| end if; |
| |
| return False; |
| end Body_Has_Contract; |
| |
| ---------------------------- |
| -- Body_Has_SPARK_Mode_On -- |
| ---------------------------- |
| |
| function Body_Has_SPARK_Mode_On return Boolean is |
| Decls : constant List_Id := Declarations (N); |
| Item : Node_Id; |
| |
| begin |
| -- Check for SPARK_Mode aspect |
| |
| if Present (Aspect_Specifications (N)) then |
| Item := First (Aspect_Specifications (N)); |
| while Present (Item) loop |
| if Get_Aspect_Id (Item) = Aspect_SPARK_Mode then |
| return Get_SPARK_Mode_From_Annotation (Item) = On; |
| end if; |
| |
| Next (Item); |
| end loop; |
| end if; |
| |
| -- Check for SPARK_Mode pragma |
| |
| if Present (Decls) then |
| Item := First (Decls); |
| while Present (Item) loop |
| |
| -- Pragmas that apply to a subprogram body are usually grouped |
| -- together. Look for a potential pragma SPARK_Mode among them. |
| |
| if Nkind (Item) = N_Pragma then |
| if Get_Pragma_Id (Item) = Pragma_SPARK_Mode then |
| return Get_SPARK_Mode_From_Annotation (Item) = On; |
| end if; |
| |
| -- Otherwise the first non-pragma declarative item terminates |
| -- the region where pragma SPARK_Mode may appear. |
| |
| else |
| exit; |
| end if; |
| |
| Next (Item); |
| end loop; |
| end if; |
| |
| -- Otherwise, the applicable SPARK_Mode is inherited from the |
| -- enclosing subprogram or package. |
| |
| return SPARK_Mode = On; |
| end Body_Has_SPARK_Mode_On; |
| |
| ---------------------------------- |
| -- Build_Subprogram_Declaration -- |
| ---------------------------------- |
| |
| procedure Build_Subprogram_Declaration is |
| procedure Move_Pragmas (From : Node_Id; To : Node_Id); |
| -- Relocate certain categorization pragmas from the declarative list |
| -- of subprogram body From and insert them after node To. The pragmas |
| -- in question are: |
| -- Ghost |
| -- Volatile_Function |
| -- Also copy pragma SPARK_Mode if present in the declarative list |
| -- of subprogram body From and insert it after node To. This pragma |
| -- should not be moved, as it applies to the body too. |
| |
| ------------------ |
| -- Move_Pragmas -- |
| ------------------ |
| |
| procedure Move_Pragmas (From : Node_Id; To : Node_Id) is |
| Decl : Node_Id; |
| Next_Decl : Node_Id; |
| |
| begin |
| pragma Assert (Nkind (From) = N_Subprogram_Body); |
| |
| -- The destination node must be part of a list, as the pragmas are |
| -- inserted after it. |
| |
| pragma Assert (Is_List_Member (To)); |
| |
| -- Inspect the declarations of the subprogram body looking for |
| -- specific pragmas. |
| |
| Decl := First (Declarations (N)); |
| while Present (Decl) loop |
| Next_Decl := Next (Decl); |
| |
| if Nkind (Decl) = N_Pragma then |
| if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then |
| Insert_After (To, New_Copy_Tree (Decl)); |
| |
| elsif Nam_In (Pragma_Name_Unmapped (Decl), |
| Name_Ghost, |
| Name_Volatile_Function) |
| then |
| Remove (Decl); |
| Insert_After (To, Decl); |
| end if; |
| end if; |
| |
| Decl := Next_Decl; |
| end loop; |
| end Move_Pragmas; |
| |
| -- Local variables |
| |
| Decl : Node_Id; |
| Subp_Decl : Node_Id; |
| |
| -- Start of processing for Build_Subprogram_Declaration |
| |
| begin |
| -- Create a matching subprogram spec using the profile of the body. |
| -- The structure of the tree is identical, but has new entities for |
| -- the defining unit name and formal parameters. |
| |
| Subp_Decl := |
| Make_Subprogram_Declaration (Loc, |
| Specification => Copy_Subprogram_Spec (Body_Spec)); |
| Set_Comes_From_Source (Subp_Decl, True); |
| |
| -- Also mark parameters as coming from source |
| |
| if Present (Parameter_Specifications (Specification (Subp_Decl))) then |
| declare |
| Form : Entity_Id; |
| begin |
| Form := |
| First (Parameter_Specifications (Specification (Subp_Decl))); |
| |
| while Present (Form) loop |
| Set_Comes_From_Source (Defining_Identifier (Form), True); |
| Next (Form); |
| end loop; |
| end; |
| end if; |
| |
| -- Relocate the aspects and relevant pragmas from the subprogram body |
| -- to the generated spec because it acts as the initial declaration. |
| |
| Insert_Before (N, Subp_Decl); |
| Move_Aspects (N, To => Subp_Decl); |
| Move_Pragmas (N, To => Subp_Decl); |
| |
| -- Ensure that the generated corresponding spec and original body |
| -- share the same SPARK_Mode pragma or aspect. As a result, both have |
| -- the same SPARK_Mode attributes, and the global SPARK_Mode value is |
| -- correctly set for local subprograms. |
| |
| Copy_SPARK_Mode_Aspect (Subp_Decl, To => N); |
| |
| Analyze (Subp_Decl); |
| |
| -- Propagate the attributes Rewritten_For_C and Corresponding_Proc to |
| -- the body since the expander may generate calls using that entity. |
| -- Required to ensure that Expand_Call rewrites calls to this |
| -- function by calls to the built procedure. |
| |
| if Modify_Tree_For_C |
| and then Nkind (Body_Spec) = N_Function_Specification |
| and then |
| Rewritten_For_C (Defining_Entity (Specification (Subp_Decl))) |
| then |
| Set_Rewritten_For_C (Defining_Entity (Body_Spec)); |
| Set_Corresponding_Procedure (Defining_Entity (Body_Spec), |
| Corresponding_Procedure |
| (Defining_Entity (Specification (Subp_Decl)))); |
| end if; |
| |
| -- Analyze any relocated source pragmas or pragmas created for aspect |
| -- specifications. |
| |
| Decl := Next (Subp_Decl); |
| while Present (Decl) loop |
| |
| -- Stop the search for pragmas once the body has been reached as |
| -- this terminates the region where pragmas may appear. |
| |
| if Decl = N then |
| exit; |
| |
| elsif Nkind (Decl) = N_Pragma then |
| Analyze (Decl); |
| end if; |
| |
| Next (Decl); |
| end loop; |
| |
| Spec_Id := Defining_Entity (Subp_Decl); |
| Set_Corresponding_Spec (N, Spec_Id); |
| |
| -- Mark the generated spec as a source construct to ensure that all |
| -- calls to it are properly registered in ALI files for GNATprove. |
| |
| Set_Comes_From_Source (Spec_Id, True); |
| |
| -- Ensure that the specs of the subprogram declaration and its body |
| -- are identical, otherwise they will appear non-conformant due to |
| -- rewritings in the default values of formal parameters. |
| |
| Body_Spec := Copy_Subprogram_Spec (Body_Spec); |
| Set_Specification (N, Body_Spec); |
| Body_Id := Analyze_Subprogram_Specification (Body_Spec); |
| end Build_Subprogram_Declaration; |
| |
| ---------------------------- |
| -- Check_Anonymous_Return -- |
| ---------------------------- |
| |
| procedure Check_Anonymous_Return is |
| Decl : Node_Id; |
| Par : Node_Id; |
| Scop : Entity_Id; |
| |
| begin |
| if Present (Spec_Id) then |
| Scop := Spec_Id; |
| else |
| Scop := Body_Id; |
| end if; |
| |
| if Ekind (Scop) = E_Function |
| and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type |
| and then not Is_Thunk (Scop) |
| |
| -- Skip internally built functions which handle the case of |
| -- a null access (see Expand_Interface_Conversion) |
| |
| and then not (Is_Interface (Designated_Type (Etype (Scop))) |
| and then not Comes_From_Source (Parent (Scop))) |
| |
| and then (Has_Task (Designated_Type (Etype (Scop))) |
| or else |
| (Is_Class_Wide_Type (Designated_Type (Etype (Scop))) |
| and then |
| Is_Limited_Record (Designated_Type (Etype (Scop))))) |
| and then Expander_Active |
| |
| -- Avoid cases with no tasking support |
| |
| and then RTE_Available (RE_Current_Master) |
| and then not Restriction_Active (No_Task_Hierarchy) |
| then |
| Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uMaster), |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Master_Id), Loc), |
| Expression => |
| Make_Explicit_Dereference (Loc, |
| New_Occurrence_Of (RTE (RE_Current_Master), Loc))); |
| |
| if Present (Declarations (N)) then |
| Prepend (Decl, Declarations (N)); |
| else |
| Set_Declarations (N, New_List (Decl)); |
| end if; |
| |
| Set_Master_Id (Etype (Scop), Defining_Identifier (Decl)); |
| Set_Has_Master_Entity (Scop); |
| |
| -- Now mark the containing scope as a task master |
| |
| Par := N; |
| while Nkind (Par) /= N_Compilation_Unit loop |
| Par := Parent (Par); |
| pragma Assert (Present (Par)); |
| |
| -- If we fall off the top, we are at the outer level, and |
| -- the environment task is our effective master, so nothing |
| -- to mark. |
| |
| if Nkind_In |
| (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) |
| then |
| Set_Is_Task_Master (Par, True); |
| exit; |
| end if; |
| end loop; |
| end if; |
| end Check_Anonymous_Return; |
| |
| ------------------------- |
| -- Check_Inline_Pragma -- |
| ------------------------- |
| |
| procedure Check_Inline_Pragma (Spec : in out Node_Id) is |
| Prag : Node_Id; |
| Plist : List_Id; |
| |
| function Is_Inline_Pragma (N : Node_Id) return Boolean; |
| -- True when N is a pragma Inline or Inline_Always that applies |
| -- to this subprogram. |
| |
| ----------------------- |
| -- Is_Inline_Pragma -- |
| ----------------------- |
| |
| function Is_Inline_Pragma (N : Node_Id) return Boolean is |
| begin |
| if Nkind (N) = N_Pragma |
| and then |
| (Pragma_Name_Unmapped (N) = Name_Inline_Always |
| or else (Pragma_Name_Unmapped (N) = Name_Inline |
| and then |
| (Front_End_Inlining or else Optimization_Level > 0))) |
| and then Present (Pragma_Argument_Associations (N)) |
| then |
| declare |
| Pragma_Arg : Node_Id := |
| Expression (First (Pragma_Argument_Associations (N))); |
| begin |
| if Nkind (Pragma_Arg) = N_Selected_Component then |
| Pragma_Arg := Selector_Name (Pragma_Arg); |
| end if; |
| |
| return Chars (Pragma_Arg) = Chars (Body_Id); |
| end; |
| |
| else |
| return False; |
| end if; |
| end Is_Inline_Pragma; |
| |
| -- Start of processing for Check_Inline_Pragma |
| |
| begin |
| if not Expander_Active then |
| return; |
| end if; |
| |
| if Is_List_Member (N) |
| and then Present (Next (N)) |
| and then Is_Inline_Pragma (Next (N)) |
| then |
| Prag := Next (N); |
| |
| elsif Nkind (N) /= N_Subprogram_Body_Stub |
| and then Present (Declarations (N)) |
| and then Is_Inline_Pragma (First (Declarations (N))) |
| then |
| Prag := First (Declarations (N)); |
| |
| else |
| Prag := Empty; |
| end if; |
| |
| if Present (Prag) then |
| if Present (Spec_Id) then |
| if Is_List_Member (N) |
| and then Is_List_Member (Unit_Declaration_Node (Spec_Id)) |
| and then In_Same_List (N, Unit_Declaration_Node (Spec_Id)) |
| then |
| Analyze (Prag); |
| end if; |
| |
| else |
| -- Create a subprogram declaration, to make treatment uniform. |
| -- Make the sloc of the subprogram name that of the entity in |
| -- the body, so that style checks find identical strings. |
| |
| declare |
| Subp : constant Entity_Id := |
| Make_Defining_Identifier |
| (Sloc (Body_Id), Chars (Body_Id)); |
| Decl : constant Node_Id := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| New_Copy_Tree (Specification (N))); |
| |
| begin |
| -- Link the body and the generated spec |
| |
| Set_Corresponding_Body (Decl, Body_Id); |
| Set_Corresponding_Spec (N, Subp); |
| |
| Set_Defining_Unit_Name (Specification (Decl), Subp); |
| |
| -- To ensure proper coverage when body is inlined, indicate |
| -- whether the subprogram comes from source. |
| |
| Set_Comes_From_Source (Subp, Comes_From_Source (N)); |
| |
| if Present (First_Formal (Body_Id)) then |
| Plist := Copy_Parameter_List (Body_Id); |
| Set_Parameter_Specifications |
| (Specification (Decl), Plist); |
| end if; |
| |
| -- Move aspects to the new spec |
| |
| if Has_Aspects (N) then |
| Move_Aspects (N, To => Decl); |
| end if; |
| |
| Insert_Before (N, Decl); |
| Analyze (Decl); |
| Analyze (Prag); |
| Set_Has_Pragma_Inline (Subp); |
| |
| if Pragma_Name (Prag) = Name_Inline_Always then |
| Set_Is_Inlined (Subp); |
| Set_Has_Pragma_Inline_Always (Subp); |
| end if; |
| |
| -- Prior to copying the subprogram body to create a template |
| -- for it for subsequent inlining, remove the pragma from |
| -- the current body so that the copy that will produce the |
| -- new body will start from a completely unanalyzed tree. |
| |
| if Nkind (Parent (Prag)) = N_Subprogram_Body then |
| Rewrite (Prag, Make_Null_Statement (Sloc (Prag))); |
| end if; |
| |
| Spec := Subp; |
| end; |
| end if; |
| end if; |
| end Check_Inline_Pragma; |
| |
| -------------------------- |
| -- Check_Missing_Return -- |
| -------------------------- |
| |
| procedure Check_Missing_Return is |
| Id : Entity_Id; |
| Missing_Ret : Boolean; |
| |
| begin |
| if Nkind (Body_Spec) = N_Function_Specification then |
| if Present (Spec_Id) then |
| Id := Spec_Id; |
| else |
| Id := Body_Id; |
| end if; |
| |
| if Return_Present (Id) then |
| Check_Returns (HSS, 'F', Missing_Ret); |
| |
| if Missing_Ret then |
| Set_Has_Missing_Return (Id); |
| end if; |
| |
| -- Within a premature instantiation of a package with no body, we |
| -- build completions of the functions therein, with a Raise |
| -- statement. No point in complaining about a missing return in |
| -- this case. |
| |
| elsif Ekind (Id) = E_Function |
| and then In_Instance |
| and then Present (Statements (HSS)) |
| and then Nkind (First (Statements (HSS))) = N_Raise_Program_Error |
| then |
| null; |
| |
| elsif Is_Generic_Subprogram (Id) |
| or else not Is_Machine_Code_Subprogram (Id) |
| then |
| Error_Msg_N ("missing RETURN statement in function body", N); |
| end if; |
| |
| -- If procedure with No_Return, check returns |
| |
| elsif Nkind (Body_Spec) = N_Procedure_Specification then |
| if Present (Spec_Id) then |
| Id := Spec_Id; |
| else |
| Id := Body_Id; |
| end if; |
| |
| if No_Return (Id) then |
| Check_Returns (HSS, 'P', Missing_Ret, Id); |
| end if; |
| end if; |
| |
| -- Special checks in SPARK mode |
| |
| if Nkind (Body_Spec) = N_Function_Specification then |
| |
| -- In SPARK mode, last statement of a function should be a return |
| |
| declare |
| Stat : constant Node_Id := Last_Source_Statement (HSS); |
| begin |
| if Present (Stat) |
| and then not Nkind_In (Stat, N_Simple_Return_Statement, |
| N_Extended_Return_Statement) |
| then |
| Check_SPARK_05_Restriction |
| ("last statement in function should be RETURN", Stat); |
| end if; |
| end; |
| |
| -- In SPARK mode, verify that a procedure has no return |
| |
| elsif Nkind (Body_Spec) = N_Procedure_Specification then |
| if Present (Spec_Id) then |
| Id := Spec_Id; |
| else |
| Id := Body_Id; |
| end if; |
| |
| -- Would be nice to point to return statement here, can we |
| -- borrow the Check_Returns procedure here ??? |
| |
| if Return_Present (Id) then |
| Check_SPARK_05_Restriction |
| ("procedure should not have RETURN", N); |
| end if; |
| end if; |
| end Check_Missing_Return; |
| |
| ----------------------- |
| -- Disambiguate_Spec -- |
| ----------------------- |
| |
| function Disambiguate_Spec return Entity_Id is |
| Priv_Spec : Entity_Id; |
| Spec_N : Entity_Id; |
| |
| procedure Replace_Types (To_Corresponding : Boolean); |
| -- Depending on the flag, replace the type of formal parameters of |
| -- Body_Id if it is a concurrent type implementing interfaces with |
| -- the corresponding record type or the other way around. |
| |
| procedure Replace_Types (To_Corresponding : Boolean) is |
| Formal : Entity_Id; |
| Formal_Typ : Entity_Id; |
| |
| begin |
| Formal := First_Formal (Body_Id); |
| while Present (Formal) loop |
| Formal_Typ := Etype (Formal); |
| |
| if Is_Class_Wide_Type (Formal_Typ) then |
| Formal_Typ := Root_Type (Formal_Typ); |
| end if; |
| |
| -- From concurrent type to corresponding record |
| |
| if To_Corresponding then |
| if Is_Concurrent_Type (Formal_Typ) |
| and then Present (Corresponding_Record_Type (Formal_Typ)) |
| and then |
| Present (Interfaces |
| (Corresponding_Record_Type (Formal_Typ))) |
| then |
| Set_Etype (Formal, |
| Corresponding_Record_Type (Formal_Typ)); |
| end if; |
| |
| -- From corresponding record to concurrent type |
| |
| else |
| if Is_Concurrent_Record_Type (Formal_Typ) |
| and then Present (Interfaces (Formal_Typ)) |
| then |
| Set_Etype (Formal, |
| Corresponding_Concurrent_Type (Formal_Typ)); |
| end if; |
| end if; |
| |
| Next_Formal (Formal); |
| end loop; |
| end Replace_Types; |
| |
| -- Start of processing for Disambiguate_Spec |
| |
| begin |
| -- Try to retrieve the specification of the body as is. All error |
| -- messages are suppressed because the body may not have a spec in |
| -- its current state. |
| |
| Spec_N := Find_Corresponding_Spec (N, False); |
| |
| -- It is possible that this is the body of a primitive declared |
| -- between a private and a full view of a concurrent type. The |
| -- controlling parameter of the spec carries the concurrent type, |
| -- not the corresponding record type as transformed by Analyze_ |
| -- Subprogram_Specification. In such cases, we undo the change |
| -- made by the analysis of the specification and try to find the |
| -- spec again. |
| |
| -- Note that wrappers already have their corresponding specs and |
| -- bodies set during their creation, so if the candidate spec is |
| -- a wrapper, then we definitely need to swap all types to their |
| -- original concurrent status. |
| |
| if No (Spec_N) |
| or else Is_Primitive_Wrapper (Spec_N) |
| then |
| -- Restore all references of corresponding record types to the |
| -- original concurrent types. |
| |
| Replace_Types (To_Corresponding => False); |
| Priv_Spec := Find_Corresponding_Spec (N, False); |
| |
| -- The current body truly belongs to a primitive declared between |
| -- a private and a full view. We leave the modified body as is, |
| -- and return the true spec. |
| |
| if Present (Priv_Spec) |
| and then Is_Private_Primitive (Priv_Spec) |
| then |
| return Priv_Spec; |
| end if; |
| |
| -- In case that this is some sort of error, restore the original |
| -- state of the body. |
| |
| Replace_Types (To_Corresponding => True); |
| end if; |
| |
| return Spec_N; |
| end Disambiguate_Spec; |
| |
| ---------------------------- |
| -- Exchange_Limited_Views -- |
| ---------------------------- |
| |
| function Exchange_Limited_Views (Subp_Id : Entity_Id) return Elist_Id is |
| Result : Elist_Id := No_Elist; |
| |
| procedure Detect_And_Exchange (Id : Entity_Id); |
| -- Determine whether Id's type denotes an incomplete type associated |
| -- with a limited with clause and exchange the limited view with the |
| -- non-limited one when available. Note that the non-limited view |
| -- may exist because of a with_clause in another unit in the context, |
| -- but cannot be used because the current view of the enclosing unit |
| -- is still a limited view. |
| |
| ------------------------- |
| -- Detect_And_Exchange -- |
| ------------------------- |
| |
| procedure Detect_And_Exchange (Id : Entity_Id) is |
| Typ : constant Entity_Id := Etype (Id); |
| begin |
| if From_Limited_With (Typ) |
| and then Has_Non_Limited_View (Typ) |
| and then not From_Limited_With (Scope (Typ)) |
| then |
| if No (Result) then |
| Result := New_Elmt_List; |
| end if; |
| |
| Prepend_Elmt (Typ, Result); |
| Prepend_Elmt (Id, Result); |
| Set_Etype (Id, Non_Limited_View (Typ)); |
| end if; |
| end Detect_And_Exchange; |
| |
| -- Local variables |
| |
| Formal : Entity_Id; |
| |
| -- Start of processing for Exchange_Limited_Views |
| |
| begin |
| -- Do not process subprogram bodies as they already use the non- |
| -- limited view of types. |
| |
| if not Ekind_In (Subp_Id, E_Function, E_Procedure) then |
| return No_Elist; |
| end if; |
| |
| -- Examine all formals and swap views when applicable |
| |
| Formal := First_Formal (Subp_Id); |
| while Present (Formal) loop |
| Detect_And_Exchange (Formal); |
| |
| Next_Formal (Formal); |
| end loop; |
| |
| -- Process the return type of a function |
| |
| if Ekind (Subp_Id) = E_Function then |
| Detect_And_Exchange (Subp_Id); |
| end if; |
| |
| return Result; |
| end Exchange_Limited_Views; |
| |
| ------------------------------------- |
| -- Is_Private_Concurrent_Primitive -- |
| ------------------------------------- |
| |
| function Is_Private_Concurrent_Primitive |
| (Subp_Id : Entity_Id) return Boolean |
| is |
| Formal_Typ : Entity_Id; |
| |
| begin |
| if Present (First_Formal (Subp_Id)) then |
| Formal_Typ := Etype (First_Formal (Subp_Id)); |
| |
| if Is_Concurrent_Record_Type (Formal_Typ) then |
| if Is_Class_Wide_Type (Formal_Typ) then |
| Formal_Typ := Root_Type (Formal_Typ); |
| end if; |
| |
| Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ); |
| end if; |
| |
| -- The type of the first formal is a concurrent tagged type with |
| -- a private view. |
| |
| return |
| Is_Concurrent_Type (Formal_Typ) |
| and then Is_Tagged_Type (Formal_Typ) |
| and then Has_Private_Declaration (Formal_Typ); |
| end if; |
| |
| return False; |
| end Is_Private_Concurrent_Primitive; |
| |
| ------------------------- |
| -- Mask_Unfrozen_Types -- |
| ------------------------- |
| |
| function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id is |
| Result : Elist_Id := No_Elist; |
| |
| function Mask_Type_Refs (Node : Node_Id) return Traverse_Result; |
| -- Mask all types referenced in the subtree rooted at Node |
| |
| -------------------- |
| -- Mask_Type_Refs -- |
| -------------------- |
| |
| function Mask_Type_Refs (Node : Node_Id) return Traverse_Result is |
| procedure Mask_Type (Typ : Entity_Id); |
| -- ??? what does this do? |
| |
| --------------- |
| -- Mask_Type -- |
| --------------- |
| |
| procedure Mask_Type (Typ : Entity_Id) is |
| begin |
| -- Skip Itypes created by the preanalysis |
| |
| if Is_Itype (Typ) |
| and then Scope_Within_Or_Same (Scope (Typ), Spec_Id) |
| then |
| return; |
| end if; |
| |
| if not Is_Frozen (Typ) then |
| if Scope (Typ) /= Current_Scope then |
| Set_Is_Frozen (Typ); |
| Append_New_Elmt (Typ, Result); |
| else |
| Freeze_Before (N, Typ); |
| end if; |
| end if; |
| end Mask_Type; |
| |
| -- Start of processing for Mask_Type_Refs |
| |
| begin |
| if Is_Entity_Name (Node) and then Present (Entity (Node)) then |
| Mask_Type (Etype (Entity (Node))); |
| |
| if Ekind_In (Entity (Node), E_Component, E_Discriminant) then |
| Mask_Type (Scope (Entity (Node))); |
| end if; |
| |
| elsif Nkind_In (Node, N_Aggregate, N_Null, N_Type_Conversion) |
| and then Present (Etype (Node)) |
| then |
| Mask_Type (Etype (Node)); |
| end if; |
| |
| return OK; |
| end Mask_Type_Refs; |
| |
| procedure Mask_References is new Traverse_Proc (Mask_Type_Refs); |
| |
| -- Local variables |
| |
| Return_Stmt : constant Node_Id := |
| First (Statements (Handled_Statement_Sequence (N))); |
| |
| -- Start of processing for Mask_Unfrozen_Types |
| |
| begin |
| pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement); |
| |
| Mask_References (Expression (Return_Stmt)); |
| |
| return Result; |
| end Mask_Unfrozen_Types; |
| |
| --------------------------- |
| -- Restore_Limited_Views -- |
| --------------------------- |
| |
| procedure Restore_Limited_Views (Restore_List : Elist_Id) is |
| Elmt : Elmt_Id := First_Elmt (Restore_List); |
| Id : Entity_Id; |
| |
| begin |
| while Present (Elmt) loop |
| Id := Node (Elmt); |
| Next_Elmt (Elmt); |
| Set_Etype (Id, Node (Elmt)); |
| Next_Elmt (Elmt); |
| end loop; |
| end Restore_Limited_Views; |
| |
| ---------------------------- |
| -- Set_Trivial_Subprogram -- |
| ---------------------------- |
| |
| procedure Set_Trivial_Subprogram (N : Node_Id) is |
| Nxt : constant Node_Id := Next (N); |
| |
| begin |
| Set_Is_Trivial_Subprogram (Body_Id); |
| |
| if Present (Spec_Id) then |
| Set_Is_Trivial_Subprogram (Spec_Id); |
| end if; |
| |
| if Present (Nxt) |
| and then Nkind (Nxt) = N_Simple_Return_Statement |
| and then No (Next (Nxt)) |
| and then Present (Expression (Nxt)) |
| and then Is_Entity_Name (Expression (Nxt)) |
| then |
| Set_Never_Set_In_Source (Entity (Expression (Nxt)), False); |
| end if; |
| end Set_Trivial_Subprogram; |
| |
| --------------------------- |
| -- Unmask_Unfrozen_Types -- |
| --------------------------- |
| |
| procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id) is |
| Elmt : Elmt_Id := First_Elmt (Unmask_List); |
| |
| begin |
| while Present (Elmt) loop |
| Set_Is_Frozen (Node (Elmt), False); |
| Next_Elmt (Elmt); |
| end loop; |
| end Unmask_Unfrozen_Types; |
| |
| --------------------------------- |
| -- Verify_Overriding_Indicator -- |
| --------------------------------- |
| |
| procedure Verify_Overriding_Indicator is |
| begin |
| if Must_Override (Body_Spec) then |
| if Nkind (Spec_Id) = N_Defining_Operator_Symbol |
| and then Operator_Matches_Spec (Spec_Id, Spec_Id) |
| then |
| null; |
| |
| elsif not Present (Overridden_Operation (Spec_Id)) then |
| Error_Msg_NE |
| ("subprogram& is not overriding", Body_Spec, Spec_Id); |
| |
| -- Overriding indicators aren't allowed for protected subprogram |
| -- bodies (see the Confirmation in Ada Comment AC95-00213). Change |
| -- this to a warning if -gnatd.E is enabled. |
| |
| elsif Ekind (Scope (Spec_Id)) = E_Protected_Type then |
| Error_Msg_Warn := Error_To_Warning; |
| Error_Msg_N |
| ("<<overriding indicator not allowed for protected " |
| & "subprogram body", Body_Spec); |
| end if; |
| |
| elsif Must_Not_Override (Body_Spec) then |
| if Present (Overridden_Operation (Spec_Id)) then |
| Error_Msg_NE |
| ("subprogram& overrides inherited operation", |
| Body_Spec, Spec_Id); |
| |
| elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol |
| and then Operator_Matches_Spec (Spec_Id, Spec_Id) |
| then |
| Error_Msg_NE |
| ("subprogram& overrides predefined operator ", |
| Body_Spec, Spec_Id); |
| |
| -- Overriding indicators aren't allowed for protected subprogram |
| -- bodies (see the Confirmation in Ada Comment AC95-00213). Change |
| -- this to a warning if -gnatd.E is enabled. |
| |
| elsif Ekind (Scope (Spec_Id)) = E_Protected_Type then |
| Error_Msg_Warn := Error_To_Warning; |
| |
| Error_Msg_N |
| ("<<overriding indicator not allowed " |
| & "for protected subprogram body", Body_Spec); |
| |
| -- If this is not a primitive operation, then the overriding |
| -- indicator is altogether illegal. |
| |
| elsif not Is_Primitive (Spec_Id) then |
| Error_Msg_N |
| ("overriding indicator only allowed " |
| & "if subprogram is primitive", Body_Spec); |
| end if; |
| |
| -- If checking the style rule and the operation overrides, then |
| -- issue a warning about a missing overriding_indicator. Protected |
| -- subprogram bodies are excluded from this style checking, since |
| -- they aren't primitives (even though their declarations can |
| -- override) and aren't allowed to have an overriding_indicator. |
| |
| elsif Style_Check |
| and then Present (Overridden_Operation (Spec_Id)) |
| and then Ekind (Scope (Spec_Id)) /= E_Protected_Type |
| then |
| pragma Assert (Unit_Declaration_Node (Body_Id) = N); |
| Style.Missing_Overriding (N, Body_Id); |
| |
| elsif Style_Check |
| and then Can_Override_Operator (Spec_Id) |
| and then not In_Predefined_Unit (Spec_Id) |
| then |
| pragma Assert (Unit_Declaration_Node (Body_Id) = N); |
| Style.Missing_Overriding (N, Body_Id); |
| end if; |
| end Verify_Overriding_Indicator; |
| |
| -- Local variables |
| |
| Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; |
| Saved_IGR : constant Node_Id := Ignored_Ghost_Region; |
| Saved_EA : constant Boolean := Expander_Active; |
| Saved_ISMP : constant Boolean := |
| Ignore_SPARK_Mode_Pragmas_In_Instance; |
| -- Save the Ghost and SPARK mode-related data to restore on exit |
| |
| -- Start of processing for Analyze_Subprogram_Body_Helper |
| |
| begin |
| -- A [generic] subprogram body freezes the contract of the nearest |
| -- enclosing package body and all other contracts encountered in the |
| -- same declarative part up to and excluding the subprogram body: |
| |
| -- package body Nearest_Enclosing_Package |
| -- with Refined_State => (State => Constit) |
| -- is |
| -- Constit : ...; |
| |
| -- procedure Freezes_Enclosing_Package_Body |
| -- with Refined_Depends => (Input => Constit) ... |
| |
| -- This ensures that any annotations referenced by the contract of the |
| -- [generic] subprogram body are available. This form of freezing is |
| -- decoupled from the usual Freeze_xxx mechanism because it must also |
| -- work in the context of generics where normal freezing is disabled. |
| |
| -- Only bodies coming from source should cause this type of freezing. |
| -- Expression functions that act as bodies and complete an initial |
| -- declaration must be included in this category, hence the use of |
| -- Original_Node. |
| |
| if Comes_From_Source (Original_Node (N)) then |
| Freeze_Previous_Contracts (N); |
| end if; |
| |
| -- Generic subprograms are handled separately. They always have a |
| -- generic specification. Determine whether current scope has a |
| -- previous declaration. |
| |
| -- If the subprogram body is defined within an instance of the same |
| -- name, the instance appears as a package renaming, and will be hidden |
| -- within the subprogram. |
| |
| if Present (Prev_Id) |
| and then not Is_Overloadable (Prev_Id) |
| and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration |
| or else Comes_From_Source (Prev_Id)) |
| then |
| if Is_Generic_Subprogram (Prev_Id) then |
| Spec_Id := Prev_Id; |
| |
| -- A subprogram body is Ghost when it is stand-alone and subject |
| -- to pragma Ghost or when the corresponding spec is Ghost. Set |
| -- the mode now to ensure that any nodes generated during analysis |
| -- and expansion are properly marked as Ghost. |
| |
| Mark_And_Set_Ghost_Body (N, Spec_Id); |
| |
| -- If the body completes the initial declaration of a compilation |
| -- unit which is subject to pragma Elaboration_Checks, set the |
| -- model specified by the pragma because it applies to all parts |
| -- of the unit. |
| |
| Install_Elaboration_Model (Spec_Id); |
| |
| Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); |
| Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); |
| |
| Analyze_Generic_Subprogram_Body (N, Spec_Id); |
| |
| if Nkind (N) = N_Subprogram_Body then |
| HSS := Handled_Statement_Sequence (N); |
| Check_Missing_Return; |
| end if; |
| |
| goto Leave; |
| |
| -- Otherwise a previous entity conflicts with the subprogram name. |
| -- Attempting to enter name will post error. |
| |
| else |
| Enter_Name (Body_Id); |
| goto Leave; |
| end if; |
| |
| -- Non-generic case, find the subprogram declaration, if one was seen, |
| -- or enter new overloaded entity in the current scope. If the |
| -- Current_Entity is the Body_Id itself, the unit is being analyzed as |
| -- part of the context of one of its subunits. No need to redo the |
| -- analysis. |
| |
| elsif Prev_Id = Body_Id and then Has_Completion (Body_Id) then |
| goto Leave; |
| |
| else |
| Body_Id := Analyze_Subprogram_Specification (Body_Spec); |
| |
| if Nkind (N) = N_Subprogram_Body_Stub |
| or else No (Corresponding_Spec (N)) |
| then |
| if Is_Private_Concurrent_Primitive (Body_Id) then |
| Spec_Id := Disambiguate_Spec; |
| |
| -- A subprogram body is Ghost when it is stand-alone and |
| -- subject to pragma Ghost or when the corresponding spec is |
| -- Ghost. Set the mode now to ensure that any nodes generated |
| -- during analysis and expansion are properly marked as Ghost. |
| |
| Mark_And_Set_Ghost_Body (N, Spec_Id); |
| |
| -- If the body completes a compilation unit which is subject |
| -- to pragma Elaboration_Checks, set the model specified by |
| -- the pragma because it applies to all parts of the unit. |
| |
| Install_Elaboration_Model (Spec_Id); |
| |
| else |
| Spec_Id := Find_Corresponding_Spec (N); |
| |
| -- A subprogram body is Ghost when it is stand-alone and |
| -- subject to pragma Ghost or when the corresponding spec is |
| -- Ghost. Set the mode now to ensure that any nodes generated |
| -- during analysis and expansion are properly marked as Ghost. |
| |
| Mark_And_Set_Ghost_Body (N, Spec_Id); |
| |
| -- If the body completes a compilation unit which is subject |
| -- to pragma Elaboration_Checks, set the model specified by |
| -- the pragma because it applies to all parts of the unit. |
| |
| Install_Elaboration_Model (Spec_Id); |
| |
| -- In GNATprove mode, if the body has no previous spec, create |
| -- one so that the inlining machinery can operate properly. |
| -- Transfer aspects, if any, to the new spec, so that they |
| -- are legal and can be processed ahead of the body. |
| -- We make two copies of the given spec, one for the new |
| -- declaration, and one for the body. |
| |
| if No (Spec_Id) and then GNATprove_Mode |
| |
| -- Inlining does not apply during preanalysis of code |
| |
| and then Full_Analysis |
| |
| -- Inlining only applies to full bodies, not stubs |
| |
| and then Nkind (N) /= N_Subprogram_Body_Stub |
| |
| -- Inlining only applies to bodies in the source code, not to |
| -- those generated by the compiler. In particular, expression |
| -- functions, whose body is generated by the compiler, are |
| -- treated specially by GNATprove. |
| |
| and then Comes_From_Source (Body_Id) |
| |
| -- This cannot be done for a compilation unit, which is not |
| -- in a context where we can insert a new spec. |
| |
| and then Is_List_Member (N) |
| |
| -- Inlining only applies to subprograms without contracts, |
| -- as a contract is a sign that GNATprove should perform a |
| -- modular analysis of the subprogram instead of a contextual |
| -- analysis at each call site. The same test is performed in |
| -- Inline.Can_Be_Inlined_In_GNATprove_Mode. It is repeated |
| -- here in another form (because the contract has not been |
| -- attached to the body) to avoid front-end errors in case |
| -- pragmas are used instead of aspects, because the |
| -- corresponding pragmas in the body would not be transferred |
| -- to the spec, leading to legality errors. |
| |
| and then not Body_Has_Contract |
| and then not Inside_A_Generic |
| then |
| Build_Subprogram_Declaration; |
| |
| -- If this is a function that returns a constrained array, and |
| -- we are generating SPARK_For_C, create subprogram declaration |
| -- to simplify subsequent C generation. |
| |
| elsif No (Spec_Id) |
| and then Modify_Tree_For_C |
| and then Nkind (Body_Spec) = N_Function_Specification |
| and then Is_Array_Type (Etype (Body_Id)) |
| and then Is_Constrained (Etype (Body_Id)) |
| then |
| Build_Subprogram_Declaration; |
| end if; |
| end if; |
| |
| -- If this is a duplicate body, no point in analyzing it |
| |
| if Error_Posted (N) then |
| goto Leave; |
| end if; |
| |
| -- A subprogram body should cause freezing of its own declaration, |
| -- but if there was no previous explicit declaration, then the |
| -- subprogram will get frozen too late (there may be code within |
| -- the body that depends on the subprogram having been frozen, |
| -- such as uses of extra formals), so we force it to be frozen |
| -- here. Same holds if the body and spec are compilation units. |
| -- Finally, if the return type is an anonymous access to protected |
| -- subprogram, it must be frozen before the body because its |
| -- expansion has generated an equivalent type that is used when |
| -- elaborating the body. |
| |
| -- An exception in the case of Ada 2012, AI05-177: The bodies |
| -- created for expression functions do not freeze. |
| |
| if No (Spec_Id) |
| and then Nkind (Original_Node (N)) /= N_Expression_Function |
| then |
| Freeze_Before (N, Body_Id); |
| |
| elsif Nkind (Parent (N)) = N_Compilation_Unit then |
| Freeze_Before (N, Spec_Id); |
| |
| elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then |
| Freeze_Before (N, Etype (Body_Id)); |
| end if; |
| |
| else |
| Spec_Id := Corresponding_Spec (N); |
| |
| -- A subprogram body is Ghost when it is stand-alone and subject |
| -- to pragma Ghost or when the corresponding spec is Ghost. Set |
| -- the mode now to ensure that any nodes generated during analysis |
| -- and expansion are properly marked as Ghost. |
| |
| Mark_And_Set_Ghost_Body (N, Spec_Id); |
| |
| -- If the body completes the initial declaration of a compilation |
| -- unit which is subject to pragma Elaboration_Checks, set the |
| -- model specified by the pragma because it applies to all parts |
| -- of the unit. |
| |
| Install_Elaboration_Model (Spec_Id); |
| end if; |
| end if; |
| |
| -- Deactivate expansion inside the body of ignored Ghost entities, |
| -- as this code will ultimately be ignored. This avoids requiring the |
| -- presence of run-time units which are not needed. Only do this for |
| -- user entities, as internally generated entitities might still need |
| -- to be expanded (e.g. those generated for types). |
| |
| if Present (Ignored_Ghost_Region) |
| and then Comes_From_Source (Body_Id) |
| then |
| Expander_Active := False; |
| end if; |
| |
| -- Previously we scanned the body to look for nested subprograms, and |
| -- rejected an inline directive if nested subprograms were present, |
| -- because the back-end would generate conflicting symbols for the |
| -- nested bodies. This is now unnecessary. |
| |
| -- Look ahead to recognize a pragma Inline that appears after the body |
| |
| Check_Inline_Pragma (Spec_Id); |
| |
| -- Deal with special case of a fully private operation in the body of |
| -- the protected type. We must create a declaration for the subprogram, |
| -- in order to attach the protected subprogram that will be used in |
| -- internal calls. We exclude compiler generated bodies from the |
| -- expander since the issue does not arise for those cases. |
| |
| if No (Spec_Id) |
| and then Comes_From_Source (N) |
| and then Is_Protected_Type (Current_Scope) |
| then |
| Spec_Id := Build_Private_Protected_Declaration (N); |
| end if; |
| |
| -- If we are generating C and this is a function returning a constrained |
| -- array type for which we must create a procedure with an extra out |
| -- parameter, build and analyze the body now. The procedure declaration |
| -- has already been created. We reuse the source body of the function, |
| -- because in an instance it may contain global references that cannot |
| -- be reanalyzed. The source function itself is not used any further, |
| -- so we mark it as having a completion. If the subprogram is a stub the |
| -- transformation is done later, when the proper body is analyzed. |
| |
| if Expander_Active |
| and then Modify_Tree_For_C |
| and then Present (Spec_Id) |
| and then Ekind (Spec_Id) = E_Function |
| and then Nkind (N) /= N_Subprogram_Body_Stub |
| and then Rewritten_For_C (Spec_Id) |
| then |
| Set_Has_Completion (Spec_Id); |
| |
| Rewrite (N, Build_Procedure_Body_Form (Spec_Id, N)); |
| Analyze (N); |
| |
| -- The entity for the created procedure must remain invisible, so it |
| -- does not participate in resolution of subsequent references to the |
| -- function. |
| |
| Set_Is_Immediately_Visible (Corresponding_Spec (N), False); |
| goto Leave; |
| end if; |
| |
| -- If a separate spec is present, then deal with freezing issues |
| |
| if Present (Spec_Id) then |
| Spec_Decl := Unit_Declaration_Node (Spec_Id); |
| Verify_Overriding_Indicator; |
| |
| -- In general, the spec will be frozen when we start analyzing the |
| -- body. However, for internally generated operations, such as |
| -- wrapper functions for inherited operations with controlling |
| -- results, the spec may not have been frozen by the time we expand |
| -- the freeze actions that include the bodies. In particular, extra |
| -- formals for accessibility or for return-in-place may need to be |
| -- generated. Freeze nodes, if any, are inserted before the current |
| -- body. These freeze actions are also needed in ASIS mode and in |
| -- Compile_Only mode to enable the proper back-end type annotations. |
| -- They are necessary in any case to insure order of elaboration |
| -- in gigi. |
| |
| if Nkind (N) = N_Subprogram_Body |
| and then Was_Expression_Function (N) |
| and then not Has_Completion (Spec_Id) |
| and then Serious_Errors_Detected = 0 |
| and then (Expander_Active |
| or else ASIS_Mode |
| or else Operating_Mode = Check_Semantics) |
| then |
| -- The body generated for an expression function that is not a |
| -- completion is a freeze point neither for the profile nor for |
| -- anything else. That's why, in order to prevent any freezing |
| -- during analysis, we need to mask types declared outside the |
| -- expression (and in an outer scope) that are not yet frozen. |
| |
| Set_Is_Frozen (Spec_Id); |
| Mask_Types := Mask_Unfrozen_Types (Spec_Id); |
| |
| elsif not Is_Frozen (Spec_Id) |
| and then Serious_Errors_Detected = 0 |
| then |
| Set_Has_Delayed_Freeze (Spec_Id); |
| Freeze_Before (N, Spec_Id); |
| end if; |
| end if; |
| |
| -- If the subprogram has a class-wide clone, build its body as a copy |
| -- of the original body, and rewrite body of original subprogram as a |
| -- wrapper that calls the clone. If N is a stub, this construction will |
| -- take place when the proper body is analyzed. No action needed if this |
| -- subprogram has been eliminated. |
| |
| if Present (Spec_Id) |
| and then Present (Class_Wide_Clone (Spec_Id)) |
| and then (Comes_From_Source (N) or else Was_Expression_Function (N)) |
| and then Nkind (N) /= N_Subprogram_Body_Stub |
| and then not (Expander_Active and then Is_Eliminated (Spec_Id)) |
| then |
| Build_Class_Wide_Clone_Body (Spec_Id, N); |
| |
| -- This is the new body for the existing primitive operation |
| |
| Rewrite (N, Build_Class_Wide_Clone_Call |
| (Sloc (N), New_List, Spec_Id, Parent (Spec_Id))); |
| Set_Has_Completion (Spec_Id, False); |
| Analyze (N); |
| return; |
| end if; |
| |
| -- Place subprogram on scope stack, and make formals visible. If there |
| -- is a spec, the visible entity remains that of the spec. |
| |
| if Present (Spec_Id) then |
| Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); |
| |
| if Is_Child_Unit (Spec_Id) then |
| Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False); |
| end if; |
| |
| if Style_Check then |
| Style.Check_Identifier (Body_Id, Spec_Id); |
| end if; |
| |
| Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); |
| Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); |
| |
| if Is_Abstract_Subprogram (Spec_Id) then |
| Error_Msg_N ("an abstract subprogram cannot have a body", N); |
| goto Leave; |
| |
| else |
| Set_Convention (Body_Id, Convention (Spec_Id)); |
| Set_Has_Completion (Spec_Id); |
| |
| if Is_Protected_Type (Scope (Spec_Id)) then |
| Prot_Typ := Scope (Spec_Id); |
| end if; |
| |
| -- If this is a body generated for a renaming, do not check for |
| -- full conformance. The check is redundant, because the spec of |
| -- the body is a copy of the spec in the renaming declaration, |
| -- and the test can lead to spurious errors on nested defaults. |
| |
| if Present (Spec_Decl) |
| and then not Comes_From_Source (N) |
| and then |
| (Nkind (Original_Node (Spec_Decl)) = |
| N_Subprogram_Renaming_Declaration |
| or else (Present (Corresponding_Body (Spec_Decl)) |
| and then |
| Nkind (Unit_Declaration_Node |
| (Corresponding_Body (Spec_Decl))) = |
| N_Subprogram_Renaming_Declaration)) |
| then |
| Conformant := True; |
| |
| -- Conversely, the spec may have been generated for specless body |
| -- with an inline pragma. The entity comes from source, which is |
| -- both semantically correct and necessary for proper inlining. |
| -- The subprogram declaration itself is not in the source. |
| |
| elsif Comes_From_Source (N) |
| and then Present (Spec_Decl) |
| and then not Comes_From_Source (Spec_Decl) |
| and then Has_Pragma_Inline (Spec_Id) |
| then |
| Conformant := True; |
| |
| else |
| Check_Conformance |
| (Body_Id, Spec_Id, |
| Fully_Conformant, True, Conformant, Body_Id); |
| end if; |
| |
| -- If the body is not fully conformant, we have to decide if we |
| -- should analyze it or not. If it has a really messed up profile |
| -- then we probably should not analyze it, since we will get too |
| -- many bogus messages. |
| |
| -- Our decision is to go ahead in the non-fully conformant case |
| -- only if it is at least mode conformant with the spec. Note |
| -- that the call to Check_Fully_Conformant has issued the proper |
| -- error messages to complain about the lack of conformance. |
| |
| if not Conformant |
| and then not Mode_Conformant (Body_Id, Spec_Id) |
| then |
| goto Leave; |
| end if; |
| end if; |
| |
| -- In the case we are dealing with an expression function we check |
| -- the formals attached to the spec instead of the body - so we don't |
| -- reference body formals. |
| |
| if Spec_Id /= Body_Id |
| and then not Is_Expression_Function (Spec_Id) |
| then |
| Reference_Body_Formals (Spec_Id, Body_Id); |
| end if; |
| |
| Set_Ekind (Body_Id, E_Subprogram_Body); |
| |
| if Nkind (N) = N_Subprogram_Body_Stub then |
| Set_Corresponding_Spec_Of_Stub (N, Spec_Id); |
| |
| -- Regular body |
| |
| else |
| Set_Corresponding_Spec (N, Spec_Id); |
| |
| -- Ada 2005 (AI-345): If the operation is a primitive operation |
| -- of a concurrent type, the type of the first parameter has been |
| -- replaced with the corresponding record, which is the proper |
| -- run-time structure to use. However, within the body there may |
| -- be uses of the formals that depend on primitive operations |
| -- of the type (in particular calls in prefixed form) for which |
| -- we need the original concurrent type. The operation may have |
| -- several controlling formals, so the replacement must be done |
| -- for all of them. |
| |
| if Comes_From_Source (Spec_Id) |
| and then Present (First_Entity (Spec_Id)) |
| and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type |
| and then Is_Tagged_Type (Etype (First_Entity (Spec_Id))) |
| and then Present (Interfaces (Etype (First_Entity (Spec_Id)))) |
| and then Present (Corresponding_Concurrent_Type |
| (Etype (First_Entity (Spec_Id)))) |
| then |
| declare |
| Typ : constant Entity_Id := Etype (First_Entity (Spec_Id)); |
| Form : Entity_Id; |
| |
| begin |
| Form := First_Formal (Spec_Id); |
| while Present (Form) loop |
| if Etype (Form) = Typ then |
| Set_Etype (Form, Corresponding_Concurrent_Type (Typ)); |
| end if; |
| |
| Next_Formal (Form); |
| end loop; |
| end; |
| end if; |
| |
| -- Make the formals visible, and place subprogram on scope stack. |
| -- This is also the point at which we set Last_Real_Spec_Entity |
| -- to mark the entities which will not be moved to the body. |
| |
| Install_Formals (Spec_Id); |
| Last_Real_Spec_Entity := Last_Entity (Spec_Id); |
| |
| -- Within an instance, add local renaming declarations so that |
| -- gdb can retrieve the values of actuals more easily. This is |
| -- only relevant if generating code (and indeed we definitely |
| -- do not want these definitions -gnatc mode, because that would |
| -- confuse ASIS). |
| |
| if Is_Generic_Instance (Spec_Id) |
| and then Is_Wrapper_Package (Current_Scope) |
| and then Expander_Active |
| then |
| Build_Subprogram_Instance_Renamings (N, Current_Scope); |
| end if; |
| |
| Push_Scope (Spec_Id); |
| |
| -- Make sure that the subprogram is immediately visible. For |
| -- child units that have no separate spec this is indispensable. |
| -- Otherwise it is safe albeit redundant. |
| |
| Set_Is_Immediately_Visible (Spec_Id); |
| end if; |
| |
| Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id); |
| Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id)); |
| Set_Scope (Body_Id, Scope (Spec_Id)); |
| |
| -- Case of subprogram body with no previous spec |
| |
| else |
| -- Check for style warning required |
| |
| if Style_Check |
| |
| -- Only apply check for source level subprograms for which checks |
| -- have not been suppressed. |
| |
| and then Comes_From_Source (Body_Id) |
| and then not Suppress_Style_Checks (Body_Id) |
| |
| -- No warnings within an instance |
| |
| and then not In_Instance |
| |
| -- No warnings for expression functions |
| |
| and then Nkind (Original_Node (N)) /= N_Expression_Function |
| then |
| Style.Body_With_No_Spec (N); |
| end if; |
| |
| New_Overloaded_Entity (Body_Id); |
| |
| if Nkind (N) /= N_Subprogram_Body_Stub then |
| Set_Acts_As_Spec (N); |
| Generate_Definition (Body_Id); |
| Generate_Reference |
| (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True); |
| |
| -- If the body is an entry wrapper created for an entry with |
| -- preconditions, it must be compiled in the context of the |
| -- enclosing synchronized object, because it may mention other |
| -- operations of the type. |
| |
| if Is_Entry_Wrapper (Body_Id) then |
| declare |
| Prot : constant Entity_Id := Etype (First_Entity (Body_Id)); |
| begin |
| Push_Scope (Prot); |
| Install_Declarations (Prot); |
| end; |
| end if; |
| |
| Install_Formals (Body_Id); |
| |
| Push_Scope (Body_Id); |
| end if; |
| |
| -- For stubs and bodies with no previous spec, generate references to |
| -- formals. |
| |
| Generate_Reference_To_Formals (Body_Id); |
| end if; |
| |
| -- Entry barrier functions are generated outside the protected type and |
| -- should not carry the SPARK_Mode of the enclosing context. |
| |
| if Nkind (N) = N_Subprogram_Body |
| and then Is_Entry_Barrier_Function (N) |
| then |
| null; |
| |
| -- The body is generated as part of expression function expansion. When |
| -- the expression function appears in the visible declarations of a |
| -- package, the body is added to the private declarations. Since both |
| -- declarative lists may be subject to a different SPARK_Mode, inherit |
| -- the mode of the spec. |
| |
| -- package P with SPARK_Mode is |
| -- function Expr_Func ... is (...); -- original |
| -- [function Expr_Func ...;] -- generated spec |
| -- -- mode is ON |
| -- private |
| -- pragma SPARK_Mode (Off); |
| -- [function Expr_Func ... is return ...;] -- generated body |
| -- end P; -- mode is ON |
| |
| elsif not Comes_From_Source (N) |
| and then Present (Spec_Id) |
| and then Is_Expression_Function (Spec_Id) |
| then |
| Set_SPARK_Pragma (Body_Id, SPARK_Pragma (Spec_Id)); |
| Set_SPARK_Pragma_Inherited |
| (Body_Id, SPARK_Pragma_Inherited (Spec_Id)); |
| |
| -- Set the SPARK_Mode from the current context (may be overwritten later |
| -- with explicit pragma). Exclude the case where the SPARK_Mode appears |
| -- initially on a stand-alone subprogram body, but is then relocated to |
| -- a generated corresponding spec. In this scenario the mode is shared |
| -- between the spec and body. |
| |
| elsif No (SPARK_Pragma (Body_Id)) then |
| Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (Body_Id); |
| end if; |
| |
| -- A subprogram body may be instantiated or inlined at a later pass. |
| -- Restore the state of Ignore_SPARK_Mode_Pragmas_In_Instance when it |
| -- applied to the initial declaration of the body. |
| |
| if Present (Spec_Id) then |
| if Ignore_SPARK_Mode_Pragmas (Spec_Id) then |
| Ignore_SPARK_Mode_Pragmas_In_Instance := True; |
| end if; |
| |
| else |
| -- Save the state of flag Ignore_SPARK_Mode_Pragmas_In_Instance in |
| -- case the body is instantiated or inlined later and out of context. |
| -- The body uses this attribute to restore the value of the global |
| -- flag. |
| |
| if Ignore_SPARK_Mode_Pragmas_In_Instance then |
| Set_Ignore_SPARK_Mode_Pragmas (Body_Id); |
| |
| elsif Ignore_SPARK_Mode_Pragmas (Body_Id) then |
| Ignore_SPARK_Mode_Pragmas_In_Instance := True; |
| end if; |
| end if; |
| |
| -- 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. |
| |
| if No (Spec_Id) then |
| Mark_Elaboration_Attributes |
| (N_Id => Body_Id, |
| Checks => True, |
| Warnings => True); |
| end if; |
| |
| -- If this is the proper body of a stub, we must verify that the stub |
| -- conforms to the body, and to the previous spec if one was present. |
| -- We know already that the body conforms to that spec. This test is |
| -- only required for subprograms that come from source. |
| |
| if Nkind (Parent (N)) = N_Subunit |
| and then Comes_From_Source (N) |
| and then not Error_Posted (Body_Id) |
| and then Nkind (Corresponding_Stub (Parent (N))) = |
| N_Subprogram_Body_Stub |
| then |
| declare |
| Old_Id : constant Entity_Id := |
| Defining_Entity |
| (Specification (Corresponding_Stub (Parent (N)))); |
| |
| Conformant : Boolean := False; |
| |
| begin |
| if No (Spec_Id) then |
| Check_Fully_Conformant (Body_Id, Old_Id); |
| |
| else |
| Check_Conformance |
| (Body_Id, Old_Id, Fully_Conformant, False, Conformant); |
| |
| if not Conformant then |
| |
| -- The stub was taken to be a new declaration. Indicate that |
| -- it lacks a body. |
| |
| Set_Has_Completion (Old_Id, False); |
| end if; |
| end if; |
| end; |
| end if; |
| |
| Set_Has_Completion (Body_Id); |
| Check_Eliminated (Body_Id); |
| |
| -- Analyze any aspect specifications that appear on the subprogram body |
| -- stub. Stop the analysis now as the stub does not have a declarative |
| -- or a statement part, and it cannot be inlined. |
| |
| if Nkind (N) = N_Subprogram_Body_Stub then |
| if Has_Aspects (N) then |
| Analyze_Aspects_On_Subprogram_Body_Or_Stub (N); |
| end if; |
| |
| goto Leave; |
| end if; |
| |
| -- Handle inlining |
| |
| -- Note: Normally we don't do any inlining if expansion is off, since |
| -- we won't generate code in any case. An exception arises in GNATprove |
| -- mode where we want to expand some calls in place, even with expansion |
| -- disabled, since the inlining eases formal verification. |
| |
| if not GNATprove_Mode |
| and then Expander_Active |
| and then Serious_Errors_Detected = 0 |
| and then Present (Spec_Id) |
| and then Has_Pragma_Inline (Spec_Id) |
| then |
| -- Legacy implementation (relying on front-end inlining) |
| |
| if not Back_End_Inlining then |
| if (Has_Pragma_Inline_Always (Spec_Id) |
| and then not Opt.Disable_FE_Inline_Always) |
| or else (Front_End_Inlining |
| and then not Opt.Disable_FE_Inline) |
| then |
| Build_Body_To_Inline (N, Spec_Id); |
| end if; |
| |
| -- New implementation (relying on back-end inlining) |
| |
| else |
| if Has_Pragma_Inline_Always (Spec_Id) |
| or else Optimization_Level > 0 |
| then |
| -- Handle function returning an unconstrained type |
| |
| if Comes_From_Source (Body_Id) |
| and then Ekind (Spec_Id) = E_Function |
| and then Returns_Unconstrained_Type (Spec_Id) |
| |
| -- If function builds in place, i.e. returns a limited type, |
| -- inlining cannot be done. |
| |
| and then not Is_Limited_Type (Etype (Spec_Id)) |
| then |
| Check_And_Split_Unconstrained_Function (N, Spec_Id, Body_Id); |
| |
| else |
| declare |
| Subp_Body : constant Node_Id := |
| Unit_Declaration_Node (Body_Id); |
| Subp_Decl : constant List_Id := Declarations (Subp_Body); |
| |
| begin |
| -- Do not pass inlining to the backend if the subprogram |
| -- has declarations or statements which cannot be inlined |
| -- by the backend. This check is done here to emit an |
| -- error instead of the generic warning message reported |
| -- by the GCC backend (ie. "function might not be |
| -- inlinable"). |
| |
| if Present (Subp_Decl) |
| and then Has_Excluded_Declaration (Spec_Id, Subp_Decl) |
| then |
| null; |
| |
| elsif Has_Excluded_Statement |
| (Spec_Id, |
| Statements |
| (Handled_Statement_Sequence (Subp_Body))) |
| then |
| null; |
| |
| -- If the backend inlining is available then at this |
| -- stage we only have to mark the subprogram as inlined. |
| -- The expander will take care of registering it in the |
| -- table of subprograms inlined by the backend a part of |
| -- processing calls to it (cf. Expand_Call) |
| |
| else |
| Set_Is_Inlined (Spec_Id); |
| end if; |
| end; |
| end if; |
| end if; |
| end if; |
| |
| -- In GNATprove mode, inline only when there is a separate subprogram |
| -- declaration for now, as inlining of subprogram bodies acting as |
| -- declarations, or subprogram stubs, are not supported by front-end |
| -- inlining. This inlining should occur after analysis of the body, so |
| -- that it is known whether the value of SPARK_Mode, which can be |
| -- defined by a pragma inside the body, is applicable to the body. |
| -- Inlining can be disabled with switch -gnatdm |
| |
| elsif GNATprove_Mode |
| and then Full_Analysis |
| and then not Inside_A_Generic |
| and then Present (Spec_Id) |
| and then |
| Nkind (Unit_Declaration_Node (Spec_Id)) = N_Subprogram_Declaration |
| and then Body_Has_SPARK_Mode_On |
| and then Can_Be_Inlined_In_GNATprove_Mode (Spec_Id, Body_Id) |
| and then not Body_Has_Contract |
| and then not Debug_Flag_M |
| then |
| Build_Body_To_Inline (N, Spec_Id); |
| end if; |
| |
| -- When generating code, inherited pre/postconditions are handled when |
| -- expanding the corresponding contract. |
| |
| -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis |
| -- of the specification we have to install the private withed units. |
| -- This holds for child units as well. |
| |
| if Is_Compilation_Unit (Body_Id) |
| or else Nkind (Parent (N)) = N_Compilation_Unit |
| then |
| Install_Private_With_Clauses (Body_Id); |
| end if; |
| |
| Check_Anonymous_Return; |
| |
| -- Set the Protected_Formal field of each extra formal of the protected |
| -- subprogram to reference the corresponding extra formal of the |
| -- subprogram that implements it. For regular formals this occurs when |
| -- the protected subprogram's declaration is expanded, but the extra |
| -- formals don't get created until the subprogram is frozen. We need to |
| -- do this before analyzing the protected subprogram's body so that any |
| -- references to the original subprogram's extra formals will be changed |
| -- refer to the implementing subprogram's formals (see Expand_Formal). |
| |
| if Present (Spec_Id) |
| and then Is_Protected_Type (Scope (Spec_Id)) |
| and then Present (Protected_Body_Subprogram (Spec_Id)) |
| then |
| declare |
| Impl_Subp : constant Entity_Id := |
| Protected_Body_Subprogram (Spec_Id); |
| Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id); |
| Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp); |
| |
| begin |
| while Present (Prot_Ext_Formal) loop |
| pragma Assert (Present (Impl_Ext_Formal)); |
| Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal); |
| Next_Formal_With_Extras (Prot_Ext_Formal); |
| Next_Formal_With_Extras (Impl_Ext_Formal); |
| end loop; |
| end; |
| end if; |
| |
| -- Now we can go on to analyze the body |
| |
| HSS := Handled_Statement_Sequence (N); |
| Set_Actual_Subtypes (N, Current_Scope); |
| |
| -- Add a declaration for the Protection object, renaming declarations |
| -- for discriminals and privals and finally a declaration for the entry |
| -- family index (if applicable). This form of early expansion is done |
| -- when the Expander is active because Install_Private_Data_Declarations |
| |