| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ C H 6 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, 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 Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Expander; use Expander; |
| with Exp_Ch3; use Exp_Ch3; |
| with Exp_Ch6; use Exp_Ch6; |
| 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 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.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| 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; |
| with Warnsw; use Warnsw; |
| |
| 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. |
| |
| 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_Formal_Subprogram_Conformance |
| (New_Id : Entity_Id; |
| Old_Id : Entity_Id; |
| Err_Loc : Node_Id; |
| Errmsg : Boolean; |
| Conforms : out Boolean); |
| -- Core implementation of Check_Formal_Subprogram_Conformance from spec. |
| -- Errmsg can be set to False to not emit error messages. |
| -- Conforms is set to True if there is conformance, False otherwise. |
| |
| 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 |
| 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 := Empty; |
| Ret : Node_Id; |
| Typ : Entity_Id := Empty; |
| |
| 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. |
| |
| 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); |
| |
| Typ := Etype (Def_Id); |
| |
| -- 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); |
| |
| elsif Present (Prev) |
| and then Is_Overloadable (Prev) |
| and then not Is_Formal_Subprogram (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 => Typ, |
| 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); |
| |
| -- 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); |
| |
| -- 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); |
| |
| Typ := Etype (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 this is an ignored Ghost entity, analysis of the generated |
| -- body is needed to hide external references (as is done in |
| -- Analyze_Subprogram_Body) after which the the subprogram profile |
| -- can be frozen, which is needed to expand calls to such an ignored |
| -- Ghost subprogram. |
| |
| if Inside_A_Generic then |
| Set_Has_Completion (Def_Id, not Is_Ignored_Ghost_Entity (Def_Id)); |
| Push_Scope (Def_Id); |
| Install_Formals (Def_Id); |
| Preanalyze_Spec_Expression (Expr, Typ); |
| End_Scope; |
| else |
| Push_Scope (Def_Id); |
| Install_Formals (Def_Id); |
| Preanalyze_Formal_Expression (Expr, Typ); |
| Check_Limited_Return (Orig_N, Expr, Typ); |
| End_Scope; |
| end if; |
| |
| -- If this is a wrapper created 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); |
| |
| -- 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. |
| |
| else |
| declare |
| Decls : List_Id := List_Containing (N); |
| Par : constant Node_Id := Parent (Decls); |
| |
| begin |
| if Nkind (Par) = N_Package_Specification |
| and then Decls = Visible_Declarations (Par) |
| and then not Is_Empty_List (Private_Declarations (Par)) |
| then |
| Decls := Private_Declarations (Par); |
| end if; |
| |
| Insert_After (Last (Decls), New_Body); |
| end; |
| end if; |
| |
| -- In the case of an expression function marked with the aspect |
| -- Static, we need to check the requirement that the function's |
| -- expression is a potentially static expression. This is done |
| -- by making a full copy of the expression tree and performing |
| -- a special preanalysis on that tree with the global flag |
| -- Checking_Potentially_Static_Expression enabled. If the |
| -- resulting expression is static, then it's OK, but if not, that |
| -- means the expression violates the requirements of the Ada 2022 |
| -- RM in 4.9(3.2/5-3.4/5) and we flag an error. |
| |
| if Is_Static_Function (Def_Id) then |
| if not Is_Static_Expression (Expr) then |
| declare |
| Exp_Copy : constant Node_Id := New_Copy_Tree (Expr); |
| begin |
| Set_Checking_Potentially_Static_Expression (True); |
| |
| Preanalyze_Formal_Expression (Exp_Copy, Typ); |
| |
| if not Is_Static_Expression (Exp_Copy) then |
| Error_Msg_N |
| ("static expression function requires " |
| & "potentially static expression", Expr); |
| end if; |
| |
| Set_Checking_Potentially_Static_Expression (False); |
| end; |
| end if; |
| |
| -- We also make an additional copy of the expression and |
| -- replace the expression of the expression function with |
| -- this copy, because the currently present expression is |
| -- now associated with the body created for the static |
| -- expression function, which will later be analyzed and |
| -- possibly rewritten, and we need to have the separate |
| -- unanalyzed copy available for use with later static |
| -- calls. |
| |
| Set_Expression |
| (Original_Node (Subprogram_Spec (Def_Id)), |
| New_Copy_Tree (Expr)); |
| |
| -- Mark static expression functions as inlined, to ensure |
| -- that even calls with nonstatic actuals will be inlined. |
| |
| Set_Has_Pragma_Inline (Def_Id); |
| Set_Is_Inlined (Def_Id); |
| end if; |
| 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 Is_Tagged_Type (Typ) |
| then |
| Check_Dynamically_Tagged_Expression |
| (Expr => Expr, |
| Typ => Typ, |
| Related_Nod => Orig_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 : Node_Id; |
| Form_Old_Def : Entity_Id; |
| Form_Old_Spec : Node_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 |
| 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_No_Return_Expression (Return_Expr : Node_Id); |
| -- Ada 2022: Check that the return expression in a No_Return function |
| -- meets the conditions specified by RM 6.5.1(5.1/5). |
| |
| procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id); |
| -- Apply legality rule of 6.5 (5.9) 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_No_Return_Expression -- |
| -------------------------------- |
| |
| procedure Check_No_Return_Expression (Return_Expr : Node_Id) is |
| Kind : constant Node_Kind := Nkind (Return_Expr); |
| |
| begin |
| if Kind = N_Raise_Expression then |
| return; |
| |
| elsif Kind = N_Function_Call |
| and then Is_Entity_Name (Name (Return_Expr)) |
| and then Ekind (Entity (Name (Return_Expr))) in |
| E_Function | E_Generic_Function |
| and then No_Return (Entity (Name (Return_Expr))) |
| then |
| return; |
| end if; |
| |
| Error_Msg_N |
| ("illegal expression in RETURN statement of No_Return function", |
| Return_Expr); |
| Error_Msg_N |
| ("\must be raise expression or call to No_Return (RM 6.5.1(5.1/5))", |
| Return_Expr); |
| end Check_No_Return_Expression; |
| |
| ------------------------------------------ |
| -- Check_Return_Construct_Accessibility -- |
| ------------------------------------------ |
| |
| procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is |
| |
| function First_Selector (Assoc : Node_Id) return Node_Id; |
| -- Obtain the first selector or choice from a given association |
| |
| -------------------- |
| -- First_Selector -- |
| -------------------- |
| |
| function First_Selector (Assoc : Node_Id) return Node_Id is |
| begin |
| if Nkind (Assoc) = N_Component_Association then |
| return First (Choices (Assoc)); |
| |
| elsif Nkind (Assoc) = N_Discriminant_Association then |
| return (First (Selector_Names (Assoc))); |
| |
| else |
| raise Program_Error; |
| end if; |
| end First_Selector; |
| |
| -- Local declarations |
| |
| Assoc : Node_Id := Empty; |
| -- Assoc should perhaps be renamed and declared as a |
| -- Node_Or_Entity_Id since it encompasses not only component and |
| -- discriminant associations, but also discriminant components within |
| -- a type declaration or subtype indication ??? |
| |
| Assoc_Expr : Node_Id; |
| Assoc_Present : Boolean := False; |
| |
| Check_Cond : Node_Id; |
| Unseen_Disc_Count : Nat := 0; |
| Seen_Discs : Elist_Id; |
| Disc : Entity_Id; |
| First_Disc : Entity_Id; |
| |
| Obj_Decl : Node_Id; |
| Return_Con : Node_Id; |
| Unqual : Node_Id; |
| |
| -- Start of processing for Check_Return_Construct_Accessibility |
| |
| begin |
| -- Only perform checks on record types with access discriminants and |
| -- non-internally generated functions. |
| |
| if not Is_Record_Type (R_Type) |
| or else not Has_Anonymous_Access_Discriminant (R_Type) |
| or else not Comes_From_Source (Return_Stmt) |
| then |
| return; |
| end if; |
| |
| -- We are only interested in return statements |
| |
| if Nkind (Return_Stmt) not in |
| N_Extended_Return_Statement | N_Simple_Return_Statement |
| then |
| return; |
| end if; |
| |
| -- Fetch the object from the return statement, in the case of a |
| -- simple return statement the expression is part of the node. |
| |
| if Nkind (Return_Stmt) = N_Extended_Return_Statement then |
| -- Obtain the object definition from the expanded extended return |
| |
| Return_Con := First (Return_Object_Declarations (Return_Stmt)); |
| while Present (Return_Con) loop |
| -- Inspect the original node to avoid object declarations |
| -- expanded into renamings. |
| |
| if Nkind (Original_Node (Return_Con)) = N_Object_Declaration |
| and then Comes_From_Source (Original_Node (Return_Con)) |
| then |
| exit; |
| end if; |
| |
| Nlists.Next (Return_Con); |
| end loop; |
| |
| pragma Assert (Present (Return_Con)); |
| |
| -- Could be dealing with a renaming |
| |
| Return_Con := Original_Node (Return_Con); |
| else |
| Return_Con := Expression (Return_Stmt); |
| end if; |
| |
| -- Obtain the accessibility levels of the expressions associated |
| -- with all anonymous access discriminants, then generate a |
| -- dynamic check or static error when relevant. |
| |
| Unqual := Unqualify (Original_Node (Return_Con)); |
| |
| -- Get the corresponding declaration based on the return object's |
| -- identifier. |
| |
| if Nkind (Unqual) = N_Identifier |
| and then Nkind (Parent (Entity (Unqual))) |
| in N_Object_Declaration |
| | N_Object_Renaming_Declaration |
| then |
| Obj_Decl := Original_Node (Parent (Entity (Unqual))); |
| |
| -- We were passed the object declaration directly, so use it |
| |
| elsif Nkind (Unqual) in N_Object_Declaration |
| | N_Object_Renaming_Declaration |
| then |
| Obj_Decl := Unqual; |
| |
| -- Otherwise, we are looking at something else |
| |
| else |
| Obj_Decl := Empty; |
| |
| end if; |
| |
| -- Hop up object renamings when present |
| |
| if Present (Obj_Decl) |
| and then Nkind (Obj_Decl) = N_Object_Renaming_Declaration |
| then |
| while Nkind (Obj_Decl) = N_Object_Renaming_Declaration loop |
| |
| if Nkind (Name (Obj_Decl)) not in N_Entity then |
| -- We may be looking at the expansion of iterators or |
| -- some other internally generated construct, so it is safe |
| -- to ignore checks ??? |
| |
| if not Comes_From_Source (Obj_Decl) then |
| return; |
| end if; |
| |
| Obj_Decl := Original_Node |
| (Declaration_Node |
| (Ultimate_Prefix (Name (Obj_Decl)))); |
| |
| -- Move up to the next declaration based on the object's name |
| |
| else |
| Obj_Decl := Original_Node |
| (Declaration_Node (Name (Obj_Decl))); |
| end if; |
| end loop; |
| end if; |
| |
| -- Obtain the discriminant values from the return aggregate |
| |
| -- Do we cover extension aggregates correctly ??? |
| |
| if Nkind (Unqual) = N_Aggregate then |
| if Present (Expressions (Unqual)) then |
| Assoc := First (Expressions (Unqual)); |
| else |
| Assoc := First (Component_Associations (Unqual)); |
| end if; |
| |
| -- There is an object declaration for the return object |
| |
| elsif Present (Obj_Decl) then |
| -- When a subtype indication is present in an object declaration |
| -- it must contain the object's discriminants. |
| |
| if Nkind (Object_Definition (Obj_Decl)) = N_Subtype_Indication then |
| Assoc := First |
| (Constraints |
| (Constraint |
| (Object_Definition (Obj_Decl)))); |
| |
| -- The object declaration contains an aggregate |
| |
| elsif Present (Expression (Obj_Decl)) then |
| |
| if Nkind (Unqualify (Expression (Obj_Decl))) = N_Aggregate then |
| -- Grab the first associated discriminant expresion |
| |
| if Present |
| (Expressions (Unqualify (Expression (Obj_Decl)))) |
| then |
| Assoc := First |
| (Expressions |
| (Unqualify (Expression (Obj_Decl)))); |
| else |
| Assoc := First |
| (Component_Associations |
| (Unqualify (Expression (Obj_Decl)))); |
| end if; |
| |
| -- Otherwise, this is something else |
| |
| else |
| return; |
| end if; |
| |
| -- There are no supplied discriminants in the object declaration, |
| -- so get them from the type definition since they must be default |
| -- initialized. |
| |
| -- Do we handle constrained subtypes correctly ??? |
| |
| elsif Nkind (Unqual) = N_Object_Declaration then |
| Assoc := First_Discriminant |
| (Etype (Object_Definition (Obj_Decl))); |
| |
| else |
| Assoc := First_Discriminant (Etype (Unqual)); |
| end if; |
| |
| -- When we are not looking at an aggregate or an identifier, return |
| -- since any other construct (like a function call) is not |
| -- applicable since checks will be performed on the side of the |
| -- callee. |
| |
| else |
| return; |
| end if; |
| |
| -- Obtain the discriminants so we know the actual type in case the |
| -- value of their associated expression gets implicitly converted. |
| |
| if No (Obj_Decl) then |
| pragma Assert (Nkind (Unqual) = N_Aggregate); |
| |
| Disc := First_Discriminant (Etype (Unqual)); |
| |
| else |
| Disc := First_Discriminant |
| (Etype (Defining_Identifier (Obj_Decl))); |
| end if; |
| |
| -- Preserve the first discriminant for checking named associations |
| |
| First_Disc := Disc; |
| |
| -- Count the number of discriminants for processing an aggregate |
| -- which includes an others. |
| |
| Disc := First_Disc; |
| while Present (Disc) loop |
| Unseen_Disc_Count := Unseen_Disc_Count + 1; |
| |
| Next_Discriminant (Disc); |
| end loop; |
| |
| Seen_Discs := New_Elmt_List; |
| |
| -- Loop through each of the discriminants and check each expression |
| -- associated with an anonymous access discriminant. |
| |
| -- When named associations occur in the return aggregate then |
| -- discriminants can be in any order, so we need to ensure we do |
| -- not continue to loop when all discriminants have been seen. |
| |
| Disc := First_Disc; |
| while Present (Assoc) |
| and then (Present (Disc) or else Assoc_Present) |
| and then Unseen_Disc_Count > 0 |
| loop |
| -- Handle named associations by searching through the names of |
| -- the relevant discriminant components. |
| |
| if Nkind (Assoc) |
| in N_Component_Association | N_Discriminant_Association |
| then |
| Assoc_Expr := Expression (Assoc); |
| Assoc_Present := True; |
| |
| -- We currently don't handle box initialized discriminants, |
| -- however, since default initialized anonymous access |
| -- discriminants are a corner case, this is ok for now ??? |
| |
| if Nkind (Assoc) = N_Component_Association |
| and then Box_Present (Assoc) |
| then |
| Assoc_Present := False; |
| |
| if Nkind (First_Selector (Assoc)) = N_Others_Choice then |
| Unseen_Disc_Count := 0; |
| end if; |
| |
| -- When others is present we must identify a discriminant we |
| -- haven't already seen so as to get the appropriate type for |
| -- the static accessibility check. |
| |
| -- This works because all components within an others clause |
| -- must have the same type. |
| |
| elsif Nkind (First_Selector (Assoc)) = N_Others_Choice then |
| |
| Disc := First_Disc; |
| Outer : while Present (Disc) loop |
| declare |
| Current_Seen_Disc : Elmt_Id; |
| begin |
| -- Move through the list of identified discriminants |
| |
| Current_Seen_Disc := First_Elmt (Seen_Discs); |
| while Present (Current_Seen_Disc) loop |
| -- Exit the loop when we found a match |
| |
| exit when |
| Chars (Node (Current_Seen_Disc)) = Chars (Disc); |
| |
| Next_Elmt (Current_Seen_Disc); |
| end loop; |
| |
| -- When we have exited the above loop without finding |
| -- a match then we know that Disc has not been seen. |
| |
| exit Outer when No (Current_Seen_Disc); |
| end; |
| |
| Next_Discriminant (Disc); |
| end loop Outer; |
| |
| -- If we got to an others clause with a non-zero |
| -- discriminant count there must be a discriminant left to |
| -- check. |
| |
| pragma Assert (Present (Disc)); |
| |
| -- Set the unseen discriminant count to zero because we know |
| -- an others clause sets all remaining components of an |
| -- aggregate. |
| |
| Unseen_Disc_Count := 0; |
| |
| -- Move through each of the selectors in the named association |
| -- and obtain a discriminant for accessibility checking if one |
| -- is referenced in the list. Also track which discriminants |
| -- are referenced for the purpose of handling an others clause. |
| |
| else |
| declare |
| Assoc_Choice : Node_Id; |
| Curr_Disc : Node_Id; |
| begin |
| |
| Disc := Empty; |
| Curr_Disc := First_Disc; |
| while Present (Curr_Disc) loop |
| -- Check each of the choices in the associations for a |
| -- match to the name of the current discriminant. |
| |
| Assoc_Choice := First_Selector (Assoc); |
| while Present (Assoc_Choice) loop |
| -- When the name matches we track that we have seen |
| -- the discriminant, but instead of exiting the |
| -- loop we continue iterating to make sure all the |
| -- discriminants within the named association get |
| -- tracked. |
| |
| if Chars (Assoc_Choice) = Chars (Curr_Disc) then |
| Append_Elmt (Curr_Disc, Seen_Discs); |
| |
| Disc := Curr_Disc; |
| Unseen_Disc_Count := Unseen_Disc_Count - 1; |
| end if; |
| |
| Next (Assoc_Choice); |
| end loop; |
| |
| Next_Discriminant (Curr_Disc); |
| end loop; |
| end; |
| end if; |
| |
| -- Unwrap the associated expression if we are looking at a default |
| -- initialized type declaration. In this case Assoc is not really |
| -- an association, but a component declaration. Should Assoc be |
| -- renamed in some way to be more clear ??? |
| |
| -- This occurs when the return object does not initialize |
| -- discriminant and instead relies on the type declaration for |
| -- their supplied values. |
| |
| elsif Nkind (Assoc) in N_Entity |
| and then Ekind (Assoc) = E_Discriminant |
| then |
| Append_Elmt (Disc, Seen_Discs); |
| |
| Assoc_Expr := Discriminant_Default_Value (Assoc); |
| Unseen_Disc_Count := Unseen_Disc_Count - 1; |
| |
| -- Otherwise, there is nothing to do because Assoc is an |
| -- expression within the return aggregate itself. |
| |
| else |
| Append_Elmt (Disc, Seen_Discs); |
| |
| Assoc_Expr := Assoc; |
| Unseen_Disc_Count := Unseen_Disc_Count - 1; |
| end if; |
| |
| -- Check the accessibility level of the expression when the |
| -- discriminant is of an anonymous access type. |
| |
| if Present (Assoc_Expr) |
| and then Present (Disc) |
| and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type |
| then |
| -- Generate a dynamic check based on the extra accessibility of |
| -- the result or the scope. |
| |
| Check_Cond := |
| Make_Op_Gt (Loc, |
| Left_Opnd => Accessibility_Level |
| (Expr => Assoc_Expr, |
| Level => Dynamic_Level, |
| In_Return_Context => True), |
| Right_Opnd => (if Present |
| (Extra_Accessibility_Of_Result |
| (Scope_Id)) |
| then |
| Extra_Accessibility_Of_Result (Scope_Id) |
| else |
| Make_Integer_Literal |
| (Loc, Scope_Depth (Scope (Scope_Id))))); |
| |
| Insert_Before_And_Analyze (Return_Stmt, |
| Make_Raise_Program_Error (Loc, |
| Condition => Check_Cond, |
| Reason => PE_Accessibility_Check_Failed)); |
| |
| -- If constant folding has happened on the condition for the |
| -- generated error, then warn about it being unconditional when |
| -- we know an error will be raised. |
| |
| if Nkind (Check_Cond) = N_Identifier |
| and then Entity (Check_Cond) = Standard_True |
| then |
| Error_Msg_N |
| ("access discriminant in return object would be a dangling" |
| & " reference", Return_Stmt); |
| end if; |
| end if; |
| |
| -- Iterate over the discriminants, except when we have encountered |
| -- a named association since the discriminant order becomes |
| -- irrelevant in that case. |
| |
| if not Assoc_Present then |
| Next_Discriminant (Disc); |
| end if; |
| |
| -- Iterate over associations |
| |
| if not Is_List_Member (Assoc) then |
| exit; |
| else |
| Nlists.Next (Assoc); |
| end if; |
| end loop; |
| end Check_Return_Construct_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 (Expr) in 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 Nkind (Expr) not in 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); |
| |
| Check_Return_Construct_Accessibility (N); |
| |
| -- Ada 2022 (AI12-0269): Any return statement that applies to a |
| -- nonreturning function shall be a simple_return_statement with |
| -- an expression that is a raise_expression, or else a call on a |
| -- nonreturning function, or else a parenthesized expression of |
| -- one of these. |
| |
| if Ada_Version >= Ada_2022 |
| and then No_Return (Scope_Id) |
| and then Comes_From_Source (N) |
| then |
| Check_No_Return_Expression (Original_Node (Expr)); |
| end if; |
| end if; |
| else |
| 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)); |
| |
| -- Returning a build-in-place unconstrained array type we defer |
| -- the full analysis of the returned object to avoid generating |
| -- the corresponding constrained subtype; otherwise the bounds |
| -- would be created in the stack and a dangling reference would |
| -- be returned pointing to the bounds. We perform its preanalysis |
| -- to report errors on the initializing aggregate now (if any); |
| -- we also ensure its activation chain and Master variable are |
| -- defined (if tasks are being declared) since they are generated |
| -- as part of the analysis and expansion of the object declaration |
| -- at this stage. |
| |
| if Is_Array_Type (R_Type) |
| and then not Is_Constrained (R_Type) |
| and then Is_Build_In_Place_Function (Scope_Id) |
| and then Needs_BIP_Alloc_Form (Scope_Id) |
| and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate |
| then |
| Preanalyze (Obj_Decl); |
| |
| if Expander_Active then |
| Ensure_Activation_Chain_And_Master (Obj_Decl); |
| end if; |
| |
| else |
| Analyze (Obj_Decl); |
| end if; |
| |
| 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_Return_Construct_Accessibility (N); |
| |
| -- Check RM 6.5 (5.9/3) |
| |
| if Has_Aliased then |
| if Ada_Version < Ada_2012 |
| and then Warn_On_Ada_2012_Compatibility |
| then |
| Error_Msg_N |
| ("ALIASED only allowed for limited return objects " |
| & "in Ada 2012?y?", N); |
| |
| elsif not Is_Limited_View (R_Type) then |
| Error_Msg_N |
| ("ALIASED only allowed for limited return objects", N); |
| end if; |
| end if; |
| |
| -- Ada 2022 (AI12-0269): Any return statement that applies to a |
| -- nonreturning function shall be a simple_return_statement. |
| |
| if Ada_Version >= Ada_2022 |
| and then No_Return (Scope_Id) |
| and then Comes_From_Source (N) |
| then |
| Error_Msg_N |
| ("extended RETURN statement not allowed in No_Return " |
| & "function", N); |
| 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. We |
| -- don't need a check if the subtype of the return object is the |
| -- same as the result subtype of the function. |
| |
| if Nkind (N) /= N_Extended_Return_Statement |
| or else Nkind (Obj_Decl) /= N_Object_Declaration |
| or else Nkind (Object_Definition (Obj_Decl)) not in N_Has_Entity |
| or else Entity (Object_Definition (Obj_Decl)) /= R_Type |
| then |
| Apply_Constraint_Check (Expr, R_Type); |
| end if; |
| |
| -- 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 for an extended return statement because |
| -- Analyze_Object_Declaration has already done it on Obj_Decl above. |
| -- 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 (N) /= N_Extended_Return_Statement |
| and then 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. |
| -- But we want to apply the checks to an extended return statement |
| -- only once, i.e. not to the simple return statement generated at |
| -- the end of its expansion because, prior to leaving the function, |
| -- the accessibility level of the return object changes to be a level |
| -- determined by the point of call (RM 3.10.2(10.8/3)). |
| |
| if Ada_Version >= Ada_2005 |
| and then Ekind (R_Type) = E_Anonymous_Access_Type |
| and then (Nkind (N) = N_Extended_Return_Statement |
| or else not Comes_From_Extended_Return_Statement (N)) |
| 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; |
| |
| -- Perform static accessibility checks for cases involving |
| -- dereferences of access parameters. Runtime accessibility checks |
| -- get generated elsewhere. |
| |
| if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) |
| and then Is_Limited_View (Etype (Scope_Id)) |
| and then Static_Accessibility_Level (Expr, Zero_On_Dynamic_Level) |
| > 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_N ("\Program_Error [<<", N); |
| 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 |
| Mutate_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 |
| |
| Mutate_Ekind (Gen_Id, Ekind (Body_Id)); |
| Reinit_Field_To_Zero (Body_Id, F_Has_Out_Or_In_Out_Parameter, |
| Old_Ekind => |
| (E_Function | E_Procedure | |
| E_Generic_Function | E_Generic_Procedure => True, |
| others => False)); |
| Mutate_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 |
| |
| Mutate_Ekind (Gen_Id, Kind); |
| Mutate_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 |
| |
| Reinit_Field_To_Zero (Gen_Id, F_Has_Nested_Subprogram, |
| Old_Ekind => (E_Function | E_Procedure => True, others => False)); |
| Mutate_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); |
| Mutate_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, pragma arguments, and aspect specifications. |
| |
| procedure Analyze_Operator_Symbol (N : Node_Id) is |
| Par : constant Node_Id := Parent (N); |
| |
| Maybe_Aspect_Spec : Node_Id := Par; |
| begin |
| if Nkind (Maybe_Aspect_Spec) /= N_Aspect_Specification then |
| -- deal with N_Aggregate nodes |
| Maybe_Aspect_Spec := Parent (Maybe_Aspect_Spec); |
| end if; |
| |
| 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) |
| or else (Nkind (Maybe_Aspect_Spec) = N_Aspect_Specification |
| and then Get_Aspect_Id (Maybe_Aspect_Spec) |
| |
| -- Include aspects that can be specified by a |
| -- subprogram name, which can be an operator. |
| |
| in Aspect_Stable_Properties |
| | Aspect_Integer_Literal |
| | Aspect_Real_Literal |
| | Aspect_String_Literal |
| | Aspect_Aggregate) |
| 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 Attribute_Name (P) in 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); |
| |
| elsif Ekind (Entity (P)) = E_Operator then |
| Error_Msg_Name_1 := Chars (P); |
| Error_Msg_N ("operator % cannot be used as a procedure", 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 (Entity (Selector_Name (P))) |
| in 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); |
| |
| -- Specialize the error message in the case where both a primitive |
| -- operation and a record component are visible at the same time. |
| |
| if Nkind (P) = N_Selected_Component |
| and then Is_Entity_Name (Selector_Name (P)) |
| then |
| declare |
| Sel : constant Entity_Id := Entity (Selector_Name (P)); |
| begin |
| if Ekind (Sel) = E_Component |
| and then Present (Homonym (Sel)) |
| and then Ekind (Homonym (Sel)) = E_Procedure |
| then |
| Error_Msg_NE ("\component & conflicts with" |
| & " homonym procedure (RM 4.1.3 (9.2/3))", |
| Selector_Name (P), Sel); |
| end if; |
| end; |
| end if; |
| 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 (N) in 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, and loops |
| |
| for J in reverse 0 .. Scope_Stack.Last loop |
| Result := Scope_Stack.Table (J).Entity; |
| exit when Ekind (Result) not in E_Block | E_Loop; |
| 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 Kind in E_Procedure | E_Generic_Procedure |
| and then Comes_From_Source (N) |
| then |
| Error_Msg_N |
| ("RETURN statement not allowed in No_Return procedure", 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 in E_Function | E_Generic_Function then |
| if not Returns_Object then |
| Error_Msg_N ("missing expression in return from function", N); |
| end if; |
| |
| elsif Kind in E_Procedure | E_Generic_Procedure then |
| if Returns_Object then |
| Error_Msg_N ("procedure cannot return value (use function)", N); |
| end if; |
| |
| elsif Kind in E_Entry | 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 Kind in E_Function | E_Generic_Function then |
| Analyze_Function_Return (N); |
| |
| elsif Kind in 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_Return_When_Statement -- |
| ----------------------------------- |
| |
| procedure Analyze_Return_When_Statement (N : Node_Id) is |
| begin |
| -- Verify the condition is a Boolean expression |
| |
| Analyze_And_Resolve (Condition (N), Any_Boolean); |
| Check_Unset_Reference (Condition (N)); |
| end Analyze_Return_When_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 |
| |
| -- 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); |
| |
| -- 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 |
| declare |
| IR : constant Node_Id := Make_Itype_Reference (Sloc (N)); |
| begin |
| Set_Itype (IR, Etype (Designator)); |
| Append_Freeze_Action (Typ, 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 (Parent (Parent (N))) in |
| 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); |
| |
| Body_Nod : Node_Id := Empty; |
| Minimum_Acc_Objs : List_Id := No_List; |
| |
| 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. |
| |
| function Build_Internal_Protected_Declaration |
| (N : Node_Id) return Entity_Id; |
| -- A subprogram body without a previous spec that appears in a protected |
| -- body must be expanded separately to create a subprogram declaration |
| -- for it, in order to resolve internal calls to it from other protected |
| -- operations. |
| -- |
| -- Possibly factor this with Exp_Dist.Copy_Specification ??? |
| |
| 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. |
| |
| procedure Generate_Minimum_Accessibility |
| (Extra_Access : Entity_Id; |
| Related_Form : Entity_Id := Empty); |
| -- Generate a minimum accessibility object for a given extra |
| -- accessibility formal (Extra_Access) and its related formal if it |
| -- exists. |
| |
| 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 Move_Pragmas (From : Node_Id; To : Node_Id); |
| -- Find all suitable source pragmas at the top of subprogram body |
| -- From's declarations and move them after arbitrary node To. |
| -- One exception is pragma SPARK_Mode which is copied rather than moved, |
| -- as it applies to the body too. |
| |
| 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_Internal_Protected_Declaration -- |
| ------------------------------------------ |
| |
| function Build_Internal_Protected_Declaration |
| (N : Node_Id) return Entity_Id |
| is |
| procedure Analyze_Pragmas (From : Node_Id); |
| -- Analyze all pragmas which follow arbitrary node From |
| |
| --------------------- |
| -- Analyze_Pragmas -- |
| --------------------- |
| |
| procedure Analyze_Pragmas (From : Node_Id) is |
| Decl : Node_Id; |
| |
| begin |
| Decl := Next (From); |
| while Present (Decl) loop |
| if Nkind (Decl) = N_Pragma then |
| Analyze_Pragma (Decl); |
| |
| -- No candidate pragmas are available for analysis |
| |
| else |
| exit; |
| end if; |
| |
| Next (Decl); |
| end loop; |
| end Analyze_Pragmas; |
| |
| -- Local variables |
| |
| Body_Id : constant Entity_Id := Defining_Entity (N); |
| Loc : constant Source_Ptr := Sloc (N); |
| Decl : Node_Id; |
| Formal : Entity_Id; |
| Formals : List_Id; |
| Spec : Node_Id; |
| Spec_Id : Entity_Id; |
| |
| -- Start of processing for Build_Internal_Protected_Declaration |
| |
| begin |
| Formal := First_Formal (Body_Id); |
| |
| -- The protected operation always has at least one formal, namely the |
| -- object itself, but it is only placed in the parameter list if |
| -- expansion is enabled. |
| |
| if Present (Formal) or else Expander_Active then |
| Formals := Copy_Parameter_List (Body_Id); |
| else |
| Formals := No_List; |
| end if; |
| |
| Spec_Id := |
| Make_Defining_Identifier (Sloc (Body_Id), |
| Chars => Chars (Body_Id)); |
| |
| -- Indicate that the entity comes from source, to ensure that cross- |
| -- reference information is properly generated. The body itself is |
| -- rewritten during expansion, and the body entity will not appear in |
| -- calls to the operation. |
| |
| Set_Comes_From_Source (Spec_Id, True); |
| |
| if Nkind (Specification (N)) = N_Procedure_Specification then |
| Spec := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Spec_Id, |
| Parameter_Specifications => Formals); |
| else |
| Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Spec_Id, |
| Parameter_Specifications => Formals, |
| Result_Definition => |
| New_Occurrence_Of (Etype (Body_Id), Loc)); |
| end if; |
| |
| Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); |
| Set_Corresponding_Body (Decl, Body_Id); |
| Set_Corresponding_Spec (N, Spec_Id); |
| |
| Insert_Before (N, Decl); |
| |
| -- Associate all aspects and pragmas of the body with the spec. This |
| -- ensures that these annotations apply to the initial declaration of |
| -- the subprogram body. |
| |
| Move_Aspects (From => N, To => Decl); |
| Move_Pragmas (From => N, To => Decl); |
| |
| Analyze (Decl); |
| |
| -- The analysis of the spec may generate pragmas which require manual |
| -- analysis. Since the generation of the spec and the relocation of |
| -- the annotations is driven by the expansion of the stand-alone |
| -- body, the pragmas will not be analyzed in a timely manner. Do this |
| -- now. |
| |
| Analyze_Pragmas (Decl); |
| |
| -- This subprogram has convention Intrinsic as per RM 6.3.1(10/2) |
| -- ensuring in particular that 'Access is illegal. |
| |
| Set_Convention (Spec_Id, Convention_Intrinsic); |
| Set_Has_Completion (Spec_Id); |
| |
| return Spec_Id; |
| end Build_Internal_Protected_Declaration; |
| |
| ---------------------------------- |
| -- Build_Subprogram_Declaration -- |
| ---------------------------------- |
| |
| procedure Build_Subprogram_Declaration is |
| Decl : Node_Id; |
| Subp_Decl : Node_Id; |
| |
| 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 Transform_Function_Array |
| 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 |
| then |
| Decl := Build_Master_Declaration (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 (Par) |
| in 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) and then Is_List_Member (N) then |
| if Present (Spec_Id) then |
| if 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); |
| |
| if Nkind (N) = N_Subprogram_Body_Stub then |
| Set_Corresponding_Spec_Of_Stub (N, Subp); |
| else |
| Set_Corresponding_Spec (N, Subp); |
| end if; |
| |
| Set_Defining_Unit_Name (Specification (Decl), Subp); |
| |
| -- To ensure proper coverage when body is inlined, indicate |
| -- whether the subprogram comes from source. |
| |
| Preserve_Comes_From_Source (Subp, 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; |
| 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 Ekind (Subp_Id) not in 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; |
| |
| ------------------------------------ |
| -- Generate_Minimum_Accessibility -- |
| ------------------------------------ |
| |
| procedure Generate_Minimum_Accessibility |
| (Extra_Access : Entity_Id; |
| Related_Form : Entity_Id := Empty) |
| is |
| Loc : constant Source_Ptr := Sloc (Body_Nod); |
| Form : Entity_Id; |
| Obj_Node : Node_Id; |
| begin |
| -- When no related formal exists then we are dealing with an |
| -- extra accessibility formal for a function result. |
| |
| if No (Related_Form) then |
| Form := Extra_Access; |
| else |
| Form := Related_Form; |
| end if; |
| |
| -- Create the minimum accessibility object |
| |
| Obj_Node := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Temporary |
| (Loc, 'A', Extra_Access), |
| Object_Definition => New_Occurrence_Of |
| (Standard_Natural, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of |
| (Standard_Natural, Loc), |
| Attribute_Name => Name_Min, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, |
| Scope_Depth (Body_Id)), |
| New_Occurrence_Of |
| (Extra_Access, Loc)))); |
| |
| -- Add the new local object to the Minimum_Acc_Obj to |
| -- be later prepended to the subprogram's list of |
| -- declarations after we are sure all expansion is |
| -- done. |
| |
| if Present (Minimum_Acc_Objs) then |
| Prepend (Obj_Node, Minimum_Acc_Objs); |
| else |
| Minimum_Acc_Objs := New_List (Obj_Node); |
| end if; |
| |
| -- Register the object and analyze it |
| |
| Set_Minimum_Accessibility |
| (Form, Defining_Identifier (Obj_Node)); |
| |
| Analyze (Obj_Node); |
| end Generate_Minimum_Accessibility; |
| |
| ------------------------------------- |
| -- 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 as |
| -- formally frozen. |
| |
| -------------------- |
| -- Mask_Type_Refs -- |
| -------------------- |
| |
| function Mask_Type_Refs (Node : Node_Id) return Traverse_Result is |
| procedure Mask_Type (Typ : Entity_Id); |
| -- Mask a given type as formally frozen when outside the current |
| -- scope, or else freeze the type. |
| |
| --------------- |
| -- 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 (Entity (Node)) in E_Component | E_Discriminant then |
| Mask_Type (Scope (Entity (Node))); |
| end if; |
| |
| elsif Nkind (Node) in 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; |
| |
| ------------------ |
| -- Move_Pragmas -- |
| ------------------ |
| |
| procedure Move_Pragmas (From : Node_Id; To : Node_Id) is |
| Decl : Node_Id; |
| Insert_Nod : Node_Id; |
| Next_Decl : Node_Id; |
| |
| begin |
| pragma Assert (Nkind (From) = N_Subprogram_Body); |
| |
| -- The pragmas are moved in an order-preserving fashion |
| |
| Insert_Nod := To; |
| |
| -- Inspect the declarations of the subprogram body and relocate all |
| -- candidate pragmas. |
| |
| Decl := First (Declarations (From)); |
| while Present (Decl) loop |
| |
| -- Preserve the following declaration for iteration purposes, due |
| -- to possible relocation of a pragma. |
| |
| Next_Decl := Next (Decl); |
| |
| if Nkind (Decl) = N_Pragma then |
| -- 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. |
| |
| if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then |
| Insert_After (Insert_Nod, New_Copy_Tree (Decl)); |
| |
| -- Move relevant pragmas to the spec |
| |
| elsif Pragma_Name_Unmapped (Decl) in Name_Depends |
| | Name_Ghost |
| | Name_Global |
| | Name_Pre |
| | Name_Precondition |
| | Name_Post |
| | Name_Refined_Depends |
| | Name_Refined_Global |
| | Name_Refined_Post |
| | Name_Inline |
| | Name_Pure_Function |
| | Name_Volatile_Function |
| then |
| Remove (Decl); |
| Insert_After (Insert_Nod, Decl); |
| Insert_Nod := Decl; |
| end if; |
| |
| -- Skip internally generated code |
| |
| elsif not Comes_From_Source (Decl) then |
| null; |
| |
| -- No candidate pragmas are available for relocation |
| |
| else |
| exit; |
| end if; |
| |
| Decl := Next_Decl; |
| end loop; |
| end Move_Pragmas; |
| |
| --------------------------- |
| -- 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; |
| |
| -- Overridden controlled primitives may have had their |
| -- Overridden_Operation field cleared according to the setting of |
| -- the Is_Hidden flag. An issue arises, however, when analyzing |
| -- an instance that may have manipulated the flag during |
| -- expansion. As a result, we add an exception for this case. |
| |
| elsif not Present (Overridden_Operation (Spec_Id)) |
| and then not (Chars (Spec_Id) in Name_Adjust |
| | Name_Finalize |
| | Name_Initialize |
| and then In_Instance) |
| 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); |
|