1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Contracts; use Contracts;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Elists; use Elists;
33 with Errout; use Errout;
34 with Expander; use Expander;
35 with Exp_Ch3; use Exp_Ch3;
36 with Exp_Ch6; use Exp_Ch6;
37 with Exp_Ch7; use Exp_Ch7;
38 with Exp_Ch9; use Exp_Ch9;
39 with Exp_Dbug; use Exp_Dbug;
40 with Exp_Tss; use Exp_Tss;
41 with Exp_Util; use Exp_Util;
42 with Freeze; use Freeze;
43 with Ghost; use Ghost;
44 with Inline; use Inline;
45 with Itypes; use Itypes;
46 with Lib.Xref; use Lib.Xref;
47 with Layout; use Layout;
48 with Namet; use Namet;
50 with Nlists; use Nlists;
51 with Nmake; use Nmake;
53 with Output; use Output;
54 with Restrict; use Restrict;
55 with Rtsfind; use Rtsfind;
57 with Sem_Aux; use Sem_Aux;
58 with Sem_Cat; use Sem_Cat;
59 with Sem_Ch3; use Sem_Ch3;
60 with Sem_Ch4; use Sem_Ch4;
61 with Sem_Ch5; use Sem_Ch5;
62 with Sem_Ch8; use Sem_Ch8;
63 with Sem_Ch9; use Sem_Ch9;
64 with Sem_Ch10; use Sem_Ch10;
65 with Sem_Ch12; use Sem_Ch12;
66 with Sem_Ch13; use Sem_Ch13;
67 with Sem_Dim; use Sem_Dim;
68 with Sem_Disp; use Sem_Disp;
69 with Sem_Dist; use Sem_Dist;
70 with Sem_Elim; use Sem_Elim;
71 with Sem_Eval; use Sem_Eval;
72 with Sem_Mech; use Sem_Mech;
73 with Sem_Prag; use Sem_Prag;
74 with Sem_Res; use Sem_Res;
75 with Sem_Util; use Sem_Util;
76 with Sem_Type; use Sem_Type;
77 with Sem_Warn; use Sem_Warn;
78 with Sinput; use Sinput;
79 with Stand; use Stand;
80 with Sinfo; use Sinfo;
81 with Sinfo.CN; use Sinfo.CN;
82 with Snames; use Snames;
83 with Stringt; use Stringt;
85 with Stylesw; use Stylesw;
86 with Tbuild; use Tbuild;
87 with Uintp; use Uintp;
88 with Urealp; use Urealp;
89 with Validsw; use Validsw;
91 package body Sem_Ch6 is
93 May_Hide_Profile : Boolean := False;
94 -- This flag is used to indicate that two formals in two subprograms being
95 -- checked for conformance differ only in that one is an access parameter
96 -- while the other is of a general access type with the same designated
97 -- type. In this case, if the rest of the signatures match, a call to
98 -- either subprogram may be ambiguous, which is worth a warning. The flag
99 -- is set in Compatible_Types, and the warning emitted in
100 -- New_Overloaded_Entity.
102 -----------------------
103 -- Local Subprograms --
104 -----------------------
106 procedure Analyze_Function_Return (N : Node_Id);
107 -- Subsidiary to Analyze_Return_Statement. Called when the return statement
108 -- applies to a [generic] function.
110 procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
111 -- Analyze a generic subprogram body. N is the body to be analyzed, and
112 -- Gen_Id is the defining entity Id for the corresponding spec.
114 procedure Analyze_Null_Procedure
116 Is_Completion : out Boolean);
117 -- A null procedure can be a declaration or (Ada 2012) a completion
119 procedure Analyze_Return_Statement (N : Node_Id);
120 -- Common processing for simple and extended return statements
122 procedure Analyze_Return_Type (N : Node_Id);
123 -- Subsidiary to Process_Formals: analyze subtype mark in function
124 -- specification in a context where the formals are visible and hide
127 procedure Analyze_Subprogram_Body_Helper (N : Node_Id);
128 -- Does all the real work of Analyze_Subprogram_Body. This is split out so
129 -- that we can use RETURN but not skip the debug output at the end.
131 function Can_Override_Operator (Subp : Entity_Id) return Boolean;
132 -- Returns true if Subp can override a predefined operator.
134 procedure Check_Conformance
137 Ctype : Conformance_Type;
139 Conforms : out Boolean;
140 Err_Loc : Node_Id := Empty;
141 Get_Inst : Boolean := False;
142 Skip_Controlling_Formals : Boolean := False);
143 -- Given two entities, this procedure checks that the profiles associated
144 -- with these entities meet the conformance criterion given by the third
145 -- parameter. If they conform, Conforms is set True and control returns
146 -- to the caller. If they do not conform, Conforms is set to False, and
147 -- in addition, if Errmsg is True on the call, proper messages are output
148 -- to complain about the conformance failure. If Err_Loc is non_Empty
149 -- the error messages are placed on Err_Loc, if Err_Loc is empty, then
150 -- error messages are placed on the appropriate part of the construct
151 -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance
152 -- against a formal access-to-subprogram type so Get_Instance_Of must
155 procedure Check_Formal_Subprogram_Conformance
160 Conforms : out Boolean);
161 -- Core implementation of Check_Formal_Subprogram_Conformance from spec.
162 -- Errmsg can be set to False to not emit error messages.
163 -- Conforms is set to True if there is conformance, False otherwise.
165 procedure Check_Limited_Return
169 -- Check the appropriate (Ada 95 or Ada 2005) rules for returning limited
170 -- types. Used only for simple return statements. Expr is the expression
173 procedure Check_Subprogram_Order (N : Node_Id);
174 -- N is the N_Subprogram_Body node for a subprogram. This routine applies
175 -- the alpha ordering rule for N if this ordering requirement applicable.
177 procedure Check_Returns
181 Proc : Entity_Id := Empty);
182 -- Called to check for missing return statements in a function body, or for
183 -- returns present in a procedure body which has No_Return set. HSS is the
184 -- handled statement sequence for the subprogram body. This procedure
185 -- checks all flow paths to make sure they either have return (Mode = 'F',
186 -- used for functions) or do not have a return (Mode = 'P', used for
187 -- No_Return procedures). The flag Err is set if there are any control
188 -- paths not explicitly terminated by a return in the function case, and is
189 -- True otherwise. Proc is the entity for the procedure case and is used
190 -- in posting the warning message.
192 procedure Check_Untagged_Equality (Eq_Op : Entity_Id);
193 -- In Ada 2012, a primitive equality operator on an untagged record type
194 -- must appear before the type is frozen, and have the same visibility as
195 -- that of the type. This procedure checks that this rule is met, and
196 -- otherwise emits an error on the subprogram declaration and a warning
197 -- on the earlier freeze point if it is easy to locate. In Ada 2012 mode,
198 -- this routine outputs errors (or warnings if -gnatd.E is set). In earlier
199 -- versions of Ada, warnings are output if Warn_On_Ada_2012_Incompatibility
200 -- is set, otherwise the call has no effect.
202 procedure Enter_Overloaded_Entity (S : Entity_Id);
203 -- This procedure makes S, a new overloaded entity, into the first visible
204 -- entity with that name.
206 function Is_Non_Overriding_Operation
208 New_E : Entity_Id) return Boolean;
209 -- Enforce the rule given in 12.3(18): a private operation in an instance
210 -- overrides an inherited operation only if the corresponding operation
211 -- was overriding in the generic. This needs to be checked for primitive
212 -- operations of types derived (in the generic unit) from formal private
213 -- or formal derived types.
215 procedure Make_Inequality_Operator (S : Entity_Id);
216 -- Create the declaration for an inequality operator that is implicitly
217 -- created by a user-defined equality operator that yields a boolean.
219 procedure Preanalyze_Formal_Expression (N : Node_Id; T : Entity_Id);
220 -- Preanalysis of default expressions of subprogram formals. N is the
221 -- expression to be analyzed and T is the expected type.
223 procedure Set_Formal_Validity (Formal_Id : Entity_Id);
224 -- Formal_Id is an formal parameter entity. This procedure deals with
225 -- setting the proper validity status for this entity, which depends on
226 -- the kind of parameter and the validity checking mode.
228 ---------------------------------------------
229 -- Analyze_Abstract_Subprogram_Declaration --
230 ---------------------------------------------
232 procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
233 Scop : constant Entity_Id := Current_Scope;
234 Subp_Id : constant Entity_Id :=
235 Analyze_Subprogram_Specification (Specification (N));
238 Generate_Definition (Subp_Id);
240 -- Set the SPARK mode from the current context (may be overwritten later
241 -- with explicit pragma).
243 Set_SPARK_Pragma (Subp_Id, SPARK_Mode_Pragma);
244 Set_SPARK_Pragma_Inherited (Subp_Id);
246 -- Preserve relevant elaboration-related attributes of the context which
247 -- are no longer available or very expensive to recompute once analysis,
248 -- resolution, and expansion are over.
250 Mark_Elaboration_Attributes
255 Set_Is_Abstract_Subprogram (Subp_Id);
256 New_Overloaded_Entity (Subp_Id);
257 Check_Delayed_Subprogram (Subp_Id);
259 Set_Categorization_From_Scope (Subp_Id, Scop);
261 if Ekind (Scope (Subp_Id)) = E_Protected_Type then
262 Error_Msg_N ("abstract subprogram not allowed in protected type", N);
264 -- Issue a warning if the abstract subprogram is neither a dispatching
265 -- operation nor an operation that overrides an inherited subprogram or
266 -- predefined operator, since this most likely indicates a mistake.
268 elsif Warn_On_Redundant_Constructs
269 and then not Is_Dispatching_Operation (Subp_Id)
270 and then not Present (Overridden_Operation (Subp_Id))
271 and then (not Is_Operator_Symbol_Name (Chars (Subp_Id))
272 or else Scop /= Scope (Etype (First_Formal (Subp_Id))))
275 ("abstract subprogram is not dispatching or overriding?r?", N);
278 Generate_Reference_To_Formals (Subp_Id);
279 Check_Eliminated (Subp_Id);
281 if Has_Aspects (N) then
282 Analyze_Aspect_Specifications (N, Subp_Id);
284 end Analyze_Abstract_Subprogram_Declaration;
286 ---------------------------------
287 -- Analyze_Expression_Function --
288 ---------------------------------
290 procedure Analyze_Expression_Function (N : Node_Id) is
291 Expr : constant Node_Id := Expression (N);
292 Loc : constant Source_Ptr := Sloc (N);
293 LocX : constant Source_Ptr := Sloc (Expr);
294 Spec : constant Node_Id := Specification (N);
304 Def_Id : Entity_Id := Empty;
306 -- If the expression is a completion, Prev is the entity whose
307 -- declaration is completed. Def_Id is needed to analyze the spec.
310 -- This is one of the occasions on which we transform the tree during
311 -- semantic analysis. If this is a completion, transform the expression
312 -- function into an equivalent subprogram body, and analyze it.
314 -- Expression functions are inlined unconditionally. The back-end will
315 -- determine whether this is possible.
317 Inline_Processing_Required := True;
319 -- Create a specification for the generated body. This must be done
320 -- prior to the analysis of the initial declaration.
322 New_Spec := Copy_Subprogram_Spec (Spec);
323 Prev := Current_Entity_In_Scope (Defining_Entity (Spec));
325 -- If there are previous overloadable entities with the same name,
326 -- check whether any of them is completed by the expression function.
327 -- In a generic context a formal subprogram has no completion.
330 and then Is_Overloadable (Prev)
331 and then not Is_Formal_Subprogram (Prev)
333 Def_Id := Analyze_Subprogram_Specification (Spec);
334 Prev := Find_Corresponding_Spec (N);
336 -- The previous entity may be an expression function as well, in
337 -- which case the redeclaration is illegal.
340 and then Nkind (Original_Node (Unit_Declaration_Node (Prev))) =
341 N_Expression_Function
343 Error_Msg_Sloc := Sloc (Prev);
344 Error_Msg_N ("& conflicts with declaration#", Def_Id);
349 Ret := Make_Simple_Return_Statement (LocX, Expr);
352 Make_Subprogram_Body (Loc,
353 Specification => New_Spec,
354 Declarations => Empty_List,
355 Handled_Statement_Sequence =>
356 Make_Handled_Sequence_Of_Statements (LocX,
357 Statements => New_List (Ret)));
358 Set_Was_Expression_Function (New_Body);
360 -- If the expression completes a generic subprogram, we must create a
361 -- separate node for the body, because at instantiation the original
362 -- node of the generic copy must be a generic subprogram body, and
363 -- cannot be a expression function. Otherwise we just rewrite the
364 -- expression with the non-generic body.
366 if Present (Prev) and then Ekind (Prev) = E_Generic_Function then
367 Insert_After (N, New_Body);
369 -- Propagate any aspects or pragmas that apply to the expression
370 -- function to the proper body when the expression function acts
373 if Has_Aspects (N) then
374 Move_Aspects (N, To => New_Body);
377 Relocate_Pragmas_To_Body (New_Body);
379 Rewrite (N, Make_Null_Statement (Loc));
380 Set_Has_Completion (Prev, False);
383 Set_Is_Inlined (Prev);
385 -- If the expression function is a completion, the previous declaration
386 -- must come from source. We know already that it appears in the current
387 -- scope. The entity itself may be internally created if within a body
391 and then Is_Overloadable (Prev)
392 and then not Is_Formal_Subprogram (Prev)
393 and then Comes_From_Source (Parent (Prev))
395 Set_Has_Completion (Prev, False);
396 Set_Is_Inlined (Prev);
398 -- AI12-0103: Expression functions that are a completion freeze their
399 -- expression but don't freeze anything else (unlike regular bodies).
401 -- Note that we cannot defer this freezing to the analysis of the
402 -- expression itself, because a freeze node might appear in a nested
403 -- scope, leading to an elaboration order issue in gigi.
404 -- As elsewhere, we do not emit freeze nodes within a generic unit.
406 if not Inside_A_Generic then
409 Typ => Etype (Def_Id),
414 -- For navigation purposes, indicate that the function is a body
416 Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True);
417 Rewrite (N, New_Body);
419 -- Remove any existing aspects from the original node because the act
420 -- of rewriting causes the list to be shared between the two nodes.
422 Orig_N := Original_Node (N);
423 Remove_Aspects (Orig_N);
425 -- Propagate any pragmas that apply to expression function to the
426 -- proper body when the expression function acts as a completion.
427 -- Aspects are automatically transfered because of node rewriting.
429 Relocate_Pragmas_To_Body (N);
432 -- Prev is the previous entity with the same name, but it is can
433 -- be an unrelated spec that is not completed by the expression
434 -- function. In that case the relevant entity is the one in the body.
435 -- Not clear that the backend can inline it in this case ???
437 if Has_Completion (Prev) then
439 -- The formals of the expression function are body formals,
440 -- and do not appear in the ali file, which will only contain
441 -- references to the formals of the original subprogram spec.
448 F1 := First_Formal (Def_Id);
449 F2 := First_Formal (Prev);
451 while Present (F1) loop
452 Set_Spec_Entity (F1, F2);
459 Set_Is_Inlined (Defining_Entity (New_Body));
462 -- If this is not a completion, create both a declaration and a body, so
463 -- that the expression can be inlined whenever possible.
466 -- An expression function that is not a completion is not a
467 -- subprogram declaration, and thus cannot appear in a protected
470 if Nkind (Parent (N)) = N_Protected_Definition then
472 ("an expression function is not a legal protected operation", N);
475 Rewrite (N, Make_Subprogram_Declaration (Loc, Specification => Spec));
477 -- Remove any existing aspects from the original node because the act
478 -- of rewriting causes the list to be shared between the two nodes.
480 Orig_N := Original_Node (N);
481 Remove_Aspects (Orig_N);
485 -- If aspect SPARK_Mode was specified on the body, it needs to be
486 -- repeated both on the generated spec and the body.
488 Asp := Find_Aspect (Defining_Unit_Name (Spec), Aspect_SPARK_Mode);
490 if Present (Asp) then
491 Asp := New_Copy_Tree (Asp);
492 Set_Analyzed (Asp, False);
493 Set_Aspect_Specifications (New_Body, New_List (Asp));
496 Def_Id := Defining_Entity (N);
497 Set_Is_Inlined (Def_Id);
499 -- Establish the linkages between the spec and the body. These are
500 -- used when the expression function acts as the prefix of attribute
501 -- 'Access in order to freeze the original expression which has been
502 -- moved to the generated body.
504 Set_Corresponding_Body (N, Defining_Entity (New_Body));
505 Set_Corresponding_Spec (New_Body, Def_Id);
507 -- Within a generic preanalyze the original expression for name
508 -- capture. The body is also generated but plays no role in
509 -- this because it is not part of the original source.
510 -- If this is an ignored Ghost entity, analysis of the generated
511 -- body is needed to hide external references (as is done in
512 -- Analyze_Subprogram_Body) after which the the subprogram profile
513 -- can be frozen, which is needed to expand calls to such an ignored
516 if Inside_A_Generic then
517 Set_Has_Completion (Def_Id, not Is_Ignored_Ghost_Entity (Def_Id));
519 Install_Formals (Def_Id);
520 Preanalyze_Spec_Expression (Expr, Etype (Def_Id));
524 -- To prevent premature freeze action, insert the new body at the end
525 -- of the current declarations, or at the end of the package spec.
526 -- However, resolve usage names now, to prevent spurious visibility
527 -- on later entities. Note that the function can now be called in
528 -- the current declarative part, which will appear to be prior to
529 -- the presence of the body in the code. There are nevertheless no
530 -- order of elaboration issues because all name resolution has taken
531 -- place at the point of declaration.
534 Decls : List_Id := List_Containing (N);
535 Expr : constant Node_Id := Expression (Ret);
536 Par : constant Node_Id := Parent (Decls);
537 Typ : constant Entity_Id := Etype (Def_Id);
540 -- If this is a wrapper created for in an instance for a formal
541 -- subprogram, insert body after declaration, to be analyzed when
542 -- the enclosing instance is analyzed.
545 and then Is_Generic_Actual_Subprogram (Def_Id)
547 Insert_After (N, New_Body);
550 if Nkind (Par) = N_Package_Specification
551 and then Decls = Visible_Declarations (Par)
552 and then Present (Private_Declarations (Par))
553 and then not Is_Empty_List (Private_Declarations (Par))
555 Decls := Private_Declarations (Par);
558 Insert_After (Last (Decls), New_Body);
560 -- Preanalyze the expression if not already done above
562 if not Inside_A_Generic then
564 Install_Formals (Def_Id);
565 Preanalyze_Formal_Expression (Expr, Typ);
566 Check_Limited_Return (Original_Node (N), Expr, Typ);
570 -- In the case of an expression function marked with the
571 -- aspect Static, we need to check the requirement that the
572 -- function's expression is a potentially static expression.
573 -- This is done by making a full copy of the expression tree
574 -- and performing a special preanalysis on that tree with
575 -- the global flag Checking_Potentially_Static_Expression
576 -- enabled. If the resulting expression is static, then it's
577 -- OK, but if not, that means the expression violates the
578 -- requirements of the Ada 202x RM in 4.9(3.2/5-3.4/5) and
581 if Is_Static_Function (Def_Id) then
582 if not Is_Static_Expression (Expr) then
584 Exp_Copy : constant Node_Id := New_Copy_Tree (Expr);
586 Set_Checking_Potentially_Static_Expression (True);
588 Preanalyze_Formal_Expression (Exp_Copy, Typ);
590 if not Is_Static_Expression (Exp_Copy) then
592 ("static expression function requires "
593 & "potentially static expression", Expr);
596 Set_Checking_Potentially_Static_Expression (False);
600 -- We also make an additional copy of the expression and
601 -- replace the expression of the expression function with
602 -- this copy, because the currently present expression is
603 -- now associated with the body created for the static
604 -- expression function, which will later be analyzed and
605 -- possibly rewritten, and we need to have the separate
606 -- unanalyzed copy available for use with later static
610 (Original_Node (Subprogram_Spec (Def_Id)),
611 New_Copy_Tree (Expr));
617 -- Check incorrect use of dynamically tagged expression. This doesn't
618 -- fall out automatically when analyzing the generated function body,
619 -- because Check_Dynamically_Tagged_Expression deliberately ignores
620 -- nodes that don't come from source.
623 and then Nkind (Def_Id) in N_Has_Etype
624 and then Is_Tagged_Type (Etype (Def_Id))
626 Check_Dynamically_Tagged_Expression
628 Typ => Etype (Def_Id),
629 Related_Nod => Original_Node (N));
632 -- We must enforce checks for unreferenced formals in our newly
633 -- generated function, so we propagate the referenced flag from the
634 -- original spec to the new spec as well as setting Comes_From_Source.
636 if Present (Parameter_Specifications (New_Spec)) then
638 Form_New_Def : Entity_Id;
639 Form_New_Spec : Entity_Id;
640 Form_Old_Def : Entity_Id;
641 Form_Old_Spec : Entity_Id;
644 Form_New_Spec := First (Parameter_Specifications (New_Spec));
645 Form_Old_Spec := First (Parameter_Specifications (Spec));
647 while Present (Form_New_Spec) and then Present (Form_Old_Spec) loop
648 Form_New_Def := Defining_Identifier (Form_New_Spec);
649 Form_Old_Def := Defining_Identifier (Form_Old_Spec);
651 Set_Comes_From_Source (Form_New_Def, True);
653 -- Because of the usefulness of unreferenced controlling
654 -- formals we exempt them from unreferenced warnings by marking
655 -- them as always referenced.
657 Set_Referenced (Form_Old_Def,
658 (Is_Formal (Form_Old_Def)
659 and then Is_Controlling_Formal (Form_Old_Def))
660 or else Referenced (Form_Old_Def));
662 Next (Form_New_Spec);
663 Next (Form_Old_Spec);
667 end Analyze_Expression_Function;
669 ----------------------------------------
670 -- Analyze_Extended_Return_Statement --
671 ----------------------------------------
673 procedure Analyze_Extended_Return_Statement (N : Node_Id) is
675 Check_Compiler_Unit ("extended return statement", N);
676 Analyze_Return_Statement (N);
677 end Analyze_Extended_Return_Statement;
679 ----------------------------
680 -- Analyze_Function_Call --
681 ----------------------------
683 procedure Analyze_Function_Call (N : Node_Id) is
684 Actuals : constant List_Id := Parameter_Associations (N);
685 Func_Nam : constant Node_Id := Name (N);
691 -- A call of the form A.B (X) may be an Ada 2005 call, which is
692 -- rewritten as B (A, X). If the rewriting is successful, the call
693 -- has been analyzed and we just return.
695 if Nkind (Func_Nam) = N_Selected_Component
696 and then Name (N) /= Func_Nam
697 and then Is_Rewrite_Substitution (N)
698 and then Present (Etype (N))
703 -- If error analyzing name, then set Any_Type as result type and return
705 if Etype (Func_Nam) = Any_Type then
706 Set_Etype (N, Any_Type);
710 -- Otherwise analyze the parameters
712 if Present (Actuals) then
713 Actual := First (Actuals);
714 while Present (Actual) loop
716 Check_Parameterless_Call (Actual);
722 end Analyze_Function_Call;
724 -----------------------------
725 -- Analyze_Function_Return --
726 -----------------------------
728 procedure Analyze_Function_Return (N : Node_Id) is
729 Loc : constant Source_Ptr := Sloc (N);
730 Stm_Entity : constant Entity_Id := Return_Statement_Entity (N);
731 Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity);
733 R_Type : constant Entity_Id := Etype (Scope_Id);
734 -- Function result subtype
736 procedure Check_No_Return_Expression (Return_Expr : Node_Id);
737 -- Ada 2020: Check that the return expression in a No_Return function
738 -- meets the conditions specified by RM 6.5.1(5.1/5).
740 procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id);
741 -- Apply legality rule of 6.5 (5.9) to the access discriminants of an
742 -- aggregate in a return statement.
744 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
745 -- Check that the return_subtype_indication properly matches the result
746 -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
748 --------------------------------
749 -- Check_No_Return_Expression --
750 --------------------------------
752 procedure Check_No_Return_Expression (Return_Expr : Node_Id) is
753 Kind : constant Node_Kind := Nkind (Return_Expr);
756 if Kind = N_Raise_Expression then
759 elsif Kind = N_Function_Call
760 and then Is_Entity_Name (Name (Return_Expr))
761 and then Ekind (Entity (Name (Return_Expr))) in
762 E_Function | E_Generic_Function
763 and then No_Return (Entity (Name (Return_Expr)))
769 ("illegal expression in RETURN statement of No_Return function",
772 ("\must be raise expression or call to No_Return (RM 6.5.1(5.1/5))",
774 end Check_No_Return_Expression;
776 ------------------------------------------
777 -- Check_Return_Construct_Accessibility --
778 ------------------------------------------
780 procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is
782 Agg : Node_Id := Empty;
786 Process_Exprs : Boolean := False;
787 Return_Con : Node_Id;
790 -- Only perform checks on record types with access discriminants and
791 -- non-internally generated functions.
793 if not Is_Record_Type (R_Type)
794 or else not Has_Discriminants (R_Type)
795 or else not Comes_From_Source (Return_Stmt)
800 -- We are only interested in return statements
802 if Nkind (Return_Stmt) not in
803 N_Extended_Return_Statement | N_Simple_Return_Statement
808 -- Fetch the object from the return statement, in the case of a
809 -- simple return statement the expression is part of the node.
811 if Nkind (Return_Stmt) = N_Extended_Return_Statement then
812 -- Obtain the object definition from the expanded extended return
814 Return_Con := First (Return_Object_Declarations (Return_Stmt));
815 while Present (Return_Con) loop
816 -- Inspect the original node to avoid object declarations
817 -- expanded into renamings.
819 if Nkind (Original_Node (Return_Con)) = N_Object_Declaration
820 and then Comes_From_Source (Original_Node (Return_Con))
825 Nlists.Next (Return_Con);
828 pragma Assert (Present (Return_Con));
830 -- Could be dealing with a renaming
832 Return_Con := Original_Node (Return_Con);
834 Return_Con := Return_Stmt;
837 -- We may need to check an aggregate or a subtype indication
838 -- depending on how the discriminants were specified and whether
839 -- we are looking at an extended return statement.
841 if Nkind (Return_Con) = N_Object_Declaration
842 and then Nkind (Object_Definition (Return_Con))
843 = N_Subtype_Indication
845 Assoc := Original_Node
848 (Constraint (Object_Definition (Return_Con)))));
850 -- Qualified expressions may be nested
852 Agg := Original_Node (Expression (Return_Con));
853 while Nkind (Agg) = N_Qualified_Expression loop
854 Agg := Original_Node (Expression (Agg));
857 -- If we are looking at an aggregate instead of a function call we
858 -- can continue checking accessibility for the supplied
859 -- discriminant associations.
861 if Nkind (Agg) = N_Aggregate then
862 if Present (Expressions (Agg)) then
863 Assoc := First (Expressions (Agg));
864 Process_Exprs := True;
866 Assoc := First (Component_Associations (Agg));
869 -- Otherwise the expression is not of interest ???
876 -- Move through the discriminants checking the accessibility level
877 -- of each co-extension's associated expression.
879 Discr := First_Discriminant (R_Type);
880 while Present (Discr) loop
881 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
883 if Nkind (Assoc) = N_Attribute_Reference then
885 elsif Nkind (Assoc) in
886 N_Component_Association | N_Discriminant_Association
888 Expr := Expression (Assoc);
893 -- This anonymous access discriminant has an associated
894 -- expression which needs checking.
897 and then Nkind (Expr) = N_Attribute_Reference
898 and then Attribute_Name (Expr) /= Name_Unrestricted_Access
900 -- Obtain the object to perform static checks on by moving
901 -- up the prefixes in the expression taking into account
902 -- named access types and renamed objects within the
905 -- Note, this loop duplicates some of the logic in
906 -- Object_Access_Level since we have to check special rules
907 -- based on the context we are in (a return aggregate)
908 -- relating to formals of the current function.
910 Obj := Original_Node (Prefix (Expr));
912 while Nkind (Obj) in N_Explicit_Dereference
913 | N_Indexed_Component
914 | N_Selected_Component
916 -- When we encounter a named access type then we can
917 -- ignore accessibility checks on the dereference.
919 if Ekind (Etype (Original_Node (Prefix (Obj))))
921 E_Access_Protected_Subprogram_Type
923 if Nkind (Obj) = N_Selected_Component then
924 Obj := Selector_Name (Obj);
926 Obj := Original_Node (Prefix (Obj));
931 Obj := Original_Node (Prefix (Obj));
934 if Nkind (Obj) = N_Selected_Component then
935 Obj := Selector_Name (Obj);
938 -- Check for renamings
940 pragma Assert (Is_Entity_Name (Obj));
942 if Present (Renamed_Object (Entity (Obj))) then
943 Obj := Renamed_Object (Entity (Obj));
949 -- Do not check aliased formals statically
951 if Is_Formal (Entity (Obj))
952 and then (Is_Aliased (Entity (Obj))
953 or else Ekind (Etype (Entity (Obj))) =
954 E_Anonymous_Access_Type)
958 -- Otherwise, handle the expression normally, avoiding the
959 -- special logic above, and call Object_Access_Level with
960 -- the original expression.
962 elsif Object_Access_Level (Expr) >
963 Scope_Depth (Scope (Scope_Id))
966 ("access discriminant in return aggregate would "
967 & "be a dangling reference", Obj);
972 Next_Discriminant (Discr);
974 if not Is_List_Member (Assoc) then
980 -- After aggregate expressions, examine component associations if
985 and then Process_Exprs
986 and then Present (Component_Associations (Agg))
988 Assoc := First (Component_Associations (Agg));
989 Process_Exprs := False;
995 end Check_Return_Construct_Accessibility;
997 -------------------------------------
998 -- Check_Return_Subtype_Indication --
999 -------------------------------------
1001 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is
1002 Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl);
1004 R_Stm_Type : constant Entity_Id := Etype (Return_Obj);
1005 -- Subtype given in the extended return statement (must match R_Type)
1007 Subtype_Ind : constant Node_Id :=
1008 Object_Definition (Original_Node (Obj_Decl));
1010 procedure Error_No_Match (N : Node_Id);
1011 -- Output error messages for case where types do not statically
1012 -- match. N is the location for the messages.
1014 --------------------
1015 -- Error_No_Match --
1016 --------------------
1018 procedure Error_No_Match (N : Node_Id) is
1021 ("subtype must statically match function result subtype", N);
1023 if not Predicates_Match (R_Stm_Type, R_Type) then
1024 Error_Msg_Node_2 := R_Type;
1026 ("\predicate of& does not match predicate of&",
1031 -- Start of processing for Check_Return_Subtype_Indication
1034 -- First, avoid cascaded errors
1036 if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then
1040 -- "return access T" case; check that the return statement also has
1041 -- "access T", and that the subtypes statically match:
1042 -- if this is an access to subprogram the signatures must match.
1044 if Is_Anonymous_Access_Type (R_Type) then
1045 if Is_Anonymous_Access_Type (R_Stm_Type) then
1046 if Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
1048 if Base_Type (Designated_Type (R_Stm_Type)) /=
1049 Base_Type (Designated_Type (R_Type))
1050 or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
1052 Error_No_Match (Subtype_Mark (Subtype_Ind));
1056 -- For two anonymous access to subprogram types, the types
1057 -- themselves must be type conformant.
1059 if not Conforming_Types
1060 (R_Stm_Type, R_Type, Fully_Conformant)
1062 Error_No_Match (Subtype_Ind);
1067 Error_Msg_N ("must use anonymous access type", Subtype_Ind);
1070 -- If the return object is of an anonymous access type, then report
1071 -- an error if the function's result type is not also anonymous.
1073 elsif Is_Anonymous_Access_Type (R_Stm_Type) then
1074 pragma Assert (not Is_Anonymous_Access_Type (R_Type));
1076 ("anonymous access not allowed for function with named access "
1077 & "result", Subtype_Ind);
1079 -- Subtype indication case: check that the return object's type is
1080 -- covered by the result type, and that the subtypes statically match
1081 -- when the result subtype is constrained. Also handle record types
1082 -- with unknown discriminants for which we have built the underlying
1083 -- record view. Coverage is needed to allow specific-type return
1084 -- objects when the result type is class-wide (see AI05-32).
1086 elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type))
1087 or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type))
1090 (Base_Type (R_Type),
1091 Underlying_Record_View (Base_Type (R_Stm_Type))))
1093 -- A null exclusion may be present on the return type, on the
1094 -- function specification, on the object declaration or on the
1097 if Is_Access_Type (R_Type)
1099 (Can_Never_Be_Null (R_Type)
1100 or else Null_Exclusion_Present (Parent (Scope_Id))) /=
1101 Can_Never_Be_Null (R_Stm_Type)
1103 Error_No_Match (Subtype_Ind);
1106 -- AI05-103: for elementary types, subtypes must statically match
1108 if Is_Constrained (R_Type) or else Is_Access_Type (R_Type) then
1109 if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
1110 Error_No_Match (Subtype_Ind);
1114 -- All remaining cases are illegal
1116 -- Note: previous versions of this subprogram allowed the return
1117 -- value to be the ancestor of the return type if the return type
1118 -- was a null extension. This was plainly incorrect.
1122 ("wrong type for return_subtype_indication", Subtype_Ind);
1124 end Check_Return_Subtype_Indication;
1126 ---------------------
1127 -- Local Variables --
1128 ---------------------
1131 Obj_Decl : Node_Id := Empty;
1133 -- Start of processing for Analyze_Function_Return
1136 Set_Return_Present (Scope_Id);
1138 if Nkind (N) = N_Simple_Return_Statement then
1139 Expr := Expression (N);
1141 -- Guard against a malformed expression. The parser may have tried to
1142 -- recover but the node is not analyzable.
1144 if Nkind (Expr) = N_Error then
1145 Set_Etype (Expr, Any_Type);
1146 Expander_Mode_Save_And_Set (False);
1150 -- The resolution of a controlled [extension] aggregate associated
1151 -- with a return statement creates a temporary which needs to be
1152 -- finalized on function exit. Wrap the return statement inside a
1153 -- block so that the finalization machinery can detect this case.
1154 -- This early expansion is done only when the return statement is
1155 -- not part of a handled sequence of statements.
1157 if Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
1158 and then Needs_Finalization (R_Type)
1159 and then Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
1162 Make_Block_Statement (Loc,
1163 Handled_Statement_Sequence =>
1164 Make_Handled_Sequence_Of_Statements (Loc,
1165 Statements => New_List (Relocate_Node (N)))));
1173 -- Ada 2005 (AI-251): If the type of the returned object is
1174 -- an access to an interface type then we add an implicit type
1175 -- conversion to force the displacement of the "this" pointer to
1176 -- reference the secondary dispatch table. We cannot delay the
1177 -- generation of this implicit conversion until the expansion
1178 -- because in this case the type resolution changes the decoration
1179 -- of the expression node to match R_Type; by contrast, if the
1180 -- returned object is a class-wide interface type then it is too
1181 -- early to generate here the implicit conversion since the return
1182 -- statement may be rewritten by the expander into an extended
1183 -- return statement whose expansion takes care of adding the
1184 -- implicit type conversion to displace the pointer to the object.
1187 and then Serious_Errors_Detected = 0
1188 and then Is_Access_Type (R_Type)
1189 and then Nkind (Expr) not in N_Null | N_Raise_Expression
1190 and then Is_Interface (Designated_Type (R_Type))
1191 and then Is_Progenitor (Designated_Type (R_Type),
1192 Designated_Type (Etype (Expr)))
1194 Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
1198 Resolve (Expr, R_Type);
1199 Check_Limited_Return (N, Expr, R_Type);
1201 Check_Return_Construct_Accessibility (N);
1203 -- Ada 2020 (AI12-0269): Any return statement that applies to a
1204 -- nonreturning function shall be a simple_return_statement with
1205 -- an expression that is a raise_expression, or else a call on a
1206 -- nonreturning function, or else a parenthesized expression of
1209 if Ada_Version >= Ada_2020
1210 and then No_Return (Scope_Id)
1211 and then Comes_From_Source (N)
1213 Check_No_Return_Expression (Original_Node (Expr));
1217 Obj_Decl := Last (Return_Object_Declarations (N));
1219 -- Analyze parts specific to extended_return_statement:
1222 Has_Aliased : constant Boolean := Aliased_Present (Obj_Decl);
1223 HSS : constant Node_Id := Handled_Statement_Sequence (N);
1226 Expr := Expression (Obj_Decl);
1228 -- Note: The check for OK_For_Limited_Init will happen in
1229 -- Analyze_Object_Declaration; we treat it as a normal
1230 -- object declaration.
1232 Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
1234 -- Returning a build-in-place unconstrained array type we defer
1235 -- the full analysis of the returned object to avoid generating
1236 -- the corresponding constrained subtype; otherwise the bounds
1237 -- would be created in the stack and a dangling reference would
1238 -- be returned pointing to the bounds. We perform its preanalysis
1239 -- to report errors on the initializing aggregate now (if any);
1240 -- we also ensure its activation chain and Master variable are
1241 -- defined (if tasks are being declared) since they are generated
1242 -- as part of the analysis and expansion of the object declaration
1245 if Is_Array_Type (R_Type)
1246 and then not Is_Constrained (R_Type)
1247 and then Is_Build_In_Place_Function (Scope_Id)
1248 and then Needs_BIP_Alloc_Form (Scope_Id)
1249 and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
1251 Preanalyze (Obj_Decl);
1253 if Expander_Active then
1254 Ensure_Activation_Chain_And_Master (Obj_Decl);
1261 Check_Return_Subtype_Indication (Obj_Decl);
1263 if Present (HSS) then
1266 if Present (Exception_Handlers (HSS)) then
1268 -- ???Has_Nested_Block_With_Handler needs to be set.
1269 -- Probably by creating an actual N_Block_Statement.
1270 -- Probably in Expand.
1276 -- Mark the return object as referenced, since the return is an
1277 -- implicit reference of the object.
1279 Set_Referenced (Defining_Identifier (Obj_Decl));
1281 Check_References (Stm_Entity);
1283 Check_Return_Construct_Accessibility (N);
1285 -- Check RM 6.5 (5.9/3)
1288 if Ada_Version < Ada_2012 then
1290 -- Shouldn't this test Warn_On_Ada_2012_Compatibility ???
1291 -- Can it really happen (extended return???)
1294 ("aliased only allowed for limited return objects "
1295 & "in Ada 2012??", N);
1297 elsif not Is_Limited_View (R_Type) then
1299 ("aliased only allowed for limited return objects", N);
1303 -- Ada 2020 (AI12-0269): Any return statement that applies to a
1304 -- nonreturning function shall be a simple_return_statement.
1306 if Ada_Version >= Ada_2020
1307 and then No_Return (Scope_Id)
1308 and then Comes_From_Source (N)
1311 ("extended RETURN statement not allowed in No_Return "
1317 -- Case of Expr present
1319 if Present (Expr) then
1321 -- Defend against previous errors
1323 if Nkind (Expr) = N_Empty
1324 or else No (Etype (Expr))
1329 -- Apply constraint check. Note that this is done before the implicit
1330 -- conversion of the expression done for anonymous access types to
1331 -- ensure correct generation of the null-excluding check associated
1332 -- with null-excluding expressions found in return statements. We
1333 -- don't need a check if the subtype of the return object is the
1334 -- same as the result subtype of the function.
1336 if Nkind (N) /= N_Extended_Return_Statement
1337 or else Nkind (Obj_Decl) /= N_Object_Declaration
1338 or else Nkind (Object_Definition (Obj_Decl)) not in N_Has_Entity
1339 or else Entity (Object_Definition (Obj_Decl)) /= R_Type
1341 Apply_Constraint_Check (Expr, R_Type);
1344 -- The return value is converted to the return type of the function,
1345 -- which implies a predicate check if the return type is predicated.
1346 -- We do not apply the check for an extended return statement because
1347 -- Analyze_Object_Declaration has already done it on Obj_Decl above.
1348 -- We do not apply the check to a case expression because it will
1349 -- be expanded into a series of return statements, each of which
1350 -- will receive a predicate check.
1352 if Nkind (N) /= N_Extended_Return_Statement
1353 and then Nkind (Expr) /= N_Case_Expression
1355 Apply_Predicate_Check (Expr, R_Type);
1358 -- Ada 2005 (AI-318-02): When the result type is an anonymous access
1359 -- type, apply an implicit conversion of the expression to that type
1360 -- to force appropriate static and run-time accessibility checks.
1361 -- But we want to apply the checks to an extended return statement
1362 -- only once, i.e. not to the simple return statement generated at
1363 -- the end of its expansion because, prior to leaving the function,
1364 -- the accessibility level of the return object changes to be a level
1365 -- determined by the point of call (RM 3.10.2(10.8/3)).
1367 if Ada_Version >= Ada_2005
1368 and then Ekind (R_Type) = E_Anonymous_Access_Type
1369 and then (Nkind (N) = N_Extended_Return_Statement
1370 or else not Comes_From_Extended_Return_Statement (N))
1372 Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
1373 Analyze_And_Resolve (Expr, R_Type);
1375 -- If this is a local anonymous access to subprogram, the
1376 -- accessibility check can be applied statically. The return is
1377 -- illegal if the access type of the return expression is declared
1378 -- inside of the subprogram (except if it is the subtype indication
1379 -- of an extended return statement).
1381 elsif Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type then
1382 if not Comes_From_Source (Current_Scope)
1383 or else Ekind (Current_Scope) = E_Return_Statement
1388 Scope_Depth (Scope (Etype (Expr))) >= Scope_Depth (Scope_Id)
1390 Error_Msg_N ("cannot return local access to subprogram", N);
1393 -- The expression cannot be of a formal incomplete type
1395 elsif Ekind (Etype (Expr)) = E_Incomplete_Type
1396 and then Is_Generic_Type (Etype (Expr))
1399 ("cannot return expression of a formal incomplete type", N);
1402 -- If the result type is class-wide, then check that the return
1403 -- expression's type is not declared at a deeper level than the
1404 -- function (RM05-6.5(5.6/2)).
1406 if Ada_Version >= Ada_2005
1407 and then Is_Class_Wide_Type (R_Type)
1409 if Type_Access_Level (Etype (Expr)) >
1410 Subprogram_Access_Level (Scope_Id)
1413 ("level of return expression type is deeper than "
1414 & "class-wide function!", Expr);
1418 -- Check incorrect use of dynamically tagged expression
1420 if Is_Tagged_Type (R_Type) then
1421 Check_Dynamically_Tagged_Expression
1427 -- ??? A real run-time accessibility check is needed in cases
1428 -- involving dereferences of access parameters. For now we just
1429 -- check the static cases.
1431 if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
1432 and then Is_Limited_View (Etype (Scope_Id))
1433 and then Object_Access_Level (Expr) >
1434 Subprogram_Access_Level (Scope_Id)
1436 -- Suppress the message in a generic, where the rewriting
1439 if Inside_A_Generic then
1444 Make_Raise_Program_Error (Loc,
1445 Reason => PE_Accessibility_Check_Failed));
1448 Error_Msg_Warn := SPARK_Mode /= On;
1449 Error_Msg_N ("cannot return a local value by reference<<", N);
1450 Error_Msg_NE ("\& [<<", N, Standard_Program_Error);
1454 if Known_Null (Expr)
1455 and then Nkind (Parent (Scope_Id)) = N_Function_Specification
1456 and then Null_Exclusion_Present (Parent (Scope_Id))
1458 Apply_Compile_Time_Constraint_Error
1460 Msg => "(Ada 2005) null not allowed for "
1461 & "null-excluding return??",
1462 Reason => CE_Null_Not_Allowed);
1465 -- RM 6.5 (5.4/3): accessibility checks also apply if the return object
1466 -- has no initializing expression.
1468 elsif Ada_Version > Ada_2005 and then Is_Class_Wide_Type (R_Type) then
1469 if Type_Access_Level (Etype (Defining_Identifier (Obj_Decl))) >
1470 Subprogram_Access_Level (Scope_Id)
1473 ("level of return expression type is deeper than "
1474 & "class-wide function!", Obj_Decl);
1477 end Analyze_Function_Return;
1479 -------------------------------------
1480 -- Analyze_Generic_Subprogram_Body --
1481 -------------------------------------
1483 procedure Analyze_Generic_Subprogram_Body
1487 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id);
1488 Kind : constant Entity_Kind := Ekind (Gen_Id);
1489 Body_Id : Entity_Id;
1494 -- Copy body and disable expansion while analyzing the generic For a
1495 -- stub, do not copy the stub (which would load the proper body), this
1496 -- will be done when the proper body is analyzed.
1498 if Nkind (N) /= N_Subprogram_Body_Stub then
1499 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
1502 -- Once the contents of the generic copy and the template are
1503 -- swapped, do the same for their respective aspect specifications.
1505 Exchange_Aspects (N, New_N);
1507 -- Collect all contract-related source pragmas found within the
1508 -- template and attach them to the contract of the subprogram body.
1509 -- This contract is used in the capture of global references within
1512 Create_Generic_Contract (N);
1517 Spec := Specification (N);
1519 -- Within the body of the generic, the subprogram is callable, and
1520 -- behaves like the corresponding non-generic unit.
1522 Body_Id := Defining_Entity (Spec);
1524 if Kind = E_Generic_Procedure
1525 and then Nkind (Spec) /= N_Procedure_Specification
1527 Error_Msg_N ("invalid body for generic procedure ", Body_Id);
1530 elsif Kind = E_Generic_Function
1531 and then Nkind (Spec) /= N_Function_Specification
1533 Error_Msg_N ("invalid body for generic function ", Body_Id);
1537 Set_Corresponding_Body (Gen_Decl, Body_Id);
1539 if Has_Completion (Gen_Id)
1540 and then Nkind (Parent (N)) /= N_Subunit
1542 Error_Msg_N ("duplicate generic body", N);
1545 Set_Has_Completion (Gen_Id);
1548 if Nkind (N) = N_Subprogram_Body_Stub then
1549 Set_Ekind (Defining_Entity (Specification (N)), Kind);
1551 Set_Corresponding_Spec (N, Gen_Id);
1554 if Nkind (Parent (N)) = N_Compilation_Unit then
1555 Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
1558 -- Make generic parameters immediately visible in the body. They are
1559 -- needed to process the formals declarations. Then make the formals
1560 -- visible in a separate step.
1562 Push_Scope (Gen_Id);
1566 First_Ent : Entity_Id;
1569 First_Ent := First_Entity (Gen_Id);
1572 while Present (E) and then not Is_Formal (E) loop
1577 Set_Use (Generic_Formal_Declarations (Gen_Decl));
1579 -- Now generic formals are visible, and the specification can be
1580 -- analyzed, for subsequent conformance check.
1582 Body_Id := Analyze_Subprogram_Specification (Spec);
1584 -- Make formal parameters visible
1588 -- E is the first formal parameter, we loop through the formals
1589 -- installing them so that they will be visible.
1591 Set_First_Entity (Gen_Id, E);
1592 while Present (E) loop
1598 -- Visible generic entity is callable within its own body
1600 Set_Ekind (Gen_Id, Ekind (Body_Id));
1601 Set_Ekind (Body_Id, E_Subprogram_Body);
1602 Set_Convention (Body_Id, Convention (Gen_Id));
1603 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
1604 Set_Scope (Body_Id, Scope (Gen_Id));
1606 Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
1608 if Nkind (N) = N_Subprogram_Body_Stub then
1610 -- No body to analyze, so restore state of generic unit
1612 Set_Ekind (Gen_Id, Kind);
1613 Set_Ekind (Body_Id, Kind);
1615 if Present (First_Ent) then
1616 Set_First_Entity (Gen_Id, First_Ent);
1623 -- If this is a compilation unit, it must be made visible explicitly,
1624 -- because the compilation of the declaration, unlike other library
1625 -- unit declarations, does not. If it is not a unit, the following
1626 -- is redundant but harmless.
1628 Set_Is_Immediately_Visible (Gen_Id);
1629 Reference_Body_Formals (Gen_Id, Body_Id);
1631 if Is_Child_Unit (Gen_Id) then
1632 Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False);
1635 Set_Actual_Subtypes (N, Current_Scope);
1637 Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
1638 Set_SPARK_Pragma_Inherited (Body_Id);
1640 -- Analyze any aspect specifications that appear on the generic
1643 if Has_Aspects (N) then
1644 Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
1647 Analyze_Declarations (Declarations (N));
1650 -- Process the contract of the subprogram body after all declarations
1651 -- have been analyzed. This ensures that any contract-related pragmas
1652 -- are available through the N_Contract node of the body.
1654 Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id);
1656 Analyze (Handled_Statement_Sequence (N));
1657 Save_Global_References (Original_Node (N));
1659 -- Prior to exiting the scope, include generic formals again (if any
1660 -- are present) in the set of local entities.
1662 if Present (First_Ent) then
1663 Set_First_Entity (Gen_Id, First_Ent);
1666 Check_References (Gen_Id);
1669 Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
1670 Update_Use_Clause_Chain;
1671 Validate_Categorization_Dependency (N, Gen_Id);
1673 Check_Subprogram_Order (N);
1675 -- Outside of its body, unit is generic again
1677 Set_Ekind (Gen_Id, Kind);
1678 Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
1681 Style.Check_Identifier (Body_Id, Gen_Id);
1685 end Analyze_Generic_Subprogram_Body;
1687 ----------------------------
1688 -- Analyze_Null_Procedure --
1689 ----------------------------
1691 -- WARNING: This routine manages Ghost regions. Return statements must be
1692 -- replaced by gotos that jump to the end of the routine and restore the
1695 procedure Analyze_Null_Procedure
1697 Is_Completion : out Boolean)
1699 Loc : constant Source_Ptr := Sloc (N);
1700 Spec : constant Node_Id := Specification (N);
1702 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1703 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1704 Saved_ISMP : constant Boolean :=
1705 Ignore_SPARK_Mode_Pragmas_In_Instance;
1706 -- Save the Ghost and SPARK mode-related data to restore on exit
1708 Designator : Entity_Id;
1710 Null_Body : Node_Id := Empty;
1711 Null_Stmt : Node_Id := Null_Statement (Spec);
1715 Prev := Current_Entity_In_Scope (Defining_Entity (Spec));
1717 -- A null procedure is Ghost when it is stand-alone and is subject to
1718 -- pragma Ghost, or when the corresponding spec is Ghost. Set the mode
1719 -- now, to ensure that any nodes generated during analysis and expansion
1720 -- are properly marked as Ghost.
1722 if Present (Prev) then
1723 Mark_And_Set_Ghost_Body (N, Prev);
1726 -- Capture the profile of the null procedure before analysis, for
1727 -- expansion at the freeze point and at each point of call. The body is
1728 -- used if the procedure has preconditions, or if it is a completion. In
1729 -- the first case the body is analyzed at the freeze point, in the other
1730 -- it replaces the null procedure declaration.
1732 -- For a null procedure that comes from source, a NULL statement is
1733 -- provided by the parser, which carries the source location of the
1734 -- NULL keyword, and has Comes_From_Source set. For a null procedure
1735 -- from expansion, create one now.
1737 if No (Null_Stmt) then
1738 Null_Stmt := Make_Null_Statement (Loc);
1742 Make_Subprogram_Body (Loc,
1743 Specification => New_Copy_Tree (Spec),
1744 Declarations => New_List,
1745 Handled_Statement_Sequence =>
1746 Make_Handled_Sequence_Of_Statements (Loc,
1747 Statements => New_List (Null_Stmt)));
1749 -- Create new entities for body and formals
1751 Set_Defining_Unit_Name (Specification (Null_Body),
1752 Make_Defining_Identifier
1753 (Sloc (Defining_Entity (N)),
1754 Chars (Defining_Entity (N))));
1756 Form := First (Parameter_Specifications (Specification (Null_Body)));
1757 while Present (Form) loop
1758 Set_Defining_Identifier (Form,
1759 Make_Defining_Identifier
1760 (Sloc (Defining_Identifier (Form)),
1761 Chars (Defining_Identifier (Form))));
1765 -- Determine whether the null procedure may be a completion of a generic
1766 -- suprogram, in which case we use the new null body as the completion
1767 -- and set minimal semantic information on the original declaration,
1768 -- which is rewritten as a null statement.
1770 if Present (Prev) and then Is_Generic_Subprogram (Prev) then
1771 Insert_Before (N, Null_Body);
1772 Set_Ekind (Defining_Entity (N), Ekind (Prev));
1774 Rewrite (N, Make_Null_Statement (Loc));
1775 Analyze_Generic_Subprogram_Body (Null_Body, Prev);
1776 Is_Completion := True;
1781 -- Resolve the types of the formals now, because the freeze point may
1782 -- appear in a different context, e.g. an instantiation.
1784 Form := First (Parameter_Specifications (Specification (Null_Body)));
1785 while Present (Form) loop
1786 if Nkind (Parameter_Type (Form)) /= N_Access_Definition then
1787 Find_Type (Parameter_Type (Form));
1789 elsif No (Access_To_Subprogram_Definition
1790 (Parameter_Type (Form)))
1792 Find_Type (Subtype_Mark (Parameter_Type (Form)));
1794 -- The case of a null procedure with a formal that is an
1795 -- access-to-subprogram type, and that is used as an actual
1796 -- in an instantiation is left to the enthusiastic reader.
1806 -- If there are previous overloadable entities with the same name, check
1807 -- whether any of them is completed by the null procedure.
1809 if Present (Prev) and then Is_Overloadable (Prev) then
1810 Designator := Analyze_Subprogram_Specification (Spec);
1811 Prev := Find_Corresponding_Spec (N);
1814 if No (Prev) or else not Comes_From_Source (Prev) then
1815 Designator := Analyze_Subprogram_Specification (Spec);
1816 Set_Has_Completion (Designator);
1818 -- Signal to caller that this is a procedure declaration
1820 Is_Completion := False;
1822 -- Null procedures are always inlined, but generic formal subprograms
1823 -- which appear as such in the internal instance of formal packages,
1824 -- need no completion and are not marked Inline.
1827 and then Nkind (N) /= N_Formal_Concrete_Subprogram_Declaration
1829 Set_Corresponding_Body (N, Defining_Entity (Null_Body));
1830 Set_Body_To_Inline (N, Null_Body);
1831 Set_Is_Inlined (Designator);
1835 -- The null procedure is a completion. We unconditionally rewrite
1836 -- this as a null body (even if expansion is not active), because
1837 -- there are various error checks that are applied on this body
1838 -- when it is analyzed (e.g. correct aspect placement).
1840 if Has_Completion (Prev) then
1841 Error_Msg_Sloc := Sloc (Prev);
1842 Error_Msg_NE ("duplicate body for & declared#", N, Prev);
1845 Check_Previous_Null_Procedure (N, Prev);
1847 Is_Completion := True;
1848 Rewrite (N, Null_Body);
1853 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
1854 Restore_Ghost_Region (Saved_GM, Saved_IGR);
1855 end Analyze_Null_Procedure;
1857 -----------------------------
1858 -- Analyze_Operator_Symbol --
1859 -----------------------------
1861 -- An operator symbol such as "+" or "and" may appear in context where the
1862 -- literal denotes an entity name, such as "+"(x, y) or in context when it
1863 -- is just a string, as in (conjunction = "or"). In these cases the parser
1864 -- generates this node, and the semantics does the disambiguation. Other
1865 -- such case are actuals in an instantiation, the generic unit in an
1866 -- instantiation, and pragma arguments.
1868 procedure Analyze_Operator_Symbol (N : Node_Id) is
1869 Par : constant Node_Id := Parent (N);
1872 if (Nkind (Par) = N_Function_Call and then N = Name (Par))
1873 or else Nkind (Par) = N_Function_Instantiation
1874 or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
1875 or else (Nkind (Par) = N_Pragma_Argument_Association
1876 and then not Is_Pragma_String_Literal (Par))
1877 or else Nkind (Par) = N_Subprogram_Renaming_Declaration
1878 or else (Nkind (Par) = N_Attribute_Reference
1879 and then Attribute_Name (Par) /= Name_Value)
1881 Find_Direct_Name (N);
1884 Change_Operator_Symbol_To_String_Literal (N);
1887 end Analyze_Operator_Symbol;
1889 -----------------------------------
1890 -- Analyze_Parameter_Association --
1891 -----------------------------------
1893 procedure Analyze_Parameter_Association (N : Node_Id) is
1895 Analyze (Explicit_Actual_Parameter (N));
1896 end Analyze_Parameter_Association;
1898 ----------------------------
1899 -- Analyze_Procedure_Call --
1900 ----------------------------
1902 -- WARNING: This routine manages Ghost regions. Return statements must be
1903 -- replaced by gotos that jump to the end of the routine and restore the
1906 procedure Analyze_Procedure_Call (N : Node_Id) is
1907 procedure Analyze_Call_And_Resolve;
1908 -- Do Analyze and Resolve calls for procedure call. At the end, check
1909 -- for illegal order dependence.
1910 -- ??? where is the check for illegal order dependencies?
1912 ------------------------------
1913 -- Analyze_Call_And_Resolve --
1914 ------------------------------
1916 procedure Analyze_Call_And_Resolve is
1918 if Nkind (N) = N_Procedure_Call_Statement then
1920 Resolve (N, Standard_Void_Type);
1924 end Analyze_Call_And_Resolve;
1928 Actuals : constant List_Id := Parameter_Associations (N);
1929 Loc : constant Source_Ptr := Sloc (N);
1930 P : constant Node_Id := Name (N);
1932 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1933 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1934 -- Save the Ghost-related attributes to restore on exit
1939 -- Start of processing for Analyze_Procedure_Call
1942 -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
1943 -- a procedure call or an entry call. The prefix may denote an access
1944 -- to subprogram type, in which case an implicit dereference applies.
1945 -- If the prefix is an indexed component (without implicit dereference)
1946 -- then the construct denotes a call to a member of an entire family.
1947 -- If the prefix is a simple name, it may still denote a call to a
1948 -- parameterless member of an entry family. Resolution of these various
1949 -- interpretations is delicate.
1951 -- Do not analyze machine code statements to avoid rejecting them in
1954 if CodePeer_Mode and then Nkind (P) = N_Qualified_Expression then
1955 Set_Etype (P, Standard_Void_Type);
1960 -- If this is a call of the form Obj.Op, the call may have been analyzed
1961 -- and possibly rewritten into a block, in which case we are done.
1963 if Analyzed (N) then
1966 -- If there is an error analyzing the name (which may have been
1967 -- rewritten if the original call was in prefix notation) then error
1968 -- has been emitted already, mark node and return.
1970 elsif Error_Posted (N) or else Etype (Name (N)) = Any_Type then
1971 Set_Etype (N, Any_Type);
1975 -- A procedure call is Ghost when its name denotes a Ghost procedure.
1976 -- Set the mode now to ensure that any nodes generated during analysis
1977 -- and expansion are properly marked as Ghost.
1979 Mark_And_Set_Ghost_Procedure_Call (N);
1981 -- Otherwise analyze the parameters
1983 if Present (Actuals) then
1984 Actual := First (Actuals);
1986 while Present (Actual) loop
1988 Check_Parameterless_Call (Actual);
1993 -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
1995 if Nkind (P) = N_Attribute_Reference
1996 and then Attribute_Name (P) in Name_Elab_Spec
1998 | Name_Elab_Subp_Body
2000 if Present (Actuals) then
2002 ("no parameters allowed for this call", First (Actuals));
2006 Set_Etype (N, Standard_Void_Type);
2009 elsif Is_Entity_Name (P)
2010 and then Is_Record_Type (Etype (Entity (P)))
2011 and then Remote_AST_I_Dereference (P)
2015 elsif Is_Entity_Name (P)
2016 and then Ekind (Entity (P)) /= E_Entry_Family
2018 if Is_Access_Type (Etype (P))
2019 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
2020 and then No (Actuals)
2021 and then Comes_From_Source (N)
2023 Error_Msg_N ("missing explicit dereference in call", N);
2025 elsif Ekind (Entity (P)) = E_Operator then
2026 Error_Msg_Name_1 := Chars (P);
2027 Error_Msg_N ("operator % cannot be used as a procedure", N);
2030 Analyze_Call_And_Resolve;
2032 -- If the prefix is the simple name of an entry family, this is a
2033 -- parameterless call from within the task body itself.
2035 elsif Is_Entity_Name (P)
2036 and then Nkind (P) = N_Identifier
2037 and then Ekind (Entity (P)) = E_Entry_Family
2038 and then Present (Actuals)
2039 and then No (Next (First (Actuals)))
2041 -- Can be call to parameterless entry family. What appears to be the
2042 -- sole argument is in fact the entry index. Rewrite prefix of node
2043 -- accordingly. Source representation is unchanged by this
2047 Make_Indexed_Component (Loc,
2049 Make_Selected_Component (Loc,
2050 Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
2051 Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
2052 Expressions => Actuals);
2053 Set_Name (N, New_N);
2054 Set_Etype (New_N, Standard_Void_Type);
2055 Set_Parameter_Associations (N, No_List);
2056 Analyze_Call_And_Resolve;
2058 elsif Nkind (P) = N_Explicit_Dereference then
2059 if Ekind (Etype (P)) = E_Subprogram_Type then
2060 Analyze_Call_And_Resolve;
2062 Error_Msg_N ("expect access to procedure in call", P);
2065 -- The name can be a selected component or an indexed component that
2066 -- yields an access to subprogram. Such a prefix is legal if the call
2067 -- has parameter associations.
2069 elsif Is_Access_Type (Etype (P))
2070 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
2072 if Present (Actuals) then
2073 Analyze_Call_And_Resolve;
2075 Error_Msg_N ("missing explicit dereference in call ", N);
2078 -- If not an access to subprogram, then the prefix must resolve to the
2079 -- name of an entry, entry family, or protected operation.
2081 -- For the case of a simple entry call, P is a selected component where
2082 -- the prefix is the task and the selector name is the entry. A call to
2083 -- a protected procedure will have the same syntax. If the protected
2084 -- object contains overloaded operations, the entity may appear as a
2085 -- function, the context will select the operation whose type is Void.
2087 elsif Nkind (P) = N_Selected_Component
2088 and then Ekind (Entity (Selector_Name (P)))
2089 in E_Entry | E_Function | E_Procedure
2091 -- When front-end inlining is enabled, as with SPARK_Mode, a call
2092 -- in prefix notation may still be missing its controlling argument,
2093 -- so perform the transformation now.
2095 if SPARK_Mode = On and then In_Inlined_Body then
2097 Subp : constant Entity_Id := Entity (Selector_Name (P));
2098 Typ : constant Entity_Id := Etype (Prefix (P));
2101 if Is_Tagged_Type (Typ)
2102 and then Present (First_Formal (Subp))
2103 and then (Etype (First_Formal (Subp)) = Typ
2105 Class_Wide_Type (Etype (First_Formal (Subp))) = Typ)
2106 and then Try_Object_Operation (P)
2111 Analyze_Call_And_Resolve;
2116 Analyze_Call_And_Resolve;
2119 elsif Nkind (P) = N_Selected_Component
2120 and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
2121 and then Present (Actuals)
2122 and then No (Next (First (Actuals)))
2124 -- Can be call to parameterless entry family. What appears to be the
2125 -- sole argument is in fact the entry index. Rewrite prefix of node
2126 -- accordingly. Source representation is unchanged by this
2130 Make_Indexed_Component (Loc,
2131 Prefix => New_Copy (P),
2132 Expressions => Actuals);
2133 Set_Name (N, New_N);
2134 Set_Etype (New_N, Standard_Void_Type);
2135 Set_Parameter_Associations (N, No_List);
2136 Analyze_Call_And_Resolve;
2138 -- For the case of a reference to an element of an entry family, P is
2139 -- an indexed component whose prefix is a selected component (task and
2140 -- entry family), and whose index is the entry family index.
2142 elsif Nkind (P) = N_Indexed_Component
2143 and then Nkind (Prefix (P)) = N_Selected_Component
2144 and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
2146 Analyze_Call_And_Resolve;
2148 -- If the prefix is the name of an entry family, it is a call from
2149 -- within the task body itself.
2151 elsif Nkind (P) = N_Indexed_Component
2152 and then Nkind (Prefix (P)) = N_Identifier
2153 and then Ekind (Entity (Prefix (P))) = E_Entry_Family
2156 Make_Selected_Component (Loc,
2158 New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
2159 Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
2160 Rewrite (Prefix (P), New_N);
2162 Analyze_Call_And_Resolve;
2164 -- In Ada 2012. a qualified expression is a name, but it cannot be a
2165 -- procedure name, so the construct can only be a qualified expression.
2167 elsif Nkind (P) = N_Qualified_Expression
2168 and then Ada_Version >= Ada_2012
2170 Rewrite (N, Make_Code_Statement (Loc, Expression => P));
2173 -- Anything else is an error
2176 Error_Msg_N ("invalid procedure or entry call", N);
2180 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2181 end Analyze_Procedure_Call;
2183 ------------------------------
2184 -- Analyze_Return_Statement --
2185 ------------------------------
2187 procedure Analyze_Return_Statement (N : Node_Id) is
2189 (Nkind (N) in N_Extended_Return_Statement | N_Simple_Return_Statement);
2191 Returns_Object : constant Boolean :=
2192 Nkind (N) = N_Extended_Return_Statement
2194 (Nkind (N) = N_Simple_Return_Statement
2195 and then Present (Expression (N)));
2196 -- True if we're returning something; that is, "return <expression>;"
2197 -- or "return Result : T [:= ...]". False for "return;". Used for error
2198 -- checking: If Returns_Object is True, N should apply to a function
2199 -- body; otherwise N should apply to a procedure body, entry body,
2200 -- accept statement, or extended return statement.
2202 function Find_What_It_Applies_To return Entity_Id;
2203 -- Find the entity representing the innermost enclosing body, accept
2204 -- statement, or extended return statement. If the result is a callable
2205 -- construct or extended return statement, then this will be the value
2206 -- of the Return_Applies_To attribute. Otherwise, the program is
2207 -- illegal. See RM-6.5(4/2).
2209 -----------------------------
2210 -- Find_What_It_Applies_To --
2211 -----------------------------
2213 function Find_What_It_Applies_To return Entity_Id is
2214 Result : Entity_Id := Empty;
2217 -- Loop outward through the Scope_Stack, skipping blocks, loops,
2218 -- and postconditions.
2220 for J in reverse 0 .. Scope_Stack.Last loop
2221 Result := Scope_Stack.Table (J).Entity;
2222 exit when Ekind (Result) not in E_Block | E_Loop
2223 and then Chars (Result) /= Name_uPostconditions;
2226 pragma Assert (Present (Result));
2228 end Find_What_It_Applies_To;
2230 -- Local declarations
2232 Scope_Id : constant Entity_Id := Find_What_It_Applies_To;
2233 Kind : constant Entity_Kind := Ekind (Scope_Id);
2234 Loc : constant Source_Ptr := Sloc (N);
2235 Stm_Entity : constant Entity_Id :=
2237 (E_Return_Statement, Current_Scope, Loc, 'R');
2239 -- Start of processing for Analyze_Return_Statement
2242 Set_Return_Statement_Entity (N, Stm_Entity);
2244 Set_Etype (Stm_Entity, Standard_Void_Type);
2245 Set_Return_Applies_To (Stm_Entity, Scope_Id);
2247 -- Place Return entity on scope stack, to simplify enforcement of 6.5
2248 -- (4/2): an inner return statement will apply to this extended return.
2250 if Nkind (N) = N_Extended_Return_Statement then
2251 Push_Scope (Stm_Entity);
2254 -- Check that pragma No_Return is obeyed. Don't complain about the
2255 -- implicitly-generated return that is placed at the end.
2257 if No_Return (Scope_Id)
2258 and then Kind in E_Procedure | E_Generic_Procedure
2259 and then Comes_From_Source (N)
2262 ("RETURN statement not allowed in No_Return procedure", N);
2265 -- Warn on any unassigned OUT parameters if in procedure
2267 if Ekind (Scope_Id) = E_Procedure then
2268 Warn_On_Unassigned_Out_Parameter (N, Scope_Id);
2271 -- Check that functions return objects, and other things do not
2273 if Kind in E_Function | E_Generic_Function then
2274 if not Returns_Object then
2275 Error_Msg_N ("missing expression in return from function", N);
2278 elsif Kind in E_Procedure | E_Generic_Procedure then
2279 if Returns_Object then
2280 Error_Msg_N ("procedure cannot return value (use function)", N);
2283 elsif Kind in E_Entry | E_Entry_Family then
2284 if Returns_Object then
2285 if Is_Protected_Type (Scope (Scope_Id)) then
2286 Error_Msg_N ("entry body cannot return value", N);
2288 Error_Msg_N ("accept statement cannot return value", N);
2292 elsif Kind = E_Return_Statement then
2294 -- We are nested within another return statement, which must be an
2295 -- extended_return_statement.
2297 if Returns_Object then
2298 if Nkind (N) = N_Extended_Return_Statement then
2300 ("extended return statement cannot be nested (use `RETURN;`)",
2303 -- Case of a simple return statement with a value inside extended
2304 -- return statement.
2308 ("return nested in extended return statement cannot return "
2309 & "value (use `RETURN;`)", N);
2314 Error_Msg_N ("illegal context for return statement", N);
2317 if Kind in E_Function | E_Generic_Function then
2318 Analyze_Function_Return (N);
2320 elsif Kind in E_Procedure | E_Generic_Procedure then
2321 Set_Return_Present (Scope_Id);
2324 if Nkind (N) = N_Extended_Return_Statement then
2328 Kill_Current_Values (Last_Assignment_Only => True);
2329 Check_Unreachable_Code (N);
2331 Analyze_Dimension (N);
2332 end Analyze_Return_Statement;
2334 -------------------------------------
2335 -- Analyze_Simple_Return_Statement --
2336 -------------------------------------
2338 procedure Analyze_Simple_Return_Statement (N : Node_Id) is
2340 if Present (Expression (N)) then
2341 Mark_Coextensions (N, Expression (N));
2344 Analyze_Return_Statement (N);
2345 end Analyze_Simple_Return_Statement;
2347 -------------------------
2348 -- Analyze_Return_Type --
2349 -------------------------
2351 procedure Analyze_Return_Type (N : Node_Id) is
2352 Designator : constant Entity_Id := Defining_Entity (N);
2353 Typ : Entity_Id := Empty;
2356 -- Normal case where result definition does not indicate an error
2358 if Result_Definition (N) /= Error then
2359 if Nkind (Result_Definition (N)) = N_Access_Definition then
2361 -- Ada 2005 (AI-254): Handle anonymous access to subprograms
2364 AD : constant Node_Id :=
2365 Access_To_Subprogram_Definition (Result_Definition (N));
2367 if Present (AD) and then Protected_Present (AD) then
2368 Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N);
2370 Typ := Access_Definition (N, Result_Definition (N));
2374 Set_Parent (Typ, Result_Definition (N));
2375 Set_Is_Local_Anonymous_Access (Typ);
2376 Set_Etype (Designator, Typ);
2378 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
2380 Null_Exclusion_Static_Checks (N);
2382 -- Subtype_Mark case
2385 Find_Type (Result_Definition (N));
2386 Typ := Entity (Result_Definition (N));
2387 Set_Etype (Designator, Typ);
2389 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
2391 Null_Exclusion_Static_Checks (N);
2393 -- If a null exclusion is imposed on the result type, then create
2394 -- a null-excluding itype (an access subtype) and use it as the
2395 -- function's Etype. Note that the null exclusion checks are done
2396 -- right before this, because they don't get applied to types that
2397 -- do not come from source.
2399 if Is_Access_Type (Typ) and then Null_Exclusion_Present (N) then
2400 Set_Etype (Designator,
2401 Create_Null_Excluding_Itype
2404 Scope_Id => Scope (Current_Scope)));
2406 -- The new subtype must be elaborated before use because
2407 -- it is visible outside of the function. However its base
2408 -- type may not be frozen yet, so the reference that will
2409 -- force elaboration must be attached to the freezing of
2412 -- If the return specification appears on a proper body,
2413 -- the subtype will have been created already on the spec.
2415 if Is_Frozen (Typ) then
2416 if Nkind (Parent (N)) = N_Subprogram_Body
2417 and then Nkind (Parent (Parent (N))) = N_Subunit
2421 Build_Itype_Reference (Etype (Designator), Parent (N));
2425 Ensure_Freeze_Node (Typ);
2428 IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
2430 Set_Itype (IR, Etype (Designator));
2431 Append_Freeze_Actions (Typ, New_List (IR));
2436 Set_Etype (Designator, Typ);
2439 if Ekind (Typ) = E_Incomplete_Type
2440 or else (Is_Class_Wide_Type (Typ)
2441 and then Ekind (Root_Type (Typ)) = E_Incomplete_Type)
2443 -- AI05-0151: Tagged incomplete types are allowed in all formal
2444 -- parts. Untagged incomplete types are not allowed in bodies.
2445 -- As a consequence, limited views cannot appear in a basic
2446 -- declaration that is itself within a body, because there is
2447 -- no point at which the non-limited view will become visible.
2449 if Ada_Version >= Ada_2012 then
2450 if From_Limited_With (Typ) and then In_Package_Body then
2452 ("invalid use of incomplete type&",
2453 Result_Definition (N), Typ);
2455 -- The return type of a subprogram body cannot be of a
2456 -- formal incomplete type.
2458 elsif Is_Generic_Type (Typ)
2459 and then Nkind (Parent (N)) = N_Subprogram_Body
2462 ("return type cannot be a formal incomplete type",
2463 Result_Definition (N));
2465 elsif Is_Class_Wide_Type (Typ)
2466 and then Is_Generic_Type (Root_Type (Typ))
2467 and then Nkind (Parent (N)) = N_Subprogram_Body
2470 ("return type cannot be a formal incomplete type",
2471 Result_Definition (N));
2473 elsif Is_Tagged_Type (Typ) then
2476 -- Use is legal in a thunk generated for an operation
2477 -- inherited from a progenitor.
2479 elsif Is_Thunk (Designator)
2480 and then Present (Non_Limited_View (Typ))
2484 elsif Nkind (Parent (N)) = N_Subprogram_Body
2485 or else Nkind (Parent (Parent (N))) in
2486 N_Accept_Statement | N_Entry_Body
2489 ("invalid use of untagged incomplete type&",
2493 -- The type must be completed in the current package. This
2494 -- is checked at the end of the package declaration when
2495 -- Taft-amendment types are identified. If the return type
2496 -- is class-wide, there is no required check, the type can
2497 -- be a bona fide TAT.
2499 if Ekind (Scope (Current_Scope)) = E_Package
2500 and then In_Private_Part (Scope (Current_Scope))
2501 and then not Is_Class_Wide_Type (Typ)
2503 Append_Elmt (Designator, Private_Dependents (Typ));
2508 ("invalid use of incomplete type&", Designator, Typ);
2513 -- Case where result definition does indicate an error
2516 Set_Etype (Designator, Any_Type);
2518 end Analyze_Return_Type;
2520 -----------------------------
2521 -- Analyze_Subprogram_Body --
2522 -----------------------------
2524 procedure Analyze_Subprogram_Body (N : Node_Id) is
2525 Loc : constant Source_Ptr := Sloc (N);
2526 Body_Spec : constant Node_Id := Specification (N);
2527 Body_Id : constant Entity_Id := Defining_Entity (Body_Spec);
2530 if Debug_Flag_C then
2531 Write_Str ("==> subprogram body ");
2532 Write_Name (Chars (Body_Id));
2533 Write_Str (" from ");
2534 Write_Location (Loc);
2539 Trace_Scope (N, Body_Id, " Analyze subprogram: ");
2541 -- The real work is split out into the helper, so it can do "return;"
2542 -- without skipping the debug output:
2544 Analyze_Subprogram_Body_Helper (N);
2546 if Debug_Flag_C then
2548 Write_Str ("<== subprogram body ");
2549 Write_Name (Chars (Body_Id));
2550 Write_Str (" from ");
2551 Write_Location (Loc);
2554 end Analyze_Subprogram_Body;
2556 ------------------------------------
2557 -- Analyze_Subprogram_Body_Helper --
2558 ------------------------------------
2560 -- This procedure is called for regular subprogram bodies, generic bodies,
2561 -- and for subprogram stubs of both kinds. In the case of stubs, only the
2562 -- specification matters, and is used to create a proper declaration for
2563 -- the subprogram, or to perform conformance checks.
2565 -- WARNING: This routine manages Ghost regions. Return statements must be
2566 -- replaced by gotos that jump to the end of the routine and restore the
2569 procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is
2570 Body_Spec : Node_Id := Specification (N);
2571 Body_Id : Entity_Id := Defining_Entity (Body_Spec);
2572 Loc : constant Source_Ptr := Sloc (N);
2573 Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
2575 Conformant : Boolean;
2576 Desig_View : Entity_Id := Empty;
2577 Exch_Views : Elist_Id := No_Elist;
2579 Mask_Types : Elist_Id := No_Elist;
2580 Prot_Typ : Entity_Id := Empty;
2581 Spec_Decl : Node_Id := Empty;
2582 Spec_Id : Entity_Id;
2584 Last_Real_Spec_Entity : Entity_Id := Empty;
2585 -- When we analyze a separate spec, the entity chain ends up containing
2586 -- the formals, as well as any itypes generated during analysis of the
2587 -- default expressions for parameters, or the arguments of associated
2588 -- precondition/postcondition pragmas (which are analyzed in the context
2589 -- of the spec since they have visibility on formals).
2591 -- These entities belong with the spec and not the body. However we do
2592 -- the analysis of the body in the context of the spec (again to obtain
2593 -- visibility to the formals), and all the entities generated during
2594 -- this analysis end up also chained to the entity chain of the spec.
2595 -- But they really belong to the body, and there is circuitry to move
2596 -- them from the spec to the body.
2598 -- However, when we do this move, we don't want to move the real spec
2599 -- entities (first para above) to the body. The Last_Real_Spec_Entity
2600 -- variable points to the last real spec entity, so we only move those
2601 -- chained beyond that point. It is initialized to Empty to deal with
2602 -- the case where there is no separate spec.
2604 function Body_Has_Contract return Boolean;
2605 -- Check whether unanalyzed body has an aspect or pragma that may
2606 -- generate a SPARK contract.
2608 function Body_Has_SPARK_Mode_On return Boolean;
2609 -- Check whether SPARK_Mode On applies to the subprogram body, either
2610 -- because it is specified directly on the body, or because it is
2611 -- inherited from the enclosing subprogram or package.
2613 function Build_Internal_Protected_Declaration
2614 (N : Node_Id) return Entity_Id;
2615 -- A subprogram body without a previous spec that appears in a protected
2616 -- body must be expanded separately to create a subprogram declaration
2617 -- for it, in order to resolve internal calls to it from other protected
2620 -- Possibly factor this with Exp_Dist.Copy_Specification ???
2622 procedure Build_Subprogram_Declaration;
2623 -- Create a matching subprogram declaration for subprogram body N
2625 procedure Check_Anonymous_Return;
2626 -- Ada 2005: if a function returns an access type that denotes a task,
2627 -- or a type that contains tasks, we must create a master entity for
2628 -- the anonymous type, which typically will be used in an allocator
2629 -- in the body of the function.
2631 procedure Check_Inline_Pragma (Spec : in out Node_Id);
2632 -- Look ahead to recognize a pragma that may appear after the body.
2633 -- If there is a previous spec, check that it appears in the same
2634 -- declarative part. If the pragma is Inline_Always, perform inlining
2635 -- unconditionally, otherwise only if Front_End_Inlining is requested.
2636 -- If the body acts as a spec, and inlining is required, we create a
2637 -- subprogram declaration for it, in order to attach the body to inline.
2638 -- If pragma does not appear after the body, check whether there is
2639 -- an inline pragma before any local declarations.
2641 procedure Check_Missing_Return;
2642 -- Checks for a function with a no return statements, and also performs
2643 -- the warning checks implemented by Check_Returns. In formal mode, also
2644 -- verify that a function ends with a RETURN and that a procedure does
2645 -- not contain any RETURN.
2647 function Disambiguate_Spec return Entity_Id;
2648 -- When a primitive is declared between the private view and the full
2649 -- view of a concurrent type which implements an interface, a special
2650 -- mechanism is used to find the corresponding spec of the primitive
2653 function Exchange_Limited_Views (Subp_Id : Entity_Id) return Elist_Id;
2654 -- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains
2655 -- incomplete types coming from a limited context and replace their
2656 -- limited views with the non-limited ones. Return the list of changes
2657 -- to be used to undo the transformation.
2659 function Is_Private_Concurrent_Primitive
2660 (Subp_Id : Entity_Id) return Boolean;
2661 -- Determine whether subprogram Subp_Id is a primitive of a concurrent
2662 -- type that implements an interface and has a private view.
2664 function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id;
2665 -- N is the body generated for an expression function that is not a
2666 -- completion and Spec_Id the defining entity of its spec. Mark all
2667 -- the not-yet-frozen types referenced by the simple return statement
2668 -- of the function as formally frozen.
2670 procedure Move_Pragmas (From : Node_Id; To : Node_Id);
2671 -- Find all suitable source pragmas at the top of subprogram body
2672 -- From's declarations and move them after arbitrary node To.
2673 -- One exception is pragma SPARK_Mode which is copied rather than moved,
2674 -- as it applies to the body too.
2676 procedure Restore_Limited_Views (Restore_List : Elist_Id);
2677 -- Undo the transformation done by Exchange_Limited_Views.
2679 procedure Set_Trivial_Subprogram (N : Node_Id);
2680 -- Sets the Is_Trivial_Subprogram flag in both spec and body of the
2681 -- subprogram whose body is being analyzed. N is the statement node
2682 -- causing the flag to be set, if the following statement is a return
2683 -- of an entity, we mark the entity as set in source to suppress any
2684 -- warning on the stylized use of function stubs with a dummy return.
2686 procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id);
2687 -- Undo the transformation done by Mask_Unfrozen_Types
2689 procedure Verify_Overriding_Indicator;
2690 -- If there was a previous spec, the entity has been entered in the
2691 -- current scope previously. If the body itself carries an overriding
2692 -- indicator, check that it is consistent with the known status of the
2695 -----------------------
2696 -- Body_Has_Contract --
2697 -----------------------
2699 function Body_Has_Contract return Boolean is
2700 Decls : constant List_Id := Declarations (N);
2704 -- Check for aspects that may generate a contract
2706 if Present (Aspect_Specifications (N)) then
2707 Item := First (Aspect_Specifications (N));
2708 while Present (Item) loop
2709 if Is_Subprogram_Contract_Annotation (Item) then
2717 -- Check for pragmas that may generate a contract
2719 if Present (Decls) then
2720 Item := First (Decls);
2721 while Present (Item) loop
2722 if Nkind (Item) = N_Pragma
2723 and then Is_Subprogram_Contract_Annotation (Item)
2733 end Body_Has_Contract;
2735 ----------------------------
2736 -- Body_Has_SPARK_Mode_On --
2737 ----------------------------
2739 function Body_Has_SPARK_Mode_On return Boolean is
2740 Decls : constant List_Id := Declarations (N);
2744 -- Check for SPARK_Mode aspect
2746 if Present (Aspect_Specifications (N)) then
2747 Item := First (Aspect_Specifications (N));
2748 while Present (Item) loop
2749 if Get_Aspect_Id (Item) = Aspect_SPARK_Mode then
2750 return Get_SPARK_Mode_From_Annotation (Item) = On;
2757 -- Check for SPARK_Mode pragma
2759 if Present (Decls) then
2760 Item := First (Decls);
2761 while Present (Item) loop
2763 -- Pragmas that apply to a subprogram body are usually grouped
2764 -- together. Look for a potential pragma SPARK_Mode among them.
2766 if Nkind (Item) = N_Pragma then
2767 if Get_Pragma_Id (Item) = Pragma_SPARK_Mode then
2768 return Get_SPARK_Mode_From_Annotation (Item) = On;
2771 -- Otherwise the first non-pragma declarative item terminates
2772 -- the region where pragma SPARK_Mode may appear.
2782 -- Otherwise, the applicable SPARK_Mode is inherited from the
2783 -- enclosing subprogram or package.
2785 return SPARK_Mode = On;
2786 end Body_Has_SPARK_Mode_On;
2788 ------------------------------------------
2789 -- Build_Internal_Protected_Declaration --
2790 ------------------------------------------
2792 function Build_Internal_Protected_Declaration
2793 (N : Node_Id) return Entity_Id
2795 procedure Analyze_Pragmas (From : Node_Id);
2796 -- Analyze all pragmas which follow arbitrary node From
2798 ---------------------
2799 -- Analyze_Pragmas --
2800 ---------------------
2802 procedure Analyze_Pragmas (From : Node_Id) is
2806 Decl := Next (From);
2807 while Present (Decl) loop
2808 if Nkind (Decl) = N_Pragma then
2809 Analyze_Pragma (Decl);
2811 -- No candidate pragmas are available for analysis
2819 end Analyze_Pragmas;
2823 Body_Id : constant Entity_Id := Defining_Entity (N);
2824 Loc : constant Source_Ptr := Sloc (N);
2829 Spec_Id : Entity_Id;
2831 -- Start of processing for Build_Internal_Protected_Declaration
2834 Formal := First_Formal (Body_Id);
2836 -- The protected operation always has at least one formal, namely the
2837 -- object itself, but it is only placed in the parameter list if
2838 -- expansion is enabled.
2840 if Present (Formal) or else Expander_Active then
2841 Formals := Copy_Parameter_List (Body_Id);
2847 Make_Defining_Identifier (Sloc (Body_Id),
2848 Chars => Chars (Body_Id));
2850 -- Indicate that the entity comes from source, to ensure that cross-
2851 -- reference information is properly generated. The body itself is
2852 -- rewritten during expansion, and the body entity will not appear in
2853 -- calls to the operation.
2855 Set_Comes_From_Source (Spec_Id, True);
2857 if Nkind (Specification (N)) = N_Procedure_Specification then
2859 Make_Procedure_Specification (Loc,
2860 Defining_Unit_Name => Spec_Id,
2861 Parameter_Specifications => Formals);
2864 Make_Function_Specification (Loc,
2865 Defining_Unit_Name => Spec_Id,
2866 Parameter_Specifications => Formals,
2867 Result_Definition =>
2868 New_Occurrence_Of (Etype (Body_Id), Loc));
2871 Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
2872 Set_Corresponding_Body (Decl, Body_Id);
2873 Set_Corresponding_Spec (N, Spec_Id);
2875 Insert_Before (N, Decl);
2877 -- Associate all aspects and pragmas of the body with the spec. This
2878 -- ensures that these annotations apply to the initial declaration of
2879 -- the subprogram body.
2881 Move_Aspects (From => N, To => Decl);
2882 Move_Pragmas (From => N, To => Decl);
2886 -- The analysis of the spec may generate pragmas which require manual
2887 -- analysis. Since the generation of the spec and the relocation of
2888 -- the annotations is driven by the expansion of the stand-alone
2889 -- body, the pragmas will not be analyzed in a timely manner. Do this
2892 Analyze_Pragmas (Decl);
2894 -- This subprogram has convention Intrinsic as per RM 6.3.1(10/2)
2895 -- ensuring in particular that 'Access is illegal.
2897 Set_Convention (Spec_Id, Convention_Intrinsic);
2898 Set_Has_Completion (Spec_Id);
2901 end Build_Internal_Protected_Declaration;
2903 ----------------------------------
2904 -- Build_Subprogram_Declaration --
2905 ----------------------------------
2907 procedure Build_Subprogram_Declaration is
2909 Subp_Decl : Node_Id;
2912 -- Create a matching subprogram spec using the profile of the body.
2913 -- The structure of the tree is identical, but has new entities for
2914 -- the defining unit name and formal parameters.
2917 Make_Subprogram_Declaration (Loc,
2918 Specification => Copy_Subprogram_Spec (Body_Spec));
2919 Set_Comes_From_Source (Subp_Decl, True);
2921 -- Also mark parameters as coming from source
2923 if Present (Parameter_Specifications (Specification (Subp_Decl))) then
2928 First (Parameter_Specifications (Specification (Subp_Decl)));
2930 while Present (Form) loop
2931 Set_Comes_From_Source (Defining_Identifier (Form), True);
2937 -- Relocate the aspects and relevant pragmas from the subprogram body
2938 -- to the generated spec because it acts as the initial declaration.
2940 Insert_Before (N, Subp_Decl);
2941 Move_Aspects (N, To => Subp_Decl);
2942 Move_Pragmas (N, To => Subp_Decl);
2944 -- Ensure that the generated corresponding spec and original body
2945 -- share the same SPARK_Mode pragma or aspect. As a result, both have
2946 -- the same SPARK_Mode attributes, and the global SPARK_Mode value is
2947 -- correctly set for local subprograms.
2949 Copy_SPARK_Mode_Aspect (Subp_Decl, To => N);
2951 Analyze (Subp_Decl);
2953 -- Propagate the attributes Rewritten_For_C and Corresponding_Proc to
2954 -- the body since the expander may generate calls using that entity.
2955 -- Required to ensure that Expand_Call rewrites calls to this
2956 -- function by calls to the built procedure.
2958 if Modify_Tree_For_C
2959 and then Nkind (Body_Spec) = N_Function_Specification
2961 Rewritten_For_C (Defining_Entity (Specification (Subp_Decl)))
2963 Set_Rewritten_For_C (Defining_Entity (Body_Spec));
2964 Set_Corresponding_Procedure (Defining_Entity (Body_Spec),
2965 Corresponding_Procedure
2966 (Defining_Entity (Specification (Subp_Decl))));
2969 -- Analyze any relocated source pragmas or pragmas created for aspect
2972 Decl := Next (Subp_Decl);
2973 while Present (Decl) loop
2975 -- Stop the search for pragmas once the body has been reached as
2976 -- this terminates the region where pragmas may appear.
2981 elsif Nkind (Decl) = N_Pragma then
2988 Spec_Id := Defining_Entity (Subp_Decl);
2989 Set_Corresponding_Spec (N, Spec_Id);
2991 -- Mark the generated spec as a source construct to ensure that all
2992 -- calls to it are properly registered in ALI files for GNATprove.
2994 Set_Comes_From_Source (Spec_Id, True);
2996 -- Ensure that the specs of the subprogram declaration and its body
2997 -- are identical, otherwise they will appear non-conformant due to
2998 -- rewritings in the default values of formal parameters.
3000 Body_Spec := Copy_Subprogram_Spec (Body_Spec);
3001 Set_Specification (N, Body_Spec);
3002 Body_Id := Analyze_Subprogram_Specification (Body_Spec);
3003 end Build_Subprogram_Declaration;
3005 ----------------------------
3006 -- Check_Anonymous_Return --
3007 ----------------------------
3009 procedure Check_Anonymous_Return is
3015 if Present (Spec_Id) then
3021 if Ekind (Scop) = E_Function
3022 and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type
3023 and then not Is_Thunk (Scop)
3025 -- Skip internally built functions which handle the case of
3026 -- a null access (see Expand_Interface_Conversion)
3028 and then not (Is_Interface (Designated_Type (Etype (Scop)))
3029 and then not Comes_From_Source (Parent (Scop)))
3031 and then (Has_Task (Designated_Type (Etype (Scop)))
3033 (Is_Class_Wide_Type (Designated_Type (Etype (Scop)))
3035 Is_Limited_Record (Designated_Type (Etype (Scop)))))
3036 and then Expander_Active
3038 Decl := Build_Master_Declaration (Loc);
3040 if Present (Declarations (N)) then
3041 Prepend (Decl, Declarations (N));
3043 Set_Declarations (N, New_List (Decl));
3046 Set_Master_Id (Etype (Scop), Defining_Identifier (Decl));
3047 Set_Has_Master_Entity (Scop);
3049 -- Now mark the containing scope as a task master
3052 while Nkind (Par) /= N_Compilation_Unit loop
3053 Par := Parent (Par);
3054 pragma Assert (Present (Par));
3056 -- If we fall off the top, we are at the outer level, and
3057 -- the environment task is our effective master, so nothing
3061 in N_Task_Body | N_Block_Statement | N_Subprogram_Body
3063 Set_Is_Task_Master (Par, True);
3068 end Check_Anonymous_Return;
3070 -------------------------
3071 -- Check_Inline_Pragma --
3072 -------------------------
3074 procedure Check_Inline_Pragma (Spec : in out Node_Id) is
3078 function Is_Inline_Pragma (N : Node_Id) return Boolean;
3079 -- True when N is a pragma Inline or Inline_Always that applies
3080 -- to this subprogram.
3082 -----------------------
3083 -- Is_Inline_Pragma --
3084 -----------------------
3086 function Is_Inline_Pragma (N : Node_Id) return Boolean is
3088 if Nkind (N) = N_Pragma
3090 (Pragma_Name_Unmapped (N) = Name_Inline_Always
3091 or else (Pragma_Name_Unmapped (N) = Name_Inline
3093 (Front_End_Inlining or else Optimization_Level > 0)))
3094 and then Present (Pragma_Argument_Associations (N))
3097 Pragma_Arg : Node_Id :=
3098 Expression (First (Pragma_Argument_Associations (N)));
3100 if Nkind (Pragma_Arg) = N_Selected_Component then
3101 Pragma_Arg := Selector_Name (Pragma_Arg);
3104 return Chars (Pragma_Arg) = Chars (Body_Id);
3110 end Is_Inline_Pragma;
3112 -- Start of processing for Check_Inline_Pragma
3115 if not Expander_Active then
3119 if Is_List_Member (N)
3120 and then Present (Next (N))
3121 and then Is_Inline_Pragma (Next (N))
3125 elsif Nkind (N) /= N_Subprogram_Body_Stub
3126 and then Present (Declarations (N))
3127 and then Is_Inline_Pragma (First (Declarations (N)))
3129 Prag := First (Declarations (N));
3135 if Present (Prag) then
3136 if Present (Spec_Id) then
3137 if Is_List_Member (N)
3138 and then Is_List_Member (Unit_Declaration_Node (Spec_Id))
3139 and then In_Same_List (N, Unit_Declaration_Node (Spec_Id))
3145 -- Create a subprogram declaration, to make treatment uniform.
3146 -- Make the sloc of the subprogram name that of the entity in
3147 -- the body, so that style checks find identical strings.
3150 Subp : constant Entity_Id :=
3151 Make_Defining_Identifier
3152 (Sloc (Body_Id), Chars (Body_Id));
3153 Decl : constant Node_Id :=
3154 Make_Subprogram_Declaration (Loc,
3156 New_Copy_Tree (Specification (N)));
3159 -- Link the body and the generated spec
3161 Set_Corresponding_Body (Decl, Body_Id);
3162 Set_Corresponding_Spec (N, Subp);
3164 Set_Defining_Unit_Name (Specification (Decl), Subp);
3166 -- To ensure proper coverage when body is inlined, indicate
3167 -- whether the subprogram comes from source.
3169 Preserve_Comes_From_Source (Subp, N);
3171 if Present (First_Formal (Body_Id)) then
3172 Plist := Copy_Parameter_List (Body_Id);
3173 Set_Parameter_Specifications
3174 (Specification (Decl), Plist);
3177 -- Move aspects to the new spec
3179 if Has_Aspects (N) then
3180 Move_Aspects (N, To => Decl);
3183 Insert_Before (N, Decl);
3186 Set_Has_Pragma_Inline (Subp);
3188 if Pragma_Name (Prag) = Name_Inline_Always then
3189 Set_Is_Inlined (Subp);
3190 Set_Has_Pragma_Inline_Always (Subp);
3193 -- Prior to copying the subprogram body to create a template
3194 -- for it for subsequent inlining, remove the pragma from
3195 -- the current body so that the copy that will produce the
3196 -- new body will start from a completely unanalyzed tree.
3198 if Nkind (Parent (Prag)) = N_Subprogram_Body then
3199 Rewrite (Prag, Make_Null_Statement (Sloc (Prag)));
3206 end Check_Inline_Pragma;
3208 --------------------------
3209 -- Check_Missing_Return --
3210 --------------------------
3212 procedure Check_Missing_Return is
3214 Missing_Ret : Boolean;
3217 if Nkind (Body_Spec) = N_Function_Specification then
3218 if Present (Spec_Id) then
3224 if Return_Present (Id) then
3225 Check_Returns (HSS, 'F', Missing_Ret);
3228 Set_Has_Missing_Return (Id);
3231 -- Within a premature instantiation of a package with no body, we
3232 -- build completions of the functions therein, with a Raise
3233 -- statement. No point in complaining about a missing return in
3236 elsif Ekind (Id) = E_Function
3237 and then In_Instance
3238 and then Present (Statements (HSS))
3239 and then Nkind (First (Statements (HSS))) = N_Raise_Program_Error
3243 elsif Is_Generic_Subprogram (Id)
3244 or else not Is_Machine_Code_Subprogram (Id)
3246 Error_Msg_N ("missing RETURN statement in function body", N);
3249 -- If procedure with No_Return, check returns
3251 elsif Nkind (Body_Spec) = N_Procedure_Specification then
3252 if Present (Spec_Id) then
3258 if No_Return (Id) then
3259 Check_Returns (HSS, 'P', Missing_Ret, Id);
3262 end Check_Missing_Return;
3264 -----------------------
3265 -- Disambiguate_Spec --
3266 -----------------------
3268 function Disambiguate_Spec return Entity_Id is
3269 Priv_Spec : Entity_Id;
3272 procedure Replace_Types (To_Corresponding : Boolean);
3273 -- Depending on the flag, replace the type of formal parameters of
3274 -- Body_Id if it is a concurrent type implementing interfaces with
3275 -- the corresponding record type or the other way around.
3277 procedure Replace_Types (To_Corresponding : Boolean) is
3279 Formal_Typ : Entity_Id;
3282 Formal := First_Formal (Body_Id);
3283 while Present (Formal) loop
3284 Formal_Typ := Etype (Formal);
3286 if Is_Class_Wide_Type (Formal_Typ) then
3287 Formal_Typ := Root_Type (Formal_Typ);
3290 -- From concurrent type to corresponding record
3292 if To_Corresponding then
3293 if Is_Concurrent_Type (Formal_Typ)
3294 and then Present (Corresponding_Record_Type (Formal_Typ))
3297 (Corresponding_Record_Type (Formal_Typ)))
3300 Corresponding_Record_Type (Formal_Typ));
3303 -- From corresponding record to concurrent type
3306 if Is_Concurrent_Record_Type (Formal_Typ)
3307 and then Present (Interfaces (Formal_Typ))
3310 Corresponding_Concurrent_Type (Formal_Typ));
3314 Next_Formal (Formal);
3318 -- Start of processing for Disambiguate_Spec
3321 -- Try to retrieve the specification of the body as is. All error
3322 -- messages are suppressed because the body may not have a spec in
3323 -- its current state.
3325 Spec_N := Find_Corresponding_Spec (N, False);
3327 -- It is possible that this is the body of a primitive declared
3328 -- between a private and a full view of a concurrent type. The
3329 -- controlling parameter of the spec carries the concurrent type,
3330 -- not the corresponding record type as transformed by Analyze_
3331 -- Subprogram_Specification. In such cases, we undo the change
3332 -- made by the analysis of the specification and try to find the
3335 -- Note that wrappers already have their corresponding specs and
3336 -- bodies set during their creation, so if the candidate spec is
3337 -- a wrapper, then we definitely need to swap all types to their
3338 -- original concurrent status.
3341 or else Is_Primitive_Wrapper (Spec_N)
3343 -- Restore all references of corresponding record types to the
3344 -- original concurrent types.
3346 Replace_Types (To_Corresponding => False);
3347 Priv_Spec := Find_Corresponding_Spec (N, False);
3349 -- The current body truly belongs to a primitive declared between
3350 -- a private and a full view. We leave the modified body as is,
3351 -- and return the true spec.
3353 if Present (Priv_Spec)
3354 and then Is_Private_Primitive (Priv_Spec)
3359 -- In case that this is some sort of error, restore the original
3360 -- state of the body.
3362 Replace_Types (To_Corresponding => True);
3366 end Disambiguate_Spec;
3368 ----------------------------
3369 -- Exchange_Limited_Views --
3370 ----------------------------
3372 function Exchange_Limited_Views (Subp_Id : Entity_Id) return Elist_Id is
3373 Result : Elist_Id := No_Elist;
3375 procedure Detect_And_Exchange (Id : Entity_Id);
3376 -- Determine whether Id's type denotes an incomplete type associated
3377 -- with a limited with clause and exchange the limited view with the
3378 -- non-limited one when available. Note that the non-limited view
3379 -- may exist because of a with_clause in another unit in the context,
3380 -- but cannot be used because the current view of the enclosing unit
3381 -- is still a limited view.
3383 -------------------------
3384 -- Detect_And_Exchange --
3385 -------------------------
3387 procedure Detect_And_Exchange (Id : Entity_Id) is
3388 Typ : constant Entity_Id := Etype (Id);
3390 if From_Limited_With (Typ)
3391 and then Has_Non_Limited_View (Typ)
3392 and then not From_Limited_With (Scope (Typ))
3395 Result := New_Elmt_List;
3398 Prepend_Elmt (Typ, Result);
3399 Prepend_Elmt (Id, Result);
3400 Set_Etype (Id, Non_Limited_View (Typ));
3402 end Detect_And_Exchange;
3408 -- Start of processing for Exchange_Limited_Views
3411 -- Do not process subprogram bodies as they already use the non-
3412 -- limited view of types.
3414 if Ekind (Subp_Id) not in E_Function | E_Procedure then
3418 -- Examine all formals and swap views when applicable
3420 Formal := First_Formal (Subp_Id);
3421 while Present (Formal) loop
3422 Detect_And_Exchange (Formal);
3424 Next_Formal (Formal);
3427 -- Process the return type of a function
3429 if Ekind (Subp_Id) = E_Function then
3430 Detect_And_Exchange (Subp_Id);
3434 end Exchange_Limited_Views;
3436 -------------------------------------
3437 -- Is_Private_Concurrent_Primitive --
3438 -------------------------------------
3440 function Is_Private_Concurrent_Primitive
3441 (Subp_Id : Entity_Id) return Boolean
3443 Formal_Typ : Entity_Id;
3446 if Present (First_Formal (Subp_Id)) then
3447 Formal_Typ := Etype (First_Formal (Subp_Id));
3449 if Is_Concurrent_Record_Type (Formal_Typ) then
3450 if Is_Class_Wide_Type (Formal_Typ) then
3451 Formal_Typ := Root_Type (Formal_Typ);
3454 Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ);
3457 -- The type of the first formal is a concurrent tagged type with
3461 Is_Concurrent_Type (Formal_Typ)
3462 and then Is_Tagged_Type (Formal_Typ)
3463 and then Has_Private_Declaration (Formal_Typ);
3467 end Is_Private_Concurrent_Primitive;
3469 -------------------------
3470 -- Mask_Unfrozen_Types --
3471 -------------------------
3473 function Mask_Unfrozen_Types (Spec_Id : Entity_Id) return Elist_Id is
3474 Result : Elist_Id := No_Elist;
3476 function Mask_Type_Refs (Node : Node_Id) return Traverse_Result;
3477 -- Mask all types referenced in the subtree rooted at Node
3479 --------------------
3480 -- Mask_Type_Refs --
3481 --------------------
3483 function Mask_Type_Refs (Node : Node_Id) return Traverse_Result is
3484 procedure Mask_Type (Typ : Entity_Id);
3485 -- ??? what does this do?
3491 procedure Mask_Type (Typ : Entity_Id) is
3493 -- Skip Itypes created by the preanalysis
3496 and then Scope_Within_Or_Same (Scope (Typ), Spec_Id)
3501 if not Is_Frozen (Typ) then
3502 if Scope (Typ) /= Current_Scope then
3503 Set_Is_Frozen (Typ);
3504 Append_New_Elmt (Typ, Result);
3506 Freeze_Before (N, Typ);
3511 -- Start of processing for Mask_Type_Refs
3514 if Is_Entity_Name (Node) and then Present (Entity (Node)) then
3515 Mask_Type (Etype (Entity (Node)));
3517 if Ekind (Entity (Node)) in E_Component | E_Discriminant then
3518 Mask_Type (Scope (Entity (Node)));
3521 elsif Nkind (Node) in N_Aggregate | N_Null | N_Type_Conversion
3522 and then Present (Etype (Node))
3524 Mask_Type (Etype (Node));
3530 procedure Mask_References is new Traverse_Proc (Mask_Type_Refs);
3534 Return_Stmt : constant Node_Id :=
3535 First (Statements (Handled_Statement_Sequence (N)));
3537 -- Start of processing for Mask_Unfrozen_Types
3540 pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement);
3542 Mask_References (Expression (Return_Stmt));
3545 end Mask_Unfrozen_Types;
3551 procedure Move_Pragmas (From : Node_Id; To : Node_Id) is
3553 Insert_Nod : Node_Id;
3554 Next_Decl : Node_Id;
3557 pragma Assert (Nkind (From) = N_Subprogram_Body);
3559 -- The pragmas are moved in an order-preserving fashion
3563 -- Inspect the declarations of the subprogram body and relocate all
3564 -- candidate pragmas.
3566 Decl := First (Declarations (From));
3567 while Present (Decl) loop
3569 -- Preserve the following declaration for iteration purposes, due
3570 -- to possible relocation of a pragma.
3572 Next_Decl := Next (Decl);
3574 if Nkind (Decl) = N_Pragma then
3575 -- Copy pragma SPARK_Mode if present in the declarative list
3576 -- of subprogram body From and insert it after node To. This
3577 -- pragma should not be moved, as it applies to the body too.
3579 if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then
3580 Insert_After (Insert_Nod, New_Copy_Tree (Decl));
3582 -- Move relevant pragmas to the spec
3584 elsif Pragma_Name_Unmapped (Decl) in Name_Depends
3590 | Name_Refined_Depends
3591 | Name_Refined_Global
3594 | Name_Pure_Function
3595 | Name_Volatile_Function
3598 Insert_After (Insert_Nod, Decl);
3602 -- Skip internally generated code
3604 elsif not Comes_From_Source (Decl) then
3607 -- No candidate pragmas are available for relocation
3617 ---------------------------
3618 -- Restore_Limited_Views --
3619 ---------------------------
3621 procedure Restore_Limited_Views (Restore_List : Elist_Id) is
3622 Elmt : Elmt_Id := First_Elmt (Restore_List);
3626 while Present (Elmt) loop
3629 Set_Etype (Id, Node (Elmt));
3632 end Restore_Limited_Views;
3634 ----------------------------
3635 -- Set_Trivial_Subprogram --
3636 ----------------------------
3638 procedure Set_Trivial_Subprogram (N : Node_Id) is
3639 Nxt : constant Node_Id := Next (N);
3642 Set_Is_Trivial_Subprogram (Body_Id);
3644 if Present (Spec_Id) then
3645 Set_Is_Trivial_Subprogram (Spec_Id);
3649 and then Nkind (Nxt) = N_Simple_Return_Statement
3650 and then No (Next (Nxt))
3651 and then Present (Expression (Nxt))
3652 and then Is_Entity_Name (Expression (Nxt))
3654 Set_Never_Set_In_Source (Entity (Expression (Nxt)), False);
3656 end Set_Trivial_Subprogram;
3658 ---------------------------
3659 -- Unmask_Unfrozen_Types --
3660 ---------------------------
3662 procedure Unmask_Unfrozen_Types (Unmask_List : Elist_Id) is
3663 Elmt : Elmt_Id := First_Elmt (Unmask_List);
3666 while Present (Elmt) loop
3667 Set_Is_Frozen (Node (Elmt), False);
3670 end Unmask_Unfrozen_Types;
3672 ---------------------------------
3673 -- Verify_Overriding_Indicator --
3674 ---------------------------------
3676 procedure Verify_Overriding_Indicator is
3678 if Must_Override (Body_Spec) then
3679 if Nkind (Spec_Id) = N_Defining_Operator_Symbol
3680 and then Operator_Matches_Spec (Spec_Id, Spec_Id)
3684 -- Overridden controlled primitives may have had their
3685 -- Overridden_Operation field cleared according to the setting of
3686 -- the Is_Hidden flag. An issue arises, however, when analyzing
3687 -- an instance that may have manipulated the flag during
3688 -- expansion. As a result, we add an exception for this case.
3690 elsif not Present (Overridden_Operation (Spec_Id))
3691 and then not (Chars (Spec_Id) in Name_Adjust
3694 and then In_Instance)
3697 ("subprogram& is not overriding", Body_Spec, Spec_Id);
3699 -- Overriding indicators aren't allowed for protected subprogram
3700 -- bodies (see the Confirmation in Ada Comment AC95-00213). Change
3701 -- this to a warning if -gnatd.E is enabled.
3703 elsif Ekind (Scope (Spec_Id)) = E_Protected_Type then
3704 Error_Msg_Warn := Error_To_Warning;
3706 ("<<overriding indicator not allowed for protected "
3707 & "subprogram body", Body_Spec);
3710 elsif Must_Not_Override (Body_Spec) then
3711 if Present (Overridden_Operation (Spec_Id)) then
3713 ("subprogram& overrides inherited operation",
3714 Body_Spec, Spec_Id);
3716 elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol
3717 and then Operator_Matches_Spec (Spec_Id, Spec_Id)
3720 ("subprogram& overrides predefined operator ",
3721 Body_Spec, Spec_Id);
3723 -- Overriding indicators aren't allowed for protected subprogram
3724 -- bodies (see the Confirmation in Ada Comment AC95-00213). Change
3725 -- this to a warning if -gnatd.E is enabled.
3727 elsif Ekind (Scope (Spec_Id)) = E_Protected_Type then
3728 Error_Msg_Warn := Error_To_Warning;
3731 ("<<overriding indicator not allowed "
3732 & "for protected subprogram body", Body_Spec);
3734 -- If this is not a primitive operation, then the overriding
3735 -- indicator is altogether illegal.
3737 elsif not Is_Primitive (Spec_Id) then
3739 ("overriding indicator only allowed "
3740 & "if subprogram is primitive", Body_Spec);
3743 -- If checking the style rule and the operation overrides, then
3744 -- issue a warning about a missing overriding_indicator. Protected
3745 -- subprogram bodies are excluded from this style checking, since
3746 -- they aren't primitives (even though their declarations can
3747 -- override) and aren't allowed to have an overriding_indicator.
3750 and then Present (Overridden_Operation (Spec_Id))
3751 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
3753 pragma Assert (Unit_Declaration_Node (Body_Id) = N);
3754 Style.Missing_Overriding (N, Body_Id);
3757 and then Can_Override_Operator (Spec_Id)
3758 and then not In_Predefined_Unit (Spec_Id)
3760 pragma Assert (Unit_Declaration_Node (Body_Id) = N);
3761 Style.Missing_Overriding (N, Body_Id);
3763 end Verify_Overriding_Indicator;
3767 Body_Nod : Node_Id := Empty;
3768 Minimum_Acc_Objs : List_Id := No_List;
3770 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3771 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3772 Saved_EA : constant Boolean := Expander_Active;
3773 Saved_ISMP : constant Boolean :=
3774 Ignore_SPARK_Mode_Pragmas_In_Instance;
3775 -- Save the Ghost and SPARK mode-related data to restore on exit
3777 -- Start of processing for Analyze_Subprogram_Body_Helper
3780 -- A [generic] subprogram body freezes the contract of the nearest
3781 -- enclosing package body and all other contracts encountered in the
3782 -- same declarative part up to and excluding the subprogram body:
3784 -- package body Nearest_Enclosing_Package
3785 -- with Refined_State => (State => Constit)
3789 -- procedure Freezes_Enclosing_Package_Body
3790 -- with Refined_Depends => (Input => Constit) ...
3792 -- This ensures that any annotations referenced by the contract of the
3793 -- [generic] subprogram body are available. This form of freezing is
3794 -- decoupled from the usual Freeze_xxx mechanism because it must also
3795 -- work in the context of generics where normal freezing is disabled.
3797 -- Only bodies coming from source should cause this type of freezing.
3798 -- Expression functions that act as bodies and complete an initial
3799 -- declaration must be included in this category, hence the use of
3802 if Comes_From_Source (Original_Node (N)) then
3803 Freeze_Previous_Contracts (N);
3806 -- Generic subprograms are handled separately. They always have a
3807 -- generic specification. Determine whether current scope has a
3808 -- previous declaration.
3810 -- If the subprogram body is defined within an instance of the same
3811 -- name, the instance appears as a package renaming, and will be hidden
3812 -- within the subprogram.
3814 if Present (Prev_Id)
3815 and then not Is_Overloadable (Prev_Id)
3816 and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
3817 or else Comes_From_Source (Prev_Id))
3819 if Is_Generic_Subprogram (Prev_Id) then
3822 -- A subprogram body is Ghost when it is stand-alone and subject
3823 -- to pragma Ghost or when the corresponding spec is Ghost. Set
3824 -- the mode now to ensure that any nodes generated during analysis
3825 -- and expansion are properly marked as Ghost.
3827 Mark_And_Set_Ghost_Body (N, Spec_Id);
3829 -- If the body completes the initial declaration of a compilation
3830 -- unit which is subject to pragma Elaboration_Checks, set the
3831 -- model specified by the pragma because it applies to all parts
3834 Install_Elaboration_Model (Spec_Id);
3836 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
3837 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
3839 Analyze_Generic_Subprogram_Body (N, Spec_Id);
3841 if Nkind (N) = N_Subprogram_Body then
3842 HSS := Handled_Statement_Sequence (N);
3843 Check_Missing_Return;
3848 -- Otherwise a previous entity conflicts with the subprogram name.
3849 -- Attempting to enter name will post error.
3852 Enter_Name (Body_Id);
3856 -- Non-generic case, find the subprogram declaration, if one was seen,
3857 -- or enter new overloaded entity in the current scope. If the
3858 -- Current_Entity is the Body_Id itself, the unit is being analyzed as
3859 -- part of the context of one of its subunits. No need to redo the
3862 elsif Prev_Id = Body_Id and then Has_Completion (Body_Id) then
3866 Body_Id := Analyze_Subprogram_Specification (Body_Spec);
3868 if Nkind (N) = N_Subprogram_Body_Stub
3869 or else No (Corresponding_Spec (N))
3871 if Is_Private_Concurrent_Primitive (Body_Id) then
3872 Spec_Id := Disambiguate_Spec;
3874 -- A subprogram body is Ghost when it is stand-alone and
3875 -- subject to pragma Ghost or when the corresponding spec is
3876 -- Ghost. Set the mode now to ensure that any nodes generated
3877 -- during analysis and expansion are properly marked as Ghost.
3879 Mark_And_Set_Ghost_Body (N, Spec_Id);
3881 -- If the body completes a compilation unit which is subject
3882 -- to pragma Elaboration_Checks, set the model specified by
3883 -- the pragma because it applies to all parts of the unit.
3885 Install_Elaboration_Model (Spec_Id);
3888 Spec_Id := Find_Corresponding_Spec (N);
3890 -- A subprogram body is Ghost when it is stand-alone and
3891 -- subject to pragma Ghost or when the corresponding spec is
3892 -- Ghost. Set the mode now to ensure that any nodes generated
3893 -- during analysis and expansion are properly marked as Ghost.
3895 Mark_And_Set_Ghost_Body (N, Spec_Id);
3897 -- If the body completes a compilation unit which is subject
3898 -- to pragma Elaboration_Checks, set the model specified by
3899 -- the pragma because it applies to all parts of the unit.
3901 Install_Elaboration_Model (Spec_Id);
3903 -- In GNATprove mode, if the body has no previous spec, create
3904 -- one so that the inlining machinery can operate properly.
3905 -- Transfer aspects, if any, to the new spec, so that they
3906 -- are legal and can be processed ahead of the body.
3907 -- We make two copies of the given spec, one for the new
3908 -- declaration, and one for the body.
3909 -- ??? This should be conditioned on front-end inlining rather
3910 -- than GNATprove_Mode.
3912 if No (Spec_Id) and then GNATprove_Mode
3914 -- Inlining does not apply during preanalysis of code
3916 and then Full_Analysis
3918 -- Inlining only applies to full bodies, not stubs
3920 and then Nkind (N) /= N_Subprogram_Body_Stub
3922 -- Inlining only applies to bodies in the source code, not to
3923 -- those generated by the compiler. In particular, expression
3924 -- functions, whose body is generated by the compiler, are
3925 -- treated specially by GNATprove.
3927 and then Comes_From_Source (Body_Id)
3929 -- This cannot be done for a compilation unit, which is not
3930 -- in a context where we can insert a new spec.
3932 and then Is_List_Member (N)
3934 -- Inlining only applies to subprograms without contracts,
3935 -- as a contract is a sign that GNATprove should perform a
3936 -- modular analysis of the subprogram instead of a contextual
3937 -- analysis at each call site. The same test is performed in
3938 -- Inline.Can_Be_Inlined_In_GNATprove_Mode. It is repeated
3939 -- here in another form (because the contract has not been
3940 -- attached to the body) to avoid front-end errors in case
3941 -- pragmas are used instead of aspects, because the
3942 -- corresponding pragmas in the body would not be transferred
3943 -- to the spec, leading to legality errors.
3945 and then not Body_Has_Contract
3946 and then not Inside_A_Generic
3948 Build_Subprogram_Declaration;
3950 -- If this is a function that returns a constrained array, and
3951 -- we are generating C code, create subprogram declaration
3952 -- to simplify subsequent C generation.
3955 and then Modify_Tree_For_C
3956 and then Nkind (Body_Spec) = N_Function_Specification
3957 and then Is_Array_Type (Etype (Body_Id))
3958 and then Is_Constrained (Etype (Body_Id))
3960 Build_Subprogram_Declaration;
3964 -- If this is a duplicate body, no point in analyzing it
3966 if Error_Posted (N) then
3970 -- A subprogram body should cause freezing of its own declaration,
3971 -- but if there was no previous explicit declaration, then the
3972 -- subprogram will get frozen too late (there may be code within
3973 -- the body that depends on the subprogram having been frozen,
3974 -- such as uses of extra formals), so we force it to be frozen
3975 -- here. Same holds if the body and spec are compilation units.
3976 -- Finally, if the return type is an anonymous access to protected
3977 -- subprogram, it must be frozen before the body because its
3978 -- expansion has generated an equivalent type that is used when
3979 -- elaborating the body.
3981 -- An exception in the case of Ada 2012, AI05-177: The bodies
3982 -- created for expression functions do not freeze.
3985 and then Nkind (Original_Node (N)) /= N_Expression_Function
3987 Freeze_Before (N, Body_Id);
3989 elsif Nkind (Parent (N)) = N_Compilation_Unit then
3990 Freeze_Before (N, Spec_Id);
3992 elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then
3993 Freeze_Before (N, Etype (Body_Id));
3997 Spec_Id := Corresponding_Spec (N);
3999 -- A subprogram body is Ghost when it is stand-alone and subject
4000 -- to pragma Ghost or when the corresponding spec is Ghost. Set
4001 -- the mode now to ensure that any nodes generated during analysis
4002 -- and expansion are properly marked as Ghost.
4004 Mark_And_Set_Ghost_Body (N, Spec_Id);
4006 -- If the body completes the initial declaration of a compilation
4007 -- unit which is subject to pragma Elaboration_Checks, set the
4008 -- model specified by the pragma because it applies to all parts
4011 Install_Elaboration_Model (Spec_Id);
4015 -- Deactivate expansion inside the body of ignored Ghost entities,
4016 -- as this code will ultimately be ignored. This avoids requiring the
4017 -- presence of run-time units which are not needed. Only do this for
4018 -- user entities, as internally generated entitities might still need
4019 -- to be expanded (e.g. those generated for types).
4021 if Present (Ignored_Ghost_Region)
4022 and then Comes_From_Source (Body_Id)
4024 Expander_Active := False;
4027 -- Previously we scanned the body to look for nested subprograms, and
4028 -- rejected an inline directive if nested subprograms were present,
4029 -- because the back-end would generate conflicting symbols for the
4030 -- nested bodies. This is now unnecessary.
4032 -- Look ahead to recognize a pragma Inline that appears after the body
4034 Check_Inline_Pragma (Spec_Id);
4036 -- Deal with special case of a fully private operation in the body of
4037 -- the protected type. We must create a declaration for the subprogram,
4038 -- in order to attach the subprogram that will be used in internal
4039 -- calls. We exclude compiler generated bodies from the expander since
4040 -- the issue does not arise for those cases.
4043 and then Comes_From_Source (N)
4044 and then Is_Protected_Type (Current_Scope)
4046 Spec_Id := Build_Internal_Protected_Declaration (N);
4049 -- If we are generating C and this is a function returning a constrained
4050 -- array type for which we must create a procedure with an extra out
4051 -- parameter, build and analyze the body now. The procedure declaration
4052 -- has already been created. We reuse the source body of the function,
4053 -- because in an instance it may contain global references that cannot
4054 -- be reanalyzed. The source function itself is not used any further,
4055 -- so we mark it as having a completion. If the subprogram is a stub the
4056 -- transformation is done later, when the proper body is analyzed.
4059 and then Modify_Tree_For_C
4060 and then Present (Spec_Id)
4061 and then Ekind (Spec_Id) = E_Function
4062 and then Nkind (N) /= N_Subprogram_Body_Stub
4063 and then Rewritten_For_C (Spec_Id)
4065 Set_Has_Completion (Spec_Id);
4067 Rewrite (N, Build_Procedure_Body_Form (Spec_Id, N));
4070 -- The entity for the created procedure must remain invisible, so it
4071 -- does not participate in resolution of subsequent references to the
4074 Set_Is_Immediately_Visible (Corresponding_Spec (N), False);
4078 -- If a separate spec is present, then deal with freezing issues
4080 if Present (Spec_Id) then
4081 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4082 Verify_Overriding_Indicator;
4084 -- In general, the spec will be frozen when we start analyzing the
4085 -- body. However, for internally generated operations, such as
4086 -- wrapper functions for inherited operations with controlling
4087 -- results, the spec may not have been frozen by the time we expand
4088 -- the freeze actions that include the bodies. In particular, extra
4089 -- formals for accessibility or for return-in-place may need to be
4090 -- generated. Freeze nodes, if any, are inserted before the current
4091 -- body. These freeze actions are also needed in Compile_Only mode to
4092 -- enable the proper back-end type annotations.
4093 -- They are necessary in any case to ensure proper elaboration order
4096 if Nkind (N) = N_Subprogram_Body
4097 and then Was_Expression_Function (N)
4098 and then not Has_Completion (Spec_Id)
4099 and then Serious_Errors_Detected = 0
4100 and then (Expander_Active
4101 or else Operating_Mode = Check_Semantics
4102 or else Is_Ignored_Ghost_Entity (Spec_Id))
4104 -- The body generated for an expression function that is not a
4105 -- completion is a freeze point neither for the profile nor for
4106 -- anything else. That's why, in order to prevent any freezing
4107 -- during analysis, we need to mask types declared outside the
4108 -- expression (and in an outer scope) that are not yet frozen.
4109 -- This also needs to be done in the case of an ignored Ghost
4110 -- expression function, where the expander isn't active.
4112 Set_Is_Frozen (Spec_Id);
4113 Mask_Types := Mask_Unfrozen_Types (Spec_Id);
4115 elsif not Is_Frozen (Spec_Id)
4116 and then Serious_Errors_Detected = 0
4118 Set_Has_Delayed_Freeze (Spec_Id);
4119 Freeze_Before (N, Spec_Id);
4123 -- If the subprogram has a class-wide clone, build its body as a copy
4124 -- of the original body, and rewrite body of original subprogram as a
4125 -- wrapper that calls the clone. If N is a stub, this construction will
4126 -- take place when the proper body is analyzed. No action needed if this
4127 -- subprogram has been eliminated.
4129 if Present (Spec_Id)
4130 and then Present (Class_Wide_Clone (Spec_Id))
4131 and then (Comes_From_Source (N) or else Was_Expression_Function (N))
4132 and then Nkind (N) /= N_Subprogram_Body_Stub
4133 and then not (Expander_Active and then Is_Eliminated (Spec_Id))
4135 Build_Class_Wide_Clone_Body (Spec_Id, N);
4137 -- This is the new body for the existing primitive operation
4139 Rewrite (N, Build_Class_Wide_Clone_Call
4140 (Sloc (N), New_List, Spec_Id, Parent (Spec_Id)));
4141 Set_Has_Completion (Spec_Id, False);
4146 -- Place subprogram on scope stack, and make formals visible. If there
4147 -- is a spec, the visible entity remains that of the spec.
4149 if Present (Spec_Id) then
4150 Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
4152 if Is_Child_Unit (Spec_Id) then
4153 Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False);
4157 Style.Check_Identifier (Body_Id, Spec_Id);
4160 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
4161 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
4163 if Is_Abstract_Subprogram (Spec_Id) then
4164 Error_Msg_N ("an abstract subprogram cannot have a body", N);
4168 Set_Convention (Body_Id, Convention (Spec_Id));
4169 Set_Has_Completion (Spec_Id);
4171 if Is_Protected_Type (Scope (Spec_Id)) then
4172 Prot_Typ := Scope (Spec_Id);
4175 -- If this is a body generated for a renaming, do not check for
4176 -- full conformance. The check is redundant, because the spec of
4177 -- the body is a copy of the spec in the renaming declaration,
4178 -- and the test can lead to spurious errors on nested defaults.
4180 if Present (Spec_Decl)
4181 and then not Comes_From_Source (N)
4183 (Nkind (Original_Node (Spec_Decl)) =
4184 N_Subprogram_Renaming_Declaration
4185 or else (Present (Corresponding_Body (Spec_Decl))
4187 Nkind (Unit_Declaration_Node
4188 (Corresponding_Body (Spec_Decl))) =
4189 N_Subprogram_Renaming_Declaration))
4193 -- Conversely, the spec may have been generated for specless body
4194 -- with an inline pragma. The entity comes from source, which is
4195 -- both semantically correct and necessary for proper inlining.
4196 -- The subprogram declaration itself is not in the source.
4198 elsif Comes_From_Source (N)
4199 and then Present (Spec_Decl)
4200 and then not Comes_From_Source (Spec_Decl)
4201 and then Has_Pragma_Inline (Spec_Id)
4208 Fully_Conformant, True, Conformant, Body_Id);
4211 -- If the body is not fully conformant, we have to decide if we
4212 -- should analyze it or not. If it has a really messed up profile
4213 -- then we probably should not analyze it, since we will get too
4214 -- many bogus messages.
4216 -- Our decision is to go ahead in the non-fully conformant case
4217 -- only if it is at least mode conformant with the spec. Note
4218 -- that the call to Check_Fully_Conformant has issued the proper
4219 -- error messages to complain about the lack of conformance.
4222 and then not Mode_Conformant (Body_Id, Spec_Id)
4228 -- In the case we are dealing with an expression function we check
4229 -- the formals attached to the spec instead of the body - so we don't
4230 -- reference body formals.
4232 if Spec_Id /= Body_Id
4233 and then not Is_Expression_Function (Spec_Id)
4235 Reference_Body_Formals (Spec_Id, Body_Id);
4238 Set_Ekind (Body_Id, E_Subprogram_Body);
4240 if Nkind (N) = N_Subprogram_Body_Stub then
4241 Set_Corresponding_Spec_Of_Stub (N, Spec_Id);
4246 Set_Corresponding_Spec (N, Spec_Id);
4248 -- Ada 2005 (AI-345): If the operation is a primitive operation
4249 -- of a concurrent type, the type of the first parameter has been
4250 -- replaced with the corresponding record, which is the proper
4251 -- run-time structure to use. However, within the body there may
4252 -- be uses of the formals that depend on primitive operations
4253 -- of the type (in particular calls in prefixed form) for which
4254 -- we need the original concurrent type. The operation may have
4255 -- several controlling formals, so the replacement must be done
4258 if Comes_From_Source (Spec_Id)
4259 and then Present (First_Entity (Spec_Id))
4260 and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
4261 and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
4262 and then Present (Interfaces (Etype (First_Entity (Spec_Id))))
4263 and then Present (Corresponding_Concurrent_Type
4264 (Etype (First_Entity (Spec_Id))))
4267 Typ : constant Entity_Id := Etype (First_Entity (Spec_Id));
4271 Form := First_Formal (Spec_Id);
4272 while Present (Form) loop
4273 if Etype (Form) = Typ then
4274 Set_Etype (Form, Corresponding_Concurrent_Type (Typ));
4282 -- Make the formals visible, and place subprogram on scope stack.
4283 -- This is also the point at which we set Last_Real_Spec_Entity
4284 -- to mark the entities which will not be moved to the body.
4286 Install_Formals (Spec_Id);
4287 Last_Real_Spec_Entity := Last_Entity (Spec_Id);
4289 -- Within an instance, add local renaming declarations so that
4290 -- gdb can retrieve the values of actuals more easily. This is
4291 -- only relevant if generating code.
4293 if Is_Generic_Instance (Spec_Id)
4294 and then Is_Wrapper_Package (Current_Scope)
4295 and then Expander_Active
4297 Build_Subprogram_Instance_Renamings (N, Current_Scope);
4300 Push_Scope (Spec_Id);
4302 -- Make sure that the subprogram is immediately visible. For
4303 -- child units that have no separate spec this is indispensable.
4304 -- Otherwise it is safe albeit redundant.
4306 Set_Is_Immediately_Visible (Spec_Id);
4309 Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
4310 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
4311 Set_Scope (Body_Id, Scope (Spec_Id));
4313 -- Case of subprogram body with no previous spec
4316 -- Check for style warning required
4320 -- Only apply check for source level subprograms for which checks
4321 -- have not been suppressed.
4323 and then Comes_From_Source (Body_Id)
4324 and then not Suppress_Style_Checks (Body_Id)
4326 -- No warnings within an instance
4328 and then not In_Instance
4330 -- No warnings for expression functions
4332 and then Nkind (Original_Node (N)) /= N_Expression_Function
4334 Style.Body_With_No_Spec (N);
4337 New_Overloaded_Entity (Body_Id);
4339 if Nkind (N) /= N_Subprogram_Body_Stub then
4340 Set_Acts_As_Spec (N);
4341 Generate_Definition (Body_Id);
4343 (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
4345 -- If the body is an entry wrapper created for an entry with
4346 -- preconditions, it must be compiled in the context of the
4347 -- enclosing synchronized object, because it may mention other
4348 -- operations of the type.
4350 if Is_Entry_Wrapper (Body_Id) then
4352 Prot : constant Entity_Id := Etype (First_Entity (Body_Id));
4355 Install_Declarations (Prot);
4359 Install_Formals (Body_Id);
4361 Push_Scope (Body_Id);
4364 -- For stubs and bodies with no previous spec, generate references to
4367 Generate_Reference_To_Formals (Body_Id);
4370 -- Entry barrier functions are generated outside the protected type and
4371 -- should not carry the SPARK_Mode of the enclosing context.
4373 if Nkind (N) = N_Subprogram_Body
4374 and then Is_Entry_Barrier_Function (N)
4378 -- The body is generated as part of expression function expansion. When
4379 -- the expression function appears in the visible declarations of a
4380 -- package, the body is added to the private declarations. Since both
4381 -- declarative lists may be subject to a different SPARK_Mode, inherit
4382 -- the mode of the spec.
4384 -- package P with SPARK_Mode is
4385 -- function Expr_Func ... is (...); -- original
4386 -- [function Expr_Func ...;] -- generated spec
4389 -- pragma SPARK_Mode (Off);
4390 -- [function Expr_Func ... is return ...;] -- generated body
4391 -- end P; -- mode is ON
4393 elsif not Comes_From_Source (N)
4394 and then Present (Spec_Id)
4395 and then Is_Expression_Function (Spec_Id)
4397 Set_SPARK_Pragma (Body_Id, SPARK_Pragma (Spec_Id));
4398 Set_SPARK_Pragma_Inherited
4399 (Body_Id, SPARK_Pragma_Inherited (Spec_Id));
4401 -- Set the SPARK_Mode from the current context (may be overwritten later
4402 -- with explicit pragma). Exclude the case where the SPARK_Mode appears
4403 -- initially on a stand-alone subprogram body, but is then relocated to
4404 -- a generated corresponding spec. In this scenario the mode is shared
4405 -- between the spec and body.
4407 elsif No (SPARK_Pragma (Body_Id)) then
4408 Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
4409 Set_SPARK_Pragma_Inherited (Body_Id);
4412 -- A subprogram body may be instantiated or inlined at a later pass.
4413 -- Restore the state of Ignore_SPARK_Mode_Pragmas_In_Instance when it
4414 -- applied to the initial declaration of the body.
4416 if Present (Spec_Id) then
4417 if Ignore_SPARK_Mode_Pragmas (Spec_Id) then
4418 Ignore_SPARK_Mode_Pragmas_In_Instance := True;
4422 -- Save the state of flag Ignore_SPARK_Mode_Pragmas_In_Instance in
4423 -- case the body is instantiated or inlined later and out of context.
4424 -- The body uses this attribute to restore the value of the global
4427 if Ignore_SPARK_Mode_Pragmas_In_Instance then
4428 Set_Ignore_SPARK_Mode_Pragmas (Body_Id);
4430 elsif Ignore_SPARK_Mode_Pragmas (Body_Id) then
4431 Ignore_SPARK_Mode_Pragmas_In_Instance := True;
4435 -- Preserve relevant elaboration-related attributes of the context which
4436 -- are no longer available or very expensive to recompute once analysis,
4437 -- resolution, and expansion are over.
4439 if No (Spec_Id) then
4440 Mark_Elaboration_Attributes
4446 -- If this is the proper body of a stub, we must verify that the stub
4447 -- conforms to the body, and to the previous spec if one was present.
4448 -- We know already that the body conforms to that spec. This test is
4449 -- only required for subprograms that come from source.
4451 if Nkind (Parent (N)) = N_Subunit
4452 and then Comes_From_Source (N)
4453 and then not Error_Posted (Body_Id)
4454 and then Nkind (Corresponding_Stub (Parent (N))) =
4455 N_Subprogram_Body_Stub
4458 Old_Id : constant Entity_Id :=
4460 (Specification (Corresponding_Stub (Parent (N))));
4462 Conformant : Boolean := False;
4465 if No (Spec_Id) then
4466 Check_Fully_Conformant (Body_Id, Old_Id);
4470 (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
4472 if not Conformant then
4474 -- The stub was taken to be a new declaration. Indicate that
4477 Set_Has_Completion (Old_Id, False);
4483 Set_Has_Completion (Body_Id);
4484 Check_Eliminated (Body_Id);
4486 -- Analyze any aspect specifications that appear on the subprogram body
4487 -- stub. Stop the analysis now as the stub does not have a declarative
4488 -- or a statement part, and it cannot be inlined.
4490 if Nkind (N) = N_Subprogram_Body_Stub then
4491 if Has_Aspects (N) then
4492 Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
4501 and then Serious_Errors_Detected = 0
4502 and then Present (Spec_Id)
4503 and then Has_Pragma_Inline (Spec_Id)
4505 -- Legacy implementation (relying on front-end inlining)
4507 if not Back_End_Inlining then
4508 if Has_Pragma_Inline_Always (Spec_Id)
4509 or else (Front_End_Inlining
4510 and then not Opt.Disable_FE_Inline)
4512 Build_Body_To_Inline (N, Spec_Id);
4515 -- New implementation (relying on back-end inlining)
4518 if Has_Pragma_Inline_Always (Spec_Id)
4519 or else Optimization_Level > 0
4521 -- Handle function returning an unconstrained type
4523 if Comes_From_Source (Body_Id)
4524 and then Ekind (Spec_Id) = E_Function
4525 and then Returns_Unconstrained_Type (Spec_Id)
4527 -- If function builds in place, i.e. returns a limited type,
4528 -- inlining cannot be done.
4530 and then not Is_Limited_Type (Etype (Spec_Id))
4532 Check_And_Split_Unconstrained_Function (N, Spec_Id, Body_Id);
4536 Subp_Body : constant Node_Id :=
4537 Unit_Declaration_Node (Body_Id);
4538 Subp_Decl : constant List_Id := Declarations (Subp_Body);
4541 -- Do not pass inlining to the backend if the subprogram
4542 -- has declarations or statements which cannot be inlined
4543 -- by the backend. This check is done here to emit an
4544 -- error instead of the generic warning message reported
4545 -- by the GCC backend (ie. "function might not be
4548 if Present (Subp_Decl)
4549 and then Has_Excluded_Declaration (Spec_Id, Subp_Decl)
4553 elsif Has_Excluded_Statement
4556 (Handled_Statement_Sequence (Subp_Body)))
4560 -- If the backend inlining is available then at this
4561 -- stage we only have to mark the subprogram as inlined.
4562 -- The expander will take care of registering it in the
4563 -- table of subprograms inlined by the backend a part of
4564 -- processing calls to it (cf. Expand_Call)
4567 Set_Is_Inlined (Spec_Id);
4574 -- In GNATprove mode, inline only when there is a separate subprogram
4575 -- declaration for now, as inlining of subprogram bodies acting as
4576 -- declarations, or subprogram stubs, are not supported by front-end
4577 -- inlining. This inlining should occur after analysis of the body, so
4578 -- that it is known whether the value of SPARK_Mode, which can be
4579 -- defined by a pragma inside the body, is applicable to the body.
4580 -- Inlining can be disabled with switch -gnatdm
4582 elsif GNATprove_Mode
4583 and then Full_Analysis
4584 and then not Inside_A_Generic
4585 and then Present (Spec_Id)
4587 Nkind (Unit_Declaration_Node (Spec_Id)) = N_Subprogram_Declaration
4588 and then Body_Has_SPARK_Mode_On
4589 and then Can_Be_Inlined_In_GNATprove_Mode (Spec_Id, Body_Id)
4590 and then not Body_Has_Contract
4591 and then not Debug_Flag_M
4593 Build_Body_To_Inline (N, Spec_Id);
4596 -- When generating code, inherited pre/postconditions are handled when
4597 -- expanding the corresponding contract.
4599 -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
4600 -- of the specification we have to install the private withed units.
4601 -- This holds for child units as well.
4603 if Is_Compilation_Unit (Body_Id)
4604 or else Nkind (Parent (N)) = N_Compilation_Unit
4606 Install_Private_With_Clauses (Body_Id);
4609 Check_Anonymous_Return;
4611 -- Set the Protected_Formal field of each extra formal of the protected
4612 -- subprogram to reference the corresponding extra formal of the
4613 -- subprogram that implements it. For regular formals this occurs when
4614 -- the protected subprogram's declaration is expanded, but the extra
4615 -- formals don't get created until the subprogram is frozen. We need to
4616 -- do this before analyzing the protected subprogram's body so that any
4617 -- references to the original subprogram's extra formals will be changed
4618 -- refer to the implementing subprogram's formals (see Expand_Formal).
4620 if Present (Spec_Id)
4621 and then Is_Protected_Type (Scope (Spec_Id))
4622 and then Present (Protected_Body_Subprogram (Spec_Id))
4625 Impl_Subp : constant Entity_Id :=
4626 Protected_Body_Subprogram (Spec_Id);
4627 Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id);
4628 Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp);
4631 while Present (Prot_Ext_Formal) loop
4632 pragma Assert (Present (Impl_Ext_Formal));
4633 Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
4634 Next_Formal_With_Extras (Prot_Ext_Formal);
4635 Next_Formal_With_Extras (Impl_Ext_Formal);
4640 -- Generate minimum accessibility local objects to correspond with
4641 -- any extra formal added for anonymous access types. This new local
4642 -- object can then be used instead of the formal in case it is used
4643 -- in an actual to a call to a nested subprogram.
4645 -- This method is used to supplement our "small integer model" for
4646 -- accessibility-check generation (for more information see
4647 -- Dynamic_Accessibility_Level).
4649 -- Because we allow accessibility values greater than our expected value
4650 -- passing along the same extra accessibility formal as an actual
4651 -- to a nested subprogram becomes a problem because high values mean
4652 -- different things to the callee even though they are the same to the
4653 -- caller. So, as described in the first section, we create a local
4654 -- object representing the minimum of the accessibility level value that
4655 -- is passed in and the accessibility level of the callee's parameter
4656 -- and locals and use it in the case of a call to a nested subprogram.
4657 -- This generated object is refered to as a "minimum accessiblity
4660 if Present (Spec_Id) or else Present (Body_Id) then
4661 Body_Nod := Unit_Declaration_Node (Body_Id);
4666 -- Grab the appropriate formal depending on whether there exists
4667 -- an actual spec for the subprogram or whether we are dealing
4668 -- with a protected subprogram.
4670 if Present (Spec_Id) then
4671 if Present (Protected_Body_Subprogram (Spec_Id)) then
4672 Form := First_Formal (Protected_Body_Subprogram (Spec_Id));
4674 Form := First_Formal (Spec_Id);
4677 Form := First_Formal (Body_Id);
4680 -- Loop through formals if the subprogram is capable of accepting
4681 -- a generated local object. If it is not then it is also not
4682 -- capable of having local subprograms meaning it would not need
4683 -- a minimum accessibility level object anyway.
4685 if Present (Body_Nod)
4686 and then Has_Declarations (Body_Nod)
4687 and then Nkind (Body_Nod) /= N_Package_Specification
4689 while Present (Form) loop
4691 if Present (Extra_Accessibility (Form))
4692 and then No (Minimum_Accessibility (Form))
4694 -- Generate the minimum accessibility level object
4696 -- A60b : natural := natural'min(1, paramL);
4699 Loc : constant Source_Ptr := Sloc (Body_Nod);
4700 Obj_Node : constant Node_Id :=
4701 Make_Object_Declaration (Loc,
4702 Defining_Identifier =>
4704 (Loc, 'A', Extra_Accessibility (Form)),
4705 Object_Definition => New_Occurrence_Of
4706 (Standard_Natural, Loc),
4708 Make_Attribute_Reference (Loc,
4709 Prefix => New_Occurrence_Of
4710 (Standard_Natural, Loc),
4711 Attribute_Name => Name_Min,
4712 Expressions => New_List (
4713 Make_Integer_Literal (Loc,
4714 Object_Access_Level (Form)),
4716 (Extra_Accessibility (Form), Loc))));
4718 -- Add the new local object to the Minimum_Acc_Obj to
4719 -- be later prepended to the subprogram's list of
4720 -- declarations after we are sure all expansion is
4723 if Present (Minimum_Acc_Objs) then
4724 Prepend (Obj_Node, Minimum_Acc_Objs);
4726 Minimum_Acc_Objs := New_List (Obj_Node);
4729 -- Register the object and analyze it
4731 Set_Minimum_Accessibility
4732 (Form, Defining_Identifier (Obj_Node));
4744 -- Now we can go on to analyze the body
4746 HSS := Handled_Statement_Sequence (N);
4747 Set_Actual_Subtypes (N, Current_Scope);
4749 -- Add a declaration for the Protection object, renaming declarations
4750 -- for discriminals and privals and finally a declaration for the entry
4751 -- family index (if applicable). This form of early expansion is done
4752 -- when the Expander is active because Install_Private_Data_Declarations
4753 -- references entities which were created during regular expansion. The
4754 -- subprogram entity must come from source, and not be an internally
4755 -- generated subprogram.
4758 and then Present (Prot_Typ)
4759 and then Present (Spec_Id)
4760 and then Comes_From_Source (Spec_Id)
4761 and then not Is_Eliminated (Spec_Id)
4763 Install_Private_Data_Declarations
4764 (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N));
4767 -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context
4768 -- may now appear in parameter and result profiles. Since the analysis
4769 -- of a subprogram body may use the parameter and result profile of the
4770 -- spec, swap any limited views with their non-limited counterpart.
4772 if Ada_Version >= Ada_2012 and then Present (Spec_Id) then
4773 Exch_Views := Exchange_Limited_Views (Spec_Id);
4776 -- If the return type is an anonymous access type whose designated type
4777 -- is the limited view of a class-wide type and the non-limited view is
4778 -- available, update the return type accordingly.
4780 if Ada_Version >= Ada_2005 and then Present (Spec_Id) then
4786 Rtyp := Etype (Spec_Id);
4788 if Ekind (Rtyp) = E_Anonymous_Access_Type then
4789 Etyp := Directly_Designated_Type (Rtyp);
4791 if Is_Class_Wide_Type (Etyp)
4792 and then From_Limited_With (Etyp)
4795 Set_Directly_Designated_Type (Rtyp, Available_View (Etyp));
4801 -- Analyze any aspect specifications that appear on the subprogram body
4803 if Has_Aspects (N) then
4804 Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
4807 Analyze_Declarations (Declarations (N));
4809 -- Verify that the SPARK_Mode of the body agrees with that of its spec
4811 if Present (Spec_Id) and then Present (SPARK_Pragma (Body_Id)) then
4812 if Present (SPARK_Pragma (Spec_Id)) then
4813 if Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) = Off
4815 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = On
4817 Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id));
4818 Error_Msg_N ("incorrect application of SPARK_Mode#", N);
4819 Error_Msg_Sloc := Sloc (SPARK_Pragma (Spec_Id));
4821 ("\value Off was set for SPARK_Mode on & #", N, Spec_Id);
4824 elsif Nkind (Parent (Parent (Spec_Id))) = N_Subprogram_Body_Stub then
4827 -- SPARK_Mode Off could complete no SPARK_Mode in a generic, either
4828 -- as specified in source code, or because SPARK_Mode On is ignored
4829 -- in an instance where the context is SPARK_Mode Off/Auto.
4831 elsif Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = Off
4832 and then (Is_Generic_Unit (Spec_Id) or else In_Instance)
4837 Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id));
4838 Error_Msg_N ("incorrect application of SPARK_Mode #", N);
4839 Error_Msg_Sloc := Sloc (Spec_Id);
4841 ("\no value was set for SPARK_Mode on & #", N, Spec_Id);
4845 -- A subprogram body freezes its own contract. Analyze the contract
4846 -- after the declarations of the body have been processed as pragmas
4847 -- are now chained on the contract of the subprogram body.
4849 Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id);
4851 -- Check completion, and analyze the statements
4854 Inspect_Deferred_Constant_Completion (Declarations (N));
4857 -- Add the generated minimum accessibility objects to the subprogram
4858 -- body's list of declarations after analysis of the statements and
4861 while Is_Non_Empty_List (Minimum_Acc_Objs) loop
4862 if Present (Declarations (Body_Nod)) then
4863 Prepend (Remove_Head (Minimum_Acc_Objs), Declarations (Body_Nod));
4866 (Body_Nod, New_List (Remove_Head (Minimum_Acc_Objs)));
4870 -- Deal with end of scope processing for the body
4872 Process_End_Label (HSS, 't', Current_Scope);
4873 Update_Use_Clause_Chain;
4876 -- If we are compiling an entry wrapper, remove the enclosing
4877 -- synchronized object from the stack.
4879 if Is_Entry_Wrapper (Body_Id) then
4883 Check_Subprogram_Order (N);
4884 Set_Analyzed (Body_Id);
4886 -- If we have a separate spec, then the analysis of the declarations
4887 -- caused the entities in the body to be chained to the spec id, but
4888 -- we want them chained to the body id. Only the formal parameters
4889 -- end up chained to the spec id in this case.
4891 if Present (Spec_Id) then
4893 -- We must conform to the categorization of our spec
4895 Validate_Categorization_Dependency (N, Spec_Id);
4897 -- And if this is a child unit, the parent units must conform
4899 if Is_Child_Unit (Spec_Id) then
4900 Validate_Categorization_Dependency
4901 (Unit_Declaration_Node (Spec_Id), Spec_Id);
4904 -- Here is where we move entities from the spec to the body
4906 -- Case where there are entities that stay with the spec
4908 if Present (Last_Real_Spec_Entity) then
4910 -- No body entities (happens when the only real spec entities come
4911 -- from precondition and postcondition pragmas).
4913 if No (Last_Entity (Body_Id)) then
4914 Set_First_Entity (Body_Id, Next_Entity (Last_Real_Spec_Entity));
4916 -- Body entities present (formals), so chain stuff past them
4920 (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity));
4923 Set_Next_Entity (Last_Real_Spec_Entity, Empty);
4924 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
4925 Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity);
4927 -- Case where there are no spec entities, in this case there can be
4928 -- no body entities either, so just move everything.
4930 -- If the body is generated for an expression function, it may have
4931 -- been preanalyzed already, if 'access was applied to it.
4934 if Nkind (Original_Node (Unit_Declaration_Node (Spec_Id))) /=
4935 N_Expression_Function
4937 pragma Assert (No (Last_Entity (Body_Id)));
4941 Set_First_Entity (Body_Id, First_Entity (Spec_Id));
4942 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
4943 Set_First_Entity (Spec_Id, Empty);
4944 Set_Last_Entity (Spec_Id, Empty);
4947 -- Otherwise the body does not complete a previous declaration. Check
4948 -- the categorization of the body against the units it withs.
4951 Validate_Categorization_Dependency (N, Body_Id);
4954 Check_Missing_Return;
4956 -- Now we are going to check for variables that are never modified in
4957 -- the body of the procedure. But first we deal with a special case
4958 -- where we want to modify this check. If the body of the subprogram
4959 -- starts with a raise statement or its equivalent, or if the body
4960 -- consists entirely of a null statement, then it is pretty obvious that
4961 -- it is OK to not reference the parameters. For example, this might be
4962 -- the following common idiom for a stubbed function: statement of the
4963 -- procedure raises an exception. In particular this deals with the
4964 -- common idiom of a stubbed function, which appears something like:
4966 -- function F (A : Integer) return Some_Type;
4969 -- raise Program_Error;
4973 -- Here the purpose of X is simply to satisfy the annoying requirement
4974 -- in Ada that there be at least one return, and we certainly do not
4975 -- want to go posting warnings on X that it is not initialized. On
4976 -- the other hand, if X is entirely unreferenced that should still
4979 -- What we do is to detect these cases, and if we find them, flag the
4980 -- subprogram as being Is_Trivial_Subprogram and then use that flag to
4981 -- suppress unwanted warnings. For the case of the function stub above
4982 -- we have a special test to set X as apparently assigned to suppress
4989 -- Skip call markers installed by the ABE mechanism, labels, and
4990 -- Push_xxx_Error_Label to find the first real statement.
4992 Stm := First (Statements (HSS));
4993 while Nkind (Stm) in N_Call_Marker | N_Label | N_Push_xxx_Label loop
4997 -- Do the test on the original statement before expansion
5000 Ostm : constant Node_Id := Original_Node (Stm);
5003 -- If explicit raise statement, turn on flag
5005 if Nkind (Ostm) = N_Raise_Statement then
5006 Set_Trivial_Subprogram (Stm);
5008 -- If null statement, and no following statements, turn on flag
5010 elsif Nkind (Stm) = N_Null_Statement
5011 and then Comes_From_Source (Stm)
5012 and then No (Next (Stm))
5014 Set_Trivial_Subprogram (Stm);
5016 -- Check for explicit call cases which likely raise an exception
5018 elsif Nkind (Ostm) = N_Procedure_Call_Statement then
5019 if Is_Entity_Name (Name (Ostm)) then
5021 Ent : constant Entity_Id := Entity (Name (Ostm));
5024 -- If the procedure is marked No_Return, then likely it
5025 -- raises an exception, but in any case it is not coming
5026 -- back here, so turn on the flag.
5029 and then Ekind (Ent) = E_Procedure
5030 and then No_Return (Ent)
5032 Set_Trivial_Subprogram (Stm);
5040 -- Check for variables that are never modified
5047 -- If there is a separate spec, then transfer Never_Set_In_Source
5048 -- flags from out parameters to the corresponding entities in the
5049 -- body. The reason we do that is we want to post error flags on
5050 -- the body entities, not the spec entities.
5052 if Present (Spec_Id) then
5053 E1 := First_Entity (Spec_Id);
5054 while Present (E1) loop
5055 if Ekind (E1) = E_Out_Parameter then
5056 E2 := First_Entity (Body_Id);
5057 while Present (E2) loop
5058 exit when Chars (E1) = Chars (E2);
5062 if Present (E2) then
5063 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
5071 -- Check references of the subprogram spec when we are dealing with
5072 -- an expression function due to it having a generated body.
5073 -- Otherwise, we simply check the formals of the subprogram body.
5075 if Present (Spec_Id)
5076 and then Is_Expression_Function (Spec_Id)
5078 Check_References (Spec_Id);
5080 Check_References (Body_Id);
5084 -- Check for nested subprogram, and mark outer level subprogram if so
5090 if Present (Spec_Id) then
5097 Ent := Enclosing_Subprogram (Ent);
5098 exit when No (Ent) or else Is_Subprogram (Ent);
5101 if Present (Ent) then
5102 Set_Has_Nested_Subprogram (Ent);
5106 -- Restore the limited views in the spec, if any, to let the back end
5107 -- process it without running into circularities.
5109 if Exch_Views /= No_Elist then
5110 Restore_Limited_Views (Exch_Views);
5113 if Mask_Types /= No_Elist then
5114 Unmask_Unfrozen_Types (Mask_Types);
5117 if Present (Desig_View) then
5118 Set_Directly_Designated_Type (Etype (Spec_Id), Desig_View);
5122 if Present (Ignored_Ghost_Region) then
5123 Expander_Active := Saved_EA;
5126 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
5127 Restore_Ghost_Region (Saved_GM, Saved_IGR);
5128 end Analyze_Subprogram_Body_Helper;
5130 ------------------------------------
5131 -- Analyze_Subprogram_Declaration --
5132 ------------------------------------
5134 procedure Analyze_Subprogram_Declaration (N : Node_Id) is
5135 Scop : constant Entity_Id := Current_Scope;
5136 Designator : Entity_Id;
5138 Is_Completion : Boolean;
5139 -- Indicates whether a null procedure declaration is a completion
5142 -- Null procedures are not allowed in SPARK
5144 if Nkind (Specification (N)) = N_Procedure_Specification
5145 and then Null_Present (Specification (N))
5147 -- Null procedures are allowed in protected types, following the
5148 -- recent AI12-0147.
5150 if Is_Protected_Type (Current_Scope)
5151 and then Ada_Version < Ada_2012
5153 Error_Msg_N ("protected operation cannot be a null procedure", N);
5156 Analyze_Null_Procedure (N, Is_Completion);
5158 -- The null procedure acts as a body, nothing further is needed
5160 if Is_Completion then
5165 Designator := Analyze_Subprogram_Specification (Specification (N));
5167 -- A reference may already have been generated for the unit name, in
5168 -- which case the following call is redundant. However it is needed for
5169 -- declarations that are the rewriting of an expression function.
5171 Generate_Definition (Designator);
5173 -- Set the SPARK mode from the current context (may be overwritten later
5174 -- with explicit pragma). This is not done for entry barrier functions
5175 -- because they are generated outside the protected type and should not
5176 -- carry the mode of the enclosing context.
5178 if Nkind (N) = N_Subprogram_Declaration
5179 and then Is_Entry_Barrier_Function (N)
5184 Set_SPARK_Pragma (Designator, SPARK_Mode_Pragma);
5185 Set_SPARK_Pragma_Inherited (Designator);
5188 -- Save the state of flag Ignore_SPARK_Mode_Pragmas_In_Instance in case
5189 -- the body of this subprogram is instantiated or inlined later and out
5190 -- of context. The body uses this attribute to restore the value of the
5193 if Ignore_SPARK_Mode_Pragmas_In_Instance then
5194 Set_Ignore_SPARK_Mode_Pragmas (Designator);
5197 -- Preserve relevant elaboration-related attributes of the context which
5198 -- are no longer available or very expensive to recompute once analysis,
5199 -- resolution, and expansion are over.
5201 Mark_Elaboration_Attributes
5202 (N_Id => Designator,
5206 if Debug_Flag_C then
5207 Write_Str ("==> subprogram spec ");
5208 Write_Name (Chars (Designator));
5209 Write_Str (" from ");
5210 Write_Location (Sloc (N));
5215 Validate_RCI_Subprogram_Declaration (N);
5216 New_Overloaded_Entity (Designator);
5217 Check_Delayed_Subprogram (Designator);
5219 -- If the type of the first formal of the current subprogram is a non-
5220 -- generic tagged private type, mark the subprogram as being a private
5221 -- primitive. Ditto if this is a function with controlling result, and
5222 -- the return type is currently private. In both cases, the type of the
5223 -- controlling argument or result must be in the current scope for the
5224 -- operation to be primitive.
5226 if Has_Controlling_Result (Designator)
5227 and then Is_Private_Type (Etype (Designator))
5228 and then Scope (Etype (Designator)) = Current_Scope
5229 and then not Is_Generic_Actual_Type (Etype (Designator))
5231 Set_Is_Private_Primitive (Designator);
5233 elsif Present (First_Formal (Designator)) then
5235 Formal_Typ : constant Entity_Id :=
5236 Etype (First_Formal (Designator));
5238 Set_Is_Private_Primitive (Designator,
5239 Is_Tagged_Type (Formal_Typ)
5240 and then Scope (Formal_Typ) = Current_Scope
5241 and then Is_Private_Type (Formal_Typ)
5242 and then not Is_Generic_Actual_Type (Formal_Typ));
5246 -- Ada 2005 (AI-251): Abstract interface primitives must be abstract
5249 if Ada_Version >= Ada_2005
5250 and then Comes_From_Source (N)
5251 and then Is_Dispatching_Operation (Designator)
5258 if Has_Controlling_Result (Designator) then
5259 Etyp := Etype (Designator);
5262 E := First_Entity (Designator);
5264 and then Is_Formal (E)
5265 and then not Is_Controlling_Formal (E)
5273 if Is_Access_Type (Etyp) then
5274 Etyp := Directly_Designated_Type (Etyp);
5277 if Is_Interface (Etyp)
5278 and then not Is_Abstract_Subprogram (Designator)
5279 and then not (Ekind (Designator) = E_Procedure
5280 and then Null_Present (Specification (N)))
5282 Error_Msg_Name_1 := Chars (Defining_Entity (N));
5284 -- Specialize error message based on procedures vs. functions,
5285 -- since functions can't be null subprograms.
5287 if Ekind (Designator) = E_Procedure then
5289 ("interface procedure % must be abstract or null", N);
5292 ("interface function % must be abstract", N);
5298 -- What is the following code for, it used to be
5300 -- ??? Set_Suppress_Elaboration_Checks
5301 -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
5303 -- The following seems equivalent, but a bit dubious
5305 if Elaboration_Checks_Suppressed (Designator) then
5306 Set_Kill_Elaboration_Checks (Designator);
5309 -- For a compilation unit, set body required. This flag will only be
5310 -- reset if a valid Import or Interface pragma is processed later on.
5312 if Nkind (Parent (N)) = N_Compilation_Unit then
5313 Set_Body_Required (Parent (N), True);
5315 if Ada_Version >= Ada_2005
5316 and then Nkind (Specification (N)) = N_Procedure_Specification
5317 and then Null_Present (Specification (N))
5320 ("null procedure cannot be declared at library level", N);
5324 Generate_Reference_To_Formals (Designator);
5325 Check_Eliminated (Designator);
5327 if Debug_Flag_C then
5329 Write_Str ("<== subprogram spec ");
5330 Write_Name (Chars (Designator));
5331 Write_Str (" from ");
5332 Write_Location (Sloc (N));
5336 -- Indicate that this is a protected operation, because it may be used
5337 -- in subsequent declarations within the protected type.
5339 if Is_Protected_Type (Current_Scope) then
5340 Set_Convention (Designator, Convention_Protected);
5343 List_Inherited_Pre_Post_Aspects (Designator);
5345 -- Process the aspects before establishing the proper categorization in
5346 -- case the subprogram is a compilation unit and one of its aspects is
5347 -- converted into a categorization pragma.
5349 if Has_Aspects (N) then
5350 Analyze_Aspect_Specifications (N, Designator);
5353 if Scop /= Standard_Standard and then not Is_Child_Unit (Designator) then
5354 Set_Categorization_From_Scope (Designator, Scop);
5356 -- Otherwise the unit is a compilation unit and/or a child unit. Set the
5357 -- proper categorization of the unit based on its pragmas.
5360 Push_Scope (Designator);
5361 Set_Categorization_From_Pragmas (N);
5362 Validate_Categorization_Dependency (N, Designator);
5365 end Analyze_Subprogram_Declaration;
5367 --------------------------------------
5368 -- Analyze_Subprogram_Specification --
5369 --------------------------------------
5371 -- Reminder: N here really is a subprogram specification (not a subprogram
5372 -- declaration). This procedure is called to analyze the specification in
5373 -- both subprogram bodies and subprogram declarations (specs).
5375 function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
5376 function Is_Invariant_Procedure_Or_Body (E : Entity_Id) return Boolean;
5377 -- Determine whether entity E denotes the spec or body of an invariant
5380 ------------------------------------
5381 -- Is_Invariant_Procedure_Or_Body --
5382 ------------------------------------
5384 function Is_Invariant_Procedure_Or_Body (E : Entity_Id) return Boolean is
5385 Decl : constant Node_Id := Unit_Declaration_Node (E);
5389 if Nkind (Decl) = N_Subprogram_Body then
5390 Spec := Corresponding_Spec (Decl);
5397 and then Ekind (Spec) = E_Procedure
5398 and then (Is_Partial_Invariant_Procedure (Spec)
5399 or else Is_Invariant_Procedure (Spec));
5400 end Is_Invariant_Procedure_Or_Body;
5404 Designator : constant Entity_Id := Defining_Entity (N);
5405 Formals : constant List_Id := Parameter_Specifications (N);
5407 -- Start of processing for Analyze_Subprogram_Specification
5410 -- Proceed with analysis. Do not emit a cross-reference entry if the
5411 -- specification comes from an expression function, because it may be
5412 -- the completion of a previous declaration. If it is not, the cross-
5413 -- reference entry will be emitted for the new subprogram declaration.
5415 if Nkind (Parent (N)) /= N_Expression_Function then
5416 Generate_Definition (Designator);
5419 if Nkind (N) = N_Function_Specification then
5420 Set_Ekind (Designator, E_Function);
5421 Set_Mechanism (Designator, Default_Mechanism);
5423 Set_Ekind (Designator, E_Procedure);
5424 Set_Etype (Designator, Standard_Void_Type);
5427 -- Flag Is_Inlined_Always is True by default, and reversed to False for
5428 -- those subprograms which could be inlined in GNATprove mode (because
5429 -- Body_To_Inline is non-Empty) but should not be inlined.
5431 if GNATprove_Mode then
5432 Set_Is_Inlined_Always (Designator);
5435 -- Introduce new scope for analysis of the formals and the return type
5437 Set_Scope (Designator, Current_Scope);
5439 if Present (Formals) then
5440 Push_Scope (Designator);
5441 Process_Formals (Formals, N);
5443 -- Check dimensions in N for formals with default expression
5445 Analyze_Dimension_Formals (N, Formals);
5447 -- Ada 2005 (AI-345): If this is an overriding operation of an
5448 -- inherited interface operation, and the controlling type is
5449 -- a synchronized type, replace the type with its corresponding
5450 -- record, to match the proper signature of an overriding operation.
5451 -- Same processing for an access parameter whose designated type is
5452 -- derived from a synchronized interface.
5454 -- This modification is not done for invariant procedures because
5455 -- the corresponding record may not necessarely be visible when the
5456 -- concurrent type acts as the full view of a private type.
5459 -- type Prot is private with Type_Invariant => ...;
5460 -- procedure ConcInvariant (Obj : Prot);
5462 -- protected type Prot is ...;
5463 -- type Concurrent_Record_Prot is record ...;
5464 -- procedure ConcInvariant (Obj : Prot) is
5466 -- end ConcInvariant;
5469 -- In the example above, both the spec and body of the invariant
5470 -- procedure must utilize the private type as the controlling type.
5472 if Ada_Version >= Ada_2005
5473 and then not Is_Invariant_Procedure_Or_Body (Designator)
5477 Formal_Typ : Entity_Id;
5478 Rec_Typ : Entity_Id;
5479 Desig_Typ : Entity_Id;
5482 Formal := First_Formal (Designator);
5483 while Present (Formal) loop
5484 Formal_Typ := Etype (Formal);
5486 if Is_Concurrent_Type (Formal_Typ)
5487 and then Present (Corresponding_Record_Type (Formal_Typ))
5489 Rec_Typ := Corresponding_Record_Type (Formal_Typ);
5491 if Present (Interfaces (Rec_Typ)) then
5492 Set_Etype (Formal, Rec_Typ);
5495 elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then
5496 Desig_Typ := Designated_Type (Formal_Typ);
5498 if Is_Concurrent_Type (Desig_Typ)
5499 and then Present (Corresponding_Record_Type (Desig_Typ))
5501 Rec_Typ := Corresponding_Record_Type (Desig_Typ);
5503 if Present (Interfaces (Rec_Typ)) then
5504 Set_Directly_Designated_Type (Formal_Typ, Rec_Typ);
5509 Next_Formal (Formal);
5516 -- The subprogram scope is pushed and popped around the processing of
5517 -- the return type for consistency with call above to Process_Formals
5518 -- (which itself can call Analyze_Return_Type), and to ensure that any
5519 -- itype created for the return type will be associated with the proper
5522 elsif Nkind (N) = N_Function_Specification then
5523 Push_Scope (Designator);
5524 Analyze_Return_Type (N);
5530 if Nkind (N) = N_Function_Specification then
5532 -- Deal with operator symbol case
5534 if Nkind (Designator) = N_Defining_Operator_Symbol then
5535 Valid_Operator_Definition (Designator);
5538 May_Need_Actuals (Designator);
5540 -- Ada 2005 (AI-251): If the return type is abstract, verify that
5541 -- the subprogram is abstract also. This does not apply to renaming
5542 -- declarations, where abstractness is inherited, and to subprogram
5543 -- bodies generated for stream operations, which become renamings as
5546 -- In case of primitives associated with abstract interface types
5547 -- the check is applied later (see Analyze_Subprogram_Declaration).
5549 if Nkind (Original_Node (Parent (N))) not in
5550 N_Abstract_Subprogram_Declaration |
5551 N_Formal_Abstract_Subprogram_Declaration |
5552 N_Subprogram_Renaming_Declaration
5554 if Is_Abstract_Type (Etype (Designator)) then
5556 ("function that returns abstract type must be abstract", N);
5558 -- Ada 2012 (AI-0073): Extend this test to subprograms with an
5559 -- access result whose designated type is abstract.
5561 elsif Ada_Version >= Ada_2012
5562 and then Nkind (Result_Definition (N)) = N_Access_Definition
5564 not Is_Class_Wide_Type (Designated_Type (Etype (Designator)))
5565 and then Is_Abstract_Type (Designated_Type (Etype (Designator)))
5568 ("function whose access result designates abstract type "
5569 & "must be abstract", N);
5575 end Analyze_Subprogram_Specification;
5577 -----------------------
5578 -- Check_Conformance --
5579 -----------------------
5581 procedure Check_Conformance
5582 (New_Id : Entity_Id;
5584 Ctype : Conformance_Type;
5586 Conforms : out Boolean;
5587 Err_Loc : Node_Id := Empty;
5588 Get_Inst : Boolean := False;
5589 Skip_Controlling_Formals : Boolean := False)
5591 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
5592 -- Sets Conforms to False. If Errmsg is False, then that's all it does.
5593 -- If Errmsg is True, then processing continues to post an error message
5594 -- for conformance error on given node. Two messages are output. The
5595 -- first message points to the previous declaration with a general "no
5596 -- conformance" message. The second is the detailed reason, supplied as
5597 -- Msg. The parameter N provide information for a possible & insertion
5598 -- in the message, and also provides the location for posting the
5599 -- message in the absence of a specified Err_Loc location.
5601 function Conventions_Match (Id1, Id2 : Entity_Id) return Boolean;
5602 -- True if the conventions of entities Id1 and Id2 match.
5604 function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean;
5605 -- True if the null exclusions of two formals of anonymous access type
5608 -----------------------
5609 -- Conformance_Error --
5610 -----------------------
5612 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
5619 if No (Err_Loc) then
5625 Error_Msg_Sloc := Sloc (Old_Id);
5628 when Type_Conformant =>
5629 Error_Msg_N -- CODEFIX
5630 ("not type conformant with declaration#!", Enode);
5632 when Mode_Conformant =>
5633 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
5635 ("not mode conformant with operation inherited#!",
5639 ("not mode conformant with declaration#!", Enode);
5642 when Subtype_Conformant =>
5643 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
5645 ("not subtype conformant with operation inherited#!",
5649 ("not subtype conformant with declaration#!", Enode);
5652 when Fully_Conformant =>
5653 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
5654 Error_Msg_N -- CODEFIX
5655 ("not fully conformant with operation inherited#!",
5658 Error_Msg_N -- CODEFIX
5659 ("not fully conformant with declaration#!", Enode);
5663 Error_Msg_NE (Msg, Enode, N);
5665 end Conformance_Error;
5667 -----------------------
5668 -- Conventions_Match --
5669 -----------------------
5671 function Conventions_Match
5673 Id2 : Entity_Id) return Boolean
5676 -- Ignore the conventions of anonymous access-to-subprogram types
5677 -- and subprogram types because these are internally generated and
5678 -- the only way these may receive a convention is if they inherit
5679 -- the convention of a related subprogram.
5681 if Ekind (Id1) in E_Anonymous_Access_Subprogram_Type
5684 Ekind (Id2) in E_Anonymous_Access_Subprogram_Type
5689 -- Otherwise compare the conventions directly
5692 return Convention (Id1) = Convention (Id2);
5694 end Conventions_Match;
5696 ---------------------------
5697 -- Null_Exclusions_Match --
5698 ---------------------------
5700 function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean is
5702 if not Is_Anonymous_Access_Type (Etype (F1))
5703 or else not Is_Anonymous_Access_Type (Etype (F2))
5708 -- AI12-0289-1: Case of controlling access parameter; False if the
5709 -- partial view is untagged, the full view is tagged, and no explicit
5710 -- "not null". Note that at this point, we're processing the package
5711 -- body, so private/full types have been swapped. The Sloc test below
5712 -- is to detect the (legal) case where F1 comes after the full type
5713 -- declaration. This part is disabled pre-2005, because "not null" is
5714 -- not allowed on those language versions.
5716 if Ada_Version >= Ada_2005
5717 and then Is_Controlling_Formal (F1)
5718 and then not Null_Exclusion_Present (Parent (F1))
5719 and then not Null_Exclusion_Present (Parent (F2))
5722 D : constant Entity_Id := Directly_Designated_Type (Etype (F1));
5723 Partial_View_Of_Desig : constant Entity_Id :=
5724 Incomplete_Or_Partial_View (D);
5726 return No (Partial_View_Of_Desig)
5727 or else Is_Tagged_Type (Partial_View_Of_Desig)
5728 or else Sloc (D) < Sloc (F1);
5731 -- Not a controlling parameter, or one or both views have an explicit
5735 return Null_Exclusion_Present (Parent (F1)) =
5736 Null_Exclusion_Present (Parent (F2));
5738 end Null_Exclusions_Match;
5742 Old_Type : constant Entity_Id := Etype (Old_Id);
5743 New_Type : constant Entity_Id := Etype (New_Id);
5744 Old_Formal : Entity_Id;
5745 New_Formal : Entity_Id;
5746 Old_Formal_Base : Entity_Id;
5747 New_Formal_Base : Entity_Id;
5749 -- Start of processing for Check_Conformance
5754 -- We need a special case for operators, since they don't appear
5757 if Ctype = Type_Conformant then
5758 if Ekind (New_Id) = E_Operator
5759 and then Operator_Matches_Spec (New_Id, Old_Id)
5765 -- If both are functions/operators, check return types conform
5767 if Old_Type /= Standard_Void_Type
5769 New_Type /= Standard_Void_Type
5771 -- If we are checking interface conformance we omit controlling
5772 -- arguments and result, because we are only checking the conformance
5773 -- of the remaining parameters.
5775 if Has_Controlling_Result (Old_Id)
5776 and then Has_Controlling_Result (New_Id)
5777 and then Skip_Controlling_Formals
5781 elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
5782 if Ctype >= Subtype_Conformant
5783 and then not Predicates_Match (Old_Type, New_Type)
5786 ("\predicate of return type does not match!", New_Id);
5789 ("\return type does not match!", New_Id);
5795 -- Ada 2005 (AI-231): In case of anonymous access types check the
5796 -- null-exclusion and access-to-constant attributes match.
5798 if Ada_Version >= Ada_2005
5799 and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
5801 (Can_Never_Be_Null (Old_Type) /= Can_Never_Be_Null (New_Type)
5802 or else Is_Access_Constant (Etype (Old_Type)) /=
5803 Is_Access_Constant (Etype (New_Type)))
5805 Conformance_Error ("\return type does not match!", New_Id);
5809 -- If either is a function/operator and the other isn't, error
5811 elsif Old_Type /= Standard_Void_Type
5812 or else New_Type /= Standard_Void_Type
5814 Conformance_Error ("\functions can only match functions!", New_Id);
5818 -- In subtype conformant case, conventions must match (RM 6.3.1(16)).
5819 -- If this is a renaming as body, refine error message to indicate that
5820 -- the conflict is with the original declaration. If the entity is not
5821 -- frozen, the conventions don't have to match, the one of the renamed
5822 -- entity is inherited.
5824 if Ctype >= Subtype_Conformant then
5825 if not Conventions_Match (Old_Id, New_Id) then
5826 if not Is_Frozen (New_Id) then
5829 elsif Present (Err_Loc)
5830 and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
5831 and then Present (Corresponding_Spec (Err_Loc))
5833 Error_Msg_Name_1 := Chars (New_Id);
5835 Name_Ada + Convention_Id'Pos (Convention (New_Id));
5836 Conformance_Error ("\prior declaration for% has convention %!");
5840 Conformance_Error ("\calling conventions do not match!");
5844 Check_Formal_Subprogram_Conformance
5845 (New_Id, Old_Id, Err_Loc, Errmsg, Conforms);
5847 if not Conforms then
5853 -- Deal with parameters
5855 -- Note: we use the entity information, rather than going directly
5856 -- to the specification in the tree. This is not only simpler, but
5857 -- absolutely necessary for some cases of conformance tests between
5858 -- operators, where the declaration tree simply does not exist.
5860 Old_Formal := First_Formal (Old_Id);
5861 New_Formal := First_Formal (New_Id);
5862 while Present (Old_Formal) and then Present (New_Formal) loop
5863 if Is_Controlling_Formal (Old_Formal)
5864 and then Is_Controlling_Formal (New_Formal)
5865 and then Skip_Controlling_Formals
5867 -- The controlling formals will have different types when
5868 -- comparing an interface operation with its match, but both
5869 -- or neither must be access parameters.
5871 if Is_Access_Type (Etype (Old_Formal))
5873 Is_Access_Type (Etype (New_Formal))
5875 goto Skip_Controlling_Formal;
5878 ("\access parameter does not match!", New_Formal);
5882 -- Ada 2012: Mode conformance also requires that formal parameters
5883 -- be both aliased, or neither.
5885 if Ctype >= Mode_Conformant and then Ada_Version >= Ada_2012 then
5886 if Is_Aliased (Old_Formal) /= Is_Aliased (New_Formal) then
5888 ("\aliased parameter mismatch!", New_Formal);
5892 if Ctype = Fully_Conformant then
5894 -- Names must match. Error message is more accurate if we do
5895 -- this before checking that the types of the formals match.
5897 if Chars (Old_Formal) /= Chars (New_Formal) then
5898 Conformance_Error ("\name& does not match!", New_Formal);
5900 -- Set error posted flag on new formal as well to stop
5901 -- junk cascaded messages in some cases.
5903 Set_Error_Posted (New_Formal);
5907 -- Null exclusion must match
5909 if not Null_Exclusions_Match (Old_Formal, New_Formal) then
5911 ("\null exclusion for& does not match", New_Formal);
5913 -- Mark error posted on the new formal to avoid duplicated
5914 -- complaint about types not matching.
5916 Set_Error_Posted (New_Formal);
5920 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
5921 -- case occurs whenever a subprogram is being renamed and one of its
5922 -- parameters imposes a null exclusion. For example:
5924 -- type T is null record;
5925 -- type Acc_T is access T;
5926 -- subtype Acc_T_Sub is Acc_T;
5928 -- procedure P (Obj : not null Acc_T_Sub); -- itype
5929 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype
5932 Old_Formal_Base := Etype (Old_Formal);
5933 New_Formal_Base := Etype (New_Formal);
5936 Old_Formal_Base := Get_Instance_Of (Old_Formal_Base);
5937 New_Formal_Base := Get_Instance_Of (New_Formal_Base);
5940 -- Types must always match. In the visible part of an instance,
5941 -- usual overloading rules for dispatching operations apply, and
5942 -- we check base types (not the actual subtypes).
5944 if In_Instance_Visible_Part
5945 and then Is_Dispatching_Operation (New_Id)
5947 if not Conforming_Types
5948 (T1 => Base_Type (Etype (Old_Formal)),
5949 T2 => Base_Type (Etype (New_Formal)),
5951 Get_Inst => Get_Inst)
5953 Conformance_Error ("\type of & does not match!", New_Formal);
5957 elsif not Conforming_Types
5958 (T1 => Old_Formal_Base,
5959 T2 => New_Formal_Base,
5961 Get_Inst => Get_Inst)
5963 -- Don't give error message if old type is Any_Type. This test
5964 -- avoids some cascaded errors, e.g. in case of a bad spec.
5966 if Errmsg and then Old_Formal_Base = Any_Type then
5969 if Ctype >= Subtype_Conformant
5971 not Predicates_Match (Old_Formal_Base, New_Formal_Base)
5974 ("\predicate of & does not match!", New_Formal);
5977 ("\type of & does not match!", New_Formal);
5979 if not Dimensions_Match (Old_Formal_Base, New_Formal_Base)
5981 Error_Msg_N ("\dimensions mismatch!", New_Formal);
5989 -- For mode conformance, mode must match
5991 if Ctype >= Mode_Conformant then
5992 if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then
5993 if Ekind (New_Id) not in E_Function | E_Procedure
5994 or else not Is_Primitive_Wrapper (New_Id)
5996 Conformance_Error ("\mode of & does not match!", New_Formal);
6000 T : constant Entity_Id := Find_Dispatching_Type (New_Id);
6002 if Is_Protected_Type (Corresponding_Concurrent_Type (T))
6007 Error_Msg_PT (New_Id, Ultimate_Alias (Old_Id));
6011 ("\mode of & does not match!", New_Formal);
6018 elsif Is_Access_Type (Old_Formal_Base)
6019 and then Is_Access_Type (New_Formal_Base)
6020 and then Is_Access_Constant (Old_Formal_Base) /=
6021 Is_Access_Constant (New_Formal_Base)
6024 ("\constant modifier does not match!", New_Formal);
6029 if Ctype >= Subtype_Conformant then
6031 -- Ada 2005 (AI-231): In case of anonymous access types check
6032 -- the null-exclusion and access-to-constant attributes must
6033 -- match. For null exclusion, we test the types rather than the
6034 -- formals themselves, since the attribute is only set reliably
6035 -- on the formals in the Ada 95 case, and we exclude the case
6036 -- where Old_Formal is marked as controlling, to avoid errors
6037 -- when matching completing bodies with dispatching declarations
6038 -- (access formals in the bodies aren't marked Can_Never_Be_Null).
6040 if Ada_Version >= Ada_2005
6041 and then Is_Anonymous_Access_Type (Etype (Old_Formal))
6042 and then Is_Anonymous_Access_Type (Etype (New_Formal))
6044 ((Can_Never_Be_Null (Etype (Old_Formal)) /=
6045 Can_Never_Be_Null (Etype (New_Formal))
6047 not Is_Controlling_Formal (Old_Formal))
6049 Is_Access_Constant (Etype (Old_Formal)) /=
6050 Is_Access_Constant (Etype (New_Formal)))
6052 -- Do not complain if error already posted on New_Formal. This
6053 -- avoids some redundant error messages.
6055 and then not Error_Posted (New_Formal)
6057 -- It is allowed to omit the null-exclusion in case of stream
6058 -- attribute subprograms. We recognize stream subprograms
6059 -- through their TSS-generated suffix.
6062 TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id);
6065 if TSS_Name /= TSS_Stream_Read
6066 and then TSS_Name /= TSS_Stream_Write
6067 and then TSS_Name /= TSS_Stream_Input
6068 and then TSS_Name /= TSS_Stream_Output
6070 -- Here we have a definite conformance error. It is worth
6071 -- special casing the error message for the case of a
6072 -- controlling formal (which excludes null).
6074 if Is_Controlling_Formal (New_Formal) then
6075 Error_Msg_Node_2 := Scope (New_Formal);
6077 ("\controlling formal & of & excludes null, "
6078 & "declaration must exclude null as well",
6081 -- Normal case (couldn't we give more detail here???)
6085 ("\type of & does not match!", New_Formal);
6094 -- Full conformance checks
6096 if Ctype = Fully_Conformant then
6098 -- We have checked already that names match
6100 if Parameter_Mode (Old_Formal) = E_In_Parameter then
6102 -- Check default expressions for in parameters
6105 NewD : constant Boolean :=
6106 Present (Default_Value (New_Formal));
6107 OldD : constant Boolean :=
6108 Present (Default_Value (Old_Formal));
6110 if NewD or OldD then
6112 -- The old default value has been analyzed because the
6113 -- current full declaration will have frozen everything
6114 -- before. The new default value has not been analyzed,
6115 -- so analyze it now before we check for conformance.
6118 Push_Scope (New_Id);
6119 Preanalyze_Spec_Expression
6120 (Default_Value (New_Formal), Etype (New_Formal));
6124 if not (NewD and OldD)
6125 or else not Fully_Conformant_Expressions
6126 (Default_Value (Old_Formal),
6127 Default_Value (New_Formal))
6130 ("\default expression for & does not match!",
6139 -- A couple of special checks for Ada 83 mode. These checks are
6140 -- skipped if either entity is an operator in package Standard,
6141 -- or if either old or new instance is not from the source program.
6143 if Ada_Version = Ada_83
6144 and then Sloc (Old_Id) > Standard_Location
6145 and then Sloc (New_Id) > Standard_Location
6146 and then Comes_From_Source (Old_Id)
6147 and then Comes_From_Source (New_Id)
6150 Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
6151 New_Param : constant Node_Id := Declaration_Node (New_Formal);
6154 -- Explicit IN must be present or absent in both cases. This
6155 -- test is required only in the full conformance case.
6157 if In_Present (Old_Param) /= In_Present (New_Param)
6158 and then Ctype = Fully_Conformant
6161 ("\(Ada 83) IN must appear in both declarations",
6166 -- Grouping (use of comma in param lists) must be the same
6167 -- This is where we catch a misconformance like:
6170 -- A : Integer; B : Integer
6172 -- which are represented identically in the tree except
6173 -- for the setting of the flags More_Ids and Prev_Ids.
6175 if More_Ids (Old_Param) /= More_Ids (New_Param)
6176 or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
6179 ("\grouping of & does not match!", New_Formal);
6185 -- This label is required when skipping controlling formals
6187 <<Skip_Controlling_Formal>>
6189 Next_Formal (Old_Formal);
6190 Next_Formal (New_Formal);
6193 if Present (Old_Formal) then
6194 Conformance_Error ("\too few parameters!");
6197 elsif Present (New_Formal) then
6198 Conformance_Error ("\too many parameters!", New_Formal);
6201 end Check_Conformance;
6203 -----------------------
6204 -- Check_Conventions --
6205 -----------------------
6207 procedure Check_Conventions (Typ : Entity_Id) is
6208 Ifaces_List : Elist_Id;
6210 procedure Check_Convention (Op : Entity_Id);
6211 -- Verify that the convention of inherited dispatching operation Op is
6212 -- consistent among all subprograms it overrides. In order to minimize
6213 -- the search, Search_From is utilized to designate a specific point in
6214 -- the list rather than iterating over the whole list once more.
6216 ----------------------
6217 -- Check_Convention --
6218 ----------------------
6220 procedure Check_Convention (Op : Entity_Id) is
6221 Op_Conv : constant Convention_Id := Convention (Op);
6222 Iface_Conv : Convention_Id;
6223 Iface_Elmt : Elmt_Id;
6224 Iface_Prim_Elmt : Elmt_Id;
6225 Iface_Prim : Entity_Id;
6228 Iface_Elmt := First_Elmt (Ifaces_List);
6229 while Present (Iface_Elmt) loop
6231 First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
6232 while Present (Iface_Prim_Elmt) loop
6233 Iface_Prim := Node (Iface_Prim_Elmt);
6234 Iface_Conv := Convention (Iface_Prim);
6236 if Is_Interface_Conformant (Typ, Iface_Prim, Op)
6237 and then Iface_Conv /= Op_Conv
6240 ("inconsistent conventions in primitive operations", Typ);
6242 Error_Msg_Name_1 := Chars (Op);
6243 Error_Msg_Name_2 := Get_Convention_Name (Op_Conv);
6244 Error_Msg_Sloc := Sloc (Op);
6246 if Comes_From_Source (Op) or else No (Alias (Op)) then
6247 if not Present (Overridden_Operation (Op)) then
6248 Error_Msg_N ("\\primitive % defined #", Typ);
6251 ("\\overriding operation % with "
6252 & "convention % defined #", Typ);
6255 else pragma Assert (Present (Alias (Op)));
6256 Error_Msg_Sloc := Sloc (Alias (Op));
6257 Error_Msg_N ("\\inherited operation % with "
6258 & "convention % defined #", Typ);
6261 Error_Msg_Name_1 := Chars (Op);
6262 Error_Msg_Name_2 := Get_Convention_Name (Iface_Conv);
6263 Error_Msg_Sloc := Sloc (Iface_Prim);
6264 Error_Msg_N ("\\overridden operation % with "
6265 & "convention % defined #", Typ);
6267 -- Avoid cascading errors
6272 Next_Elmt (Iface_Prim_Elmt);
6275 Next_Elmt (Iface_Elmt);
6277 end Check_Convention;
6281 Prim_Op : Entity_Id;
6282 Prim_Op_Elmt : Elmt_Id;
6284 -- Start of processing for Check_Conventions
6287 if not Has_Interfaces (Typ) then
6291 Collect_Interfaces (Typ, Ifaces_List);
6293 -- The algorithm checks every overriding dispatching operation against
6294 -- all the corresponding overridden dispatching operations, detecting
6295 -- differences in conventions.
6297 Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ));
6298 while Present (Prim_Op_Elmt) loop
6299 Prim_Op := Node (Prim_Op_Elmt);
6301 -- A small optimization: skip the predefined dispatching operations
6302 -- since they always have the same convention.
6304 if not Is_Predefined_Dispatching_Operation (Prim_Op) then
6305 Check_Convention (Prim_Op);
6308 Next_Elmt (Prim_Op_Elmt);
6310 end Check_Conventions;
6312 ------------------------------
6313 -- Check_Delayed_Subprogram --
6314 ------------------------------
6316 procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
6317 procedure Possible_Freeze (T : Entity_Id);
6318 -- T is the type of either a formal parameter or of the return type. If
6319 -- T is not yet frozen and needs a delayed freeze, then the subprogram
6320 -- itself must be delayed.
6322 ---------------------
6323 -- Possible_Freeze --
6324 ---------------------
6326 procedure Possible_Freeze (T : Entity_Id) is
6327 Scop : constant Entity_Id := Scope (Designator);
6330 -- If the subprogram appears within a package instance (which may be
6331 -- the wrapper package of a subprogram instance) the freeze node for
6332 -- that package will freeze the subprogram at the proper place, so
6333 -- do not emit a freeze node for the subprogram, given that it may
6334 -- appear in the wrong scope.
6336 if Ekind (Scop) = E_Package
6337 and then not Comes_From_Source (Scop)
6338 and then Is_Generic_Instance (Scop)
6342 elsif Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
6343 Set_Has_Delayed_Freeze (Designator);
6345 elsif Is_Access_Type (T)
6346 and then Has_Delayed_Freeze (Designated_Type (T))
6347 and then not Is_Frozen (Designated_Type (T))
6349 Set_Has_Delayed_Freeze (Designator);
6351 end Possible_Freeze;
6357 -- Start of processing for Check_Delayed_Subprogram
6360 -- All subprograms, including abstract subprograms, may need a freeze
6361 -- node if some formal type or the return type needs one.
6363 Possible_Freeze (Etype (Designator));
6364 Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
6366 -- Need delayed freeze if any of the formal types themselves need a
6367 -- delayed freeze and are not yet frozen.
6369 F := First_Formal (Designator);
6370 while Present (F) loop
6371 Possible_Freeze (Etype (F));
6372 Possible_Freeze (Base_Type (Etype (F))); -- needed ???
6376 -- Mark functions that return by reference. Note that it cannot be done
6377 -- for delayed_freeze subprograms because the underlying returned type
6378 -- may not be known yet (for private types).
6380 if not Has_Delayed_Freeze (Designator) and then Expander_Active then
6382 Typ : constant Entity_Id := Etype (Designator);
6383 Utyp : constant Entity_Id := Underlying_Type (Typ);
6386 if Is_Limited_View (Typ) then
6387 Set_Returns_By_Ref (Designator);
6389 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
6390 Set_Returns_By_Ref (Designator);
6394 end Check_Delayed_Subprogram;
6396 ------------------------------------
6397 -- Check_Discriminant_Conformance --
6398 ------------------------------------
6400 procedure Check_Discriminant_Conformance
6405 Old_Discr : Entity_Id := First_Discriminant (Prev);
6406 New_Discr : Node_Id := First (Discriminant_Specifications (N));
6407 New_Discr_Id : Entity_Id;
6408 New_Discr_Type : Entity_Id;
6410 procedure Conformance_Error (Msg : String; N : Node_Id);
6411 -- Post error message for conformance error on given node. Two messages
6412 -- are output. The first points to the previous declaration with a
6413 -- general "no conformance" message. The second is the detailed reason,
6414 -- supplied as Msg. The parameter N provide information for a possible
6415 -- & insertion in the message.
6417 -----------------------
6418 -- Conformance_Error --
6419 -----------------------
6421 procedure Conformance_Error (Msg : String; N : Node_Id) is
6423 Error_Msg_Sloc := Sloc (Prev_Loc);
6424 Error_Msg_N -- CODEFIX
6425 ("not fully conformant with declaration#!", N);
6426 Error_Msg_NE (Msg, N, N);
6427 end Conformance_Error;
6429 -- Start of processing for Check_Discriminant_Conformance
6432 while Present (Old_Discr) and then Present (New_Discr) loop
6433 New_Discr_Id := Defining_Identifier (New_Discr);
6435 -- The subtype mark of the discriminant on the full type has not
6436 -- been analyzed so we do it here. For an access discriminant a new
6439 if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
6441 Access_Definition (N, Discriminant_Type (New_Discr));
6444 Find_Type (Discriminant_Type (New_Discr));
6445 New_Discr_Type := Etype (Discriminant_Type (New_Discr));
6447 -- Ada 2005: if the discriminant definition carries a null
6448 -- exclusion, create an itype to check properly for consistency
6449 -- with partial declaration.
6451 if Is_Access_Type (New_Discr_Type)
6452 and then Null_Exclusion_Present (New_Discr)
6455 Create_Null_Excluding_Itype
6456 (T => New_Discr_Type,
6457 Related_Nod => New_Discr,
6458 Scope_Id => Current_Scope);
6462 if not Conforming_Types
6463 (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
6465 Conformance_Error ("type of & does not match!", New_Discr_Id);
6468 -- Treat the new discriminant as an occurrence of the old one,
6469 -- for navigation purposes, and fill in some semantic
6470 -- information, for completeness.
6472 Generate_Reference (Old_Discr, New_Discr_Id, 'r');
6473 Set_Etype (New_Discr_Id, Etype (Old_Discr));
6474 Set_Scope (New_Discr_Id, Scope (Old_Discr));
6479 if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
6480 Conformance_Error ("name & does not match!", New_Discr_Id);
6484 -- Default expressions must match
6487 NewD : constant Boolean :=
6488 Present (Expression (New_Discr));
6489 OldD : constant Boolean :=
6490 Present (Expression (Parent (Old_Discr)));
6493 if NewD or OldD then
6495 -- The old default value has been analyzed and expanded,
6496 -- because the current full declaration will have frozen
6497 -- everything before. The new default values have not been
6498 -- expanded, so expand now to check conformance.
6501 Preanalyze_Spec_Expression
6502 (Expression (New_Discr), New_Discr_Type);
6505 if not (NewD and OldD)
6506 or else not Fully_Conformant_Expressions
6507 (Expression (Parent (Old_Discr)),
6508 Expression (New_Discr))
6512 ("default expression for & does not match!",
6519 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
6521 if Ada_Version = Ada_83 then
6523 Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
6526 -- Grouping (use of comma in param lists) must be the same
6527 -- This is where we catch a misconformance like:
6530 -- A : Integer; B : Integer
6532 -- which are represented identically in the tree except
6533 -- for the setting of the flags More_Ids and Prev_Ids.
6535 if More_Ids (Old_Disc) /= More_Ids (New_Discr)
6536 or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
6539 ("grouping of & does not match!", New_Discr_Id);
6545 Next_Discriminant (Old_Discr);
6549 if Present (Old_Discr) then
6550 Conformance_Error ("too few discriminants!", Defining_Identifier (N));
6553 elsif Present (New_Discr) then
6555 ("too many discriminants!", Defining_Identifier (New_Discr));
6558 end Check_Discriminant_Conformance;
6560 -----------------------------------------
6561 -- Check_Formal_Subprogram_Conformance --
6562 -----------------------------------------
6564 procedure Check_Formal_Subprogram_Conformance
6565 (New_Id : Entity_Id;
6569 Conforms : out Boolean)
6575 if Is_Formal_Subprogram (Old_Id)
6576 or else Is_Formal_Subprogram (New_Id)
6577 or else (Is_Subprogram (New_Id)
6578 and then Present (Alias (New_Id))
6579 and then Is_Formal_Subprogram (Alias (New_Id)))
6581 if Present (Err_Loc) then
6590 Error_Msg_Sloc := Sloc (Old_Id);
6591 Error_Msg_N ("not subtype conformant with declaration#!", N);
6593 ("\formal subprograms are not subtype conformant "
6594 & "(RM 6.3.1 (17/3))", N, New_Id);
6597 end Check_Formal_Subprogram_Conformance;
6599 procedure Check_Formal_Subprogram_Conformance
6600 (New_Id : Entity_Id;
6602 Err_Loc : Node_Id := Empty)
6606 Check_Formal_Subprogram_Conformance
6607 (New_Id, Old_Id, Err_Loc, True, Ignore);
6608 end Check_Formal_Subprogram_Conformance;
6610 ----------------------------
6611 -- Check_Fully_Conformant --
6612 ----------------------------
6614 procedure Check_Fully_Conformant
6615 (New_Id : Entity_Id;
6617 Err_Loc : Node_Id := Empty)
6620 pragma Warnings (Off, Result);
6623 (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
6624 end Check_Fully_Conformant;
6626 --------------------------
6627 -- Check_Limited_Return --
6628 --------------------------
6630 procedure Check_Limited_Return
6636 -- Ada 2005 (AI-318-02): Return-by-reference types have been removed and
6637 -- replaced by anonymous access results. This is an incompatibility with
6638 -- Ada 95. Not clear whether this should be enforced yet or perhaps
6639 -- controllable with special switch. ???
6641 -- A limited interface that is not immutably limited is OK
6643 if Is_Limited_Interface (R_Type)
6645 not (Is_Task_Interface (R_Type)
6646 or else Is_Protected_Interface (R_Type)
6647 or else Is_Synchronized_Interface (R_Type))
6651 elsif Is_Limited_Type (R_Type)
6652 and then not Is_Interface (R_Type)
6653 and then Comes_From_Source (N)
6654 and then not In_Instance_Body
6655 and then not OK_For_Limited_Init_In_05 (R_Type, Expr)
6657 -- Error in Ada 2005
6659 if Ada_Version >= Ada_2005
6660 and then not Debug_Flag_Dot_L
6661 and then not GNAT_Mode
6664 ("(Ada 2005) cannot copy object of a limited type "
6665 & "(RM-2005 6.5(5.5/2))", Expr);
6667 if Is_Limited_View (R_Type) then
6669 ("\return by reference not permitted in Ada 2005", Expr);
6672 -- Warn in Ada 95 mode, to give folks a heads up about this
6675 -- In GNAT mode, this is just a warning, to allow it to be evilly
6676 -- turned off. Otherwise it is a real error.
6678 -- In a generic context, simplify the warning because it makes no
6679 -- sense to discuss pass-by-reference or copy.
6681 elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
6682 if Inside_A_Generic then
6684 ("return of limited object not permitted in Ada 2005 "
6685 & "(RM-2005 6.5(5.5/2))?y?", Expr);
6687 elsif Is_Limited_View (R_Type) then
6689 ("return by reference not permitted in Ada 2005 "
6690 & "(RM-2005 6.5(5.5/2))?y?", Expr);
6693 ("cannot copy object of a limited type in Ada 2005 "
6694 & "(RM-2005 6.5(5.5/2))?y?", Expr);
6697 -- Ada 95 mode, and compatibility warnings disabled
6700 pragma Assert (Ada_Version <= Ada_95);
6701 pragma Assert (not (Warn_On_Ada_2005_Compatibility or GNAT_Mode));
6702 return; -- skip continuation messages below
6705 if not Inside_A_Generic then
6707 ("\consider switching to return of access type", Expr);
6708 Explain_Limited_Type (R_Type, Expr);
6711 end Check_Limited_Return;
6713 ---------------------------
6714 -- Check_Mode_Conformant --
6715 ---------------------------
6717 procedure Check_Mode_Conformant
6718 (New_Id : Entity_Id;
6720 Err_Loc : Node_Id := Empty;
6721 Get_Inst : Boolean := False)
6724 pragma Warnings (Off, Result);
6727 (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
6728 end Check_Mode_Conformant;
6730 --------------------------------
6731 -- Check_Overriding_Indicator --
6732 --------------------------------
6734 procedure Check_Overriding_Indicator
6736 Overridden_Subp : Entity_Id;
6737 Is_Primitive : Boolean)
6743 -- No overriding indicator for literals
6745 if Ekind (Subp) = E_Enumeration_Literal then
6748 elsif Ekind (Subp) = E_Entry then
6749 Decl := Parent (Subp);
6751 -- No point in analyzing a malformed operator
6753 elsif Nkind (Subp) = N_Defining_Operator_Symbol
6754 and then Error_Posted (Subp)
6759 Decl := Unit_Declaration_Node (Subp);
6762 if Nkind (Decl) in N_Subprogram_Body
6763 | N_Subprogram_Body_Stub
6764 | N_Subprogram_Declaration
6765 | N_Abstract_Subprogram_Declaration
6766 | N_Subprogram_Renaming_Declaration
6768 Spec := Specification (Decl);
6770 elsif Nkind (Decl) = N_Entry_Declaration then
6777 -- An overriding indication is illegal on a subprogram declared
6778 -- in a protected body, where there is no operation to override.
6780 if (Must_Override (Spec) or else Must_Not_Override (Spec))
6781 and then Is_List_Member (Decl)
6782 and then Present (Parent (List_Containing (Decl)))
6783 and then Nkind (Parent (List_Containing (Decl))) = N_Protected_Body
6786 ("illegal overriding indication in protected body", Decl);
6790 -- The overriding operation is type conformant with the overridden one,
6791 -- but the names of the formals are not required to match. If the names
6792 -- appear permuted in the overriding operation, this is a possible
6793 -- source of confusion that is worth diagnosing. Controlling formals
6794 -- often carry names that reflect the type, and it is not worthwhile
6795 -- requiring that their names match.
6797 if Present (Overridden_Subp)
6798 and then Nkind (Subp) /= N_Defining_Operator_Symbol
6805 Form1 := First_Formal (Subp);
6806 Form2 := First_Formal (Overridden_Subp);
6808 -- If the overriding operation is a synchronized operation, skip
6809 -- the first parameter of the overridden operation, which is
6810 -- implicit in the new one. If the operation is declared in the
6811 -- body it is not primitive and all formals must match.
6813 if Is_Concurrent_Type (Scope (Subp))
6814 and then Is_Tagged_Type (Scope (Subp))
6815 and then not Has_Completion (Scope (Subp))
6817 Form2 := Next_Formal (Form2);
6820 if Present (Form1) then
6821 Form1 := Next_Formal (Form1);
6822 Form2 := Next_Formal (Form2);
6825 while Present (Form1) loop
6826 if not Is_Controlling_Formal (Form1)
6827 and then Present (Next_Formal (Form2))
6828 and then Chars (Form1) = Chars (Next_Formal (Form2))
6830 Error_Msg_Node_2 := Alias (Overridden_Subp);
6831 Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
6833 ("& does not match corresponding formal of&#",
6838 Next_Formal (Form1);
6839 Next_Formal (Form2);
6844 -- If there is an overridden subprogram, then check that there is no
6845 -- "not overriding" indicator, and mark the subprogram as overriding.
6847 -- This is not done if the overridden subprogram is marked as hidden,
6848 -- which can occur for the case of inherited controlled operations
6849 -- (see Derive_Subprogram), unless the inherited subprogram's parent
6850 -- subprogram is not itself hidden or we are within a generic instance,
6851 -- in which case the hidden flag may have been modified for the
6852 -- expansion of the instance.
6854 -- (Note: This condition could probably be simplified, leaving out the
6855 -- testing for the specific controlled cases, but it seems safer and
6856 -- clearer this way, and echoes similar special-case tests of this
6857 -- kind in other places.)
6859 if Present (Overridden_Subp)
6860 and then (not Is_Hidden (Overridden_Subp)
6862 (Chars (Overridden_Subp) in Name_Initialize
6865 and then Present (Alias (Overridden_Subp))
6866 and then (not Is_Hidden (Alias (Overridden_Subp))
6867 or else In_Instance)))
6869 if Must_Not_Override (Spec) then
6870 Error_Msg_Sloc := Sloc (Overridden_Subp);
6872 if Ekind (Subp) = E_Entry then
6874 ("entry & overrides inherited operation #", Spec, Subp);
6877 ("subprogram & overrides inherited operation #", Spec, Subp);
6880 -- Special-case to fix a GNAT oddity: Limited_Controlled is declared
6881 -- as an extension of Root_Controlled, and thus has a useless Adjust
6882 -- operation. This operation should not be inherited by other limited
6883 -- controlled types. An explicit Adjust for them is not overriding.
6885 elsif Must_Override (Spec)
6886 and then Chars (Overridden_Subp) = Name_Adjust
6887 and then Is_Limited_Type (Etype (First_Formal (Subp)))
6888 and then Present (Alias (Overridden_Subp))
6889 and then In_Predefined_Unit (Alias (Overridden_Subp))
6892 (Unit_File_Name (Get_Source_Unit (Alias (Overridden_Subp))));
6893 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
6895 elsif Is_Subprogram (Subp) then
6896 if Is_Init_Proc (Subp) then
6899 elsif No (Overridden_Operation (Subp)) then
6901 -- For entities generated by Derive_Subprograms the overridden
6902 -- operation is the inherited primitive (which is available
6903 -- through the attribute alias)
6905 if (Is_Dispatching_Operation (Subp)
6906 or else Is_Dispatching_Operation (Overridden_Subp))
6907 and then not Comes_From_Source (Overridden_Subp)
6908 and then Find_Dispatching_Type (Overridden_Subp) =
6909 Find_Dispatching_Type (Subp)
6910 and then Present (Alias (Overridden_Subp))
6911 and then Comes_From_Source (Alias (Overridden_Subp))
6913 Set_Overridden_Operation (Subp, Alias (Overridden_Subp));
6914 Inherit_Subprogram_Contract (Subp, Alias (Overridden_Subp));
6917 Set_Overridden_Operation (Subp, Overridden_Subp);
6918 Inherit_Subprogram_Contract (Subp, Overridden_Subp);
6923 -- If primitive flag is set or this is a protected operation, then
6924 -- the operation is overriding at the point of its declaration, so
6925 -- warn if necessary. Otherwise it may have been declared before the
6926 -- operation it overrides and no check is required.
6929 and then not Must_Override (Spec)
6930 and then (Is_Primitive
6931 or else Ekind (Scope (Subp)) = E_Protected_Type)
6933 Style.Missing_Overriding (Decl, Subp);
6936 -- If Subp is an operator, it may override a predefined operation, if
6937 -- it is defined in the same scope as the type to which it applies.
6938 -- In that case Overridden_Subp is empty because of our implicit
6939 -- representation for predefined operators. We have to check whether the
6940 -- signature of Subp matches that of a predefined operator. Note that
6941 -- first argument provides the name of the operator, and the second
6942 -- argument the signature that may match that of a standard operation.
6943 -- If the indicator is overriding, then the operator must match a
6944 -- predefined signature, because we know already that there is no
6945 -- explicit overridden operation.
6947 elsif Nkind (Subp) = N_Defining_Operator_Symbol then
6948 if Must_Not_Override (Spec) then
6950 -- If this is not a primitive or a protected subprogram, then
6951 -- "not overriding" is illegal.
6954 and then Ekind (Scope (Subp)) /= E_Protected_Type
6956 Error_Msg_N ("overriding indicator only allowed "
6957 & "if subprogram is primitive", Subp);
6959 elsif Can_Override_Operator (Subp) then
6961 ("subprogram& overrides predefined operator ", Spec, Subp);
6964 elsif Must_Override (Spec) then
6965 if No (Overridden_Operation (Subp))
6966 and then not Can_Override_Operator (Subp)
6968 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
6971 elsif not Error_Posted (Subp)
6972 and then Style_Check
6973 and then Can_Override_Operator (Subp)
6974 and then not In_Predefined_Unit (Subp)
6976 -- If style checks are enabled, indicate that the indicator is
6977 -- missing. However, at the point of declaration, the type of
6978 -- which this is a primitive operation may be private, in which
6979 -- case the indicator would be premature.
6981 if Has_Private_Declaration (Etype (Subp))
6982 or else Has_Private_Declaration (Etype (First_Formal (Subp)))
6986 Style.Missing_Overriding (Decl, Subp);
6990 elsif Must_Override (Spec) then
6991 if Ekind (Subp) = E_Entry then
6992 Error_Msg_NE ("entry & is not overriding", Spec, Subp);
6994 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
6997 -- If the operation is marked "not overriding" and it's not primitive
6998 -- then an error is issued, unless this is an operation of a task or
6999 -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
7000 -- has been specified have already been checked above.
7002 elsif Must_Not_Override (Spec)
7003 and then not Is_Primitive
7004 and then Ekind (Subp) /= E_Entry
7005 and then Ekind (Scope (Subp)) /= E_Protected_Type
7008 ("overriding indicator only allowed if subprogram is primitive",
7012 end Check_Overriding_Indicator;
7018 -- Note: this procedure needs to know far too much about how the expander
7019 -- messes with exceptions. The use of the flag Exception_Junk and the
7020 -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
7021 -- works, but is not very clean. It would be better if the expansion
7022 -- routines would leave Original_Node working nicely, and we could use
7023 -- Original_Node here to ignore all the peculiar expander messing ???
7025 procedure Check_Returns
7029 Proc : Entity_Id := Empty)
7033 procedure Check_Statement_Sequence (L : List_Id);
7034 -- Internal recursive procedure to check a list of statements for proper
7035 -- termination by a return statement (or a transfer of control or a
7036 -- compound statement that is itself internally properly terminated).
7038 ------------------------------
7039 -- Check_Statement_Sequence --
7040 ------------------------------
7042 procedure Check_Statement_Sequence (L : List_Id) is
7047 function Assert_False return Boolean;
7048 -- Returns True if Last_Stm is a pragma Assert (False) that has been
7049 -- rewritten as a null statement when assertions are off. The assert
7050 -- is not active, but it is still enough to kill the warning.
7056 function Assert_False return Boolean is
7057 Orig : constant Node_Id := Original_Node (Last_Stm);
7060 if Nkind (Orig) = N_Pragma
7061 and then Pragma_Name (Orig) = Name_Assert
7062 and then not Error_Posted (Orig)
7065 Arg : constant Node_Id :=
7066 First (Pragma_Argument_Associations (Orig));
7067 Exp : constant Node_Id := Expression (Arg);
7069 return Nkind (Exp) = N_Identifier
7070 and then Chars (Exp) = Name_False;
7080 Raise_Exception_Call : Boolean;
7081 -- Set True if statement sequence terminated by Raise_Exception call
7082 -- or a Reraise_Occurrence call.
7084 -- Start of processing for Check_Statement_Sequence
7087 Raise_Exception_Call := False;
7089 -- Get last real statement
7091 Last_Stm := Last (L);
7093 -- Deal with digging out exception handler statement sequences that
7094 -- have been transformed by the local raise to goto optimization.
7095 -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
7096 -- optimization has occurred, we are looking at something like:
7099 -- original stmts in block
7103 -- goto L1; | omitted if No_Exception_Propagation
7108 -- goto L3; -- skip handler when exception not raised
7110 -- <<L1>> -- target label for local exception
7124 -- and what we have to do is to dig out the estmts1 and estmts2
7125 -- sequences (which were the original sequences of statements in
7126 -- the exception handlers) and check them.
7128 if Nkind (Last_Stm) = N_Label and then Exception_Junk (Last_Stm) then
7133 exit when Nkind (Stm) /= N_Block_Statement;
7134 exit when not Exception_Junk (Stm);
7137 exit when Nkind (Stm) /= N_Label;
7138 exit when not Exception_Junk (Stm);
7139 Check_Statement_Sequence
7140 (Statements (Handled_Statement_Sequence (Next (Stm))));
7145 exit when Nkind (Stm) /= N_Goto_Statement;
7146 exit when not Exception_Junk (Stm);
7150 -- Don't count pragmas
7152 while Nkind (Last_Stm) = N_Pragma
7154 -- Don't count call to SS_Release (can happen after Raise_Exception)
7157 (Nkind (Last_Stm) = N_Procedure_Call_Statement
7159 Nkind (Name (Last_Stm)) = N_Identifier
7161 Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
7163 -- Don't count exception junk
7166 (Nkind (Last_Stm) in
7167 N_Goto_Statement | N_Label | N_Object_Declaration
7168 and then Exception_Junk (Last_Stm))
7169 or else Nkind (Last_Stm) in N_Push_xxx_Label | N_Pop_xxx_Label
7171 -- Inserted code, such as finalization calls, is irrelevant: we only
7172 -- need to check original source.
7174 or else Is_Rewrite_Insertion (Last_Stm)
7179 -- Here we have the "real" last statement
7181 Kind := Nkind (Last_Stm);
7183 -- Transfer of control, OK. Note that in the No_Return procedure
7184 -- case, we already diagnosed any explicit return statements, so
7185 -- we can treat them as OK in this context.
7187 if Is_Transfer (Last_Stm) then
7190 -- Check cases of explicit non-indirect procedure calls
7192 elsif Kind = N_Procedure_Call_Statement
7193 and then Is_Entity_Name (Name (Last_Stm))
7195 -- Check call to Raise_Exception procedure which is treated
7196 -- specially, as is a call to Reraise_Occurrence.
7198 -- We suppress the warning in these cases since it is likely that
7199 -- the programmer really does not expect to deal with the case
7200 -- of Null_Occurrence, and thus would find a warning about a
7201 -- missing return curious, and raising Program_Error does not
7202 -- seem such a bad behavior if this does occur.
7204 -- Note that in the Ada 2005 case for Raise_Exception, the actual
7205 -- behavior will be to raise Constraint_Error (see AI-329).
7207 if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
7209 Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
7211 Raise_Exception_Call := True;
7213 -- For Raise_Exception call, test first argument, if it is
7214 -- an attribute reference for a 'Identity call, then we know
7215 -- that the call cannot possibly return.
7218 Arg : constant Node_Id :=
7219 Original_Node (First_Actual (Last_Stm));
7221 if Nkind (Arg) = N_Attribute_Reference
7222 and then Attribute_Name (Arg) = Name_Identity
7229 -- If statement, need to look inside if there is an else and check
7230 -- each constituent statement sequence for proper termination.
7232 elsif Kind = N_If_Statement
7233 and then Present (Else_Statements (Last_Stm))
7235 Check_Statement_Sequence (Then_Statements (Last_Stm));
7236 Check_Statement_Sequence (Else_Statements (Last_Stm));
7238 if Present (Elsif_Parts (Last_Stm)) then
7240 Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
7243 while Present (Elsif_Part) loop
7244 Check_Statement_Sequence (Then_Statements (Elsif_Part));
7252 -- Case statement, check each case for proper termination
7254 elsif Kind = N_Case_Statement then
7258 Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
7259 while Present (Case_Alt) loop
7260 Check_Statement_Sequence (Statements (Case_Alt));
7261 Next_Non_Pragma (Case_Alt);
7267 -- Block statement, check its handled sequence of statements
7269 elsif Kind = N_Block_Statement then
7275 (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
7284 -- Loop statement. If there is an iteration scheme, we can definitely
7285 -- fall out of the loop. Similarly if there is an exit statement, we
7286 -- can fall out. In either case we need a following return.
7288 elsif Kind = N_Loop_Statement then
7289 if Present (Iteration_Scheme (Last_Stm))
7290 or else Has_Exit (Entity (Identifier (Last_Stm)))
7294 -- A loop with no exit statement or iteration scheme is either
7295 -- an infinite loop, or it has some other exit (raise/return).
7296 -- In either case, no warning is required.
7302 -- Timed entry call, check entry call and delay alternatives
7304 -- Note: in expanded code, the timed entry call has been converted
7305 -- to a set of expanded statements on which the check will work
7306 -- correctly in any case.
7308 elsif Kind = N_Timed_Entry_Call then
7310 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
7311 DCA : constant Node_Id := Delay_Alternative (Last_Stm);
7314 -- If statement sequence of entry call alternative is missing,
7315 -- then we can definitely fall through, and we post the error
7316 -- message on the entry call alternative itself.
7318 if No (Statements (ECA)) then
7321 -- If statement sequence of delay alternative is missing, then
7322 -- we can definitely fall through, and we post the error
7323 -- message on the delay alternative itself.
7325 -- Note: if both ECA and DCA are missing the return, then we
7326 -- post only one message, should be enough to fix the bugs.
7327 -- If not we will get a message next time on the DCA when the
7330 elsif No (Statements (DCA)) then
7333 -- Else check both statement sequences
7336 Check_Statement_Sequence (Statements (ECA));
7337 Check_Statement_Sequence (Statements (DCA));
7342 -- Conditional entry call, check entry call and else part
7344 -- Note: in expanded code, the conditional entry call has been
7345 -- converted to a set of expanded statements on which the check
7346 -- will work correctly in any case.
7348 elsif Kind = N_Conditional_Entry_Call then
7350 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
7353 -- If statement sequence of entry call alternative is missing,
7354 -- then we can definitely fall through, and we post the error
7355 -- message on the entry call alternative itself.
7357 if No (Statements (ECA)) then
7360 -- Else check statement sequence and else part
7363 Check_Statement_Sequence (Statements (ECA));
7364 Check_Statement_Sequence (Else_Statements (Last_Stm));
7370 -- If we fall through, issue appropriate message
7374 -- Kill warning if last statement is a raise exception call,
7375 -- or a pragma Assert (False). Note that with assertions enabled,
7376 -- such a pragma has been converted into a raise exception call
7377 -- already, so the Assert_False is for the assertions off case.
7379 if not Raise_Exception_Call and then not Assert_False then
7381 -- In GNATprove mode, it is an error to have a missing return
7383 Error_Msg_Warn := SPARK_Mode /= On;
7385 -- Issue error message or warning
7388 ("RETURN statement missing following this statement<<!",
7391 ("\Program_Error ]<<!", Last_Stm);
7394 -- Note: we set Err even though we have not issued a warning
7395 -- because we still have a case of a missing return. This is
7396 -- an extremely marginal case, probably will never be noticed
7397 -- but we might as well get it right.
7401 -- Otherwise we have the case of a procedure marked No_Return
7404 if not Raise_Exception_Call then
7405 if GNATprove_Mode then
7407 ("implied return after this statement would have raised "
7408 & "Program_Error", Last_Stm);
7410 -- In normal compilation mode, do not warn on a generated call
7411 -- (e.g. in the body of a renaming as completion).
7413 elsif Comes_From_Source (Last_Stm) then
7415 ("implied return after this statement will raise "
7416 & "Program_Error??", Last_Stm);
7419 Error_Msg_Warn := SPARK_Mode /= On;
7421 ("\procedure & is marked as No_Return<<!", Last_Stm, Proc);
7425 RE : constant Node_Id :=
7426 Make_Raise_Program_Error (Sloc (Last_Stm),
7427 Reason => PE_Implicit_Return);
7429 Insert_After (Last_Stm, RE);
7433 end Check_Statement_Sequence;
7435 -- Start of processing for Check_Returns
7439 Check_Statement_Sequence (Statements (HSS));
7441 if Present (Exception_Handlers (HSS)) then
7442 Handler := First_Non_Pragma (Exception_Handlers (HSS));
7443 while Present (Handler) loop
7444 Check_Statement_Sequence (Statements (Handler));
7445 Next_Non_Pragma (Handler);
7450 ----------------------------
7451 -- Check_Subprogram_Order --
7452 ----------------------------
7454 procedure Check_Subprogram_Order (N : Node_Id) is
7456 function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
7457 -- This is used to check if S1 > S2 in the sense required by this test,
7458 -- for example nameab < namec, but name2 < name10.
7460 -----------------------------
7461 -- Subprogram_Name_Greater --
7462 -----------------------------
7464 function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
7469 -- Deal with special case where names are identical except for a
7470 -- numerical suffix. These are handled specially, taking the numeric
7471 -- ordering from the suffix into account.
7474 while S1 (L1) in '0' .. '9' loop
7479 while S2 (L2) in '0' .. '9' loop
7483 -- If non-numeric parts non-equal, do straight compare
7485 if S1 (S1'First .. L1) /= S2 (S2'First .. L2) then
7488 -- If non-numeric parts equal, compare suffixed numeric parts. Note
7489 -- that a missing suffix is treated as numeric zero in this test.
7493 while L1 < S1'Last loop
7495 N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
7499 while L2 < S2'Last loop
7501 N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
7506 end Subprogram_Name_Greater;
7508 -- Start of processing for Check_Subprogram_Order
7511 -- Check body in alpha order if this is option
7514 and then Style_Check_Order_Subprograms
7515 and then Nkind (N) = N_Subprogram_Body
7516 and then Comes_From_Source (N)
7517 and then In_Extended_Main_Source_Unit (N)
7521 renames Scope_Stack.Table
7522 (Scope_Stack.Last).Last_Subprogram_Name;
7524 Body_Id : constant Entity_Id :=
7525 Defining_Entity (Specification (N));
7528 Get_Decoded_Name_String (Chars (Body_Id));
7531 if Subprogram_Name_Greater
7532 (LSN.all, Name_Buffer (1 .. Name_Len))
7534 Style.Subprogram_Not_In_Alpha_Order (Body_Id);
7540 LSN := new String'(Name_Buffer (1 .. Name_Len));
7543 end Check_Subprogram_Order;
7545 ------------------------------
7546 -- Check_Subtype_Conformant --
7547 ------------------------------
7549 procedure Check_Subtype_Conformant
7550 (New_Id : Entity_Id;
7552 Err_Loc : Node_Id := Empty;
7553 Skip_Controlling_Formals : Boolean := False;
7554 Get_Inst : Boolean := False)
7557 pragma Warnings (Off, Result);
7560 (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
7561 Skip_Controlling_Formals => Skip_Controlling_Formals,
7562 Get_Inst => Get_Inst);
7563 end Check_Subtype_Conformant;
7565 -----------------------------------
7566 -- Check_Synchronized_Overriding --
7567 -----------------------------------
7569 procedure Check_Synchronized_Overriding
7570 (Def_Id : Entity_Id;
7571 Overridden_Subp : out Entity_Id)
7573 Ifaces_List : Elist_Id;
7577 function Is_Valid_Formal (F : Entity_Id) return Boolean;
7578 -- Predicate for legality rule in 9.4 (11.9/2): If an inherited
7579 -- subprogram is implemented by a protected procedure or entry,
7580 -- its first parameter must be out, in out, or access-to-variable.
7582 function Matches_Prefixed_View_Profile
7583 (Prim_Params : List_Id;
7584 Iface_Params : List_Id) return Boolean;
7585 -- Determine whether a subprogram's parameter profile Prim_Params
7586 -- matches that of a potentially overridden interface subprogram
7587 -- Iface_Params. Also determine if the type of first parameter of
7588 -- Iface_Params is an implemented interface.
7590 ----------------------
7591 -- Is_Valid_Formal --
7592 ----------------------
7594 function Is_Valid_Formal (F : Entity_Id) return Boolean is
7597 Ekind (F) in E_In_Out_Parameter | E_Out_Parameter
7599 (Nkind (Parameter_Type (Parent (F))) = N_Access_Definition
7600 and then not Constant_Present (Parameter_Type (Parent (F))));
7601 end Is_Valid_Formal;
7603 -----------------------------------
7604 -- Matches_Prefixed_View_Profile --
7605 -----------------------------------
7607 function Matches_Prefixed_View_Profile
7608 (Prim_Params : List_Id;
7609 Iface_Params : List_Id) return Boolean
7611 function Is_Implemented
7612 (Ifaces_List : Elist_Id;
7613 Iface : Entity_Id) return Boolean;
7614 -- Determine if Iface is implemented by the current task or
7617 --------------------
7618 -- Is_Implemented --
7619 --------------------
7621 function Is_Implemented
7622 (Ifaces_List : Elist_Id;
7623 Iface : Entity_Id) return Boolean
7625 Iface_Elmt : Elmt_Id;
7628 Iface_Elmt := First_Elmt (Ifaces_List);
7629 while Present (Iface_Elmt) loop
7630 if Node (Iface_Elmt) = Iface then
7634 Next_Elmt (Iface_Elmt);
7642 Iface_Id : Entity_Id;
7643 Iface_Param : Node_Id;
7644 Iface_Typ : Entity_Id;
7645 Prim_Id : Entity_Id;
7646 Prim_Param : Node_Id;
7647 Prim_Typ : Entity_Id;
7649 -- Start of processing for Matches_Prefixed_View_Profile
7652 Iface_Param := First (Iface_Params);
7653 Iface_Typ := Etype (Defining_Identifier (Iface_Param));
7655 if Is_Access_Type (Iface_Typ) then
7656 Iface_Typ := Designated_Type (Iface_Typ);
7659 Prim_Param := First (Prim_Params);
7661 -- The first parameter of the potentially overridden subprogram must
7662 -- be an interface implemented by Prim.
7664 if not Is_Interface (Iface_Typ)
7665 or else not Is_Implemented (Ifaces_List, Iface_Typ)
7670 -- The checks on the object parameters are done, so move on to the
7671 -- rest of the parameters.
7673 if not In_Scope then
7678 while Present (Iface_Param) and then Present (Prim_Param) loop
7679 Iface_Id := Defining_Identifier (Iface_Param);
7680 Iface_Typ := Find_Parameter_Type (Iface_Param);
7682 Prim_Id := Defining_Identifier (Prim_Param);
7683 Prim_Typ := Find_Parameter_Type (Prim_Param);
7685 if Ekind (Iface_Typ) = E_Anonymous_Access_Type
7686 and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
7687 and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
7689 Iface_Typ := Designated_Type (Iface_Typ);
7690 Prim_Typ := Designated_Type (Prim_Typ);
7693 -- Case of multiple interface types inside a parameter profile
7695 -- (Obj_Param : in out Iface; ...; Param : Iface)
7697 -- If the interface type is implemented, then the matching type in
7698 -- the primitive should be the implementing record type.
7700 if Ekind (Iface_Typ) = E_Record_Type
7701 and then Is_Interface (Iface_Typ)
7702 and then Is_Implemented (Ifaces_List, Iface_Typ)
7704 if Prim_Typ /= Typ then
7708 -- The two parameters must be both mode and subtype conformant
7710 elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
7712 Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
7721 -- One of the two lists contains more parameters than the other
7723 if Present (Iface_Param) or else Present (Prim_Param) then
7728 end Matches_Prefixed_View_Profile;
7730 -- Start of processing for Check_Synchronized_Overriding
7733 Overridden_Subp := Empty;
7735 -- Def_Id must be an entry or a subprogram. We should skip predefined
7736 -- primitives internally generated by the front end; however at this
7737 -- stage predefined primitives are still not fully decorated. As a
7738 -- minor optimization we skip here internally generated subprograms.
7740 if (Ekind (Def_Id) /= E_Entry
7741 and then Ekind (Def_Id) /= E_Function
7742 and then Ekind (Def_Id) /= E_Procedure)
7743 or else not Comes_From_Source (Def_Id)
7748 -- Search for the concurrent declaration since it contains the list of
7749 -- all implemented interfaces. In this case, the subprogram is declared
7750 -- within the scope of a protected or a task type.
7752 if Present (Scope (Def_Id))
7753 and then Is_Concurrent_Type (Scope (Def_Id))
7754 and then not Is_Generic_Actual_Type (Scope (Def_Id))
7756 Typ := Scope (Def_Id);
7759 -- The enclosing scope is not a synchronized type and the subprogram
7762 elsif No (First_Formal (Def_Id)) then
7765 -- The subprogram has formals and hence it may be a primitive of a
7769 Typ := Etype (First_Formal (Def_Id));
7771 if Is_Access_Type (Typ) then
7772 Typ := Directly_Designated_Type (Typ);
7775 if Is_Concurrent_Type (Typ)
7776 and then not Is_Generic_Actual_Type (Typ)
7780 -- This case occurs when the concurrent type is declared within a
7781 -- generic unit. As a result the corresponding record has been built
7782 -- and used as the type of the first formal, we just have to retrieve
7783 -- the corresponding concurrent type.
7785 elsif Is_Concurrent_Record_Type (Typ)
7786 and then not Is_Class_Wide_Type (Typ)
7787 and then Present (Corresponding_Concurrent_Type (Typ))
7789 Typ := Corresponding_Concurrent_Type (Typ);
7797 -- There is no overriding to check if this is an inherited operation in
7798 -- a type derivation for a generic actual.
7800 Collect_Interfaces (Typ, Ifaces_List);
7802 if Is_Empty_Elmt_List (Ifaces_List) then
7806 -- Determine whether entry or subprogram Def_Id overrides a primitive
7807 -- operation that belongs to one of the interfaces in Ifaces_List.
7810 Candidate : Entity_Id := Empty;
7811 Hom : Entity_Id := Empty;
7812 Subp : Entity_Id := Empty;
7815 -- Traverse the homonym chain, looking for a potentially overridden
7816 -- subprogram that belongs to an implemented interface.
7818 Hom := Current_Entity_In_Scope (Def_Id);
7819 while Present (Hom) loop
7823 or else not Is_Overloadable (Subp)
7824 or else not Is_Primitive (Subp)
7825 or else not Is_Dispatching_Operation (Subp)
7826 or else not Present (Find_Dispatching_Type (Subp))
7827 or else not Is_Interface (Find_Dispatching_Type (Subp))
7831 -- Entries and procedures can override abstract or null interface
7834 elsif Ekind (Def_Id) in E_Entry | E_Procedure
7835 and then Ekind (Subp) = E_Procedure
7836 and then Matches_Prefixed_View_Profile
7837 (Parameter_Specifications (Parent (Def_Id)),
7838 Parameter_Specifications (Parent (Subp)))
7842 -- For an overridden subprogram Subp, check whether the mode
7843 -- of its first parameter is correct depending on the kind of
7844 -- synchronized type.
7847 Formal : constant Node_Id := First_Formal (Candidate);
7850 -- In order for an entry or a protected procedure to
7851 -- override, the first parameter of the overridden routine
7852 -- must be of mode "out", "in out", or access-to-variable.
7854 if Ekind (Candidate) in E_Entry | E_Procedure
7855 and then Is_Protected_Type (Typ)
7856 and then not Is_Valid_Formal (Formal)
7860 -- All other cases are OK since a task entry or routine does
7861 -- not have a restriction on the mode of the first parameter
7862 -- of the overridden interface routine.
7865 Overridden_Subp := Candidate;
7870 -- Functions can override abstract interface functions. Return
7871 -- types must be subtype conformant.
7873 elsif Ekind (Def_Id) = E_Function
7874 and then Ekind (Subp) = E_Function
7875 and then Matches_Prefixed_View_Profile
7876 (Parameter_Specifications (Parent (Def_Id)),
7877 Parameter_Specifications (Parent (Subp)))
7878 and then Conforming_Types
7879 (Etype (Def_Id), Etype (Subp), Subtype_Conformant)
7883 -- If an inherited subprogram is implemented by a protected
7884 -- function, then the first parameter of the inherited
7885 -- subprogram shall be of mode in, but not an access-to-
7886 -- variable parameter (RM 9.4(11/9)).
7888 if Present (First_Formal (Subp))
7889 and then Ekind (First_Formal (Subp)) = E_In_Parameter
7891 (not Is_Access_Type (Etype (First_Formal (Subp)))
7893 Is_Access_Constant (Etype (First_Formal (Subp))))
7895 Overridden_Subp := Subp;
7900 Hom := Homonym (Hom);
7903 -- After examining all candidates for overriding, we are left with
7904 -- the best match, which is a mode-incompatible interface routine.
7906 if In_Scope and then Present (Candidate) then
7907 Error_Msg_PT (Def_Id, Candidate);
7910 Overridden_Subp := Candidate;
7913 end Check_Synchronized_Overriding;
7915 ---------------------------
7916 -- Check_Type_Conformant --
7917 ---------------------------
7919 procedure Check_Type_Conformant
7920 (New_Id : Entity_Id;
7922 Err_Loc : Node_Id := Empty)
7925 pragma Warnings (Off, Result);
7928 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
7929 end Check_Type_Conformant;
7931 ---------------------------
7932 -- Can_Override_Operator --
7933 ---------------------------
7935 function Can_Override_Operator (Subp : Entity_Id) return Boolean is
7939 if Nkind (Subp) /= N_Defining_Operator_Symbol then
7943 Typ := Base_Type (Etype (First_Formal (Subp)));
7945 -- Check explicitly that the operation is a primitive of the type
7947 return Operator_Matches_Spec (Subp, Subp)
7948 and then not Is_Generic_Type (Typ)
7949 and then Scope (Subp) = Scope (Typ)
7950 and then not Is_Class_Wide_Type (Typ);
7952 end Can_Override_Operator;
7954 ----------------------
7955 -- Conforming_Types --
7956 ----------------------
7958 function Conforming_Types
7961 Ctype : Conformance_Type;
7962 Get_Inst : Boolean := False) return Boolean
7964 function Base_Types_Match
7966 Typ_2 : Entity_Id) return Boolean;
7967 -- If neither Typ_1 nor Typ_2 are generic actual types, or if they are
7968 -- in different scopes (e.g. parent and child instances), then verify
7969 -- that the base types are equal. Otherwise Typ_1 and Typ_2 must be on
7970 -- the same subtype chain. The whole purpose of this procedure is to
7971 -- prevent spurious ambiguities in an instantiation that may arise if
7972 -- two distinct generic types are instantiated with the same actual.
7974 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id;
7975 -- An access parameter can designate an incomplete type. If the
7976 -- incomplete type is the limited view of a type from a limited_
7977 -- with_clause, check whether the non-limited view is available.
7978 -- If it is a (non-limited) incomplete type, get the full view.
7980 function Matches_Limited_With_View
7982 Typ_2 : Entity_Id) return Boolean;
7983 -- Returns True if and only if either Typ_1 denotes a limited view of
7984 -- Typ_2 or Typ_2 denotes a limited view of Typ_1. This can arise when
7985 -- the limited with view of a type is used in a subprogram declaration
7986 -- and the subprogram body is in the scope of a regular with clause for
7987 -- the same unit. In such a case, the two type entities are considered
7988 -- identical for purposes of conformance checking.
7990 ----------------------
7991 -- Base_Types_Match --
7992 ----------------------
7994 function Base_Types_Match
7996 Typ_2 : Entity_Id) return Boolean
7998 Base_1 : constant Entity_Id := Base_Type (Typ_1);
7999 Base_2 : constant Entity_Id := Base_Type (Typ_2);
8002 if Typ_1 = Typ_2 then
8005 elsif Base_1 = Base_2 then
8007 -- The following is too permissive. A more precise test should
8008 -- check that the generic actual is an ancestor subtype of the
8011 -- See code in Find_Corresponding_Spec that applies an additional
8012 -- filter to handle accidental amiguities in instances.
8015 not Is_Generic_Actual_Type (Typ_1)
8016 or else not Is_Generic_Actual_Type (Typ_2)
8017 or else Scope (Typ_1) /= Scope (Typ_2);
8019 -- If Typ_2 is a generic actual type it is declared as the subtype of
8020 -- the actual. If that actual is itself a subtype we need to use its
8021 -- own base type to check for compatibility.
8023 elsif Ekind (Base_2) = Ekind (Typ_2)
8024 and then Base_1 = Base_Type (Base_2)
8028 elsif Ekind (Base_1) = Ekind (Typ_1)
8029 and then Base_2 = Base_Type (Base_1)
8036 end Base_Types_Match;
8038 --------------------------
8039 -- Find_Designated_Type --
8040 --------------------------
8042 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id is
8046 Desig := Directly_Designated_Type (Typ);
8048 if Ekind (Desig) = E_Incomplete_Type then
8050 -- If regular incomplete type, get full view if available
8052 if Present (Full_View (Desig)) then
8053 Desig := Full_View (Desig);
8055 -- If limited view of a type, get non-limited view if available,
8056 -- and check again for a regular incomplete type.
8058 elsif Present (Non_Limited_View (Desig)) then
8059 Desig := Get_Full_View (Non_Limited_View (Desig));
8064 end Find_Designated_Type;
8066 -------------------------------
8067 -- Matches_Limited_With_View --
8068 -------------------------------
8070 function Matches_Limited_With_View
8072 Typ_2 : Entity_Id) return Boolean
8074 function Is_Matching_Limited_View
8076 View : Entity_Id) return Boolean;
8077 -- Determine whether non-limited view View denotes type Typ in some
8078 -- conformant fashion.
8080 ------------------------------
8081 -- Is_Matching_Limited_View --
8082 ------------------------------
8084 function Is_Matching_Limited_View
8086 View : Entity_Id) return Boolean
8088 Root_Typ : Entity_Id;
8089 Root_View : Entity_Id;
8092 -- The non-limited view directly denotes the type
8097 -- The type is a subtype of the non-limited view
8099 elsif Is_Subtype_Of (Typ, View) then
8102 -- Both the non-limited view and the type denote class-wide types
8104 elsif Is_Class_Wide_Type (Typ)
8105 and then Is_Class_Wide_Type (View)
8107 Root_Typ := Root_Type (Typ);
8108 Root_View := Root_Type (View);
8110 if Root_Typ = Root_View then
8113 -- An incomplete tagged type and its full view may receive two
8114 -- distinct class-wide types when the related package has not
8115 -- been analyzed yet.
8118 -- type T is tagged; -- CW_1
8119 -- type T is tagged null record; -- CW_2
8122 -- This is because the package lacks any semantic information
8123 -- that may eventually link both views of T. As a consequence,
8124 -- a client of the limited view of Pack will see CW_2 while a
8125 -- client of the non-limited view of Pack will see CW_1.
8127 elsif Is_Incomplete_Type (Root_Typ)
8128 and then Present (Full_View (Root_Typ))
8129 and then Full_View (Root_Typ) = Root_View
8133 elsif Is_Incomplete_Type (Root_View)
8134 and then Present (Full_View (Root_View))
8135 and then Full_View (Root_View) = Root_Typ
8142 end Is_Matching_Limited_View;
8144 -- Start of processing for Matches_Limited_With_View
8147 -- In some cases a type imported through a limited_with clause, and
8148 -- its non-limited view are both visible, for example in an anonymous
8149 -- access-to-class-wide type in a formal, or when building the body
8150 -- for a subprogram renaming after the subprogram has been frozen.
8151 -- In these cases both entities designate the same type. In addition,
8152 -- if one of them is an actual in an instance, it may be a subtype of
8153 -- the non-limited view of the other.
8155 if From_Limited_With (Typ_1)
8156 and then From_Limited_With (Typ_2)
8157 and then Available_View (Typ_1) = Available_View (Typ_2)
8161 elsif From_Limited_With (Typ_1) then
8162 return Is_Matching_Limited_View (Typ_2, Available_View (Typ_1));
8164 elsif From_Limited_With (Typ_2) then
8165 return Is_Matching_Limited_View (Typ_1, Available_View (Typ_2));
8170 end Matches_Limited_With_View;
8174 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
8176 Type_1 : Entity_Id := T1;
8177 Type_2 : Entity_Id := T2;
8179 -- Start of processing for Conforming_Types
8182 -- The context is an instance association for a formal access-to-
8183 -- subprogram type; the formal parameter types require mapping because
8184 -- they may denote other formal parameters of the generic unit.
8187 Type_1 := Get_Instance_Of (T1);
8188 Type_2 := Get_Instance_Of (T2);
8191 -- If one of the types is a view of the other introduced by a limited
8192 -- with clause, treat these as conforming for all purposes.
8194 if Matches_Limited_With_View (T1, T2) then
8197 elsif Base_Types_Match (Type_1, Type_2) then
8198 if Ctype <= Mode_Conformant then
8203 Subtypes_Statically_Match (Type_1, Type_2)
8204 and then Dimensions_Match (Type_1, Type_2);
8207 elsif Is_Incomplete_Or_Private_Type (Type_1)
8208 and then Present (Full_View (Type_1))
8209 and then Base_Types_Match (Full_View (Type_1), Type_2)
8212 Ctype <= Mode_Conformant
8213 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
8215 elsif Ekind (Type_2) = E_Incomplete_Type
8216 and then Present (Full_View (Type_2))
8217 and then Base_Types_Match (Type_1, Full_View (Type_2))
8220 Ctype <= Mode_Conformant
8221 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
8223 elsif Is_Private_Type (Type_2)
8224 and then In_Instance
8225 and then Present (Full_View (Type_2))
8226 and then Base_Types_Match (Type_1, Full_View (Type_2))
8229 Ctype <= Mode_Conformant
8230 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
8232 -- Another confusion between views in a nested instance with an
8233 -- actual private type whose full view is not in scope.
8235 elsif Ekind (Type_2) = E_Private_Subtype
8236 and then In_Instance
8237 and then Etype (Type_2) = Type_1
8241 -- In Ada 2012, incomplete types (including limited views) can appear
8242 -- as actuals in instantiations, where they are conformant to the
8243 -- corresponding incomplete formal.
8245 elsif Is_Incomplete_Type (Type_1)
8246 and then Is_Incomplete_Type (Type_2)
8247 and then In_Instance
8248 and then (Used_As_Generic_Actual (Type_1)
8249 or else Used_As_Generic_Actual (Type_2))
8254 -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
8255 -- treated recursively because they carry a signature. As far as
8256 -- conformance is concerned, convention plays no role, and either
8257 -- or both could be access to protected subprograms.
8259 Are_Anonymous_Access_To_Subprogram_Types :=
8260 Ekind (Type_1) in E_Anonymous_Access_Subprogram_Type
8261 | E_Anonymous_Access_Protected_Subprogram_Type
8263 Ekind (Type_2) in E_Anonymous_Access_Subprogram_Type
8264 | E_Anonymous_Access_Protected_Subprogram_Type;
8266 -- Test anonymous access type case. For this case, static subtype
8267 -- matching is required for mode conformance (RM 6.3.1(15)). We check
8268 -- the base types because we may have built internal subtype entities
8269 -- to handle null-excluding types (see Process_Formals).
8271 if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
8273 Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
8275 -- Ada 2005 (AI-254)
8277 or else Are_Anonymous_Access_To_Subprogram_Types
8280 Desig_1 : Entity_Id;
8281 Desig_2 : Entity_Id;
8284 -- In Ada 2005, access constant indicators must match for
8285 -- subtype conformance.
8287 if Ada_Version >= Ada_2005
8288 and then Ctype >= Subtype_Conformant
8290 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
8295 Desig_1 := Find_Designated_Type (Type_1);
8296 Desig_2 := Find_Designated_Type (Type_2);
8298 -- If the context is an instance association for a formal
8299 -- access-to-subprogram type; formal access parameter designated
8300 -- types require mapping because they may denote other formal
8301 -- parameters of the generic unit.
8304 Desig_1 := Get_Instance_Of (Desig_1);
8305 Desig_2 := Get_Instance_Of (Desig_2);
8308 -- It is possible for a Class_Wide_Type to be introduced for an
8309 -- incomplete type, in which case there is a separate class_ wide
8310 -- type for the full view. The types conform if their Etypes
8311 -- conform, i.e. one may be the full view of the other. This can
8312 -- only happen in the context of an access parameter, other uses
8313 -- of an incomplete Class_Wide_Type are illegal.
8315 if Is_Class_Wide_Type (Desig_1)
8317 Is_Class_Wide_Type (Desig_2)
8321 (Etype (Base_Type (Desig_1)),
8322 Etype (Base_Type (Desig_2)), Ctype);
8324 elsif Are_Anonymous_Access_To_Subprogram_Types then
8325 if Ada_Version < Ada_2005 then
8327 Ctype = Type_Conformant
8328 or else Subtypes_Statically_Match (Desig_1, Desig_2);
8330 -- We must check the conformance of the signatures themselves
8334 Conformant : Boolean;
8337 (Desig_1, Desig_2, Ctype, False, Conformant);
8342 -- A limited view of an actual matches the corresponding
8343 -- incomplete formal.
8345 elsif Ekind (Desig_2) = E_Incomplete_Subtype
8346 and then From_Limited_With (Desig_2)
8347 and then Used_As_Generic_Actual (Etype (Desig_2))
8352 return Base_Type (Desig_1) = Base_Type (Desig_2)
8353 and then (Ctype = Type_Conformant
8355 Subtypes_Statically_Match (Desig_1, Desig_2));
8359 -- Otherwise definitely no match
8362 if ((Ekind (Type_1) = E_Anonymous_Access_Type
8363 and then Is_Access_Type (Type_2))
8364 or else (Ekind (Type_2) = E_Anonymous_Access_Type
8365 and then Is_Access_Type (Type_1)))
8368 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
8370 May_Hide_Profile := True;
8375 end Conforming_Types;
8377 --------------------------
8378 -- Create_Extra_Formals --
8379 --------------------------
8381 procedure Create_Extra_Formals (E : Entity_Id) is
8382 First_Extra : Entity_Id := Empty;
8384 Last_Extra : Entity_Id := Empty;
8386 function Add_Extra_Formal
8387 (Assoc_Entity : Entity_Id;
8390 Suffix : String) return Entity_Id;
8391 -- Add an extra formal to the current list of formals and extra formals.
8392 -- The extra formal is added to the end of the list of extra formals,
8393 -- and also returned as the result. These formals are always of mode IN.
8394 -- The new formal has the type Typ, is declared in Scope, and its name
8395 -- is given by a concatenation of the name of Assoc_Entity and Suffix.
8396 -- The following suffixes are currently used. They should not be changed
8397 -- without coordinating with CodePeer, which makes use of these to
8398 -- provide better messages.
8400 -- O denotes the Constrained bit.
8401 -- L denotes the accessibility level.
8402 -- BIP_xxx denotes an extra formal for a build-in-place function. See
8403 -- the full list in exp_ch6.BIP_Formal_Kind.
8405 ----------------------
8406 -- Add_Extra_Formal --
8407 ----------------------
8409 function Add_Extra_Formal
8410 (Assoc_Entity : Entity_Id;
8413 Suffix : String) return Entity_Id
8415 EF : constant Entity_Id :=
8416 Make_Defining_Identifier (Sloc (Assoc_Entity),
8417 Chars => New_External_Name (Chars (Assoc_Entity),
8421 -- A little optimization. Never generate an extra formal for the
8422 -- _init operand of an initialization procedure, since it could
8425 if Chars (Formal) = Name_uInit then
8429 Set_Ekind (EF, E_In_Parameter);
8430 Set_Actual_Subtype (EF, Typ);
8431 Set_Etype (EF, Typ);
8432 Set_Scope (EF, Scope);
8433 Set_Mechanism (EF, Default_Mechanism);
8434 Set_Formal_Validity (EF);
8436 if No (First_Extra) then
8438 Set_Extra_Formals (Scope, EF);
8441 if Present (Last_Extra) then
8442 Set_Extra_Formal (Last_Extra, EF);
8448 end Add_Extra_Formal;
8452 Formal_Type : Entity_Id;
8453 P_Formal : Entity_Id := Empty;
8455 -- Start of processing for Create_Extra_Formals
8458 -- We never generate extra formals if expansion is not active because we
8459 -- don't need them unless we are generating code.
8461 if not Expander_Active then
8465 -- No need to generate extra formals in interface thunks whose target
8466 -- primitive has no extra formals.
8468 if Is_Thunk (E) and then No (Extra_Formals (Thunk_Entity (E))) then
8472 -- If this is a derived subprogram then the subtypes of the parent
8473 -- subprogram's formal parameters will be used to determine the need
8474 -- for extra formals.
8476 if Is_Overloadable (E) and then Present (Alias (E)) then
8477 P_Formal := First_Formal (Alias (E));
8480 Formal := First_Formal (E);
8481 while Present (Formal) loop
8482 Last_Extra := Formal;
8483 Next_Formal (Formal);
8486 -- If Extra_Formals were already created, don't do it again. This
8487 -- situation may arise for subprogram types created as part of
8488 -- dispatching calls (see Expand_Dispatching_Call).
8490 if Present (Last_Extra) and then Present (Extra_Formal (Last_Extra)) then
8494 -- If the subprogram is a predefined dispatching subprogram then don't
8495 -- generate any extra constrained or accessibility level formals. In
8496 -- general we suppress these for internal subprograms (by not calling
8497 -- Freeze_Subprogram and Create_Extra_Formals at all), but internally
8498 -- generated stream attributes do get passed through because extra
8499 -- build-in-place formals are needed in some cases (limited 'Input).
8501 if Is_Predefined_Internal_Operation (E) then
8502 goto Test_For_Func_Result_Extras;
8505 Formal := First_Formal (E);
8506 while Present (Formal) loop
8508 -- Create extra formal for supporting the attribute 'Constrained.
8509 -- The case of a private type view without discriminants also
8510 -- requires the extra formal if the underlying type has defaulted
8513 if Ekind (Formal) /= E_In_Parameter then
8514 if Present (P_Formal) then
8515 Formal_Type := Etype (P_Formal);
8517 Formal_Type := Etype (Formal);
8520 -- Do not produce extra formals for Unchecked_Union parameters.
8521 -- Jump directly to the end of the loop.
8523 if Is_Unchecked_Union (Base_Type (Formal_Type)) then
8524 goto Skip_Extra_Formal_Generation;
8527 if not Has_Discriminants (Formal_Type)
8528 and then Ekind (Formal_Type) in Private_Kind
8529 and then Present (Underlying_Type (Formal_Type))
8531 Formal_Type := Underlying_Type (Formal_Type);
8534 -- Suppress the extra formal if formal's subtype is constrained or
8535 -- indefinite, or we're compiling for Ada 2012 and the underlying
8536 -- type is tagged and limited. In Ada 2012, a limited tagged type
8537 -- can have defaulted discriminants, but 'Constrained is required
8538 -- to return True, so the formal is never needed (see AI05-0214).
8539 -- Note that this ensures consistency of calling sequences for
8540 -- dispatching operations when some types in a class have defaults
8541 -- on discriminants and others do not (and requiring the extra
8542 -- formal would introduce distributed overhead).
8544 -- If the type does not have a completion yet, treat as prior to
8545 -- Ada 2012 for consistency.
8547 if Has_Discriminants (Formal_Type)
8548 and then not Is_Constrained (Formal_Type)
8549 and then Is_Definite_Subtype (Formal_Type)
8550 and then (Ada_Version < Ada_2012
8551 or else No (Underlying_Type (Formal_Type))
8553 (Is_Limited_Type (Formal_Type)
8556 (Underlying_Type (Formal_Type)))))
8558 Set_Extra_Constrained
8559 (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O"));
8563 -- Create extra formal for supporting accessibility checking. This
8564 -- is done for both anonymous access formals and formals of named
8565 -- access types that are marked as controlling formals. The latter
8566 -- case can occur when Expand_Dispatching_Call creates a subprogram
8567 -- type and substitutes the types of access-to-class-wide actuals
8568 -- for the anonymous access-to-specific-type of controlling formals.
8569 -- Base_Type is applied because in cases where there is a null
8570 -- exclusion the formal may have an access subtype.
8572 -- This is suppressed if we specifically suppress accessibility
8573 -- checks at the package level for either the subprogram, or the
8574 -- package in which it resides. However, we do not suppress it
8575 -- simply if the scope has accessibility checks suppressed, since
8576 -- this could cause trouble when clients are compiled with a
8577 -- different suppression setting. The explicit checks at the
8578 -- package level are safe from this point of view.
8580 if (Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
8581 or else (Is_Controlling_Formal (Formal)
8582 and then Is_Access_Type (Base_Type (Etype (Formal)))))
8584 (Explicit_Suppress (E, Accessibility_Check)
8586 Explicit_Suppress (Scope (E), Accessibility_Check))
8589 or else Present (Extra_Accessibility (P_Formal)))
8591 Set_Extra_Accessibility
8592 (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L"));
8595 -- This label is required when skipping extra formal generation for
8596 -- Unchecked_Union parameters.
8598 <<Skip_Extra_Formal_Generation>>
8600 if Present (P_Formal) then
8601 Next_Formal (P_Formal);
8604 Next_Formal (Formal);
8607 <<Test_For_Func_Result_Extras>>
8609 -- Ada 2012 (AI05-234): "the accessibility level of the result of a
8610 -- function call is ... determined by the point of call ...".
8612 if Needs_Result_Accessibility_Level (E) then
8613 Set_Extra_Accessibility_Of_Result
8614 (E, Add_Extra_Formal (E, Standard_Natural, E, "L"));
8617 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
8618 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
8620 if Is_Build_In_Place_Function (E) then
8622 Result_Subt : constant Entity_Id := Etype (E);
8623 Formal_Typ : Entity_Id;
8624 Subp_Decl : Node_Id;
8625 Discard : Entity_Id;
8628 -- In the case of functions with unconstrained result subtypes,
8629 -- add a 4-state formal indicating whether the return object is
8630 -- allocated by the caller (1), or should be allocated by the
8631 -- callee on the secondary stack (2), in the global heap (3), or
8632 -- in a user-defined storage pool (4). For the moment we just use
8633 -- Natural for the type of this formal. Note that this formal
8634 -- isn't usually needed in the case where the result subtype is
8635 -- constrained, but it is needed when the function has a tagged
8636 -- result, because generally such functions can be called in a
8637 -- dispatching context and such calls must be handled like calls
8638 -- to a class-wide function.
8640 if Needs_BIP_Alloc_Form (E) then
8643 (E, Standard_Natural,
8644 E, BIP_Formal_Suffix (BIP_Alloc_Form));
8646 -- Add BIP_Storage_Pool, in case BIP_Alloc_Form indicates to
8647 -- use a user-defined pool. This formal is not added on
8648 -- ZFP as those targets do not support pools.
8650 if RTE_Available (RE_Root_Storage_Pool_Ptr) then
8653 (E, RTE (RE_Root_Storage_Pool_Ptr),
8654 E, BIP_Formal_Suffix (BIP_Storage_Pool));
8658 -- In the case of functions whose result type needs finalization,
8659 -- add an extra formal which represents the finalization master.
8661 if Needs_BIP_Finalization_Master (E) then
8664 (E, RTE (RE_Finalization_Master_Ptr),
8665 E, BIP_Formal_Suffix (BIP_Finalization_Master));
8668 -- When the result type contains tasks, add two extra formals: the
8669 -- master of the tasks to be created, and the caller's activation
8672 if Needs_BIP_Task_Actuals (E) then
8675 (E, RTE (RE_Master_Id),
8676 E, BIP_Formal_Suffix (BIP_Task_Master));
8678 Set_Has_Master_Entity (E);
8682 (E, RTE (RE_Activation_Chain_Access),
8683 E, BIP_Formal_Suffix (BIP_Activation_Chain));
8686 -- All build-in-place functions get an extra formal that will be
8687 -- passed the address of the return object within the caller.
8690 Create_Itype (E_Anonymous_Access_Type, E, Scope_Id => Scope (E));
8692 -- Incomplete_View_From_Limited_With is needed here because
8693 -- gigi gets confused if the designated type is the full view
8694 -- coming from a limited-with'ed package. In the normal case,
8695 -- (no limited with) Incomplete_View_From_Limited_With
8696 -- returns Result_Subt.
8698 Set_Directly_Designated_Type
8699 (Formal_Typ, Incomplete_View_From_Limited_With (Result_Subt));
8700 Set_Etype (Formal_Typ, Formal_Typ);
8701 Set_Depends_On_Private
8702 (Formal_Typ, Has_Private_Component (Formal_Typ));
8703 Set_Is_Public (Formal_Typ, Is_Public (Scope (Formal_Typ)));
8704 Set_Is_Access_Constant (Formal_Typ, False);
8706 -- Ada 2005 (AI-50217): Propagate the attribute that indicates
8707 -- the designated type comes from the limited view (for back-end
8710 Set_From_Limited_With
8711 (Formal_Typ, From_Limited_With (Result_Subt));
8713 Layout_Type (Formal_Typ);
8715 -- Force the definition of the Itype in case of internal function
8716 -- calls within the same or nested scope.
8718 if Is_Subprogram_Or_Generic_Subprogram (E) then
8719 Subp_Decl := Parent (E);
8721 -- The insertion point for an Itype reference should be after
8722 -- the unit declaration node of the subprogram. An exception
8723 -- to this are inherited operations from a parent type in which
8724 -- case the derived type acts as their parent.
8726 if Nkind (Subp_Decl) in N_Function_Specification
8727 | N_Procedure_Specification
8729 Subp_Decl := Parent (Subp_Decl);
8732 Build_Itype_Reference (Formal_Typ, Subp_Decl);
8737 (E, Formal_Typ, E, BIP_Formal_Suffix (BIP_Object_Access));
8741 -- If this is an instance of a generic, we need to have extra formals
8744 if Is_Generic_Instance (E) and then Present (Alias (E)) then
8745 Set_Extra_Formals (Alias (E), Extra_Formals (E));
8747 end Create_Extra_Formals;
8749 -----------------------------
8750 -- Enter_Overloaded_Entity --
8751 -----------------------------
8753 procedure Enter_Overloaded_Entity (S : Entity_Id) is
8754 function Matches_Predefined_Op return Boolean;
8755 -- This returns an approximation of whether S matches a predefined
8756 -- operator, based on the operator symbol, and the parameter and result
8757 -- types. The rules are scattered throughout chapter 4 of the Ada RM.
8759 ---------------------------
8760 -- Matches_Predefined_Op --
8761 ---------------------------
8763 function Matches_Predefined_Op return Boolean is
8764 Formal_1 : constant Entity_Id := First_Formal (S);
8765 Formal_2 : constant Entity_Id := Next_Formal (Formal_1);
8766 Op : constant Name_Id := Chars (S);
8767 Result_Type : constant Entity_Id := Base_Type (Etype (S));
8768 Type_1 : constant Entity_Id := Base_Type (Etype (Formal_1));
8773 if Present (Formal_2) then
8775 Type_2 : constant Entity_Id := Base_Type (Etype (Formal_2));
8778 -- All but "&" and "**" have same-types parameters
8787 if Type_1 /= Type_2 then
8792 -- Check parameter and result types
8800 Is_Boolean_Type (Result_Type)
8801 and then Result_Type = Type_1;
8807 Is_Integer_Type (Result_Type)
8808 and then Result_Type = Type_1;
8816 Is_Numeric_Type (Result_Type)
8817 and then Result_Type = Type_1;
8823 Is_Boolean_Type (Result_Type)
8824 and then not Is_Limited_Type (Type_1);
8832 Is_Boolean_Type (Result_Type)
8833 and then (Is_Array_Type (Type_1)
8834 or else Is_Scalar_Type (Type_1));
8836 when Name_Op_Concat =>
8837 return Is_Array_Type (Result_Type);
8839 when Name_Op_Expon =>
8841 (Is_Integer_Type (Result_Type)
8842 or else Is_Floating_Point_Type (Result_Type))
8843 and then Result_Type = Type_1
8844 and then Type_2 = Standard_Integer;
8847 raise Program_Error;
8860 Is_Numeric_Type (Result_Type)
8861 and then Result_Type = Type_1;
8865 Is_Boolean_Type (Result_Type)
8866 and then Result_Type = Type_1;
8869 raise Program_Error;
8872 end Matches_Predefined_Op;
8876 E : Entity_Id := Current_Entity_In_Scope (S);
8877 C_E : Entity_Id := Current_Entity (S);
8879 -- Start of processing for Enter_Overloaded_Entity
8883 Set_Has_Homonym (E);
8884 Set_Has_Homonym (S);
8887 Set_Is_Immediately_Visible (S);
8888 Set_Scope (S, Current_Scope);
8890 -- Chain new entity if front of homonym in current scope, so that
8891 -- homonyms are contiguous.
8893 if Present (E) and then E /= C_E then
8894 while Homonym (C_E) /= E loop
8895 C_E := Homonym (C_E);
8898 Set_Homonym (C_E, S);
8902 Set_Current_Entity (S);
8907 if Is_Inherited_Operation (S) then
8908 Append_Inherited_Subprogram (S);
8910 Append_Entity (S, Current_Scope);
8913 Set_Public_Status (S);
8915 if Debug_Flag_E then
8916 Write_Str ("New overloaded entity chain: ");
8917 Write_Name (Chars (S));
8920 while Present (E) loop
8921 Write_Str (" "); Write_Int (Int (E));
8928 -- Generate warning for hiding
8931 and then Comes_From_Source (S)
8932 and then In_Extended_Main_Source_Unit (S)
8939 -- Warn unless genuine overloading. Do not emit warning on
8940 -- hiding predefined operators in Standard (these are either an
8941 -- artifact of our implicit declarations, or simple noise) but
8942 -- keep warning on a operator defined on a local subtype, because
8943 -- of the real danger that different operators may be applied in
8944 -- various parts of the program.
8946 -- Note that if E and S have the same scope, there is never any
8947 -- hiding. Either the two conflict, and the program is illegal,
8948 -- or S is overriding an implicit inherited subprogram.
8950 if Scope (E) /= Scope (S)
8951 and then (not Is_Overloadable (E)
8952 or else Subtype_Conformant (E, S))
8953 and then (Is_Immediately_Visible (E)
8954 or else Is_Potentially_Use_Visible (S))
8956 if Scope (E) = Standard_Standard then
8957 if Nkind (S) = N_Defining_Operator_Symbol
8958 and then Scope (Base_Type (Etype (First_Formal (S)))) /=
8960 and then Matches_Predefined_Op
8963 ("declaration of & hides predefined operator?h?", S);
8966 -- E not immediately within Standard
8969 Error_Msg_Sloc := Sloc (E);
8970 Error_Msg_N ("declaration of & hides one #?h?", S);
8975 end Enter_Overloaded_Entity;
8977 -----------------------------
8978 -- Check_Untagged_Equality --
8979 -----------------------------
8981 procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
8982 Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
8983 Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
8987 -- This check applies only if we have a subprogram declaration with an
8988 -- untagged record type that is conformant to the predefined op.
8990 if Nkind (Decl) /= N_Subprogram_Declaration
8991 or else not Is_Record_Type (Typ)
8992 or else Is_Tagged_Type (Typ)
8993 or else Etype (Next_Formal (First_Formal (Eq_Op))) /= Typ
8998 -- In Ada 2012 case, we will output errors or warnings depending on
8999 -- the setting of debug flag -gnatd.E.
9001 if Ada_Version >= Ada_2012 then
9002 Error_Msg_Warn := Debug_Flag_Dot_EE;
9004 -- In earlier versions of Ada, nothing to do unless we are warning on
9005 -- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set).
9008 if not Warn_On_Ada_2012_Compatibility then
9013 -- Cases where the type has already been frozen
9015 if Is_Frozen (Typ) then
9017 -- The check applies to a primitive operation, so check that type
9018 -- and equality operation are in the same scope.
9020 if Scope (Typ) /= Current_Scope then
9023 -- If the type is a generic actual (sub)type, the operation is not
9024 -- primitive either because the base type is declared elsewhere.
9026 elsif Is_Generic_Actual_Type (Typ) then
9029 -- Here we have a definite error of declaration after freezing
9032 if Ada_Version >= Ada_2012 then
9034 ("equality operator must be declared before type & is "
9035 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ);
9037 -- In Ada 2012 mode with error turned to warning, output one
9038 -- more warning to warn that the equality operation may not
9039 -- compose. This is the consequence of ignoring the error.
9041 if Error_Msg_Warn then
9042 Error_Msg_N ("\equality operation may not compose??", Eq_Op);
9047 ("equality operator must be declared before type& is "
9048 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ);
9051 -- If we are in the package body, we could just move the
9052 -- declaration to the package spec, so add a message saying that.
9054 if In_Package_Body (Scope (Typ)) then
9055 if Ada_Version >= Ada_2012 then
9057 ("\move declaration to package spec<<", Eq_Op);
9060 ("\move declaration to package spec (Ada 2012)?y?", Eq_Op);
9063 -- Otherwise try to find the freezing point for better message.
9066 Obj_Decl := Next (Parent (Typ));
9067 while Present (Obj_Decl) and then Obj_Decl /= Decl loop
9068 if Nkind (Obj_Decl) = N_Object_Declaration
9069 and then Etype (Defining_Identifier (Obj_Decl)) = Typ
9071 -- Freezing point, output warnings
9073 if Ada_Version >= Ada_2012 then
9075 ("type& is frozen by declaration??", Obj_Decl, Typ);
9077 ("\an equality operator cannot be declared after "
9082 ("type& is frozen by declaration (Ada 2012)?y?",
9085 ("\an equality operator cannot be declared after "
9086 & "this point (Ada 2012)?y?",
9092 -- If we reach generated code for subprogram declaration
9093 -- or body, it is the body that froze the type and the
9094 -- declaration is legal.
9096 elsif Sloc (Obj_Decl) = Sloc (Decl) then
9105 -- Here if type is not frozen yet. It is illegal to have a primitive
9106 -- equality declared in the private part if the type is visible.
9108 elsif not In_Same_List (Parent (Typ), Decl)
9109 and then not Is_Limited_Type (Typ)
9111 -- Shouldn't we give an RM reference here???
9113 if Ada_Version >= Ada_2012 then
9115 ("equality operator appears too late<<", Eq_Op);
9118 ("equality operator appears too late (Ada 2012)?y?", Eq_Op);
9121 -- No error detected
9126 end Check_Untagged_Equality;
9128 -----------------------------
9129 -- Find_Corresponding_Spec --
9130 -----------------------------
9132 function Find_Corresponding_Spec
9134 Post_Error : Boolean := True) return Entity_Id
9136 Spec : constant Node_Id := Specification (N);
9137 Designator : constant Entity_Id := Defining_Entity (Spec);
9141 function Different_Generic_Profile (E : Entity_Id) return Boolean;
9142 -- Even if fully conformant, a body may depend on a generic actual when
9143 -- the spec does not, or vice versa, in which case they were distinct
9144 -- entities in the generic.
9146 -------------------------------
9147 -- Different_Generic_Profile --
9148 -------------------------------
9150 function Different_Generic_Profile (E : Entity_Id) return Boolean is
9153 function Same_Generic_Actual (T1, T2 : Entity_Id) return Boolean;
9154 -- Check that the types of corresponding formals have the same
9155 -- generic actual if any. We have to account for subtypes of a
9156 -- generic formal, declared between a spec and a body, which may
9157 -- appear distinct in an instance but matched in the generic, and
9158 -- the subtype may be used either in the spec or the body of the
9159 -- subprogram being checked.
9161 -------------------------
9162 -- Same_Generic_Actual --
9163 -------------------------
9165 function Same_Generic_Actual (T1, T2 : Entity_Id) return Boolean is
9167 function Is_Declared_Subtype (S1, S2 : Entity_Id) return Boolean;
9168 -- Predicate to check whether S1 is a subtype of S2 in the source
9171 -------------------------
9172 -- Is_Declared_Subtype --
9173 -------------------------
9175 function Is_Declared_Subtype (S1, S2 : Entity_Id) return Boolean is
9177 return Comes_From_Source (Parent (S1))
9178 and then Nkind (Parent (S1)) = N_Subtype_Declaration
9179 and then Is_Entity_Name (Subtype_Indication (Parent (S1)))
9180 and then Entity (Subtype_Indication (Parent (S1))) = S2;
9181 end Is_Declared_Subtype;
9183 -- Start of processing for Same_Generic_Actual
9186 return Is_Generic_Actual_Type (T1) = Is_Generic_Actual_Type (T2)
9187 or else Is_Declared_Subtype (T1, T2)
9188 or else Is_Declared_Subtype (T2, T1);
9189 end Same_Generic_Actual;
9191 -- Start of processing for Different_Generic_Profile
9194 if not In_Instance then
9197 elsif Ekind (E) = E_Function
9198 and then not Same_Generic_Actual (Etype (E), Etype (Designator))
9203 F1 := First_Formal (Designator);
9204 F2 := First_Formal (E);
9205 while Present (F1) loop
9206 if not Same_Generic_Actual (Etype (F1), Etype (F2)) then
9215 end Different_Generic_Profile;
9217 -- Start of processing for Find_Corresponding_Spec
9220 E := Current_Entity (Designator);
9221 while Present (E) loop
9223 -- We are looking for a matching spec. It must have the same scope,
9224 -- and the same name, and either be type conformant, or be the case
9225 -- of a library procedure spec and its body (which belong to one
9226 -- another regardless of whether they are type conformant or not).
9228 if Scope (E) = Current_Scope then
9229 if Current_Scope = Standard_Standard
9230 or else (Ekind (E) = Ekind (Designator)
9231 and then Type_Conformant (E, Designator))
9233 -- Within an instantiation, we know that spec and body are
9234 -- subtype conformant, because they were subtype conformant in
9235 -- the generic. We choose the subtype-conformant entity here as
9236 -- well, to resolve spurious ambiguities in the instance that
9237 -- were not present in the generic (i.e. when two different
9238 -- types are given the same actual). If we are looking for a
9239 -- spec to match a body, full conformance is expected.
9243 -- Inherit the convention and "ghostness" of the matching
9244 -- spec to ensure proper full and subtype conformance.
9246 Set_Convention (Designator, Convention (E));
9248 -- Skip past subprogram bodies and subprogram renamings that
9249 -- may appear to have a matching spec, but that aren't fully
9250 -- conformant with it. That can occur in cases where an
9251 -- actual type causes unrelated homographs in the instance.
9253 if Nkind (N) in N_Subprogram_Body
9254 | N_Subprogram_Renaming_Declaration
9255 and then Present (Homonym (E))
9256 and then not Fully_Conformant (Designator, E)
9260 elsif not Subtype_Conformant (Designator, E) then
9263 elsif Different_Generic_Profile (E) then
9268 -- Ada 2012 (AI05-0165): For internally generated bodies of
9269 -- null procedures locate the internally generated spec. We
9270 -- enforce mode conformance since a tagged type may inherit
9271 -- from interfaces several null primitives which differ only
9272 -- in the mode of the formals.
9274 if not (Comes_From_Source (E))
9275 and then Is_Null_Procedure (E)
9276 and then not Mode_Conformant (Designator, E)
9280 -- For null procedures coming from source that are completions,
9281 -- analysis of the generated body will establish the link.
9283 elsif Comes_From_Source (E)
9284 and then Nkind (Spec) = N_Procedure_Specification
9285 and then Null_Present (Spec)
9289 -- Expression functions can be completions, but cannot be
9290 -- completed by an explicit body.
9292 elsif Comes_From_Source (E)
9293 and then Comes_From_Source (N)
9294 and then Nkind (N) = N_Subprogram_Body
9295 and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
9296 N_Expression_Function
9298 Error_Msg_Sloc := Sloc (E);
9299 Error_Msg_N ("body conflicts with expression function#", N);
9302 elsif not Has_Completion (E) then
9303 if Nkind (N) /= N_Subprogram_Body_Stub then
9304 Set_Corresponding_Spec (N, E);
9307 Set_Has_Completion (E);
9310 elsif Nkind (Parent (N)) = N_Subunit then
9312 -- If this is the proper body of a subunit, the completion
9313 -- flag is set when analyzing the stub.
9317 -- If E is an internal function with a controlling result that
9318 -- was created for an operation inherited by a null extension,
9319 -- it may be overridden by a body without a previous spec (one
9320 -- more reason why these should be shunned). In that case we
9321 -- remove the generated body if present, because the current
9322 -- one is the explicit overriding.
9324 elsif Ekind (E) = E_Function
9325 and then Ada_Version >= Ada_2005
9326 and then not Comes_From_Source (E)
9327 and then Has_Controlling_Result (E)
9328 and then Is_Null_Extension (Etype (E))
9329 and then Comes_From_Source (Spec)
9331 Set_Has_Completion (E, False);
9334 and then Nkind (Parent (E)) = N_Function_Specification
9337 (Unit_Declaration_Node
9338 (Corresponding_Body (Unit_Declaration_Node (E))));
9342 -- If expansion is disabled, or if the wrapper function has
9343 -- not been generated yet, this a late body overriding an
9344 -- inherited operation, or it is an overriding by some other
9345 -- declaration before the controlling result is frozen. In
9346 -- either case this is a declaration of a new entity.
9352 -- If the body already exists, then this is an error unless
9353 -- the previous declaration is the implicit declaration of a
9354 -- derived subprogram. It is also legal for an instance to
9355 -- contain type conformant overloadable declarations (but the
9356 -- generic declaration may not), per 8.3(26/2).
9358 elsif No (Alias (E))
9359 and then not Is_Intrinsic_Subprogram (E)
9360 and then not In_Instance
9363 Error_Msg_Sloc := Sloc (E);
9365 if Is_Imported (E) then
9367 ("body not allowed for imported subprogram & declared#",
9370 Error_Msg_NE ("duplicate body for & declared#", N, E);
9374 -- Child units cannot be overloaded, so a conformance mismatch
9375 -- between body and a previous spec is an error.
9377 elsif Is_Child_Unit (E)
9379 Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
9381 Nkind (Parent (Unit_Declaration_Node (Designator))) =
9386 ("body of child unit does not match previous declaration", N);
9394 -- On exit, we know that no previous declaration of subprogram exists
9397 end Find_Corresponding_Spec;
9399 ----------------------
9400 -- Fully_Conformant --
9401 ----------------------
9403 function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
9406 Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
9408 end Fully_Conformant;
9410 ----------------------------------
9411 -- Fully_Conformant_Expressions --
9412 ----------------------------------
9414 function Fully_Conformant_Expressions
9415 (Given_E1 : Node_Id;
9417 Report : Boolean := False) return Boolean
9419 E1 : constant Node_Id := Original_Node (Given_E1);
9420 E2 : constant Node_Id := Original_Node (Given_E2);
9421 -- We always test conformance on original nodes, since it is possible
9422 -- for analysis and/or expansion to make things look as though they
9423 -- conform when they do not, e.g. by converting 1+2 into 3.
9425 function FCE (Given_E1 : Node_Id; Given_E2 : Node_Id) return Boolean;
9428 function FCL (L1 : List_Id; L2 : List_Id) return Boolean;
9429 -- Compare elements of two lists for conformance. Elements have to be
9430 -- conformant, and actuals inserted as default parameters do not match
9431 -- explicit actuals with the same value.
9433 function FCO (Op_Node : Node_Id; Call_Node : Node_Id) return Boolean;
9434 -- Compare an operator node with a function call
9440 function FCE (Given_E1 : Node_Id; Given_E2 : Node_Id) return Boolean is
9442 return Fully_Conformant_Expressions (Given_E1, Given_E2, Report);
9449 function FCL (L1 : List_Id; L2 : List_Id) return Boolean is
9454 if L1 = No_List then
9460 if L2 = No_List then
9466 -- Compare two lists, skipping rewrite insertions (we want to compare
9467 -- the original trees, not the expanded versions).
9470 if Is_Rewrite_Insertion (N1) then
9472 elsif Is_Rewrite_Insertion (N2) then
9478 elsif not FCE (N1, N2) then
9491 function FCO (Op_Node : Node_Id; Call_Node : Node_Id) return Boolean is
9492 Actuals : constant List_Id := Parameter_Associations (Call_Node);
9497 or else Entity (Op_Node) /= Entity (Name (Call_Node))
9502 Act := First (Actuals);
9504 if Nkind (Op_Node) in N_Binary_Op then
9505 if not FCE (Left_Opnd (Op_Node), Act) then
9512 return Present (Act)
9513 and then FCE (Right_Opnd (Op_Node), Act)
9514 and then No (Next (Act));
9518 function User_Defined_Numeric_Literal_Mismatch return Boolean;
9519 -- Usually literals with the same value like 12345 and 12_345
9520 -- or 123.0 and 123.00 conform, but not if they are
9521 -- user-defined literals.
9523 -------------------------------------------
9524 -- User_Defined_Numeric_Literal_Mismatch --
9525 -------------------------------------------
9527 function User_Defined_Numeric_Literal_Mismatch return Boolean is
9528 E1_Is_User_Defined : constant Boolean :=
9529 Nkind (Given_E1) not in N_Integer_Literal | N_Real_Literal;
9530 E2_Is_User_Defined : constant Boolean :=
9531 Nkind (Given_E2) not in N_Integer_Literal | N_Real_Literal;
9534 pragma Assert (E1_Is_User_Defined = E2_Is_User_Defined);
9536 return E1_Is_User_Defined and then
9537 not String_Equal (String_From_Numeric_Literal (E1),
9538 String_From_Numeric_Literal (E2));
9539 end User_Defined_Numeric_Literal_Mismatch;
9545 -- Start of processing for Fully_Conformant_Expressions
9550 -- Nonconformant if paren count does not match. Note: if some idiot
9551 -- complains that we don't do this right for more than 3 levels of
9552 -- parentheses, they will be treated with the respect they deserve.
9554 if Paren_Count (E1) /= Paren_Count (E2) then
9557 -- If same entities are referenced, then they are conformant even if
9558 -- they have different forms (RM 8.3.1(19-20)).
9560 elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
9561 if Present (Entity (E1)) then
9562 Result := Entity (E1) = Entity (E2)
9564 -- One may be a discriminant that has been replaced by the
9565 -- corresponding discriminal.
9568 (Chars (Entity (E1)) = Chars (Entity (E2))
9569 and then Ekind (Entity (E1)) = E_Discriminant
9570 and then Ekind (Entity (E2)) = E_In_Parameter)
9572 -- The discriminant of a protected type is transformed into
9573 -- a local constant and then into a parameter of a protected
9577 (Ekind (Entity (E1)) = E_Constant
9578 and then Ekind (Entity (E2)) = E_In_Parameter
9579 and then Present (Discriminal_Link (Entity (E1)))
9580 and then Discriminal_Link (Entity (E1)) =
9581 Discriminal_Link (Entity (E2)))
9583 -- AI12-050: The loop variables of quantified expressions match
9584 -- if they have the same identifier, even though they may have
9585 -- different entities.
9588 (Chars (Entity (E1)) = Chars (Entity (E2))
9589 and then Ekind (Entity (E1)) = E_Loop_Parameter
9590 and then Ekind (Entity (E2)) = E_Loop_Parameter)
9592 -- A call to an instantiation of Unchecked_Conversion is
9593 -- rewritten with the name of the generated function created for
9594 -- the instance, and this must be special-cased.
9597 (Ekind (Entity (E1)) = E_Function
9598 and then Is_Intrinsic_Subprogram (Entity (E1))
9599 and then Is_Generic_Instance (Entity (E1))
9600 and then Entity (E2) = Alias (Entity (E1)));
9601 if Report and not Result then
9603 Text_Ptr'Max (Sloc (Entity (E1)), Sloc (Entity (E2)));
9605 ("Meaning of& differs because of declaration#", E1, E2);
9610 elsif Nkind (E1) = N_Expanded_Name
9611 and then Nkind (E2) = N_Expanded_Name
9612 and then Nkind (Selector_Name (E1)) = N_Character_Literal
9613 and then Nkind (Selector_Name (E2)) = N_Character_Literal
9615 return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
9618 -- Identifiers in component associations don't always have
9619 -- entities, but their names must conform.
9621 return Nkind (E1) = N_Identifier
9622 and then Nkind (E2) = N_Identifier
9623 and then Chars (E1) = Chars (E2);
9626 elsif Nkind (E1) = N_Character_Literal
9627 and then Nkind (E2) = N_Expanded_Name
9629 return Nkind (Selector_Name (E2)) = N_Character_Literal
9630 and then Chars (E1) = Chars (Selector_Name (E2));
9632 elsif Nkind (E2) = N_Character_Literal
9633 and then Nkind (E1) = N_Expanded_Name
9635 return Nkind (Selector_Name (E1)) = N_Character_Literal
9636 and then Chars (E2) = Chars (Selector_Name (E1));
9638 elsif Nkind (E1) in N_Op and then Nkind (E2) = N_Function_Call then
9639 return FCO (E1, E2);
9641 elsif Nkind (E2) in N_Op and then Nkind (E1) = N_Function_Call then
9642 return FCO (E2, E1);
9644 -- Otherwise we must have the same syntactic entity
9646 elsif Nkind (E1) /= Nkind (E2) then
9649 -- At this point, we specialize by node type
9655 FCL (Expressions (E1), Expressions (E2))
9657 FCL (Component_Associations (E1),
9658 Component_Associations (E2));
9661 if Nkind (Expression (E1)) = N_Qualified_Expression
9663 Nkind (Expression (E2)) = N_Qualified_Expression
9665 return FCE (Expression (E1), Expression (E2));
9667 -- Check that the subtype marks and any constraints
9672 Indic1 : constant Node_Id := Expression (E1);
9673 Indic2 : constant Node_Id := Expression (E2);
9678 if Nkind (Indic1) /= N_Subtype_Indication then
9680 Nkind (Indic2) /= N_Subtype_Indication
9681 and then Entity (Indic1) = Entity (Indic2);
9683 elsif Nkind (Indic2) /= N_Subtype_Indication then
9685 Nkind (Indic1) /= N_Subtype_Indication
9686 and then Entity (Indic1) = Entity (Indic2);
9689 if Entity (Subtype_Mark (Indic1)) /=
9690 Entity (Subtype_Mark (Indic2))
9695 Elt1 := First (Constraints (Constraint (Indic1)));
9696 Elt2 := First (Constraints (Constraint (Indic2)));
9697 while Present (Elt1) and then Present (Elt2) loop
9698 if not FCE (Elt1, Elt2) then
9711 when N_Attribute_Reference =>
9713 Attribute_Name (E1) = Attribute_Name (E2)
9714 and then FCL (Expressions (E1), Expressions (E2));
9718 Entity (E1) = Entity (E2)
9719 and then FCE (Left_Opnd (E1), Left_Opnd (E2))
9720 and then FCE (Right_Opnd (E1), Right_Opnd (E2));
9722 when N_Membership_Test
9726 FCE (Left_Opnd (E1), Left_Opnd (E2))
9728 FCE (Right_Opnd (E1), Right_Opnd (E2));
9730 when N_Case_Expression =>
9736 if not FCE (Expression (E1), Expression (E2)) then
9740 Alt1 := First (Alternatives (E1));
9741 Alt2 := First (Alternatives (E2));
9743 if Present (Alt1) /= Present (Alt2) then
9745 elsif No (Alt1) then
9749 if not FCE (Expression (Alt1), Expression (Alt2))
9750 or else not FCL (Discrete_Choices (Alt1),
9751 Discrete_Choices (Alt2))
9762 when N_Character_Literal =>
9764 Char_Literal_Value (E1) = Char_Literal_Value (E2);
9766 when N_Component_Association =>
9768 FCL (Choices (E1), Choices (E2))
9770 FCE (Expression (E1), Expression (E2));
9772 when N_Explicit_Dereference =>
9774 FCE (Prefix (E1), Prefix (E2));
9776 when N_Extension_Aggregate =>
9778 FCL (Expressions (E1), Expressions (E2))
9779 and then Null_Record_Present (E1) =
9780 Null_Record_Present (E2)
9781 and then FCL (Component_Associations (E1),
9782 Component_Associations (E2));
9784 when N_Function_Call =>
9786 FCE (Name (E1), Name (E2))
9788 FCL (Parameter_Associations (E1),
9789 Parameter_Associations (E2));
9791 when N_If_Expression =>
9793 FCL (Expressions (E1), Expressions (E2));
9795 when N_Indexed_Component =>
9797 FCE (Prefix (E1), Prefix (E2))
9799 FCL (Expressions (E1), Expressions (E2));
9801 when N_Integer_Literal =>
9802 return (Intval (E1) = Intval (E2))
9803 and then not User_Defined_Numeric_Literal_Mismatch;
9808 when N_Operator_Symbol =>
9810 Chars (E1) = Chars (E2);
9812 when N_Others_Choice =>
9815 when N_Parameter_Association =>
9817 Chars (Selector_Name (E1)) = Chars (Selector_Name (E2))
9818 and then FCE (Explicit_Actual_Parameter (E1),
9819 Explicit_Actual_Parameter (E2));
9821 when N_Qualified_Expression
9823 | N_Unchecked_Type_Conversion
9826 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
9828 FCE (Expression (E1), Expression (E2));
9830 when N_Quantified_Expression =>
9831 if not FCE (Condition (E1), Condition (E2)) then
9835 if Present (Loop_Parameter_Specification (E1))
9836 and then Present (Loop_Parameter_Specification (E2))
9839 L1 : constant Node_Id :=
9840 Loop_Parameter_Specification (E1);
9841 L2 : constant Node_Id :=
9842 Loop_Parameter_Specification (E2);
9846 Reverse_Present (L1) = Reverse_Present (L2)
9848 FCE (Defining_Identifier (L1),
9849 Defining_Identifier (L2))
9851 FCE (Discrete_Subtype_Definition (L1),
9852 Discrete_Subtype_Definition (L2));
9855 elsif Present (Iterator_Specification (E1))
9856 and then Present (Iterator_Specification (E2))
9859 I1 : constant Node_Id := Iterator_Specification (E1);
9860 I2 : constant Node_Id := Iterator_Specification (E2);
9864 FCE (Defining_Identifier (I1),
9865 Defining_Identifier (I2))
9867 Of_Present (I1) = Of_Present (I2)
9869 Reverse_Present (I1) = Reverse_Present (I2)
9870 and then FCE (Name (I1), Name (I2))
9871 and then FCE (Subtype_Indication (I1),
9872 Subtype_Indication (I2));
9875 -- The quantified expressions used different specifications to
9876 -- walk their respective ranges.
9884 FCE (Low_Bound (E1), Low_Bound (E2))
9886 FCE (High_Bound (E1), High_Bound (E2));
9888 when N_Real_Literal =>
9889 return (Realval (E1) = Realval (E2))
9890 and then not User_Defined_Numeric_Literal_Mismatch;
9892 when N_Selected_Component =>
9894 FCE (Prefix (E1), Prefix (E2))
9896 FCE (Selector_Name (E1), Selector_Name (E2));
9900 FCE (Prefix (E1), Prefix (E2))
9902 FCE (Discrete_Range (E1), Discrete_Range (E2));
9904 when N_String_Literal =>
9906 S1 : constant String_Id := Strval (E1);
9907 S2 : constant String_Id := Strval (E2);
9908 L1 : constant Nat := String_Length (S1);
9909 L2 : constant Nat := String_Length (S2);
9916 for J in 1 .. L1 loop
9917 if Get_String_Char (S1, J) /=
9918 Get_String_Char (S2, J)
9930 Entity (E1) = Entity (E2)
9932 FCE (Right_Opnd (E1), Right_Opnd (E2));
9934 -- All other node types cannot appear in this context. Strictly
9935 -- we should raise a fatal internal error. Instead we just ignore
9936 -- the nodes. This means that if anyone makes a mistake in the
9937 -- expander and mucks an expression tree irretrievably, the result
9938 -- will be a failure to detect a (probably very obscure) case
9939 -- of non-conformance, which is better than bombing on some
9940 -- case where two expressions do in fact conform.
9946 end Fully_Conformant_Expressions;
9948 ----------------------------------------
9949 -- Fully_Conformant_Discrete_Subtypes --
9950 ----------------------------------------
9952 function Fully_Conformant_Discrete_Subtypes
9953 (Given_S1 : Node_Id;
9954 Given_S2 : Node_Id) return Boolean
9956 S1 : constant Node_Id := Original_Node (Given_S1);
9957 S2 : constant Node_Id := Original_Node (Given_S2);
9959 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean;
9960 -- Special-case for a bound given by a discriminant, which in the body
9961 -- is replaced with the discriminal of the enclosing type.
9963 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean;
9964 -- Check both bounds
9966 -----------------------
9967 -- Conforming_Bounds --
9968 -----------------------
9970 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is
9972 if Is_Entity_Name (B1)
9973 and then Is_Entity_Name (B2)
9974 and then Ekind (Entity (B1)) = E_Discriminant
9976 return Chars (B1) = Chars (B2);
9979 return Fully_Conformant_Expressions (B1, B2);
9981 end Conforming_Bounds;
9983 -----------------------
9984 -- Conforming_Ranges --
9985 -----------------------
9987 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is
9990 Conforming_Bounds (Low_Bound (R1), Low_Bound (R2))
9992 Conforming_Bounds (High_Bound (R1), High_Bound (R2));
9993 end Conforming_Ranges;
9995 -- Start of processing for Fully_Conformant_Discrete_Subtypes
9998 if Nkind (S1) /= Nkind (S2) then
10001 elsif Is_Entity_Name (S1) then
10002 return Entity (S1) = Entity (S2);
10004 elsif Nkind (S1) = N_Range then
10005 return Conforming_Ranges (S1, S2);
10007 elsif Nkind (S1) = N_Subtype_Indication then
10009 Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2))
10012 (Range_Expression (Constraint (S1)),
10013 Range_Expression (Constraint (S2)));
10017 end Fully_Conformant_Discrete_Subtypes;
10019 --------------------
10020 -- Install_Entity --
10021 --------------------
10023 procedure Install_Entity (E : Entity_Id) is
10024 Prev : constant Entity_Id := Current_Entity (E);
10026 Set_Is_Immediately_Visible (E);
10027 Set_Current_Entity (E);
10028 Set_Homonym (E, Prev);
10029 end Install_Entity;
10031 ---------------------
10032 -- Install_Formals --
10033 ---------------------
10035 procedure Install_Formals (Id : Entity_Id) is
10038 F := First_Formal (Id);
10039 while Present (F) loop
10040 Install_Entity (F);
10043 end Install_Formals;
10045 -----------------------------
10046 -- Is_Interface_Conformant --
10047 -----------------------------
10049 function Is_Interface_Conformant
10050 (Tagged_Type : Entity_Id;
10051 Iface_Prim : Entity_Id;
10052 Prim : Entity_Id) return Boolean
10054 -- The operation may in fact be an inherited (implicit) operation
10055 -- rather than the original interface primitive, so retrieve the
10056 -- ultimate ancestor.
10058 Iface : constant Entity_Id :=
10059 Find_Dispatching_Type (Ultimate_Alias (Iface_Prim));
10060 Typ : constant Entity_Id := Find_Dispatching_Type (Prim);
10062 function Controlling_Formal (Prim : Entity_Id) return Entity_Id;
10063 -- Return the controlling formal of Prim
10065 ------------------------
10066 -- Controlling_Formal --
10067 ------------------------
10069 function Controlling_Formal (Prim : Entity_Id) return Entity_Id is
10073 E := First_Entity (Prim);
10074 while Present (E) loop
10075 if Is_Formal (E) and then Is_Controlling_Formal (E) then
10083 end Controlling_Formal;
10087 Iface_Ctrl_F : constant Entity_Id := Controlling_Formal (Iface_Prim);
10088 Prim_Ctrl_F : constant Entity_Id := Controlling_Formal (Prim);
10090 -- Start of processing for Is_Interface_Conformant
10093 pragma Assert (Is_Subprogram (Iface_Prim)
10094 and then Is_Subprogram (Prim)
10095 and then Is_Dispatching_Operation (Iface_Prim)
10096 and then Is_Dispatching_Operation (Prim));
10098 pragma Assert (Is_Interface (Iface)
10099 or else (Present (Alias (Iface_Prim))
10102 (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
10104 if Prim = Iface_Prim
10105 or else not Is_Subprogram (Prim)
10106 or else Ekind (Prim) /= Ekind (Iface_Prim)
10107 or else not Is_Dispatching_Operation (Prim)
10108 or else Scope (Prim) /= Scope (Tagged_Type)
10110 or else Base_Type (Typ) /= Base_Type (Tagged_Type)
10111 or else not Primitive_Names_Match (Iface_Prim, Prim)
10115 -- The mode of the controlling formals must match
10117 elsif Present (Iface_Ctrl_F)
10118 and then Present (Prim_Ctrl_F)
10119 and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F)
10123 -- Case of a procedure, or a function whose result type matches the
10124 -- result type of the interface primitive, or a function that has no
10125 -- controlling result (I or access I).
10127 elsif Ekind (Iface_Prim) = E_Procedure
10128 or else Etype (Prim) = Etype (Iface_Prim)
10129 or else not Has_Controlling_Result (Prim)
10131 return Type_Conformant
10132 (Iface_Prim, Prim, Skip_Controlling_Formals => True);
10134 -- Case of a function returning an interface, or an access to one. Check
10135 -- that the return types correspond.
10137 elsif Implements_Interface (Typ, Iface) then
10138 if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type)
10140 (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type)
10145 Type_Conformant (Prim, Ultimate_Alias (Iface_Prim),
10146 Skip_Controlling_Formals => True);
10152 end Is_Interface_Conformant;
10154 ---------------------------------
10155 -- Is_Non_Overriding_Operation --
10156 ---------------------------------
10158 function Is_Non_Overriding_Operation
10159 (Prev_E : Entity_Id;
10160 New_E : Entity_Id) return Boolean
10162 Formal : Entity_Id;
10164 G_Typ : Entity_Id := Empty;
10166 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
10167 -- If F_Type is a derived type associated with a generic actual subtype,
10168 -- then return its Generic_Parent_Type attribute, else return Empty.
10170 function Types_Correspond
10171 (P_Type : Entity_Id;
10172 N_Type : Entity_Id) return Boolean;
10173 -- Returns true if and only if the types (or designated types in the
10174 -- case of anonymous access types) are the same or N_Type is derived
10175 -- directly or indirectly from P_Type.
10177 -----------------------------
10178 -- Get_Generic_Parent_Type --
10179 -----------------------------
10181 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
10187 if Is_Derived_Type (F_Typ)
10188 and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
10190 -- The tree must be traversed to determine the parent subtype in
10191 -- the generic unit, which unfortunately isn't always available
10192 -- via semantic attributes. ??? (Note: The use of Original_Node
10193 -- is needed for cases where a full derived type has been
10196 -- If the parent type is a scalar type, the derivation creates
10197 -- an anonymous base type for it, and the source type is its
10200 if Is_Scalar_Type (F_Typ)
10201 and then not Comes_From_Source (F_Typ)
10205 (Original_Node (Parent (First_Subtype (F_Typ))));
10207 Defn := Type_Definition (Original_Node (Parent (F_Typ)));
10209 if Nkind (Defn) = N_Derived_Type_Definition then
10210 Indic := Subtype_Indication (Defn);
10212 if Nkind (Indic) = N_Subtype_Indication then
10213 G_Typ := Entity (Subtype_Mark (Indic));
10215 G_Typ := Entity (Indic);
10218 if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
10219 and then Present (Generic_Parent_Type (Parent (G_Typ)))
10221 return Generic_Parent_Type (Parent (G_Typ));
10227 end Get_Generic_Parent_Type;
10229 ----------------------
10230 -- Types_Correspond --
10231 ----------------------
10233 function Types_Correspond
10234 (P_Type : Entity_Id;
10235 N_Type : Entity_Id) return Boolean
10237 Prev_Type : Entity_Id := Base_Type (P_Type);
10238 New_Type : Entity_Id := Base_Type (N_Type);
10241 if Ekind (Prev_Type) = E_Anonymous_Access_Type then
10242 Prev_Type := Designated_Type (Prev_Type);
10245 if Ekind (New_Type) = E_Anonymous_Access_Type then
10246 New_Type := Designated_Type (New_Type);
10249 if Prev_Type = New_Type then
10252 elsif not Is_Class_Wide_Type (New_Type) then
10253 while Etype (New_Type) /= New_Type loop
10254 New_Type := Etype (New_Type);
10256 if New_Type = Prev_Type then
10262 end Types_Correspond;
10264 -- Start of processing for Is_Non_Overriding_Operation
10267 -- In the case where both operations are implicit derived subprograms
10268 -- then neither overrides the other. This can only occur in certain
10269 -- obscure cases (e.g., derivation from homographs created in a generic
10272 if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
10275 elsif Ekind (Current_Scope) = E_Package
10276 and then Is_Generic_Instance (Current_Scope)
10277 and then In_Private_Part (Current_Scope)
10278 and then Comes_From_Source (New_E)
10280 -- We examine the formals and result type of the inherited operation,
10281 -- to determine whether their type is derived from (the instance of)
10282 -- a generic type. The first such formal or result type is the one
10285 Formal := First_Formal (Prev_E);
10287 while Present (Formal) loop
10288 F_Typ := Base_Type (Etype (Formal));
10290 if Ekind (F_Typ) = E_Anonymous_Access_Type then
10291 F_Typ := Designated_Type (F_Typ);
10294 G_Typ := Get_Generic_Parent_Type (F_Typ);
10295 exit when Present (G_Typ);
10297 Next_Formal (Formal);
10300 -- If the function dispatches on result check the result type
10302 if No (G_Typ) and then Ekind (Prev_E) = E_Function then
10303 G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
10310 -- If the generic type is a private type, then the original operation
10311 -- was not overriding in the generic, because there was no primitive
10312 -- operation to override.
10314 if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
10315 and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
10316 N_Formal_Private_Type_Definition
10320 -- The generic parent type is the ancestor of a formal derived
10321 -- type declaration. We need to check whether it has a primitive
10322 -- operation that should be overridden by New_E in the generic.
10326 P_Formal : Entity_Id;
10327 N_Formal : Entity_Id;
10330 P_Prim : Entity_Id;
10331 Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
10334 while Present (Prim_Elt) loop
10335 P_Prim := Node (Prim_Elt);
10337 if Chars (P_Prim) = Chars (New_E)
10338 and then Ekind (P_Prim) = Ekind (New_E)
10340 P_Formal := First_Formal (P_Prim);
10341 N_Formal := First_Formal (New_E);
10342 while Present (P_Formal) and then Present (N_Formal) loop
10343 P_Typ := Etype (P_Formal);
10344 N_Typ := Etype (N_Formal);
10346 if not Types_Correspond (P_Typ, N_Typ) then
10350 Next_Entity (P_Formal);
10351 Next_Entity (N_Formal);
10354 -- Found a matching primitive operation belonging to the
10355 -- formal ancestor type, so the new subprogram is
10359 and then No (N_Formal)
10360 and then (Ekind (New_E) /= E_Function
10363 (Etype (P_Prim), Etype (New_E)))
10369 Next_Elmt (Prim_Elt);
10372 -- If no match found, then the new subprogram does not override
10373 -- in the generic (nor in the instance).
10375 -- If the type in question is not abstract, and the subprogram
10376 -- is, this will be an error if the new operation is in the
10377 -- private part of the instance. Emit a warning now, which will
10378 -- make the subsequent error message easier to understand.
10380 if Present (F_Typ) and then not Is_Abstract_Type (F_Typ)
10381 and then Is_Abstract_Subprogram (Prev_E)
10382 and then In_Private_Part (Current_Scope)
10384 Error_Msg_Node_2 := F_Typ;
10386 ("private operation& in generic unit does not override "
10387 & "any primitive operation of& (RM 12.3 (18))??",
10397 end Is_Non_Overriding_Operation;
10399 -------------------------------------
10400 -- List_Inherited_Pre_Post_Aspects --
10401 -------------------------------------
10403 procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is
10405 if Opt.List_Inherited_Aspects
10406 and then Is_Subprogram_Or_Generic_Subprogram (E)
10409 Subps : constant Subprogram_List := Inherited_Subprograms (E);
10414 for Index in Subps'Range loop
10415 Items := Contract (Subps (Index));
10417 if Present (Items) then
10418 Prag := Pre_Post_Conditions (Items);
10419 while Present (Prag) loop
10420 Error_Msg_Sloc := Sloc (Prag);
10422 if Class_Present (Prag)
10423 and then not Split_PPC (Prag)
10425 if Pragma_Name (Prag) = Name_Precondition then
10427 ("info: & inherits `Pre''Class` aspect from "
10431 ("info: & inherits `Post''Class` aspect from "
10436 Prag := Next_Pragma (Prag);
10442 end List_Inherited_Pre_Post_Aspects;
10444 ------------------------------
10445 -- Make_Inequality_Operator --
10446 ------------------------------
10448 -- S is the defining identifier of an equality operator. We build a
10449 -- subprogram declaration with the right signature. This operation is
10450 -- intrinsic, because it is always expanded as the negation of the
10451 -- call to the equality function.
10453 procedure Make_Inequality_Operator (S : Entity_Id) is
10454 Loc : constant Source_Ptr := Sloc (S);
10457 Op_Name : Entity_Id;
10459 FF : constant Entity_Id := First_Formal (S);
10460 NF : constant Entity_Id := Next_Formal (FF);
10463 -- Check that equality was properly defined, ignore call if not
10470 A : constant Entity_Id :=
10471 Make_Defining_Identifier (Sloc (FF),
10472 Chars => Chars (FF));
10474 B : constant Entity_Id :=
10475 Make_Defining_Identifier (Sloc (NF),
10476 Chars => Chars (NF));
10479 Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
10481 Formals := New_List (
10482 Make_Parameter_Specification (Loc,
10483 Defining_Identifier => A,
10485 New_Occurrence_Of (Etype (First_Formal (S)),
10486 Sloc (Etype (First_Formal (S))))),
10488 Make_Parameter_Specification (Loc,
10489 Defining_Identifier => B,
10491 New_Occurrence_Of (Etype (Next_Formal (First_Formal (S))),
10492 Sloc (Etype (Next_Formal (First_Formal (S)))))));
10495 Make_Subprogram_Declaration (Loc,
10497 Make_Function_Specification (Loc,
10498 Defining_Unit_Name => Op_Name,
10499 Parameter_Specifications => Formals,
10500 Result_Definition =>
10501 New_Occurrence_Of (Standard_Boolean, Loc)));
10503 -- Insert inequality right after equality if it is explicit or after
10504 -- the derived type when implicit. These entities are created only
10505 -- for visibility purposes, and eventually replaced in the course
10506 -- of expansion, so they do not need to be attached to the tree and
10507 -- seen by the back-end. Keeping them internal also avoids spurious
10508 -- freezing problems. The declaration is inserted in the tree for
10509 -- analysis, and removed afterwards. If the equality operator comes
10510 -- from an explicit declaration, attach the inequality immediately
10511 -- after. Else the equality is inherited from a derived type
10512 -- declaration, so insert inequality after that declaration.
10514 if No (Alias (S)) then
10515 Insert_After (Unit_Declaration_Node (S), Decl);
10516 elsif Is_List_Member (Parent (S)) then
10517 Insert_After (Parent (S), Decl);
10519 Insert_After (Parent (Etype (First_Formal (S))), Decl);
10522 Mark_Rewrite_Insertion (Decl);
10523 Set_Is_Intrinsic_Subprogram (Op_Name);
10526 Set_Has_Completion (Op_Name);
10527 Set_Corresponding_Equality (Op_Name, S);
10528 Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S));
10530 end Make_Inequality_Operator;
10532 ----------------------
10533 -- May_Need_Actuals --
10534 ----------------------
10536 procedure May_Need_Actuals (Fun : Entity_Id) is
10541 F := First_Formal (Fun);
10543 while Present (F) loop
10544 if No (Default_Value (F)) then
10552 Set_Needs_No_Actuals (Fun, B);
10553 end May_Need_Actuals;
10555 ---------------------
10556 -- Mode_Conformant --
10557 ---------------------
10559 function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
10562 Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
10564 end Mode_Conformant;
10566 ---------------------------
10567 -- New_Overloaded_Entity --
10568 ---------------------------
10570 procedure New_Overloaded_Entity
10572 Derived_Type : Entity_Id := Empty)
10574 Overridden_Subp : Entity_Id := Empty;
10575 -- Set if the current scope has an operation that is type-conformant
10576 -- with S, and becomes hidden by S.
10578 Is_Primitive_Subp : Boolean;
10579 -- Set to True if the new subprogram is primitive
10582 -- Entity that S overrides
10584 procedure Check_For_Primitive_Subprogram
10585 (Is_Primitive : out Boolean;
10586 Is_Overriding : Boolean := False);
10587 -- If the subprogram being analyzed is a primitive operation of the type
10588 -- of a formal or result, set the Has_Primitive_Operations flag on the
10589 -- type, and set Is_Primitive to True (otherwise set to False). Set the
10590 -- corresponding flag on the entity itself for later use.
10592 function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean;
10593 -- True if a) E is a subprogram whose first formal is a concurrent type
10594 -- defined in the scope of E that has some entry or subprogram whose
10595 -- profile matches E, or b) E is an internally built dispatching
10596 -- subprogram of a protected type and there is a matching subprogram
10597 -- defined in the enclosing scope of the protected type, or c) E is
10598 -- an entry of a synchronized type and a matching procedure has been
10599 -- previously defined in the enclosing scope of the synchronized type.
10601 function Is_Private_Declaration (E : Entity_Id) return Boolean;
10602 -- Check that E is declared in the private part of the current package,
10603 -- or in the package body, where it may hide a previous declaration.
10604 -- We can't use In_Private_Part by itself because this flag is also
10605 -- set when freezing entities, so we must examine the place of the
10606 -- declaration in the tree, and recognize wrapper packages as well.
10608 function Is_Overriding_Alias
10609 (Old_E : Entity_Id;
10610 New_E : Entity_Id) return Boolean;
10611 -- Check whether new subprogram and old subprogram are both inherited
10612 -- from subprograms that have distinct dispatch table entries. This can
10613 -- occur with derivations from instances with accidental homonyms. The
10614 -- function is conservative given that the converse is only true within
10615 -- instances that contain accidental overloadings.
10617 procedure Report_Conflict (S : Entity_Id; E : Entity_Id);
10618 -- Report conflict between entities S and E
10620 ------------------------------------
10621 -- Check_For_Primitive_Subprogram --
10622 ------------------------------------
10624 procedure Check_For_Primitive_Subprogram
10625 (Is_Primitive : out Boolean;
10626 Is_Overriding : Boolean := False)
10628 Formal : Entity_Id;
10632 function Visible_Part_Type (T : Entity_Id) return Boolean;
10633 -- Returns true if T is declared in the visible part of the current
10634 -- package scope; otherwise returns false. Assumes that T is declared
10637 procedure Check_Private_Overriding (T : Entity_Id);
10638 -- Checks that if a primitive abstract subprogram of a visible
10639 -- abstract type is declared in a private part, then it must override
10640 -- an abstract subprogram declared in the visible part. Also checks
10641 -- that if a primitive function with a controlling result is declared
10642 -- in a private part, then it must override a function declared in
10643 -- the visible part.
10645 ------------------------------
10646 -- Check_Private_Overriding --
10647 ------------------------------
10649 procedure Check_Private_Overriding (T : Entity_Id) is
10650 function Overrides_Private_Part_Op return Boolean;
10651 -- This detects the special case where the overriding subprogram
10652 -- is overriding a subprogram that was declared in the same
10653 -- private part. That case is illegal by 3.9.3(10).
10655 function Overrides_Visible_Function
10656 (Partial_View : Entity_Id) return Boolean;
10657 -- True if S overrides a function in the visible part. The
10658 -- overridden function could be explicitly or implicitly declared.
10660 -------------------------------
10661 -- Overrides_Private_Part_Op --
10662 -------------------------------
10664 function Overrides_Private_Part_Op return Boolean is
10665 Over_Decl : constant Node_Id :=
10666 Unit_Declaration_Node (Overridden_Operation (S));
10667 Subp_Decl : constant Node_Id := Unit_Declaration_Node (S);
10670 pragma Assert (Is_Overriding);
10672 (Nkind (Over_Decl) = N_Abstract_Subprogram_Declaration);
10674 (Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration);
10676 return In_Same_List (Over_Decl, Subp_Decl);
10677 end Overrides_Private_Part_Op;
10679 --------------------------------
10680 -- Overrides_Visible_Function --
10681 --------------------------------
10683 function Overrides_Visible_Function
10684 (Partial_View : Entity_Id) return Boolean
10687 if not Is_Overriding or else not Has_Homonym (S) then
10691 if not Present (Partial_View) then
10695 -- Search through all the homonyms H of S in the current
10696 -- package spec, and return True if we find one that matches.
10697 -- Note that Parent (H) will be the declaration of the
10698 -- partial view of T for a match.
10701 H : Entity_Id := S;
10705 exit when not Present (H) or else Scope (H) /= Scope (S);
10707 if Nkind (Parent (H)) in
10708 N_Private_Extension_Declaration |
10709 N_Private_Type_Declaration
10710 and then Defining_Identifier (Parent (H)) = Partial_View
10718 end Overrides_Visible_Function;
10720 -- Start of processing for Check_Private_Overriding
10723 if Is_Package_Or_Generic_Package (Current_Scope)
10724 and then In_Private_Part (Current_Scope)
10725 and then Visible_Part_Type (T)
10726 and then not In_Instance
10728 if Is_Abstract_Type (T)
10729 and then Is_Abstract_Subprogram (S)
10730 and then (not Is_Overriding
10731 or else not Is_Abstract_Subprogram (E)
10732 or else Overrides_Private_Part_Op)
10735 ("abstract subprograms must be visible (RM 3.9.3(10))!",
10738 elsif Ekind (S) = E_Function then
10740 Partial_View : constant Entity_Id :=
10741 Incomplete_Or_Partial_View (T);
10744 if not Overrides_Visible_Function (Partial_View) then
10746 -- Here, S is "function ... return T;" declared in
10747 -- the private part, not overriding some visible
10748 -- operation. That's illegal in the tagged case
10749 -- (but not if the private type is untagged).
10751 if ((Present (Partial_View)
10752 and then Is_Tagged_Type (Partial_View))
10753 or else (not Present (Partial_View)
10754 and then Is_Tagged_Type (T)))
10755 and then T = Base_Type (Etype (S))
10758 ("private function with tagged result must"
10759 & " override visible-part function", S);
10761 ("\move subprogram to the visible part"
10762 & " (RM 3.9.3(10))", S);
10764 -- Ada 2012 (AI05-0073): Extend this check to the case
10765 -- of a function whose result subtype is defined by an
10766 -- access_definition designating specific tagged type.
10768 elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
10769 and then Is_Tagged_Type (Designated_Type (Etype (S)))
10771 not Is_Class_Wide_Type
10772 (Designated_Type (Etype (S)))
10773 and then Ada_Version >= Ada_2012
10776 ("private function with controlling access "
10777 & "result must override visible-part function",
10780 ("\move subprogram to the visible part"
10781 & " (RM 3.9.3(10))", S);
10787 end Check_Private_Overriding;
10789 -----------------------
10790 -- Visible_Part_Type --
10791 -----------------------
10793 function Visible_Part_Type (T : Entity_Id) return Boolean is
10794 P : constant Node_Id := Unit_Declaration_Node (Scope (T));
10797 -- If the entity is a private type, then it must be declared in a
10800 if Ekind (T) in Private_Kind then
10803 elsif Is_Type (T) and then Has_Private_Declaration (T) then
10806 elsif Is_List_Member (Declaration_Node (T))
10807 and then List_Containing (Declaration_Node (T)) =
10808 Visible_Declarations (Specification (P))
10815 end Visible_Part_Type;
10817 -- Start of processing for Check_For_Primitive_Subprogram
10820 Is_Primitive := False;
10822 if not Comes_From_Source (S) then
10825 -- If subprogram is at library level, it is not primitive operation
10827 elsif Current_Scope = Standard_Standard then
10830 elsif (Is_Package_Or_Generic_Package (Current_Scope)
10831 and then not In_Package_Body (Current_Scope))
10832 or else Is_Overriding
10834 -- For function, check return type
10836 if Ekind (S) = E_Function then
10837 if Ekind (Etype (S)) = E_Anonymous_Access_Type then
10838 F_Typ := Designated_Type (Etype (S));
10840 F_Typ := Etype (S);
10843 B_Typ := Base_Type (F_Typ);
10845 if Scope (B_Typ) = Current_Scope
10846 and then not Is_Class_Wide_Type (B_Typ)
10847 and then not Is_Generic_Type (B_Typ)
10849 Is_Primitive := True;
10850 Set_Has_Primitive_Operations (B_Typ);
10851 Set_Is_Primitive (S);
10852 Check_Private_Overriding (B_Typ);
10854 -- The Ghost policy in effect at the point of declaration
10855 -- or a tagged type and a primitive operation must match
10856 -- (SPARK RM 6.9(16)).
10858 Check_Ghost_Primitive (S, B_Typ);
10862 -- For all subprograms, check formals
10864 Formal := First_Formal (S);
10865 while Present (Formal) loop
10866 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
10867 F_Typ := Designated_Type (Etype (Formal));
10869 F_Typ := Etype (Formal);
10872 B_Typ := Base_Type (F_Typ);
10874 if Ekind (B_Typ) = E_Access_Subtype then
10875 B_Typ := Base_Type (B_Typ);
10878 if Scope (B_Typ) = Current_Scope
10879 and then not Is_Class_Wide_Type (B_Typ)
10880 and then not Is_Generic_Type (B_Typ)
10882 Is_Primitive := True;
10883 Set_Is_Primitive (S);
10884 Set_Has_Primitive_Operations (B_Typ);
10885 Check_Private_Overriding (B_Typ);
10887 -- The Ghost policy in effect at the point of declaration
10888 -- of a tagged type and a primitive operation must match
10889 -- (SPARK RM 6.9(16)).
10891 Check_Ghost_Primitive (S, B_Typ);
10894 Next_Formal (Formal);
10897 -- Special case: An equality function can be redefined for a type
10898 -- occurring in a declarative part, and won't otherwise be treated as
10899 -- a primitive because it doesn't occur in a package spec and doesn't
10900 -- override an inherited subprogram. It's important that we mark it
10901 -- primitive so it can be returned by Collect_Primitive_Operations
10902 -- and be used in composing the equality operation of later types
10903 -- that have a component of the type.
10905 elsif Chars (S) = Name_Op_Eq
10906 and then Etype (S) = Standard_Boolean
10908 B_Typ := Base_Type (Etype (First_Formal (S)));
10910 if Scope (B_Typ) = Current_Scope
10912 Base_Type (Etype (Next_Formal (First_Formal (S)))) = B_Typ
10913 and then not Is_Limited_Type (B_Typ)
10915 Is_Primitive := True;
10916 Set_Is_Primitive (S);
10917 Set_Has_Primitive_Operations (B_Typ);
10918 Check_Private_Overriding (B_Typ);
10920 -- The Ghost policy in effect at the point of declaration of a
10921 -- tagged type and a primitive operation must match
10922 -- (SPARK RM 6.9(16)).
10924 Check_Ghost_Primitive (S, B_Typ);
10927 end Check_For_Primitive_Subprogram;
10929 --------------------------------------
10930 -- Has_Matching_Entry_Or_Subprogram --
10931 --------------------------------------
10933 function Has_Matching_Entry_Or_Subprogram
10934 (E : Entity_Id) return Boolean
10936 function Check_Conforming_Parameters
10937 (E1_Param : Node_Id;
10938 E2_Param : Node_Id;
10939 Ctype : Conformance_Type) return Boolean;
10940 -- Starting from the given parameters, check that all the parameters
10941 -- of two entries or subprograms are conformant. Used to skip
10942 -- the check on the controlling argument.
10944 function Matching_Entry_Or_Subprogram
10945 (Conc_Typ : Entity_Id;
10946 Subp : Entity_Id) return Entity_Id;
10947 -- Return the first entry or subprogram of the given concurrent type
10948 -- whose name matches the name of Subp and has a profile conformant
10949 -- with Subp; return Empty if not found.
10951 function Matching_Dispatching_Subprogram
10952 (Conc_Typ : Entity_Id;
10953 Ent : Entity_Id) return Entity_Id;
10954 -- Return the first dispatching primitive of Conc_Type defined in the
10955 -- enclosing scope of Conc_Type (i.e. before the full definition of
10956 -- this concurrent type) whose name matches the entry Ent and has a
10957 -- profile conformant with the profile of the corresponding (not yet
10958 -- built) dispatching primitive of Ent; return Empty if not found.
10960 function Matching_Original_Protected_Subprogram
10961 (Prot_Typ : Entity_Id;
10962 Subp : Entity_Id) return Entity_Id;
10963 -- Return the first subprogram defined in the enclosing scope of
10964 -- Prot_Typ (before the full definition of this protected type)
10965 -- whose name matches the original name of Subp and has a profile
10966 -- conformant with the profile of Subp; return Empty if not found.
10968 function Normalized_First_Parameter_Type
10969 (E : Entity_Id) return Entity_Id;
10970 -- Return the type of the first parameter unless that type
10971 -- is an anonymous access type, in which case return the
10972 -- designated type. Used to treat anonymous-access-to-synchronized
10973 -- the same as synchronized for purposes of checking for
10974 -- prefixed view profile conflicts.
10976 ---------------------------------
10977 -- Check_Conforming_Parameters --
10978 ---------------------------------
10980 function Check_Conforming_Parameters
10981 (E1_Param : Node_Id;
10982 E2_Param : Node_Id;
10983 Ctype : Conformance_Type) return Boolean
10985 Param_E1 : Node_Id := E1_Param;
10986 Param_E2 : Node_Id := E2_Param;
10989 while Present (Param_E1) and then Present (Param_E2) loop
10990 if (Ctype >= Mode_Conformant) and then
10991 Ekind (Defining_Identifier (Param_E1)) /=
10992 Ekind (Defining_Identifier (Param_E2))
10997 (Find_Parameter_Type (Param_E1),
10998 Find_Parameter_Type (Param_E2),
11008 -- The candidate is not valid if one of the two lists contains
11009 -- more parameters than the other
11011 return No (Param_E1) and then No (Param_E2);
11012 end Check_Conforming_Parameters;
11014 ----------------------------------
11015 -- Matching_Entry_Or_Subprogram --
11016 ----------------------------------
11018 function Matching_Entry_Or_Subprogram
11019 (Conc_Typ : Entity_Id;
11020 Subp : Entity_Id) return Entity_Id
11025 E := First_Entity (Conc_Typ);
11026 while Present (E) loop
11027 if Chars (Subp) = Chars (E)
11028 and then (Ekind (E) = E_Entry or else Is_Subprogram (E))
11030 Check_Conforming_Parameters
11031 (First (Parameter_Specifications (Parent (E))),
11032 Next (First (Parameter_Specifications (Parent (Subp)))),
11042 end Matching_Entry_Or_Subprogram;
11044 -------------------------------------
11045 -- Matching_Dispatching_Subprogram --
11046 -------------------------------------
11048 function Matching_Dispatching_Subprogram
11049 (Conc_Typ : Entity_Id;
11050 Ent : Entity_Id) return Entity_Id
11055 -- Search for entities in the enclosing scope of this synchonized
11058 pragma Assert (Is_Concurrent_Type (Conc_Typ));
11059 Push_Scope (Scope (Conc_Typ));
11060 E := Current_Entity_In_Scope (Ent);
11063 while Present (E) loop
11064 if Scope (E) = Scope (Conc_Typ)
11065 and then Comes_From_Source (E)
11066 and then Ekind (E) = E_Procedure
11067 and then Present (First_Entity (E))
11068 and then Is_Controlling_Formal (First_Entity (E))
11069 and then Etype (First_Entity (E)) = Conc_Typ
11071 Check_Conforming_Parameters
11072 (First (Parameter_Specifications (Parent (Ent))),
11073 Next (First (Parameter_Specifications (Parent (E)))),
11074 Subtype_Conformant)
11083 end Matching_Dispatching_Subprogram;
11085 --------------------------------------------
11086 -- Matching_Original_Protected_Subprogram --
11087 --------------------------------------------
11089 function Matching_Original_Protected_Subprogram
11090 (Prot_Typ : Entity_Id;
11091 Subp : Entity_Id) return Entity_Id
11093 ICF : constant Boolean :=
11094 Is_Controlling_Formal (First_Entity (Subp));
11098 -- Temporarily decorate the first parameter of Subp as controlling
11099 -- formal, required to invoke Subtype_Conformant.
11101 Set_Is_Controlling_Formal (First_Entity (Subp));
11104 Current_Entity_In_Scope (Original_Protected_Subprogram (Subp));
11106 while Present (E) loop
11107 if Scope (E) = Scope (Prot_Typ)
11108 and then Comes_From_Source (E)
11109 and then Ekind (Subp) = Ekind (E)
11110 and then Present (First_Entity (E))
11111 and then Is_Controlling_Formal (First_Entity (E))
11112 and then Etype (First_Entity (E)) = Prot_Typ
11113 and then Subtype_Conformant (Subp, E,
11114 Skip_Controlling_Formals => True)
11116 Set_Is_Controlling_Formal (First_Entity (Subp), ICF);
11123 Set_Is_Controlling_Formal (First_Entity (Subp), ICF);
11126 end Matching_Original_Protected_Subprogram;
11128 -------------------------------------
11129 -- Normalized_First_Parameter_Type --
11130 -------------------------------------
11132 function Normalized_First_Parameter_Type
11133 (E : Entity_Id) return Entity_Id
11135 Result : Entity_Id := Etype (First_Entity (E));
11137 if Ekind (Result) = E_Anonymous_Access_Type then
11138 Result := Designated_Type (Result);
11141 end Normalized_First_Parameter_Type;
11143 -- Start of processing for Has_Matching_Entry_Or_Subprogram
11146 -- Case 1: E is a subprogram whose first formal is a concurrent type
11147 -- defined in the scope of E that has an entry or subprogram whose
11148 -- profile matches E.
11150 if Comes_From_Source (E)
11151 and then Is_Subprogram (E)
11152 and then Present (First_Entity (E))
11153 and then Is_Concurrent_Record_Type
11154 (Normalized_First_Parameter_Type (E))
11157 Scope (Corresponding_Concurrent_Type
11158 (Normalized_First_Parameter_Type (E)))
11161 (Matching_Entry_Or_Subprogram
11162 (Corresponding_Concurrent_Type
11163 (Normalized_First_Parameter_Type (E)),
11166 Report_Conflict (E,
11167 Matching_Entry_Or_Subprogram
11168 (Corresponding_Concurrent_Type
11169 (Normalized_First_Parameter_Type (E)),
11174 -- Case 2: E is an internally built dispatching subprogram of a
11175 -- protected type and there is a subprogram defined in the enclosing
11176 -- scope of the protected type that has the original name of E and
11177 -- its profile is conformant with the profile of E. We check the
11178 -- name of the original protected subprogram associated with E since
11179 -- the expander builds dispatching primitives of protected functions
11180 -- and procedures with other names (see Exp_Ch9.Build_Selected_Name).
11182 elsif not Comes_From_Source (E)
11183 and then Is_Subprogram (E)
11184 and then Present (First_Entity (E))
11185 and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
11186 and then Present (Original_Protected_Subprogram (E))
11189 (Matching_Original_Protected_Subprogram
11190 (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
11193 Report_Conflict (E,
11194 Matching_Original_Protected_Subprogram
11195 (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
11199 -- Case 3: E is an entry of a synchronized type and a matching
11200 -- procedure has been previously defined in the enclosing scope
11201 -- of the synchronized type.
11203 elsif Comes_From_Source (E)
11204 and then Ekind (E) = E_Entry
11206 Present (Matching_Dispatching_Subprogram (Current_Scope, E))
11208 Report_Conflict (E,
11209 Matching_Dispatching_Subprogram (Current_Scope, E));
11214 end Has_Matching_Entry_Or_Subprogram;
11216 ----------------------------
11217 -- Is_Private_Declaration --
11218 ----------------------------
11220 function Is_Private_Declaration (E : Entity_Id) return Boolean is
11221 Decl : constant Node_Id := Unit_Declaration_Node (E);
11222 Priv_Decls : List_Id;
11225 if Is_Package_Or_Generic_Package (Current_Scope)
11226 and then In_Private_Part (Current_Scope)
11229 Private_Declarations (Package_Specification (Current_Scope));
11231 return In_Package_Body (Current_Scope)
11233 (Is_List_Member (Decl)
11234 and then List_Containing (Decl) = Priv_Decls)
11235 or else (Nkind (Parent (Decl)) = N_Package_Specification
11237 Is_Compilation_Unit
11238 (Defining_Entity (Parent (Decl)))
11239 and then List_Containing (Parent (Parent (Decl))) =
11244 end Is_Private_Declaration;
11246 --------------------------
11247 -- Is_Overriding_Alias --
11248 --------------------------
11250 function Is_Overriding_Alias
11251 (Old_E : Entity_Id;
11252 New_E : Entity_Id) return Boolean
11254 AO : constant Entity_Id := Alias (Old_E);
11255 AN : constant Entity_Id := Alias (New_E);
11258 return Scope (AO) /= Scope (AN)
11259 or else No (DTC_Entity (AO))
11260 or else No (DTC_Entity (AN))
11261 or else DT_Position (AO) = DT_Position (AN);
11262 end Is_Overriding_Alias;
11264 ---------------------
11265 -- Report_Conflict --
11266 ---------------------
11268 procedure Report_Conflict (S : Entity_Id; E : Entity_Id) is
11270 Error_Msg_Sloc := Sloc (E);
11272 -- Generate message, with useful additional warning if in generic
11274 if Is_Generic_Unit (E) then
11275 Error_Msg_N ("previous generic unit cannot be overloaded", S);
11276 Error_Msg_N ("\& conflicts with declaration#", S);
11278 Error_Msg_N ("& conflicts with declaration#", S);
11280 end Report_Conflict;
11282 -- Start of processing for New_Overloaded_Entity
11285 -- We need to look for an entity that S may override. This must be a
11286 -- homonym in the current scope, so we look for the first homonym of
11287 -- S in the current scope as the starting point for the search.
11289 E := Current_Entity_In_Scope (S);
11291 -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
11292 -- They are directly added to the list of primitive operations of
11293 -- Derived_Type, unless this is a rederivation in the private part
11294 -- of an operation that was already derived in the visible part of
11295 -- the current package.
11297 if Ada_Version >= Ada_2005
11298 and then Present (Derived_Type)
11299 and then Present (Alias (S))
11300 and then Is_Dispatching_Operation (Alias (S))
11301 and then Present (Find_Dispatching_Type (Alias (S)))
11302 and then Is_Interface (Find_Dispatching_Type (Alias (S)))
11304 -- For private types, when the full-view is processed we propagate to
11305 -- the full view the non-overridden entities whose attribute "alias"
11306 -- references an interface primitive. These entities were added by
11307 -- Derive_Subprograms to ensure that interface primitives are
11310 -- Inside_Freeze_Actions is non zero when S corresponds with an
11311 -- internal entity that links an interface primitive with its
11312 -- covering primitive through attribute Interface_Alias (see
11313 -- Add_Internal_Interface_Entities).
11315 if Inside_Freezing_Actions = 0
11316 and then Is_Package_Or_Generic_Package (Current_Scope)
11317 and then In_Private_Part (Current_Scope)
11318 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
11319 and then Nkind (Parent (S)) = N_Full_Type_Declaration
11320 and then Full_View (Defining_Identifier (Parent (E)))
11321 = Defining_Identifier (Parent (S))
11322 and then Alias (E) = Alias (S)
11324 Check_Operation_From_Private_View (S, E);
11325 Set_Is_Dispatching_Operation (S);
11330 Enter_Overloaded_Entity (S);
11331 Check_Dispatching_Operation (S, Empty);
11332 Check_For_Primitive_Subprogram (Is_Primitive_Subp);
11338 -- For synchronized types check conflicts of this entity with previously
11339 -- defined entities.
11341 if Ada_Version >= Ada_2005
11342 and then Has_Matching_Entry_Or_Subprogram (S)
11347 -- If there is no homonym then this is definitely not overriding
11350 Enter_Overloaded_Entity (S);
11351 Check_Dispatching_Operation (S, Empty);
11352 Check_For_Primitive_Subprogram (Is_Primitive_Subp);
11354 -- If subprogram has an explicit declaration, check whether it has an
11355 -- overriding indicator.
11357 if Comes_From_Source (S) then
11358 Check_Synchronized_Overriding (S, Overridden_Subp);
11360 -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then
11361 -- it may have overridden some hidden inherited primitive. Update
11362 -- Overridden_Subp to avoid spurious errors when checking the
11363 -- overriding indicator.
11365 if Ada_Version >= Ada_2012
11366 and then No (Overridden_Subp)
11367 and then Is_Dispatching_Operation (S)
11368 and then Present (Overridden_Operation (S))
11370 Overridden_Subp := Overridden_Operation (S);
11373 Check_Overriding_Indicator
11374 (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
11376 -- The Ghost policy in effect at the point of declaration of a
11377 -- parent subprogram and an overriding subprogram must match
11378 -- (SPARK RM 6.9(17)).
11380 Check_Ghost_Overriding (S, Overridden_Subp);
11383 -- If there is a homonym that is not overloadable, then we have an
11384 -- error, except for the special cases checked explicitly below.
11386 elsif not Is_Overloadable (E) then
11388 -- Check for spurious conflict produced by a subprogram that has the
11389 -- same name as that of the enclosing generic package. The conflict
11390 -- occurs within an instance, between the subprogram and the renaming
11391 -- declaration for the package. After the subprogram, the package
11392 -- renaming declaration becomes hidden.
11394 if Ekind (E) = E_Package
11395 and then Present (Renamed_Object (E))
11396 and then Renamed_Object (E) = Current_Scope
11397 and then Nkind (Parent (Renamed_Object (E))) =
11398 N_Package_Specification
11399 and then Present (Generic_Parent (Parent (Renamed_Object (E))))
11402 Set_Is_Immediately_Visible (E, False);
11403 Enter_Overloaded_Entity (S);
11404 Set_Homonym (S, Homonym (E));
11405 Check_Dispatching_Operation (S, Empty);
11406 Check_Overriding_Indicator (S, Empty, Is_Primitive => False);
11408 -- If the subprogram is implicit it is hidden by the previous
11409 -- declaration. However if it is dispatching, it must appear in the
11410 -- dispatch table anyway, because it can be dispatched to even if it
11411 -- cannot be called directly.
11413 elsif Present (Alias (S)) and then not Comes_From_Source (S) then
11414 Set_Scope (S, Current_Scope);
11416 if Is_Dispatching_Operation (Alias (S)) then
11417 Check_Dispatching_Operation (S, Empty);
11423 Report_Conflict (S, E);
11427 -- E exists and is overloadable
11430 Check_Synchronized_Overriding (S, Overridden_Subp);
11432 -- Loop through E and its homonyms to determine if any of them is
11433 -- the candidate for overriding by S.
11435 while Present (E) loop
11437 -- Definitely not interesting if not in the current scope
11439 if Scope (E) /= Current_Scope then
11442 -- A function can overload the name of an abstract state. The
11443 -- state can be viewed as a function with a profile that cannot
11444 -- be matched by anything.
11446 elsif Ekind (S) = E_Function
11447 and then Ekind (E) = E_Abstract_State
11449 Enter_Overloaded_Entity (S);
11452 -- Ada 2012 (AI05-0165): For internally generated bodies of null
11453 -- procedures locate the internally generated spec. We enforce
11454 -- mode conformance since a tagged type may inherit from
11455 -- interfaces several null primitives which differ only in
11456 -- the mode of the formals.
11458 elsif not Comes_From_Source (S)
11459 and then Is_Null_Procedure (S)
11460 and then not Mode_Conformant (E, S)
11464 -- Check if we have type conformance
11466 elsif Type_Conformant (E, S) then
11468 -- If the old and new entities have the same profile and one
11469 -- is not the body of the other, then this is an error, unless
11470 -- one of them is implicitly declared.
11472 -- There are some cases when both can be implicit, for example
11473 -- when both a literal and a function that overrides it are
11474 -- inherited in a derivation, or when an inherited operation
11475 -- of a tagged full type overrides the inherited operation of
11476 -- a private extension. Ada 83 had a special rule for the
11477 -- literal case. In Ada 95, the later implicit operation hides
11478 -- the former, and the literal is always the former. In the
11479 -- odd case where both are derived operations declared at the
11480 -- same point, both operations should be declared, and in that
11481 -- case we bypass the following test and proceed to the next
11482 -- part. This can only occur for certain obscure cases in
11483 -- instances, when an operation on a type derived from a formal
11484 -- private type does not override a homograph inherited from
11485 -- the actual. In subsequent derivations of such a type, the
11486 -- DT positions of these operations remain distinct, if they
11489 if Present (Alias (S))
11490 and then (No (Alias (E))
11491 or else Comes_From_Source (E)
11492 or else Is_Abstract_Subprogram (S)
11494 (Is_Dispatching_Operation (E)
11495 and then Is_Overriding_Alias (E, S)))
11496 and then Ekind (E) /= E_Enumeration_Literal
11498 -- When an derived operation is overloaded it may be due to
11499 -- the fact that the full view of a private extension
11500 -- re-inherits. It has to be dealt with.
11502 if Is_Package_Or_Generic_Package (Current_Scope)
11503 and then In_Private_Part (Current_Scope)
11505 Check_Operation_From_Private_View (S, E);
11508 -- In any case the implicit operation remains hidden by the
11509 -- existing declaration, which is overriding. Indicate that
11510 -- E overrides the operation from which S is inherited.
11512 if Present (Alias (S)) then
11513 Set_Overridden_Operation (E, Alias (S));
11514 Inherit_Subprogram_Contract (E, Alias (S));
11517 Set_Overridden_Operation (E, S);
11518 Inherit_Subprogram_Contract (E, S);
11521 -- When a dispatching operation overrides an inherited
11522 -- subprogram, it shall be subtype conformant with the
11523 -- inherited subprogram (RM 3.9.2 (10.2)).
11525 if Comes_From_Source (E)
11526 and then Is_Dispatching_Operation (E)
11527 and then Find_Dispatching_Type (S)
11528 = Find_Dispatching_Type (E)
11530 Check_Subtype_Conformant (E, S);
11533 if Comes_From_Source (E) then
11534 Check_Overriding_Indicator (E, S, Is_Primitive => False);
11536 -- The Ghost policy in effect at the point of declaration
11537 -- of a parent subprogram and an overriding subprogram
11538 -- must match (SPARK RM 6.9(17)).
11540 Check_Ghost_Overriding (E, S);
11545 -- Within an instance, the renaming declarations for actual
11546 -- subprograms may become ambiguous, but they do not hide each
11549 elsif Ekind (E) /= E_Entry
11550 and then not Comes_From_Source (E)
11551 and then not Is_Generic_Instance (E)
11552 and then (Present (Alias (E))
11553 or else Is_Intrinsic_Subprogram (E))
11554 and then (not In_Instance
11555 or else No (Parent (E))
11556 or else Nkind (Unit_Declaration_Node (E)) /=
11557 N_Subprogram_Renaming_Declaration)
11559 -- A subprogram child unit is not allowed to override an
11560 -- inherited subprogram (10.1.1(20)).
11562 if Is_Child_Unit (S) then
11564 ("child unit overrides inherited subprogram in parent",
11569 if Is_Non_Overriding_Operation (E, S) then
11570 Enter_Overloaded_Entity (S);
11572 if No (Derived_Type)
11573 or else Is_Tagged_Type (Derived_Type)
11575 Check_Dispatching_Operation (S, Empty);
11581 -- E is a derived operation or an internal operator which
11582 -- is being overridden. Remove E from further visibility.
11583 -- Furthermore, if E is a dispatching operation, it must be
11584 -- replaced in the list of primitive operations of its type
11585 -- (see Override_Dispatching_Operation).
11587 Overridden_Subp := E;
11589 -- It is possible for E to be in the current scope and
11590 -- yet not in the entity chain. This can only occur in a
11591 -- generic context where E is an implicit concatenation
11592 -- in the formal part, because in a generic body the
11593 -- entity chain starts with the formals.
11595 -- In GNATprove mode, a wrapper for an operation with
11596 -- axiomatization may be a homonym of another declaration
11597 -- for an actual subprogram (needs refinement ???).
11599 if No (Prev_Entity (E)) then
11601 and then GNATprove_Mode
11603 Nkind (Original_Node (Unit_Declaration_Node (S))) =
11604 N_Subprogram_Renaming_Declaration
11608 pragma Assert (Chars (E) = Name_Op_Concat);
11613 -- E must be removed both from the entity_list of the
11614 -- current scope, and from the visibility chain.
11616 if Debug_Flag_E then
11617 Write_Str ("Override implicit operation ");
11618 Write_Int (Int (E));
11622 -- If E is a predefined concatenation, it stands for four
11623 -- different operations. As a result, a single explicit
11624 -- declaration does not hide it. In a possible ambiguous
11625 -- situation, Disambiguate chooses the user-defined op,
11626 -- so it is correct to retain the previous internal one.
11628 if Chars (E) /= Name_Op_Concat
11629 or else Ekind (E) /= E_Operator
11631 -- For nondispatching derived operations that are
11632 -- overridden by a subprogram declared in the private
11633 -- part of a package, we retain the derived subprogram
11634 -- but mark it as not immediately visible. If the
11635 -- derived operation was declared in the visible part
11636 -- then this ensures that it will still be visible
11637 -- outside the package with the proper signature
11638 -- (calls from outside must also be directed to this
11639 -- version rather than the overriding one, unlike the
11640 -- dispatching case). Calls from inside the package
11641 -- will still resolve to the overriding subprogram
11642 -- since the derived one is marked as not visible
11643 -- within the package.
11645 -- If the private operation is dispatching, we achieve
11646 -- the overriding by keeping the implicit operation
11647 -- but setting its alias to be the overriding one. In
11648 -- this fashion the proper body is executed in all
11649 -- cases, but the original signature is used outside
11652 -- If the overriding is not in the private part, we
11653 -- remove the implicit operation altogether.
11655 if Is_Private_Declaration (S) then
11656 if not Is_Dispatching_Operation (E) then
11657 Set_Is_Immediately_Visible (E, False);
11659 -- Work done in Override_Dispatching_Operation, so
11660 -- nothing else needs to be done here.
11666 Remove_Entity_And_Homonym (E);
11670 Enter_Overloaded_Entity (S);
11672 -- For entities generated by Derive_Subprograms the
11673 -- overridden operation is the inherited primitive
11674 -- (which is available through the attribute alias).
11676 if not (Comes_From_Source (E))
11677 and then Is_Dispatching_Operation (E)
11678 and then Find_Dispatching_Type (E) =
11679 Find_Dispatching_Type (S)
11680 and then Present (Alias (E))
11681 and then Comes_From_Source (Alias (E))
11683 Set_Overridden_Operation (S, Alias (E));
11684 Inherit_Subprogram_Contract (S, Alias (E));
11686 -- Normal case of setting entity as overridden
11688 -- Note: Static_Initialization and Overridden_Operation
11689 -- attributes use the same field in subprogram entities.
11690 -- Static_Initialization is only defined for internal
11691 -- initialization procedures, where Overridden_Operation
11692 -- is irrelevant. Therefore the setting of this attribute
11693 -- must check whether the target is an init_proc.
11695 elsif not Is_Init_Proc (S) then
11696 Set_Overridden_Operation (S, E);
11697 Inherit_Subprogram_Contract (S, E);
11700 Check_Overriding_Indicator (S, E, Is_Primitive => True);
11702 -- The Ghost policy in effect at the point of declaration
11703 -- of a parent subprogram and an overriding subprogram
11704 -- must match (SPARK RM 6.9(17)).
11706 Check_Ghost_Overriding (S, E);
11708 -- If S is a user-defined subprogram or a null procedure
11709 -- expanded to override an inherited null procedure, or a
11710 -- predefined dispatching primitive then indicate that E
11711 -- overrides the operation from which S is inherited.
11713 if Comes_From_Source (S)
11715 (Present (Parent (S))
11716 and then Nkind (Parent (S)) = N_Procedure_Specification
11717 and then Null_Present (Parent (S)))
11719 (Present (Alias (E))
11721 Is_Predefined_Dispatching_Operation (Alias (E)))
11723 if Present (Alias (E)) then
11724 Set_Overridden_Operation (S, Alias (E));
11725 Inherit_Subprogram_Contract (S, Alias (E));
11729 if Is_Dispatching_Operation (E) then
11731 -- An overriding dispatching subprogram inherits the
11732 -- convention of the overridden subprogram (AI-117).
11734 Set_Convention (S, Convention (E));
11735 Check_Dispatching_Operation (S, E);
11738 Check_Dispatching_Operation (S, Empty);
11741 Check_For_Primitive_Subprogram
11742 (Is_Primitive_Subp, Is_Overriding => True);
11743 goto Check_Inequality;
11745 -- Apparent redeclarations in instances can occur when two
11746 -- formal types get the same actual type. The subprograms in
11747 -- in the instance are legal, even if not callable from the
11748 -- outside. Calls from within are disambiguated elsewhere.
11749 -- For dispatching operations in the visible part, the usual
11750 -- rules apply, and operations with the same profile are not
11751 -- legal (B830001).
11753 elsif (In_Instance_Visible_Part
11754 and then not Is_Dispatching_Operation (E))
11755 or else In_Instance_Not_Visible
11759 -- Here we have a real error (identical profile)
11762 Error_Msg_Sloc := Sloc (E);
11764 -- Avoid cascaded errors if the entity appears in
11765 -- subsequent calls.
11767 Set_Scope (S, Current_Scope);
11769 -- Generate error, with extra useful warning for the case
11770 -- of a generic instance with no completion.
11772 if Is_Generic_Instance (S)
11773 and then not Has_Completion (E)
11776 ("instantiation cannot provide body for&", S);
11777 Error_Msg_N ("\& conflicts with declaration#", S);
11779 Error_Msg_N ("& conflicts with declaration#", S);
11786 -- If one subprogram has an access parameter and the other
11787 -- a parameter of an access type, calls to either might be
11788 -- ambiguous. Verify that parameters match except for the
11789 -- access parameter.
11791 if May_Hide_Profile then
11797 F1 := First_Formal (S);
11798 F2 := First_Formal (E);
11799 while Present (F1) and then Present (F2) loop
11800 if Is_Access_Type (Etype (F1)) then
11801 if not Is_Access_Type (Etype (F2))
11802 or else not Conforming_Types
11803 (Designated_Type (Etype (F1)),
11804 Designated_Type (Etype (F2)),
11807 May_Hide_Profile := False;
11811 not Conforming_Types
11812 (Etype (F1), Etype (F2), Type_Conformant)
11814 May_Hide_Profile := False;
11821 if May_Hide_Profile
11825 Error_Msg_NE ("calls to& may be ambiguous??", S, S);
11834 -- On exit, we know that S is a new entity
11836 Enter_Overloaded_Entity (S);
11837 Check_For_Primitive_Subprogram (Is_Primitive_Subp);
11838 Check_Overriding_Indicator
11839 (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
11841 -- The Ghost policy in effect at the point of declaration of a parent
11842 -- subprogram and an overriding subprogram must match
11843 -- (SPARK RM 6.9(17)).
11845 Check_Ghost_Overriding (S, Overridden_Subp);
11847 -- If S is a derived operation for an untagged type then by
11848 -- definition it's not a dispatching operation (even if the parent
11849 -- operation was dispatching), so Check_Dispatching_Operation is not
11850 -- called in that case.
11852 if No (Derived_Type)
11853 or else Is_Tagged_Type (Derived_Type)
11855 Check_Dispatching_Operation (S, Empty);
11859 -- If this is a user-defined equality operator that is not a derived
11860 -- subprogram, create the corresponding inequality. If the operation is
11861 -- dispatching, the expansion is done elsewhere, and we do not create
11862 -- an explicit inequality operation.
11864 <<Check_Inequality>>
11865 if Chars (S) = Name_Op_Eq
11866 and then Etype (S) = Standard_Boolean
11867 and then Present (Parent (S))
11868 and then not Is_Dispatching_Operation (S)
11870 Make_Inequality_Operator (S);
11871 Check_Untagged_Equality (S);
11873 end New_Overloaded_Entity;
11875 ----------------------------------
11876 -- Preanalyze_Formal_Expression --
11877 ----------------------------------
11879 procedure Preanalyze_Formal_Expression (N : Node_Id; T : Entity_Id) is
11880 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
11882 In_Spec_Expression := True;
11883 Preanalyze_With_Freezing_And_Resolve (N, T);
11884 In_Spec_Expression := Save_In_Spec_Expression;
11885 end Preanalyze_Formal_Expression;
11887 ---------------------
11888 -- Process_Formals --
11889 ---------------------
11891 procedure Process_Formals
11893 Related_Nod : Node_Id)
11895 function Designates_From_Limited_With (Typ : Entity_Id) return Boolean;
11896 -- Determine whether an access type designates a type coming from a
11899 function Is_Class_Wide_Default (D : Node_Id) return Boolean;
11900 -- Check whether the default has a class-wide type. After analysis the
11901 -- default has the type of the formal, so we must also check explicitly
11902 -- for an access attribute.
11904 ----------------------------------
11905 -- Designates_From_Limited_With --
11906 ----------------------------------
11908 function Designates_From_Limited_With (Typ : Entity_Id) return Boolean is
11909 Desig : Entity_Id := Typ;
11912 if Is_Access_Type (Desig) then
11913 Desig := Directly_Designated_Type (Desig);
11916 if Is_Class_Wide_Type (Desig) then
11917 Desig := Root_Type (Desig);
11921 Ekind (Desig) = E_Incomplete_Type
11922 and then From_Limited_With (Desig);
11923 end Designates_From_Limited_With;
11925 ---------------------------
11926 -- Is_Class_Wide_Default --
11927 ---------------------------
11929 function Is_Class_Wide_Default (D : Node_Id) return Boolean is
11931 return Is_Class_Wide_Type (Designated_Type (Etype (D)))
11932 or else (Nkind (D) = N_Attribute_Reference
11933 and then Attribute_Name (D) = Name_Access
11934 and then Is_Class_Wide_Type (Etype (Prefix (D))));
11935 end Is_Class_Wide_Default;
11939 Context : constant Node_Id := Parent (Parent (T));
11941 Formal : Entity_Id;
11942 Formal_Type : Entity_Id;
11943 Param_Spec : Node_Id;
11946 Num_Out_Params : Nat := 0;
11947 First_Out_Param : Entity_Id := Empty;
11948 -- Used for setting Is_Only_Out_Parameter
11950 -- Start of processing for Process_Formals
11953 -- In order to prevent premature use of the formals in the same formal
11954 -- part, the Ekind is left undefined until all default expressions are
11955 -- analyzed. The Ekind is established in a separate loop at the end.
11957 Param_Spec := First (T);
11958 while Present (Param_Spec) loop
11959 Formal := Defining_Identifier (Param_Spec);
11960 Set_Never_Set_In_Source (Formal, True);
11961 Enter_Name (Formal);
11963 -- Case of ordinary parameters
11965 if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
11966 Find_Type (Parameter_Type (Param_Spec));
11967 Ptype := Parameter_Type (Param_Spec);
11969 if Ptype = Error then
11973 -- Protect against malformed parameter types
11975 if Nkind (Ptype) not in N_Has_Entity then
11976 Formal_Type := Any_Type;
11978 Formal_Type := Entity (Ptype);
11981 if Is_Incomplete_Type (Formal_Type)
11983 (Is_Class_Wide_Type (Formal_Type)
11984 and then Is_Incomplete_Type (Root_Type (Formal_Type)))
11986 -- Ada 2005 (AI-326): Tagged incomplete types allowed in
11987 -- primitive operations, as long as their completion is
11988 -- in the same declarative part. If in the private part
11989 -- this means that the type cannot be a Taft-amendment type.
11990 -- Check is done on package exit. For access to subprograms,
11991 -- the use is legal for Taft-amendment types.
11993 -- Ada 2012: tagged incomplete types are allowed as generic
11994 -- formal types. They do not introduce dependencies and the
11995 -- corresponding generic subprogram does not have a delayed
11996 -- freeze, because it does not need a freeze node. However,
11997 -- it is still the case that untagged incomplete types cannot
11998 -- be Taft-amendment types and must be completed in private
11999 -- part, so the subprogram must appear in the list of private
12000 -- dependents of the type.
12002 if Is_Tagged_Type (Formal_Type)
12003 or else (Ada_Version >= Ada_2012
12004 and then not From_Limited_With (Formal_Type)
12005 and then not Is_Generic_Type (Formal_Type))
12007 if Ekind (Scope (Current_Scope)) = E_Package
12008 and then not Is_Generic_Type (Formal_Type)
12009 and then not Is_Class_Wide_Type (Formal_Type)
12011 if Nkind (Parent (T)) not in
12012 N_Access_Function_Definition |
12013 N_Access_Procedure_Definition
12015 Append_Elmt (Current_Scope,
12016 Private_Dependents (Base_Type (Formal_Type)));
12018 -- Freezing is delayed to ensure that Register_Prim
12019 -- will get called for this operation, which is needed
12020 -- in cases where static dispatch tables aren't built.
12021 -- (Note that the same is done for controlling access
12022 -- parameter cases in function Access_Definition.)
12024 if not Is_Thunk (Current_Scope) then
12025 Set_Has_Delayed_Freeze (Current_Scope);
12030 elsif Nkind (Parent (T)) not in N_Access_Function_Definition
12031 | N_Access_Procedure_Definition
12033 -- AI05-0151: Tagged incomplete types are allowed in all
12034 -- formal parts. Untagged incomplete types are not allowed
12035 -- in bodies. Limited views of either kind are not allowed
12036 -- if there is no place at which the non-limited view can
12037 -- become available.
12039 -- Incomplete formal untagged types are not allowed in
12040 -- subprogram bodies (but are legal in their declarations).
12041 -- This excludes bodies created for null procedures, which
12042 -- are basic declarations.
12044 if Is_Generic_Type (Formal_Type)
12045 and then not Is_Tagged_Type (Formal_Type)
12046 and then Nkind (Parent (Related_Nod)) = N_Subprogram_Body
12049 ("invalid use of formal incomplete type", Param_Spec);
12051 elsif Ada_Version >= Ada_2012 then
12052 if Is_Tagged_Type (Formal_Type)
12053 and then (not From_Limited_With (Formal_Type)
12054 or else not In_Package_Body)
12058 elsif Nkind (Context) in N_Accept_Statement
12059 | N_Accept_Alternative
12061 or else (Nkind (Context) = N_Subprogram_Body
12062 and then Comes_From_Source (Context))
12065 ("invalid use of untagged incomplete type &",
12066 Ptype, Formal_Type);
12071 ("invalid use of incomplete type&",
12072 Param_Spec, Formal_Type);
12074 -- Further checks on the legality of incomplete types
12075 -- in formal parts are delayed until the freeze point
12076 -- of the enclosing subprogram or access to subprogram.
12080 elsif Ekind (Formal_Type) = E_Void then
12082 ("premature use of&",
12083 Parameter_Type (Param_Spec), Formal_Type);
12086 -- Ada 2012 (AI-142): Handle aliased parameters
12088 if Ada_Version >= Ada_2012
12089 and then Aliased_Present (Param_Spec)
12091 Set_Is_Aliased (Formal);
12093 -- AI12-001: All aliased objects are considered to be specified
12094 -- as independently addressable (RM C.6(8.1/4)).
12096 Set_Is_Independent (Formal);
12099 -- Ada 2005 (AI-231): Create and decorate an internal subtype
12100 -- declaration corresponding to the null-excluding type of the
12101 -- formal in the enclosing scope. Finally, replace the parameter
12102 -- type of the formal with the internal subtype.
12104 if Ada_Version >= Ada_2005
12105 and then Null_Exclusion_Present (Param_Spec)
12107 if not Is_Access_Type (Formal_Type) then
12109 ("`NOT NULL` allowed only for an access type", Param_Spec);
12112 if Can_Never_Be_Null (Formal_Type)
12113 and then Comes_From_Source (Related_Nod)
12116 ("`NOT NULL` not allowed (& already excludes null)",
12117 Param_Spec, Formal_Type);
12121 Create_Null_Excluding_Itype
12123 Related_Nod => Related_Nod,
12124 Scope_Id => Scope (Current_Scope));
12126 -- If the designated type of the itype is an itype that is
12127 -- not frozen yet, we set the Has_Delayed_Freeze attribute
12128 -- on the access subtype, to prevent order-of-elaboration
12129 -- issues in the backend.
12132 -- type T is access procedure;
12133 -- procedure Op (O : not null T);
12135 if Is_Itype (Directly_Designated_Type (Formal_Type))
12137 not Is_Frozen (Directly_Designated_Type (Formal_Type))
12139 Set_Has_Delayed_Freeze (Formal_Type);
12144 -- An access formal type
12148 Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
12150 -- No need to continue if we already notified errors
12152 if not Present (Formal_Type) then
12156 -- Ada 2005 (AI-254)
12159 AD : constant Node_Id :=
12160 Access_To_Subprogram_Definition
12161 (Parameter_Type (Param_Spec));
12163 if Present (AD) and then Protected_Present (AD) then
12165 Replace_Anonymous_Access_To_Protected_Subprogram
12171 Set_Etype (Formal, Formal_Type);
12173 -- Deal with default expression if present
12175 Default := Expression (Param_Spec);
12177 if Present (Default) then
12178 if Out_Present (Param_Spec) then
12180 ("default initialization only allowed for IN parameters",
12184 -- Do the special preanalysis of the expression (see section on
12185 -- "Handling of Default Expressions" in the spec of package Sem).
12187 Preanalyze_Formal_Expression (Default, Formal_Type);
12189 -- An access to constant cannot be the default for
12190 -- an access parameter that is an access to variable.
12192 if Ekind (Formal_Type) = E_Anonymous_Access_Type
12193 and then not Is_Access_Constant (Formal_Type)
12194 and then Is_Access_Type (Etype (Default))
12195 and then Is_Access_Constant (Etype (Default))
12198 ("formal that is access to variable cannot be initialized "
12199 & "with an access-to-constant expression", Default);
12202 -- Check that the designated type of an access parameter's default
12203 -- is not a class-wide type unless the parameter's designated type
12204 -- is also class-wide.
12206 if Ekind (Formal_Type) = E_Anonymous_Access_Type
12207 and then not Designates_From_Limited_With (Formal_Type)
12208 and then Is_Class_Wide_Default (Default)
12209 and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
12212 ("access to class-wide expression not allowed here", Default);
12215 -- Check incorrect use of dynamically tagged expressions
12217 if Is_Tagged_Type (Formal_Type) then
12218 Check_Dynamically_Tagged_Expression
12220 Typ => Formal_Type,
12221 Related_Nod => Default);
12225 -- Ada 2005 (AI-231): Static checks
12227 if Ada_Version >= Ada_2005
12228 and then Is_Access_Type (Etype (Formal))
12229 and then Can_Never_Be_Null (Etype (Formal))
12231 Null_Exclusion_Static_Checks (Param_Spec);
12234 -- The following checks are relevant only when SPARK_Mode is on as
12235 -- these are not standard Ada legality rules.
12237 if SPARK_Mode = On then
12238 if Ekind (Scope (Formal)) in E_Function | E_Generic_Function then
12240 -- A function cannot have a parameter of mode IN OUT or OUT
12243 if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
12245 ("function cannot have parameter of mode `OUT` or "
12246 & "`IN OUT`", Formal);
12249 -- A procedure cannot have an effectively volatile formal
12250 -- parameter of mode IN because it behaves as a constant
12251 -- (SPARK RM 7.1.3(4)).
12253 elsif Ekind (Scope (Formal)) = E_Procedure
12254 and then Ekind (Formal) = E_In_Parameter
12255 and then Is_Effectively_Volatile (Formal)
12258 ("formal parameter of mode `IN` cannot be volatile", Formal);
12266 -- If this is the formal part of a function specification, analyze the
12267 -- subtype mark in the context where the formals are visible but not
12268 -- yet usable, and may hide outer homographs.
12270 if Nkind (Related_Nod) = N_Function_Specification then
12271 Analyze_Return_Type (Related_Nod);
12274 -- Now set the kind (mode) of each formal
12276 Param_Spec := First (T);
12277 while Present (Param_Spec) loop
12278 Formal := Defining_Identifier (Param_Spec);
12279 Set_Formal_Mode (Formal);
12281 if Ekind (Formal) = E_In_Parameter then
12282 Set_Default_Value (Formal, Expression (Param_Spec));
12284 if Present (Expression (Param_Spec)) then
12285 Default := Expression (Param_Spec);
12287 if Is_Scalar_Type (Etype (Default)) then
12288 if Nkind (Parameter_Type (Param_Spec)) /=
12289 N_Access_Definition
12291 Formal_Type := Entity (Parameter_Type (Param_Spec));
12295 (Related_Nod, Parameter_Type (Param_Spec));
12298 Apply_Scalar_Range_Check (Default, Formal_Type);
12302 elsif Ekind (Formal) = E_Out_Parameter then
12303 Num_Out_Params := Num_Out_Params + 1;
12305 if Num_Out_Params = 1 then
12306 First_Out_Param := Formal;
12309 elsif Ekind (Formal) = E_In_Out_Parameter then
12310 Num_Out_Params := Num_Out_Params + 1;
12313 -- Skip remaining processing if formal type was in error
12315 if Etype (Formal) = Any_Type or else Error_Posted (Formal) then
12316 goto Next_Parameter;
12319 -- Force call by reference if aliased
12322 Conv : constant Convention_Id := Convention (Etype (Formal));
12324 if Is_Aliased (Formal) then
12325 Set_Mechanism (Formal, By_Reference);
12327 -- Warn if user asked this to be passed by copy
12329 if Conv = Convention_Ada_Pass_By_Copy then
12331 ("cannot pass aliased parameter & by copy??", Formal);
12334 -- Force mechanism if type has Convention Ada_Pass_By_Ref/Copy
12336 elsif Conv = Convention_Ada_Pass_By_Copy then
12337 Set_Mechanism (Formal, By_Copy);
12339 elsif Conv = Convention_Ada_Pass_By_Reference then
12340 Set_Mechanism (Formal, By_Reference);
12348 if Present (First_Out_Param) and then Num_Out_Params = 1 then
12349 Set_Is_Only_Out_Parameter (First_Out_Param);
12351 end Process_Formals;
12353 ----------------------------
12354 -- Reference_Body_Formals --
12355 ----------------------------
12357 procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is
12362 if Error_Posted (Spec) then
12366 -- Iterate over both lists. They may be of different lengths if the two
12367 -- specs are not conformant.
12369 Fs := First_Formal (Spec);
12370 Fb := First_Formal (Bod);
12371 while Present (Fs) and then Present (Fb) loop
12372 Generate_Reference (Fs, Fb, 'b');
12374 if Style_Check then
12375 Style.Check_Identifier (Fb, Fs);
12378 Set_Spec_Entity (Fb, Fs);
12379 Set_Referenced (Fs, False);
12383 end Reference_Body_Formals;
12385 -------------------------
12386 -- Set_Actual_Subtypes --
12387 -------------------------
12389 procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
12391 Formal : Entity_Id;
12393 First_Stmt : Node_Id := Empty;
12394 AS_Needed : Boolean;
12397 -- If this is an empty initialization procedure, no need to create
12398 -- actual subtypes (small optimization).
12400 if Ekind (Subp) = E_Procedure and then Is_Null_Init_Proc (Subp) then
12403 -- Within a predicate function we do not want to generate local
12404 -- subtypes that may generate nested predicate functions.
12406 elsif Is_Subprogram (Subp) and then Is_Predicate_Function (Subp) then
12410 -- The subtype declarations may freeze the formals. The body generated
12411 -- for an expression function is not a freeze point, so do not emit
12412 -- these declarations (small loss of efficiency in rare cases).
12414 if Nkind (N) = N_Subprogram_Body
12415 and then Was_Expression_Function (N)
12420 Formal := First_Formal (Subp);
12421 while Present (Formal) loop
12422 T := Etype (Formal);
12424 -- We never need an actual subtype for a constrained formal
12426 if Is_Constrained (T) then
12427 AS_Needed := False;
12429 -- If we have unknown discriminants, then we do not need an actual
12430 -- subtype, or more accurately we cannot figure it out. Note that
12431 -- all class-wide types have unknown discriminants.
12433 elsif Has_Unknown_Discriminants (T) then
12434 AS_Needed := False;
12436 -- At this stage we have an unconstrained type that may need an
12437 -- actual subtype. For sure the actual subtype is needed if we have
12438 -- an unconstrained array type. However, in an instance, the type
12439 -- may appear as a subtype of the full view, while the actual is
12440 -- in fact private (in which case no actual subtype is needed) so
12441 -- check the kind of the base type.
12443 elsif Is_Array_Type (Base_Type (T)) then
12446 -- The only other case needing an actual subtype is an unconstrained
12447 -- record type which is an IN parameter (we cannot generate actual
12448 -- subtypes for the OUT or IN OUT case, since an assignment can
12449 -- change the discriminant values. However we exclude the case of
12450 -- initialization procedures, since discriminants are handled very
12451 -- specially in this context, see the section entitled "Handling of
12452 -- Discriminants" in Einfo.
12454 -- We also exclude the case of Discrim_SO_Functions (functions used
12455 -- in front-end layout mode for size/offset values), since in such
12456 -- functions only discriminants are referenced, and not only are such
12457 -- subtypes not needed, but they cannot always be generated, because
12458 -- of order of elaboration issues.
12460 elsif Is_Record_Type (T)
12461 and then Ekind (Formal) = E_In_Parameter
12462 and then Chars (Formal) /= Name_uInit
12463 and then not Is_Unchecked_Union (T)
12464 and then not Is_Discrim_SO_Function (Subp)
12468 -- All other cases do not need an actual subtype
12471 AS_Needed := False;
12474 -- Generate actual subtypes for unconstrained arrays and
12475 -- unconstrained discriminated records.
12478 if Nkind (N) = N_Accept_Statement then
12480 -- If expansion is active, the formal is replaced by a local
12481 -- variable that renames the corresponding entry of the
12482 -- parameter block, and it is this local variable that may
12483 -- require an actual subtype.
12485 if Expander_Active then
12486 Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
12488 Decl := Build_Actual_Subtype (T, Formal);
12491 if Present (Handled_Statement_Sequence (N)) then
12493 First (Statements (Handled_Statement_Sequence (N)));
12494 Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
12495 Mark_Rewrite_Insertion (Decl);
12497 -- If the accept statement has no body, there will be no
12498 -- reference to the actuals, so no need to compute actual
12505 Decl := Build_Actual_Subtype (T, Formal);
12506 Prepend (Decl, Declarations (N));
12507 Mark_Rewrite_Insertion (Decl);
12510 -- The declaration uses the bounds of an existing object, and
12511 -- therefore needs no constraint checks.
12513 Analyze (Decl, Suppress => All_Checks);
12514 Set_Is_Actual_Subtype (Defining_Identifier (Decl));
12516 -- We need to freeze manually the generated type when it is
12517 -- inserted anywhere else than in a declarative part.
12519 if Present (First_Stmt) then
12520 Insert_List_Before_And_Analyze (First_Stmt,
12521 Freeze_Entity (Defining_Identifier (Decl), N));
12523 -- Ditto if the type has a dynamic predicate, because the
12524 -- generated function will mention the actual subtype. The
12525 -- predicate may come from an explicit aspect of be inherited.
12527 elsif Has_Predicates (T) then
12528 Insert_List_After_And_Analyze (Decl,
12529 Freeze_Entity (Defining_Identifier (Decl), N));
12532 if Nkind (N) = N_Accept_Statement
12533 and then Expander_Active
12535 Set_Actual_Subtype (Renamed_Object (Formal),
12536 Defining_Identifier (Decl));
12538 Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
12542 Next_Formal (Formal);
12544 end Set_Actual_Subtypes;
12546 ---------------------
12547 -- Set_Formal_Mode --
12548 ---------------------
12550 procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
12551 Spec : constant Node_Id := Parent (Formal_Id);
12552 Id : constant Entity_Id := Scope (Formal_Id);
12555 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
12556 -- since we ensure that corresponding actuals are always valid at the
12557 -- point of the call.
12559 if Out_Present (Spec) then
12561 or else Is_Subprogram_Or_Generic_Subprogram (Id)
12563 Set_Has_Out_Or_In_Out_Parameter (Id, True);
12566 if Ekind (Id) in E_Function | E_Generic_Function then
12568 -- [IN] OUT parameters allowed for functions in Ada 2012
12570 if Ada_Version >= Ada_2012 then
12572 -- Even in Ada 2012 operators can only have IN parameters
12574 if Is_Operator_Symbol_Name (Chars (Scope (Formal_Id))) then
12575 Error_Msg_N ("operators can only have IN parameters", Spec);
12578 if In_Present (Spec) then
12579 Set_Ekind (Formal_Id, E_In_Out_Parameter);
12581 Set_Ekind (Formal_Id, E_Out_Parameter);
12584 -- But not in earlier versions of Ada
12587 Error_Msg_N ("functions can only have IN parameters", Spec);
12588 Set_Ekind (Formal_Id, E_In_Parameter);
12591 elsif In_Present (Spec) then
12592 Set_Ekind (Formal_Id, E_In_Out_Parameter);
12595 Set_Ekind (Formal_Id, E_Out_Parameter);
12596 Set_Never_Set_In_Source (Formal_Id, True);
12597 Set_Is_True_Constant (Formal_Id, False);
12598 Set_Current_Value (Formal_Id, Empty);
12602 Set_Ekind (Formal_Id, E_In_Parameter);
12605 -- Set Is_Known_Non_Null for access parameters since the language
12606 -- guarantees that access parameters are always non-null. We also set
12607 -- Can_Never_Be_Null, since there is no way to change the value.
12609 if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
12611 -- Ada 2005 (AI-231): In Ada 95, access parameters are always non-
12612 -- null; In Ada 2005, only if then null_exclusion is explicit.
12614 if Ada_Version < Ada_2005
12615 or else Can_Never_Be_Null (Etype (Formal_Id))
12617 Set_Is_Known_Non_Null (Formal_Id);
12618 Set_Can_Never_Be_Null (Formal_Id);
12621 -- Ada 2005 (AI-231): Null-exclusion access subtype
12623 elsif Is_Access_Type (Etype (Formal_Id))
12624 and then Can_Never_Be_Null (Etype (Formal_Id))
12626 Set_Is_Known_Non_Null (Formal_Id);
12628 -- We can also set Can_Never_Be_Null (thus preventing some junk
12629 -- access checks) for the case of an IN parameter, which cannot
12630 -- be changed, or for an IN OUT parameter, which can be changed but
12631 -- not to a null value. But for an OUT parameter, the initial value
12632 -- passed in can be null, so we can't set this flag in that case.
12634 if Ekind (Formal_Id) /= E_Out_Parameter then
12635 Set_Can_Never_Be_Null (Formal_Id);
12639 Set_Mechanism (Formal_Id, Default_Mechanism);
12640 Set_Formal_Validity (Formal_Id);
12641 end Set_Formal_Mode;
12643 -------------------------
12644 -- Set_Formal_Validity --
12645 -------------------------
12647 procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
12649 -- If no validity checking, then we cannot assume anything about the
12650 -- validity of parameters, since we do not know there is any checking
12651 -- of the validity on the call side.
12653 if not Validity_Checks_On then
12656 -- If validity checking for parameters is enabled, this means we are
12657 -- not supposed to make any assumptions about argument values.
12659 elsif Validity_Check_Parameters then
12662 -- If we are checking in parameters, we will assume that the caller is
12663 -- also checking parameters, so we can assume the parameter is valid.
12665 elsif Ekind (Formal_Id) = E_In_Parameter
12666 and then Validity_Check_In_Params
12668 Set_Is_Known_Valid (Formal_Id, True);
12670 -- Similar treatment for IN OUT parameters
12672 elsif Ekind (Formal_Id) = E_In_Out_Parameter
12673 and then Validity_Check_In_Out_Params
12675 Set_Is_Known_Valid (Formal_Id, True);
12677 end Set_Formal_Validity;
12679 ------------------------
12680 -- Subtype_Conformant --
12681 ------------------------
12683 function Subtype_Conformant
12684 (New_Id : Entity_Id;
12685 Old_Id : Entity_Id;
12686 Skip_Controlling_Formals : Boolean := False) return Boolean
12690 Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result,
12691 Skip_Controlling_Formals => Skip_Controlling_Formals);
12693 end Subtype_Conformant;
12695 ---------------------
12696 -- Type_Conformant --
12697 ---------------------
12699 function Type_Conformant
12700 (New_Id : Entity_Id;
12701 Old_Id : Entity_Id;
12702 Skip_Controlling_Formals : Boolean := False) return Boolean
12706 May_Hide_Profile := False;
12708 (New_Id, Old_Id, Type_Conformant, False, Result,
12709 Skip_Controlling_Formals => Skip_Controlling_Formals);
12711 end Type_Conformant;
12713 -------------------------------
12714 -- Valid_Operator_Definition --
12715 -------------------------------
12717 procedure Valid_Operator_Definition (Designator : Entity_Id) is
12720 Id : constant Name_Id := Chars (Designator);
12724 F := First_Formal (Designator);
12725 while Present (F) loop
12728 if Present (Default_Value (F)) then
12730 ("default values not allowed for operator parameters",
12733 -- For function instantiations that are operators, we must check
12734 -- separately that the corresponding generic only has in-parameters.
12735 -- For subprogram declarations this is done in Set_Formal_Mode. Such
12736 -- an error could not arise in earlier versions of the language.
12738 elsif Ekind (F) /= E_In_Parameter then
12739 Error_Msg_N ("operators can only have IN parameters", F);
12745 -- Verify that user-defined operators have proper number of arguments
12746 -- First case of operators which can only be unary
12748 if Id in Name_Op_Not | Name_Op_Abs then
12751 -- Case of operators which can be unary or binary
12753 elsif Id in Name_Op_Add | Name_Op_Subtract then
12754 N_OK := (N in 1 .. 2);
12756 -- All other operators can only be binary
12764 ("incorrect number of arguments for operator", Designator);
12768 and then Base_Type (Etype (Designator)) = Standard_Boolean
12769 and then not Is_Intrinsic_Subprogram (Designator)
12772 ("explicit definition of inequality not allowed", Designator);
12774 end Valid_Operator_Definition;