1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Accessibility
; use Accessibility
;
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Contracts
; use Contracts
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Einfo
.Entities
; use Einfo
.Entities
;
34 with Einfo
.Utils
; use Einfo
.Utils
;
35 with Elists
; use Elists
;
36 with Errout
; use Errout
;
37 with Expander
; use Expander
;
38 with Exp_Ch3
; use Exp_Ch3
;
39 with Exp_Ch6
; use Exp_Ch6
;
40 with Exp_Ch9
; use Exp_Ch9
;
41 with Exp_Dbug
; use Exp_Dbug
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
45 with Ghost
; use Ghost
;
46 with Inline
; use Inline
;
47 with Itypes
; use Itypes
;
48 with Lib
.Xref
; use Lib
.Xref
;
49 with Layout
; use Layout
;
51 with Namet
; use Namet
;
53 with Nlists
; use Nlists
;
54 with Nmake
; use Nmake
;
56 with Output
; use Output
;
57 with Restrict
; use Restrict
;
58 with Rtsfind
; use Rtsfind
;
60 with Sem_Aux
; use Sem_Aux
;
61 with Sem_Cat
; use Sem_Cat
;
62 with Sem_Ch3
; use Sem_Ch3
;
63 with Sem_Ch4
; use Sem_Ch4
;
64 with Sem_Ch5
; use Sem_Ch5
;
65 with Sem_Ch8
; use Sem_Ch8
;
66 with Sem_Ch9
; use Sem_Ch9
;
67 with Sem_Ch10
; use Sem_Ch10
;
68 with Sem_Ch12
; use Sem_Ch12
;
69 with Sem_Ch13
; use Sem_Ch13
;
70 with Sem_Dim
; use Sem_Dim
;
71 with Sem_Disp
; use Sem_Disp
;
72 with Sem_Dist
; use Sem_Dist
;
73 with Sem_Elim
; use Sem_Elim
;
74 with Sem_Eval
; use Sem_Eval
;
75 with Sem_Mech
; use Sem_Mech
;
76 with Sem_Prag
; use Sem_Prag
;
77 with Sem_Res
; use Sem_Res
;
78 with Sem_Util
; use Sem_Util
;
79 with Sem_Type
; use Sem_Type
;
80 with Sem_Warn
; use Sem_Warn
;
81 with Sinput
; use Sinput
;
82 with Stand
; use Stand
;
83 with Sinfo
; use Sinfo
;
84 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
85 with Sinfo
.Utils
; use Sinfo
.Utils
;
86 with Sinfo
.CN
; use Sinfo
.CN
;
87 with Snames
; use Snames
;
88 with Stringt
; use Stringt
;
90 with Stylesw
; use Stylesw
;
91 with Tbuild
; use Tbuild
;
92 with Uintp
; use Uintp
;
93 with Urealp
; use Urealp
;
94 with Validsw
; use Validsw
;
95 with Warnsw
; use Warnsw
;
97 package body Sem_Ch6
is
99 May_Hide_Profile
: Boolean := False;
100 -- This flag is used to indicate that two formals in two subprograms being
101 -- checked for conformance differ only in that one is an access parameter
102 -- while the other is of a general access type with the same designated
103 -- type. In this case, if the rest of the signatures match, a call to
104 -- either subprogram may be ambiguous, which is worth a warning. The flag
105 -- is set in Compatible_Types, and the warning emitted in
106 -- New_Overloaded_Entity.
108 -----------------------
109 -- Local Subprograms --
110 -----------------------
112 procedure Analyze_Function_Return
(N
: Node_Id
);
113 -- Subsidiary to Analyze_Return_Statement. Called when the return statement
114 -- applies to a [generic] function.
116 procedure Analyze_Generic_Subprogram_Body
(N
: Node_Id
; Gen_Id
: Entity_Id
);
117 -- Analyze a generic subprogram body. N is the body to be analyzed, and
118 -- Gen_Id is the defining entity Id for the corresponding spec.
120 procedure Analyze_Null_Procedure
122 Is_Completion
: out Boolean);
123 -- A null procedure can be a declaration or (Ada 2012) a completion
125 procedure Analyze_Return_Statement
(N
: Node_Id
);
126 -- Common processing for simple and extended return statements
128 procedure Analyze_Return_Type
(N
: Node_Id
);
129 -- Subsidiary to Process_Formals: analyze subtype mark in function
130 -- specification in a context where the formals are visible and hide
133 procedure Analyze_Subprogram_Body_Helper
(N
: Node_Id
);
134 -- Does all the real work of Analyze_Subprogram_Body. This is split out so
135 -- that we can use RETURN but not skip the debug output at the end.
137 procedure Check_Conformance
140 Ctype
: Conformance_Type
;
142 Conforms
: out Boolean;
143 Err_Loc
: Node_Id
:= Empty
;
144 Get_Inst
: Boolean := False;
145 Skip_Controlling_Formals
: Boolean := False);
146 -- Given two entities, this procedure checks that the profiles associated
147 -- with these entities meet the conformance criterion given by the third
148 -- parameter. If they conform, Conforms is set True and control returns
149 -- to the caller. If they do not conform, Conforms is set to False, and
150 -- in addition, if Errmsg is True on the call, proper messages are output
151 -- to complain about the conformance failure. If Err_Loc is non_Empty
152 -- the error messages are placed on Err_Loc, if Err_Loc is empty, then
153 -- error messages are placed on the appropriate part of the construct
154 -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance
155 -- against a formal access-to-subprogram type so Get_Instance_Of must
158 procedure Check_Formal_Subprogram_Conformance
163 Conforms
: out Boolean);
164 -- Core implementation of Check_Formal_Subprogram_Conformance from spec.
165 -- Errmsg can be set to False to not emit error messages.
166 -- Conforms is set to True if there is conformance, False otherwise.
168 procedure Check_Limited_Return
172 -- Check the appropriate (Ada 95 or Ada 2005) rules for returning limited
173 -- types. Used only for simple return statements. Expr is the expression
176 procedure Check_Subprogram_Order
(N
: Node_Id
);
177 -- N is the N_Subprogram_Body node for a subprogram. This routine applies
178 -- the alpha ordering rule for N if this ordering requirement applicable.
180 procedure Check_Returns
184 Proc
: Entity_Id
:= Empty
);
185 -- Called to check for missing return statements in a function body, or for
186 -- returns present in a procedure body which has No_Return set. HSS is the
187 -- handled statement sequence for the subprogram body. This procedure
188 -- checks all flow paths to make sure they either have return (Mode = 'F',
189 -- used for functions) or do not have a return (Mode = 'P', used for
190 -- No_Return procedures). The flag Err is set if there are any control
191 -- paths not explicitly terminated by a return in the function case, and is
192 -- True otherwise. Proc is the entity for the procedure case and is used
193 -- in posting the warning message.
195 procedure Check_Untagged_Equality
(Eq_Op
: Entity_Id
);
196 -- In Ada 2012, a primitive equality operator for an untagged record type
197 -- must appear before the type is frozen. This procedure checks that this
198 -- rule is met, and otherwise gives an error on the subprogram declaration
199 -- and a warning on the earlier freeze point if it is easy to pinpoint. In
200 -- earlier versions of Ada, the call has not effect, unless compatibility
201 -- warnings are requested by means of Warn_On_Ada_2012_Incompatibility.
203 procedure Enter_Overloaded_Entity
(S
: Entity_Id
);
204 -- This procedure makes S, a new overloaded entity, into the first visible
205 -- entity with that name.
207 function Has_Reliable_Extra_Formals
(E
: Entity_Id
) return Boolean;
208 -- E is the entity for a subprogram spec. Returns False for abstract
209 -- predefined dispatching primitives of Root_Controlled since they
210 -- cannot have extra formals (this is required to build the runtime);
211 -- it also returns False for predefined stream dispatching operations
212 -- not emitted by the frontend. Otherwise returns True.
214 function Is_Non_Overriding_Operation
216 New_E
: Entity_Id
) return Boolean;
217 -- Enforce the rule given in 12.3(18): a private operation in an instance
218 -- overrides an inherited operation only if the corresponding operation
219 -- was overriding in the generic. This needs to be checked for primitive
220 -- operations of types derived (in the generic unit) from formal private
221 -- or formal derived types.
223 procedure Make_Inequality_Operator
(S
: Entity_Id
);
224 -- Create the declaration for an inequality operator that is implicitly
225 -- created by a user-defined equality operator that yields a boolean.
227 procedure Preanalyze_Formal_Expression
(N
: Node_Id
; T
: Entity_Id
);
228 -- Preanalysis of default expressions of subprogram formals. N is the
229 -- expression to be analyzed and T is the expected type.
231 procedure Set_Formal_Mode
(Formal_Id
: Entity_Id
);
232 -- Set proper Ekind to reflect formal mode (in, out, in out), and set
233 -- miscellaneous other attributes.
235 procedure Set_Formal_Validity
(Formal_Id
: Entity_Id
);
236 -- Formal_Id is an formal parameter entity. This procedure deals with
237 -- setting the proper validity status for this entity, which depends on
238 -- the kind of parameter and the validity checking mode.
240 ---------------------------------------------
241 -- Analyze_Abstract_Subprogram_Declaration --
242 ---------------------------------------------
244 procedure Analyze_Abstract_Subprogram_Declaration
(N
: Node_Id
) is
245 Scop
: constant Entity_Id
:= Current_Scope
;
246 Subp_Id
: constant Entity_Id
:=
247 Analyze_Subprogram_Specification
(Specification
(N
));
250 Generate_Definition
(Subp_Id
);
252 -- Set the SPARK mode from the current context (may be overwritten later
253 -- with explicit pragma).
255 Set_SPARK_Pragma
(Subp_Id
, SPARK_Mode_Pragma
);
256 Set_SPARK_Pragma_Inherited
(Subp_Id
);
258 -- Preserve relevant elaboration-related attributes of the context which
259 -- are no longer available or very expensive to recompute once analysis,
260 -- resolution, and expansion are over.
262 Mark_Elaboration_Attributes
267 Set_Is_Abstract_Subprogram
(Subp_Id
);
268 New_Overloaded_Entity
(Subp_Id
);
269 Check_Delayed_Subprogram
(Subp_Id
);
271 Set_Categorization_From_Scope
(Subp_Id
, Scop
);
273 if Ekind
(Scope
(Subp_Id
)) = E_Protected_Type
then
274 Error_Msg_N
("abstract subprogram not allowed in protected type", N
);
276 -- Issue a warning if the abstract subprogram is neither a dispatching
277 -- operation nor an operation that overrides an inherited subprogram or
278 -- predefined operator, since this most likely indicates a mistake.
280 elsif Warn_On_Redundant_Constructs
281 and then not Is_Dispatching_Operation
(Subp_Id
)
282 and then No
(Overridden_Operation
(Subp_Id
))
283 and then (not Is_Operator_Symbol_Name
(Chars
(Subp_Id
))
284 or else Scop
/= Scope
(Etype
(First_Formal
(Subp_Id
))))
287 ("abstract subprogram is not dispatching or overriding?r?", N
);
290 Generate_Reference_To_Formals
(Subp_Id
);
291 Check_Eliminated
(Subp_Id
);
293 Analyze_Aspect_Specifications
(N
, Subp_Id
);
294 end Analyze_Abstract_Subprogram_Declaration
;
296 ---------------------------------
297 -- Analyze_Expression_Function --
298 ---------------------------------
300 procedure Analyze_Expression_Function
(N
: Node_Id
) is
301 Expr
: constant Node_Id
:= Expression
(N
);
302 Loc
: constant Source_Ptr
:= Sloc
(N
);
303 LocX
: constant Source_Ptr
:= Sloc
(Expr
);
304 Spec
: constant Node_Id
:= Specification
(N
);
311 Orig_N
: Node_Id
:= Empty
;
313 Typ
: Entity_Id
:= Empty
;
315 Def_Id
: Entity_Id
:= Empty
;
317 -- If the expression is a completion, Prev is the entity whose
318 -- declaration is completed. Def_Id is needed to analyze the spec.
321 -- This is one of the occasions on which we transform the tree during
322 -- semantic analysis. If this is a completion, transform the expression
323 -- function into an equivalent subprogram body, and analyze it.
325 -- Expression functions are inlined unconditionally. The back-end will
326 -- determine whether this is possible.
328 Inline_Processing_Required
:= True;
330 -- Create a specification for the generated body. This must be done
331 -- prior to the analysis of the initial declaration.
333 New_Spec
:= Copy_Subprogram_Spec
(Spec
);
334 Prev
:= Current_Entity_In_Scope
(Defining_Entity
(Spec
));
336 -- If there are previous overloadable entities with the same name,
337 -- check whether any of them is completed by the expression function.
338 -- In a generic context a formal subprogram has no completion.
341 and then Is_Overloadable
(Prev
)
342 and then not Is_Formal_Subprogram
(Prev
)
344 Def_Id
:= Analyze_Subprogram_Specification
(Spec
);
345 Prev
:= Find_Corresponding_Spec
(N
);
347 Typ
:= Etype
(Def_Id
);
349 -- The previous entity may be an expression function as well, in
350 -- which case the redeclaration is illegal.
353 and then Nkind
(Original_Node
(Unit_Declaration_Node
(Prev
))) =
354 N_Expression_Function
356 Error_Msg_Sloc
:= Sloc
(Prev
);
357 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
362 Ret
:= Make_Simple_Return_Statement
(LocX
, Expr
);
364 -- Remove parens around the expression, so that if the expression will
365 -- appear without them when pretty-printed in error messages.
367 if Paren_Count
(Expr
) > 0 then
368 Set_Paren_Count
(Expr
, Paren_Count
(Expr
) - 1);
372 Make_Subprogram_Body
(Loc
,
373 Specification
=> New_Spec
,
374 Declarations
=> Empty_List
,
375 Handled_Statement_Sequence
=>
376 Make_Handled_Sequence_Of_Statements
(LocX
,
377 Statements
=> New_List
(Ret
)));
378 Set_Was_Expression_Function
(New_Body
);
380 -- If the expression completes a generic subprogram, we must create a
381 -- separate node for the body, because at instantiation the original
382 -- node of the generic copy must be a generic subprogram body, and
383 -- cannot be a expression function. Otherwise we just rewrite the
384 -- expression with the non-generic body.
386 if Present
(Prev
) and then Ekind
(Prev
) = E_Generic_Function
then
387 Insert_After
(N
, New_Body
);
389 -- Propagate any aspects or pragmas that apply to the expression
390 -- function to the proper body when the expression function acts
393 Move_Aspects
(N
, To
=> New_Body
);
395 Relocate_Pragmas_To_Body
(New_Body
);
397 Rewrite
(N
, Make_Null_Statement
(Loc
));
398 Set_Has_Completion
(Prev
, False);
401 Set_Is_Inlined
(Prev
);
404 and then Is_Overloadable
(Prev
)
405 and then not Is_Formal_Subprogram
(Prev
)
407 Set_Has_Completion
(Prev
, False);
408 Set_Is_Inlined
(Prev
);
410 -- AI12-0103: Expression functions that are a completion freeze their
411 -- expression but don't freeze anything else (unlike regular bodies).
413 -- Note that we cannot defer this freezing to the analysis of the
414 -- expression itself, because a freeze node might appear in a nested
415 -- scope, leading to an elaboration order issue in gigi.
416 -- As elsewhere, we do not emit freeze nodes within a generic unit.
418 if not Inside_A_Generic
then
426 -- For navigation purposes, indicate that the function is a body
428 Generate_Reference
(Prev
, Defining_Entity
(N
), 'b', Force
=> True);
429 Rewrite
(N
, New_Body
);
431 -- Keep the aspects from the original node
433 Orig_N
:= Original_Node
(N
);
434 Move_Aspects
(Orig_N
, N
);
436 -- Propagate any pragmas that apply to expression function to the
437 -- proper body when the expression function acts as a completion.
438 -- Aspects are automatically transfered because of node rewriting.
440 Relocate_Pragmas_To_Body
(N
);
443 -- Prev is the previous entity with the same name, but it is can
444 -- be an unrelated spec that is not completed by the expression
445 -- function. In that case the relevant entity is the one in the body.
446 -- Not clear that the backend can inline it in this case ???
448 if Has_Completion
(Prev
) then
450 -- The formals of the expression function are body formals,
451 -- and do not appear in the ali file, which will only contain
452 -- references to the formals of the original subprogram spec.
459 F1
:= First_Formal
(Def_Id
);
460 F2
:= First_Formal
(Prev
);
462 while Present
(F1
) loop
463 Set_Spec_Entity
(F1
, F2
);
470 Set_Is_Inlined
(Defining_Entity
(New_Body
));
473 -- If this is not a completion, create both a declaration and a body, so
474 -- that the expression can be inlined whenever possible.
477 -- An expression function that is not a completion is not a
478 -- subprogram declaration, and thus cannot appear in a protected
481 if Nkind
(Parent
(N
)) = N_Protected_Definition
then
483 ("an expression function is not a legal protected operation", N
);
486 Rewrite
(N
, Make_Subprogram_Declaration
(Loc
, Specification
=> Spec
));
488 -- Keep the aspects from the original node
490 Orig_N
:= Original_Node
(N
);
491 Move_Aspects
(Orig_N
, N
);
495 -- If aspect SPARK_Mode was specified on the body, it needs to be
496 -- repeated both on the generated spec and the body.
498 Asp
:= Find_Aspect
(Defining_Unit_Name
(Spec
), Aspect_SPARK_Mode
);
500 if Present
(Asp
) then
501 Asp
:= New_Copy_Tree
(Asp
);
502 Set_Analyzed
(Asp
, False);
503 Set_Aspect_Specifications
(New_Body
, New_List
(Asp
));
506 Def_Id
:= Defining_Entity
(N
);
507 Set_Is_Inlined
(Def_Id
);
509 Typ
:= Etype
(Def_Id
);
511 -- Establish the linkages between the spec and the body. These are
512 -- used when the expression function acts as the prefix of attribute
513 -- 'Access in order to freeze the original expression which has been
514 -- moved to the generated body.
516 Set_Corresponding_Body
(N
, Defining_Entity
(New_Body
));
517 Set_Corresponding_Spec
(New_Body
, Def_Id
);
519 -- Within a generic preanalyze the original expression for name
520 -- capture. The body is also generated but plays no role in
521 -- this because it is not part of the original source.
522 -- If this is an ignored Ghost entity, analysis of the generated
523 -- body is needed to hide external references (as is done in
524 -- Analyze_Subprogram_Body) after which the subprogram profile
525 -- can be frozen, which is needed to expand calls to such an ignored
528 if Inside_A_Generic
then
529 Set_Has_Completion
(Def_Id
, not Is_Ignored_Ghost_Entity
(Def_Id
));
531 Install_Formals
(Def_Id
);
532 Preanalyze_Spec_Expression
(Expr
, Typ
);
536 Install_Formals
(Def_Id
);
537 Preanalyze_Formal_Expression
(Expr
, Typ
);
538 Check_Limited_Return
(Orig_N
, Expr
, Typ
);
542 -- If this is a wrapper created in an instance for a formal
543 -- subprogram, insert body after declaration, to be analyzed when the
544 -- enclosing instance is analyzed.
547 and then Is_Generic_Actual_Subprogram
(Def_Id
)
549 Insert_After
(N
, New_Body
);
551 -- To prevent premature freeze action, insert the new body at the end
552 -- of the current declarations, or at the end of the package spec.
553 -- However, resolve usage names now, to prevent spurious visibility
554 -- on later entities. Note that the function can now be called in
555 -- the current declarative part, which will appear to be prior to the
556 -- presence of the body in the code. There are nevertheless no order
557 -- of elaboration issues because all name resolution has taken place
558 -- at the point of declaration.
562 Decls
: List_Id
:= List_Containing
(N
);
563 Par
: constant Node_Id
:= Parent
(Decls
);
566 if Nkind
(Par
) = N_Package_Specification
567 and then Decls
= Visible_Declarations
(Par
)
568 and then not Is_Empty_List
(Private_Declarations
(Par
))
570 Decls
:= Private_Declarations
(Par
);
573 Insert_After
(Last
(Decls
), New_Body
);
577 -- In the case of an expression function marked with the aspect
578 -- Static, we need to check the requirement that the function's
579 -- expression is a potentially static expression. This is done
580 -- by making a full copy of the expression tree and performing
581 -- a special preanalysis on that tree with the global flag
582 -- Checking_Potentially_Static_Expression enabled. If the
583 -- resulting expression is static, then it's OK, but if not, that
584 -- means the expression violates the requirements of the Ada 2022
585 -- RM in 4.9(3.2/5-3.4/5) and we flag an error.
587 if Is_Static_Function
(Def_Id
) then
589 -- If a potentially static expr like "Parameter / 0"
590 -- is transformed into "(raise Constraint_Error)", then we
591 -- need to copy the Original_Node.
592 function Make_Expr_Copy
return Node_Id
is
593 (New_Copy_Tree
(if Expr
in N_Raise_xxx_Error_Id
594 then Original_Node
(Expr
)
597 if not Is_Static_Expression
(Expr
) then
599 Exp_Copy
: constant Node_Id
:= Make_Expr_Copy
;
601 Set_Checking_Potentially_Static_Expression
(True);
603 Preanalyze_Formal_Expression
(Exp_Copy
, Typ
);
605 if not Is_Static_Expression
(Exp_Copy
) then
607 ("static expression function requires "
608 & "potentially static expression", Expr
);
611 Set_Checking_Potentially_Static_Expression
(False);
615 -- We also make an additional copy of the expression and
616 -- replace the expression of the expression function with
617 -- this copy, because the currently present expression is
618 -- now associated with the body created for the static
619 -- expression function, which will later be analyzed and
620 -- possibly rewritten, and we need to have the separate
621 -- unanalyzed copy available for use with later static
625 (Original_Node
(Subprogram_Spec
(Def_Id
)),
628 -- Mark static expression functions as inlined, to ensure
629 -- that even calls with nonstatic actuals will be inlined.
631 Set_Has_Pragma_Inline
(Def_Id
);
632 Set_Is_Inlined
(Def_Id
);
637 -- Check incorrect use of dynamically tagged expression. This doesn't
638 -- fall out automatically when analyzing the generated function body,
639 -- because Check_Dynamically_Tagged_Expression deliberately ignores
640 -- nodes that don't come from source.
643 and then Is_Tagged_Type
(Typ
)
645 Check_Dynamically_Tagged_Expression
648 Related_Nod
=> Orig_N
);
651 -- We must enforce checks for unreferenced formals in our newly
652 -- generated function, so we propagate the referenced flag from the
653 -- original spec to the new spec as well as setting Comes_From_Source.
655 if Present
(Parameter_Specifications
(New_Spec
)) then
657 Form_New_Def
: Entity_Id
;
658 Form_New_Spec
: Node_Id
;
659 Form_Old_Def
: Entity_Id
;
660 Form_Old_Spec
: Node_Id
;
663 Form_New_Spec
:= First
(Parameter_Specifications
(New_Spec
));
664 Form_Old_Spec
:= First
(Parameter_Specifications
(Spec
));
666 while Present
(Form_New_Spec
) and then Present
(Form_Old_Spec
) loop
667 Form_New_Def
:= Defining_Identifier
(Form_New_Spec
);
668 Form_Old_Def
:= Defining_Identifier
(Form_Old_Spec
);
670 Set_Comes_From_Source
(Form_New_Def
, True);
672 -- Because of the usefulness of unreferenced controlling
673 -- formals we exempt them from unreferenced warnings by marking
674 -- them as always referenced.
676 Set_Referenced
(Form_Old_Def
,
677 (Is_Formal
(Form_Old_Def
)
678 and then Is_Controlling_Formal
(Form_Old_Def
))
679 or else Referenced
(Form_Old_Def
));
681 Next
(Form_New_Spec
);
682 Next
(Form_Old_Spec
);
686 end Analyze_Expression_Function
;
688 ---------------------------------------
689 -- Analyze_Extended_Return_Statement --
690 ---------------------------------------
692 procedure Analyze_Extended_Return_Statement
(N
: Node_Id
) is
694 Analyze_Return_Statement
(N
);
695 end Analyze_Extended_Return_Statement
;
697 ----------------------------
698 -- Analyze_Function_Call --
699 ----------------------------
701 procedure Analyze_Function_Call
(N
: Node_Id
) is
702 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
703 Func_Nam
: constant Node_Id
:= Name
(N
);
709 -- A call of the form A.B (X) may be an Ada 2005 call, which is
710 -- rewritten as B (A, X). If the rewriting is successful, the call
711 -- has been analyzed and we just return.
713 if Nkind
(Func_Nam
) = N_Selected_Component
714 and then Name
(N
) /= Func_Nam
715 and then Is_Rewrite_Substitution
(N
)
716 and then Present
(Etype
(N
))
721 -- If error analyzing name, then set Any_Type as result type and return
723 if Etype
(Func_Nam
) = Any_Type
then
724 Set_Etype
(N
, Any_Type
);
728 -- Otherwise analyze the parameters
730 Actual
:= First
(Actuals
);
731 while Present
(Actual
) loop
733 Check_Parameterless_Call
(Actual
);
738 end Analyze_Function_Call
;
740 -----------------------------
741 -- Analyze_Function_Return --
742 -----------------------------
744 procedure Analyze_Function_Return
(N
: Node_Id
) is
745 Loc
: constant Source_Ptr
:= Sloc
(N
);
746 Stm_Entity
: constant Entity_Id
:= Return_Statement_Entity
(N
);
747 Scope_Id
: constant Entity_Id
:= Return_Applies_To
(Stm_Entity
);
749 R_Type
: constant Entity_Id
:= Etype
(Scope_Id
);
750 -- Function result subtype
752 procedure Check_No_Return_Expression
(Return_Expr
: Node_Id
);
753 -- Ada 2022: Check that the return expression in a No_Return function
754 -- meets the conditions specified by RM 6.5.1(5.1/5).
756 --------------------------------
757 -- Check_No_Return_Expression --
758 --------------------------------
760 procedure Check_No_Return_Expression
(Return_Expr
: Node_Id
) is
761 Kind
: constant Node_Kind
:= Nkind
(Return_Expr
);
764 if Kind
= N_Raise_Expression
then
767 elsif Kind
= N_Function_Call
768 and then Is_Entity_Name
(Name
(Return_Expr
))
769 and then Ekind
(Entity
(Name
(Return_Expr
))) in
770 E_Function | E_Generic_Function
771 and then No_Return
(Entity
(Name
(Return_Expr
)))
777 ("illegal expression in RETURN statement of No_Return function",
780 ("\must be raise expression or call to No_Return (RM 6.5.1(5.1/5))",
782 end Check_No_Return_Expression
;
784 ---------------------
785 -- Local Variables --
786 ---------------------
789 Obj_Decl
: Node_Id
:= Empty
;
791 -- Start of processing for Analyze_Function_Return
794 Set_Return_Present
(Scope_Id
);
796 if Nkind
(N
) = N_Simple_Return_Statement
then
797 Expr
:= Expression
(N
);
799 -- Guard against a malformed expression. The parser may have tried to
800 -- recover but the node is not analyzable.
802 if Nkind
(Expr
) = N_Error
then
803 Set_Etype
(Expr
, Any_Type
);
804 Expander_Mode_Save_And_Set
(False);
808 -- The resolution of a controlled [extension] aggregate associated
809 -- with a return statement creates a temporary which needs to be
810 -- finalized on function exit. Wrap the return statement inside a
811 -- block so that the finalization machinery can detect this case.
812 -- This early expansion is done only when the return statement is
813 -- not part of a handled sequence of statements.
815 if Nkind
(Expr
) in N_Aggregate | N_Extension_Aggregate
816 and then Needs_Finalization
(R_Type
)
817 and then Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
820 Make_Block_Statement
(Loc
,
821 Handled_Statement_Sequence
=>
822 Make_Handled_Sequence_Of_Statements
(Loc
,
823 Statements
=> New_List
(Relocate_Node
(N
)))));
831 -- Ada 2005 (AI-251): If the type of the returned object is
832 -- an access to an interface type then we add an implicit type
833 -- conversion to force the displacement of the "this" pointer to
834 -- reference the secondary dispatch table. We cannot delay the
835 -- generation of this implicit conversion until the expansion
836 -- because in this case the type resolution changes the decoration
837 -- of the expression node to match R_Type; by contrast, if the
838 -- returned object is a class-wide interface type then it is too
839 -- early to generate here the implicit conversion since the return
840 -- statement may be rewritten by the expander into an extended
841 -- return statement whose expansion takes care of adding the
842 -- implicit type conversion to displace the pointer to the object.
845 and then Serious_Errors_Detected
= 0
846 and then Is_Access_Type
(R_Type
)
847 and then Nkind
(Expr
) not in N_Null | N_Raise_Expression
848 and then Is_Access_Type
(Etype
(Expr
))
849 and then Is_Interface
(Designated_Type
(R_Type
))
850 and then Is_Progenitor
(Designated_Type
(R_Type
),
851 Designated_Type
(Etype
(Expr
)))
853 Rewrite
(Expr
, Convert_To
(R_Type
, Relocate_Node
(Expr
)));
857 Resolve
(Expr
, R_Type
);
859 -- The expansion of the expression may have rewritten the return
860 -- statement itself, e.g. when it is a conditional expression.
862 if Nkind
(N
) /= N_Simple_Return_Statement
then
866 Check_Limited_Return
(N
, Expr
, R_Type
);
868 Check_Return_Construct_Accessibility
(N
, Stm_Entity
);
870 -- Ada 2022 (AI12-0269): Any return statement that applies to a
871 -- nonreturning function shall be a simple_return_statement with
872 -- an expression that is a raise_expression, or else a call on a
873 -- nonreturning function, or else a parenthesized expression of
876 if Ada_Version
>= Ada_2022
877 and then No_Return
(Scope_Id
)
878 and then Comes_From_Source
(N
)
880 Check_No_Return_Expression
(Original_Node
(Expr
));
884 Obj_Decl
:= Last
(Return_Object_Declarations
(N
));
886 -- Analyze parts specific to extended_return_statement:
889 Has_Aliased
: constant Boolean := Aliased_Present
(Obj_Decl
);
890 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
893 Expr
:= Expression
(Obj_Decl
);
895 -- Note: The check for OK_For_Limited_Init will happen in
896 -- Analyze_Object_Declaration; we treat it as a normal
897 -- object declaration.
899 Set_Is_Return_Object
(Defining_Identifier
(Obj_Decl
));
902 if Present
(HSS
) then
905 if Present
(Exception_Handlers
(HSS
)) then
907 -- ???Has_Nested_Block_With_Handler needs to be set.
908 -- Probably by creating an actual N_Block_Statement.
909 -- Probably in Expand.
915 -- Mark the return object as referenced, since the return is an
916 -- implicit reference of the object.
918 Set_Referenced
(Defining_Identifier
(Obj_Decl
));
920 Check_References
(Stm_Entity
);
922 Check_Return_Construct_Accessibility
(N
, Stm_Entity
);
924 -- Check RM 6.5 (5.9/3)
926 if Has_Aliased
and then not Is_Immutably_Limited_Type
(R_Type
) then
927 if Ada_Version
< Ada_2012
928 and then Warn_On_Ada_2012_Compatibility
931 ("ALIASED only allowed for immutably limited return " &
932 "objects in Ada 2012?y?", N
);
936 ("ALIASED only allowed for immutably limited return " &
941 -- Ada 2022 (AI12-0269): Any return statement that applies to a
942 -- nonreturning function shall be a simple_return_statement.
944 if Ada_Version
>= Ada_2022
945 and then No_Return
(Scope_Id
)
946 and then Comes_From_Source
(N
)
949 ("extended RETURN statement not allowed in No_Return "
955 -- Case of Expr present
957 if Present
(Expr
) then
959 -- Defend against previous errors
961 if Nkind
(Expr
) = N_Empty
or else No
(Etype
(Expr
)) then
965 -- Apply constraint check. Note that this is done before the implicit
966 -- conversion of the expression done for anonymous access types to
967 -- ensure correct generation of the null-excluding check associated
968 -- with null-excluding expressions found in return statements. We
969 -- don't need a check if the subtype of the return object is the
970 -- same as the result subtype of the function.
972 if Nkind
(N
) /= N_Extended_Return_Statement
973 or else Nkind
(Obj_Decl
) /= N_Object_Declaration
974 or else Nkind
(Object_Definition
(Obj_Decl
)) not in N_Has_Entity
975 or else Entity
(Object_Definition
(Obj_Decl
)) /= R_Type
977 Apply_Constraint_Check
(Expr
, R_Type
);
980 -- The return value is converted to the return type of the function,
981 -- which implies a predicate check if the return type is predicated.
982 -- We do not apply the check for an extended return statement because
983 -- Analyze_Object_Declaration has already done it on Obj_Decl above.
984 -- We do not apply the check to a case expression because it will
985 -- be expanded into a series of return statements, each of which
986 -- will receive a predicate check.
988 if Nkind
(N
) /= N_Extended_Return_Statement
989 and then Nkind
(Expr
) /= N_Case_Expression
991 Apply_Predicate_Check
(Expr
, R_Type
);
994 -- Ada 2005 (AI-318-02): When the result type is an anonymous access
995 -- type, apply an implicit conversion of the expression to that type
996 -- to force appropriate static and run-time accessibility checks.
997 -- But we want to apply the checks to an extended return statement
998 -- only once, i.e. not to the simple return statement generated at
999 -- the end of its expansion because, prior to leaving the function,
1000 -- the accessibility level of the return object changes to be a level
1001 -- determined by the point of call (RM 3.10.2(10.8/3)).
1003 if Ada_Version
>= Ada_2005
1004 and then Ekind
(R_Type
) = E_Anonymous_Access_Type
1005 and then (Nkind
(N
) = N_Extended_Return_Statement
1006 or else not Comes_From_Extended_Return_Statement
(N
))
1008 Rewrite
(Expr
, Convert_To
(R_Type
, Relocate_Node
(Expr
)));
1009 Analyze_And_Resolve
(Expr
, R_Type
);
1011 -- If this is a local anonymous access to subprogram, the
1012 -- accessibility check can be applied statically. The return is
1013 -- illegal if the access type of the return expression is declared
1014 -- inside of the subprogram (except if it is the subtype indication
1015 -- of an extended return statement).
1017 elsif Ekind
(R_Type
) = E_Anonymous_Access_Subprogram_Type
then
1018 if not Comes_From_Source
(Current_Scope
)
1019 or else Ekind
(Current_Scope
) = E_Return_Statement
1024 Scope_Depth
(Scope
(Etype
(Expr
))) >= Scope_Depth
(Scope_Id
)
1026 Error_Msg_N
("cannot return local access to subprogram", N
);
1029 -- The expression cannot be of a formal incomplete type
1031 elsif Ekind
(Etype
(Expr
)) = E_Incomplete_Type
1032 and then Is_Generic_Type
(Etype
(Expr
))
1035 ("cannot return expression of a formal incomplete type", N
);
1038 -- If the result type is class-wide, then check that the return
1039 -- expression's type is not declared at a deeper level than the
1040 -- function (RM05-6.5(5.6/2)).
1042 if Ada_Version
>= Ada_2005
1043 and then Is_Class_Wide_Type
(R_Type
)
1045 if Type_Access_Level
(Etype
(Expr
)) >
1046 Subprogram_Access_Level
(Scope_Id
)
1049 ("level of return expression type is deeper than "
1050 & "class-wide function!", Expr
);
1054 -- Check incorrect use of dynamically tagged expression
1056 if Is_Tagged_Type
(R_Type
) then
1057 Check_Dynamically_Tagged_Expression
1063 -- Perform static accessibility checks for cases involving
1064 -- dereferences of access parameters. Runtime accessibility checks
1065 -- get generated elsewhere.
1067 if (Ada_Version
< Ada_2005
or else Debug_Flag_Dot_L
)
1068 and then Is_Inherently_Limited_Type
(Etype
(Scope_Id
))
1069 and then Static_Accessibility_Level
(Expr
, Zero_On_Dynamic_Level
)
1070 > Subprogram_Access_Level
(Scope_Id
)
1072 -- Suppress the message in a generic, where the rewriting
1075 if Inside_A_Generic
then
1080 Make_Raise_Program_Error
(Loc
,
1081 Reason
=> PE_Accessibility_Check_Failed
));
1084 Error_Msg_Warn
:= SPARK_Mode
/= On
;
1085 Error_Msg_N
("cannot return a local value by reference<<", N
);
1086 Error_Msg_N
("\Program_Error [<<", N
);
1090 if Known_Null
(Expr
)
1091 and then Nkind
(Parent
(Scope_Id
)) = N_Function_Specification
1092 and then Null_Exclusion_Present
(Parent
(Scope_Id
))
1094 Apply_Compile_Time_Constraint_Error
1096 Msg
=> "(Ada 2005) null not allowed for "
1097 & "null-excluding return??",
1098 Reason
=> CE_Null_Not_Allowed
);
1101 -- RM 6.5 (5.4/3): accessibility checks also apply if the return object
1102 -- has no initializing expression.
1104 elsif Ada_Version
> Ada_2005
and then Is_Class_Wide_Type
(R_Type
) then
1105 if Type_Access_Level
(Etype
(Defining_Identifier
(Obj_Decl
))) >
1106 Subprogram_Access_Level
(Scope_Id
)
1109 ("level of return expression type is deeper than "
1110 & "class-wide function!", Obj_Decl
);
1113 end Analyze_Function_Return
;
1115 -------------------------------------
1116 -- Analyze_Generic_Subprogram_Body --
1117 -------------------------------------
1119 procedure Analyze_Generic_Subprogram_Body
1123 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Id
);
1124 Kind
: constant Entity_Kind
:= Ekind
(Gen_Id
);
1125 Body_Id
: Entity_Id
;
1130 -- Copy body and disable expansion while analyzing the generic For a
1131 -- stub, do not copy the stub (which would load the proper body), this
1132 -- will be done when the proper body is analyzed.
1134 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
1135 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
1138 -- Collect all contract-related source pragmas found within the
1139 -- template and attach them to the contract of the subprogram body.
1140 -- This contract is used in the capture of global references within
1143 Create_Generic_Contract
(N
);
1148 Spec
:= Specification
(N
);
1150 -- Within the body of the generic, the subprogram is callable, and
1151 -- behaves like the corresponding non-generic unit.
1153 Body_Id
:= Defining_Entity
(Spec
);
1155 if Kind
= E_Generic_Procedure
1156 and then Nkind
(Spec
) /= N_Procedure_Specification
1158 Error_Msg_N
("invalid body for generic procedure", Body_Id
);
1161 elsif Kind
= E_Generic_Function
1162 and then Nkind
(Spec
) /= N_Function_Specification
1164 Error_Msg_N
("invalid body for generic function", Body_Id
);
1168 Set_Corresponding_Body
(Gen_Decl
, Body_Id
);
1170 if Has_Completion
(Gen_Id
)
1171 and then Nkind
(Parent
(N
)) /= N_Subunit
1173 Error_Msg_N
("duplicate generic body", N
);
1176 Set_Has_Completion
(Gen_Id
);
1179 if Nkind
(N
) = N_Subprogram_Body_Stub
then
1180 Mutate_Ekind
(Defining_Entity
(Specification
(N
)), Kind
);
1182 Set_Corresponding_Spec
(N
, Gen_Id
);
1185 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
1186 Set_Cunit_Entity
(Current_Sem_Unit
, Defining_Entity
(N
));
1189 -- Make generic parameters immediately visible in the body. They are
1190 -- needed to process the formals declarations. Then make the formals
1191 -- visible in a separate step.
1193 Push_Scope
(Gen_Id
);
1197 First_Ent
: Entity_Id
;
1200 First_Ent
:= First_Entity
(Gen_Id
);
1203 while Present
(E
) and then not Is_Formal
(E
) loop
1208 Set_Use
(Generic_Formal_Declarations
(Gen_Decl
));
1210 -- Now generic formals are visible, and the specification can be
1211 -- analyzed, for subsequent conformance check.
1213 Body_Id
:= Analyze_Subprogram_Specification
(Spec
);
1215 -- Make formal parameters visible
1219 -- E is the first formal parameter, we loop through the formals
1220 -- installing them so that they will be visible.
1222 Set_First_Entity
(Gen_Id
, E
);
1223 while Present
(E
) loop
1229 -- Visible generic entity is callable within its own body
1231 Mutate_Ekind
(Gen_Id
, Ekind
(Body_Id
));
1232 Reinit_Field_To_Zero
(Body_Id
, F_Has_Out_Or_In_Out_Parameter
,
1234 (E_Function | E_Procedure |
1235 E_Generic_Function | E_Generic_Procedure
=> True,
1237 Reinit_Field_To_Zero
(Body_Id
, F_Needs_No_Actuals
);
1238 if Ekind
(Body_Id
) in E_Function | E_Procedure
then
1239 Reinit_Field_To_Zero
(Body_Id
, F_Is_Inlined_Always
);
1241 Mutate_Ekind
(Body_Id
, E_Subprogram_Body
);
1242 Set_Convention
(Body_Id
, Convention
(Gen_Id
));
1243 Set_Is_Obsolescent
(Body_Id
, Is_Obsolescent
(Gen_Id
));
1244 Set_Scope
(Body_Id
, Scope
(Gen_Id
));
1246 Check_Fully_Conformant
(Body_Id
, Gen_Id
, Body_Id
);
1248 if Nkind
(N
) = N_Subprogram_Body_Stub
then
1250 -- No body to analyze, so restore state of generic unit
1252 Mutate_Ekind
(Gen_Id
, Kind
);
1253 Mutate_Ekind
(Body_Id
, Kind
);
1255 if Present
(First_Ent
) then
1256 Set_First_Entity
(Gen_Id
, First_Ent
);
1263 -- If this is a compilation unit, it must be made visible explicitly,
1264 -- because the compilation of the declaration, unlike other library
1265 -- unit declarations, does not. If it is not a unit, the following
1266 -- is redundant but harmless.
1268 Set_Is_Immediately_Visible
(Gen_Id
);
1269 Reference_Body_Formals
(Gen_Id
, Body_Id
);
1271 if Is_Child_Unit
(Gen_Id
) then
1272 Generate_Reference
(Gen_Id
, Scope
(Gen_Id
), 'k', False);
1275 Set_Actual_Subtypes
(N
, Current_Scope
);
1277 Set_SPARK_Pragma
(Body_Id
, SPARK_Mode_Pragma
);
1278 Set_SPARK_Pragma_Inherited
(Body_Id
);
1280 -- Analyze any aspect specifications that appear on the generic
1283 Analyze_Aspects_On_Subprogram_Body_Or_Stub
(N
);
1285 -- Process the contract of the subprogram body after analyzing all
1286 -- the contract-related pragmas within the declarations.
1288 Analyze_Pragmas_In_Declarations
(Body_Id
);
1289 Analyze_Entry_Or_Subprogram_Body_Contract
(Body_Id
);
1291 -- Continue on with analyzing the declarations and statements once
1292 -- contract expansion is done and we are done expanding contract
1293 -- related wrappers.
1295 Analyze_Declarations
(Declarations
(N
));
1298 Analyze
(Handled_Statement_Sequence
(N
));
1299 Save_Global_References
(Original_Node
(N
));
1301 -- Prior to exiting the scope, include generic formals again (if any
1302 -- are present) in the set of local entities.
1304 if Present
(First_Ent
) then
1305 Set_First_Entity
(Gen_Id
, First_Ent
);
1308 Check_References
(Gen_Id
);
1311 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Current_Scope
);
1312 Update_Use_Clause_Chain
;
1313 Validate_Categorization_Dependency
(N
, Gen_Id
);
1315 Check_Subprogram_Order
(N
);
1317 -- Outside of its body, unit is generic again
1319 Reinit_Field_To_Zero
(Gen_Id
, F_Has_Nested_Subprogram
,
1320 Old_Ekind
=> (E_Function | E_Procedure
=> True, others => False));
1321 Mutate_Ekind
(Gen_Id
, Kind
);
1322 Generate_Reference
(Gen_Id
, Body_Id
, 'b', Set_Ref
=> False);
1325 Style
.Check_Identifier
(Body_Id
, Gen_Id
);
1329 end Analyze_Generic_Subprogram_Body
;
1331 ----------------------------
1332 -- Analyze_Null_Procedure --
1333 ----------------------------
1335 -- WARNING: This routine manages Ghost regions. Return statements must be
1336 -- replaced by gotos that jump to the end of the routine and restore the
1339 procedure Analyze_Null_Procedure
1341 Is_Completion
: out Boolean)
1343 Loc
: constant Source_Ptr
:= Sloc
(N
);
1344 Spec
: constant Node_Id
:= Specification
(N
);
1346 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1347 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
1348 Saved_ISMP
: constant Boolean :=
1349 Ignore_SPARK_Mode_Pragmas_In_Instance
;
1350 -- Save the Ghost and SPARK mode-related data to restore on exit
1352 Designator
: Entity_Id
;
1354 Null_Body
: Node_Id
:= Empty
;
1355 Null_Stmt
: Node_Id
:= Null_Statement
(Spec
);
1359 Prev
:= Current_Entity_In_Scope
(Defining_Entity
(Spec
));
1361 -- A null procedure is Ghost when it is stand-alone and is subject to
1362 -- pragma Ghost, or when the corresponding spec is Ghost. Set the mode
1363 -- now, to ensure that any nodes generated during analysis and expansion
1364 -- are properly marked as Ghost.
1366 if Present
(Prev
) then
1367 Mark_And_Set_Ghost_Body
(N
, Prev
);
1370 -- Capture the profile of the null procedure before analysis, for
1371 -- expansion at the freeze point and at each point of call. The body is
1372 -- used if the procedure has preconditions, or if it is a completion. In
1373 -- the first case the body is analyzed at the freeze point, in the other
1374 -- it replaces the null procedure declaration.
1376 -- For a null procedure that comes from source, a NULL statement is
1377 -- provided by the parser, which carries the source location of the
1378 -- NULL keyword, and has Comes_From_Source set. For a null procedure
1379 -- from expansion, create one now.
1381 if No
(Null_Stmt
) then
1382 Null_Stmt
:= Make_Null_Statement
(Loc
);
1386 Make_Subprogram_Body
(Loc
,
1387 Specification
=> New_Copy_Tree
(Spec
),
1388 Declarations
=> New_List
,
1389 Handled_Statement_Sequence
=>
1390 Make_Handled_Sequence_Of_Statements
(Loc
,
1391 Statements
=> New_List
(Null_Stmt
)));
1393 -- Create new entities for body and formals
1395 Set_Defining_Unit_Name
(Specification
(Null_Body
),
1396 Make_Defining_Identifier
1397 (Sloc
(Defining_Entity
(N
)),
1398 Chars
(Defining_Entity
(N
))));
1400 Form
:= First
(Parameter_Specifications
(Specification
(Null_Body
)));
1401 while Present
(Form
) loop
1402 Set_Defining_Identifier
(Form
,
1403 Make_Defining_Identifier
1404 (Sloc
(Defining_Identifier
(Form
)),
1405 Chars
(Defining_Identifier
(Form
))));
1409 -- Determine whether the null procedure may be a completion of a generic
1410 -- subprogram, in which case we use the new null body as the completion
1411 -- and set minimal semantic information on the original declaration,
1412 -- which is rewritten as a null statement.
1414 if Present
(Prev
) and then Is_Generic_Subprogram
(Prev
) then
1415 Insert_Before
(N
, Null_Body
);
1416 Mutate_Ekind
(Defining_Entity
(N
), Ekind
(Prev
));
1418 Rewrite
(N
, Make_Null_Statement
(Loc
));
1419 Analyze_Generic_Subprogram_Body
(Null_Body
, Prev
);
1420 Is_Completion
:= True;
1422 -- Mark the newly generated subprogram body as trivial
1424 Set_Is_Trivial_Subprogram
1425 (Defining_Unit_Name
(Specification
(Null_Body
)));
1430 -- Resolve the types of the formals now, because the freeze point may
1431 -- appear in a different context, e.g. an instantiation.
1433 Form
:= First
(Parameter_Specifications
(Specification
(Null_Body
)));
1434 while Present
(Form
) loop
1435 if Nkind
(Parameter_Type
(Form
)) /= N_Access_Definition
then
1436 Find_Type
(Parameter_Type
(Form
));
1438 elsif No
(Access_To_Subprogram_Definition
1439 (Parameter_Type
(Form
)))
1441 Find_Type
(Subtype_Mark
(Parameter_Type
(Form
)));
1443 -- The case of a null procedure with a formal that is an
1444 -- access-to-subprogram type, and that is used as an actual
1445 -- in an instantiation is left to the enthusiastic reader.
1455 -- If there are previous overloadable entities with the same name, check
1456 -- whether any of them is completed by the null procedure.
1458 if Present
(Prev
) and then Is_Overloadable
(Prev
) then
1459 Designator
:= Analyze_Subprogram_Specification
(Spec
);
1460 Prev
:= Find_Corresponding_Spec
(N
);
1463 if No
(Prev
) or else not Comes_From_Source
(Prev
) then
1464 Designator
:= Analyze_Subprogram_Specification
(Spec
);
1465 Set_Has_Completion
(Designator
);
1467 -- Signal to caller that this is a procedure declaration
1469 Is_Completion
:= False;
1471 -- Null procedures are always inlined, but generic formal subprograms
1472 -- which appear as such in the internal instance of formal packages,
1473 -- need no completion and are not marked Inline.
1476 and then Nkind
(N
) /= N_Formal_Concrete_Subprogram_Declaration
1478 Set_Corresponding_Body
(N
, Defining_Entity
(Null_Body
));
1479 Set_Body_To_Inline
(N
, Null_Body
);
1480 Set_Is_Inlined
(Designator
);
1484 -- The null procedure is a completion. We unconditionally rewrite
1485 -- this as a null body (even if expansion is not active), because
1486 -- there are various error checks that are applied on this body
1487 -- when it is analyzed (e.g. correct aspect placement).
1489 if Has_Completion
(Prev
) then
1490 Error_Msg_Sloc
:= Sloc
(Prev
);
1491 Error_Msg_NE
("duplicate body for & declared#", N
, Prev
);
1494 Check_Previous_Null_Procedure
(N
, Prev
);
1496 Is_Completion
:= True;
1497 Rewrite
(N
, Null_Body
);
1498 Move_Aspects
(Original_Node
(N
), N
);
1503 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
1504 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
1505 end Analyze_Null_Procedure
;
1507 -----------------------------
1508 -- Analyze_Operator_Symbol --
1509 -----------------------------
1511 -- An operator symbol such as "+" or "and" may appear in context where the
1512 -- literal denotes an entity name, such as "+"(x, y) or in context when it
1513 -- is just a string, as in (conjunction = "or"). In these cases the parser
1514 -- generates this node, and the semantics does the disambiguation. Other
1515 -- such case are actuals in an instantiation, the generic unit in an
1516 -- instantiation, pragma arguments, and aspect specifications.
1518 procedure Analyze_Operator_Symbol
(N
: Node_Id
) is
1519 Par
: constant Node_Id
:= Parent
(N
);
1521 Maybe_Aspect_Spec
: Node_Id
:= Par
;
1523 if Nkind
(Maybe_Aspect_Spec
) /= N_Aspect_Specification
then
1524 -- deal with N_Aggregate nodes
1525 Maybe_Aspect_Spec
:= Parent
(Maybe_Aspect_Spec
);
1528 if (Nkind
(Par
) = N_Function_Call
and then N
= Name
(Par
))
1529 or else Nkind
(Par
) = N_Function_Instantiation
1530 or else (Nkind
(Par
) = N_Indexed_Component
and then N
= Prefix
(Par
))
1531 or else (Nkind
(Par
) = N_Pragma_Argument_Association
1532 and then not Is_Pragma_String_Literal
(Par
))
1533 or else Nkind
(Par
) = N_Subprogram_Renaming_Declaration
1534 or else (Nkind
(Par
) = N_Attribute_Reference
1535 and then Attribute_Name
(Par
) /= Name_Value
)
1536 or else (Nkind
(Maybe_Aspect_Spec
) = N_Aspect_Specification
1537 and then Get_Aspect_Id
(Maybe_Aspect_Spec
)
1539 -- Include aspects that can be specified by a
1540 -- subprogram name, which can be an operator.
1542 in Aspect_Stable_Properties
1543 | Aspect_Integer_Literal
1544 | Aspect_Real_Literal
1545 | Aspect_String_Literal
1548 Find_Direct_Name
(N
);
1551 Change_Operator_Symbol_To_String_Literal
(N
);
1554 end Analyze_Operator_Symbol
;
1556 -----------------------------------
1557 -- Analyze_Parameter_Association --
1558 -----------------------------------
1560 procedure Analyze_Parameter_Association
(N
: Node_Id
) is
1562 Analyze
(Explicit_Actual_Parameter
(N
));
1563 end Analyze_Parameter_Association
;
1565 ----------------------------
1566 -- Analyze_Procedure_Call --
1567 ----------------------------
1569 -- WARNING: This routine manages Ghost regions. Return statements must be
1570 -- replaced by gotos that jump to the end of the routine and restore the
1573 procedure Analyze_Procedure_Call
(N
: Node_Id
) is
1574 procedure Analyze_Call_And_Resolve
;
1575 -- Do Analyze and Resolve calls for procedure call. At the end, check
1576 -- for illegal order dependence.
1577 -- ??? where is the check for illegal order dependencies?
1579 ------------------------------
1580 -- Analyze_Call_And_Resolve --
1581 ------------------------------
1583 procedure Analyze_Call_And_Resolve
is
1585 if Nkind
(N
) = N_Procedure_Call_Statement
then
1587 Resolve
(N
, Standard_Void_Type
);
1591 end Analyze_Call_And_Resolve
;
1595 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
1596 Loc
: constant Source_Ptr
:= Sloc
(N
);
1597 P
: constant Node_Id
:= Name
(N
);
1599 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1600 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
1601 -- Save the Ghost-related attributes to restore on exit
1606 -- Start of processing for Analyze_Procedure_Call
1609 -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
1610 -- a procedure call or an entry call. The prefix may denote an access
1611 -- to subprogram type, in which case an implicit dereference applies.
1612 -- If the prefix is an indexed component (without implicit dereference)
1613 -- then the construct denotes a call to a member of an entire family.
1614 -- If the prefix is a simple name, it may still denote a call to a
1615 -- parameterless member of an entry family. Resolution of these various
1616 -- interpretations is delicate.
1618 -- Do not analyze machine code statements to avoid rejecting them in
1621 if CodePeer_Mode
and then Nkind
(P
) = N_Qualified_Expression
then
1622 Set_Etype
(P
, Standard_Void_Type
);
1627 -- If this is a call of the form Obj.Op, the call may have been analyzed
1628 -- and possibly rewritten into a block, in which case we are done.
1630 if Analyzed
(N
) then
1633 -- If there is an error analyzing the name (which may have been
1634 -- rewritten if the original call was in prefix notation) then error
1635 -- has been emitted already, mark node and return.
1637 elsif Error_Posted
(N
) or else Etype
(Name
(N
)) = Any_Type
then
1638 Set_Etype
(N
, Any_Type
);
1642 -- A procedure call is Ghost when its name denotes a Ghost procedure.
1643 -- Set the mode now to ensure that any nodes generated during analysis
1644 -- and expansion are properly marked as Ghost.
1646 Mark_And_Set_Ghost_Procedure_Call
(N
);
1648 -- Otherwise analyze the parameters
1650 Actual
:= First
(Actuals
);
1652 while Present
(Actual
) loop
1654 Check_Parameterless_Call
(Actual
);
1658 -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
1660 if Nkind
(P
) = N_Attribute_Reference
1661 and then Attribute_Name
(P
) in Name_Elab_Spec
1663 | Name_Elab_Subp_Body
1665 if Present
(Actuals
) then
1667 ("no parameters allowed for this call", First
(Actuals
));
1671 Set_Etype
(N
, Standard_Void_Type
);
1674 elsif Is_Entity_Name
(P
)
1675 and then Is_Record_Type
(Etype
(Entity
(P
)))
1676 and then Remote_AST_I_Dereference
(P
)
1680 elsif Is_Entity_Name
(P
)
1681 and then Ekind
(Entity
(P
)) /= E_Entry_Family
1683 if Is_Access_Type
(Etype
(P
))
1684 and then Ekind
(Designated_Type
(Etype
(P
))) = E_Subprogram_Type
1685 and then No
(Actuals
)
1686 and then Comes_From_Source
(N
)
1688 Error_Msg_N
("missing explicit dereference in call", N
);
1690 elsif Ekind
(Entity
(P
)) = E_Operator
then
1691 Error_Msg_Name_1
:= Chars
(P
);
1692 Error_Msg_N
("operator % cannot be used as a procedure", N
);
1695 Analyze_Call_And_Resolve
;
1697 -- If the prefix is the simple name of an entry family, this is a
1698 -- parameterless call from within the task body itself.
1700 elsif Is_Entity_Name
(P
)
1701 and then Nkind
(P
) = N_Identifier
1702 and then Ekind
(Entity
(P
)) = E_Entry_Family
1703 and then Present
(Actuals
)
1704 and then No
(Next
(First
(Actuals
)))
1706 -- Can be call to parameterless entry family. What appears to be the
1707 -- sole argument is in fact the entry index. Rewrite prefix of node
1708 -- accordingly. Source representation is unchanged by this
1712 Make_Indexed_Component
(Loc
,
1714 Make_Selected_Component
(Loc
,
1715 Prefix
=> New_Occurrence_Of
(Scope
(Entity
(P
)), Loc
),
1716 Selector_Name
=> New_Occurrence_Of
(Entity
(P
), Loc
)),
1717 Expressions
=> Actuals
);
1718 Set_Name
(N
, New_N
);
1719 Set_Etype
(New_N
, Standard_Void_Type
);
1720 Set_Parameter_Associations
(N
, No_List
);
1721 Analyze_Call_And_Resolve
;
1723 elsif Nkind
(P
) = N_Explicit_Dereference
then
1724 if Ekind
(Etype
(P
)) = E_Subprogram_Type
then
1725 Analyze_Call_And_Resolve
;
1727 Error_Msg_N
("expect access to procedure in call", P
);
1730 -- The name can be a selected component or an indexed component that
1731 -- yields an access to subprogram. Such a prefix is legal if the call
1732 -- has parameter associations.
1734 elsif Is_Access_Type
(Etype
(P
))
1735 and then Ekind
(Designated_Type
(Etype
(P
))) = E_Subprogram_Type
1737 if Present
(Actuals
) then
1738 Analyze_Call_And_Resolve
;
1740 Error_Msg_N
("missing explicit dereference in call", N
);
1743 -- If not an access to subprogram, then the prefix must resolve to the
1744 -- name of an entry, entry family, or protected operation.
1746 -- For the case of a simple entry call, P is a selected component where
1747 -- the prefix is the task and the selector name is the entry. A call to
1748 -- a protected procedure will have the same syntax. If the protected
1749 -- object contains overloaded operations, the entity may appear as a
1750 -- function, the context will select the operation whose type is Void.
1752 elsif Nkind
(P
) = N_Selected_Component
1753 and then Ekind
(Entity
(Selector_Name
(P
)))
1754 in E_Entry | E_Function | E_Procedure
1756 -- When front-end inlining is enabled, as with GNATprove mode, a call
1757 -- in prefix notation may still be missing its controlling argument,
1758 -- so perform the transformation now.
1760 if GNATprove_Mode
and then In_Inlined_Body
then
1762 Subp
: constant Entity_Id
:= Entity
(Selector_Name
(P
));
1763 Typ
: constant Entity_Id
:= Etype
(Prefix
(P
));
1766 if Is_Tagged_Type
(Typ
)
1767 and then Present
(First_Formal
(Subp
))
1768 and then (Etype
(First_Formal
(Subp
)) = Typ
1770 Class_Wide_Type
(Etype
(First_Formal
(Subp
))) = Typ
)
1771 and then Try_Object_Operation
(P
)
1776 Analyze_Call_And_Resolve
;
1781 Analyze_Call_And_Resolve
;
1784 elsif Nkind
(P
) = N_Selected_Component
1785 and then Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
1786 and then Present
(Actuals
)
1787 and then No
(Next
(First
(Actuals
)))
1789 -- Can be call to parameterless entry family. What appears to be the
1790 -- sole argument is in fact the entry index. Rewrite prefix of node
1791 -- accordingly. Source representation is unchanged by this
1795 Make_Indexed_Component
(Loc
,
1796 Prefix
=> New_Copy
(P
),
1797 Expressions
=> Actuals
);
1798 Set_Name
(N
, New_N
);
1799 Set_Etype
(New_N
, Standard_Void_Type
);
1800 Set_Parameter_Associations
(N
, No_List
);
1801 Analyze_Call_And_Resolve
;
1803 -- For the case of a reference to an element of an entry family, P is
1804 -- an indexed component whose prefix is a selected component (task and
1805 -- entry family), and whose index is the entry family index.
1807 elsif Nkind
(P
) = N_Indexed_Component
1808 and then Nkind
(Prefix
(P
)) = N_Selected_Component
1809 and then Ekind
(Entity
(Selector_Name
(Prefix
(P
)))) = E_Entry_Family
1811 Analyze_Call_And_Resolve
;
1813 -- If the prefix is the name of an entry family, it is a call from
1814 -- within the task body itself.
1816 elsif Nkind
(P
) = N_Indexed_Component
1817 and then Nkind
(Prefix
(P
)) = N_Identifier
1818 and then Ekind
(Entity
(Prefix
(P
))) = E_Entry_Family
1821 Make_Selected_Component
(Loc
,
1823 New_Occurrence_Of
(Scope
(Entity
(Prefix
(P
))), Loc
),
1824 Selector_Name
=> New_Occurrence_Of
(Entity
(Prefix
(P
)), Loc
));
1825 Rewrite
(Prefix
(P
), New_N
);
1827 Analyze_Call_And_Resolve
;
1829 -- In Ada 2012. a qualified expression is a name, but it cannot be a
1830 -- procedure name, so the construct can only be a qualified expression.
1832 elsif Nkind
(P
) = N_Qualified_Expression
1833 and then Ada_Version
>= Ada_2012
1835 Rewrite
(N
, Make_Code_Statement
(Loc
, Expression
=> P
));
1838 -- Anything else is an error
1841 Error_Msg_N
("invalid procedure or entry call", N
);
1843 -- Specialize the error message in the case where both a primitive
1844 -- operation and a record component are visible at the same time.
1846 if Nkind
(P
) = N_Selected_Component
1847 and then Is_Entity_Name
(Selector_Name
(P
))
1850 Sel
: constant Entity_Id
:= Entity
(Selector_Name
(P
));
1852 if Ekind
(Sel
) = E_Component
1853 and then Present
(Homonym
(Sel
))
1854 and then Ekind
(Homonym
(Sel
)) = E_Procedure
1856 Error_Msg_NE
("\component & conflicts with"
1857 & " homonym procedure (RM 4.1.3 (9.2/3))",
1858 Selector_Name
(P
), Sel
);
1865 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
1866 end Analyze_Procedure_Call
;
1868 ------------------------------
1869 -- Analyze_Return_Statement --
1870 ------------------------------
1872 procedure Analyze_Return_Statement
(N
: Node_Id
) is
1874 (Nkind
(N
) in N_Extended_Return_Statement | N_Simple_Return_Statement
);
1876 Returns_Object
: constant Boolean :=
1877 Nkind
(N
) = N_Extended_Return_Statement
1879 (Nkind
(N
) = N_Simple_Return_Statement
1880 and then Present
(Expression
(N
)));
1881 -- True if we're returning something; that is, "return <expression>;"
1882 -- or "return Result : T [:= ...]". False for "return;". Used for error
1883 -- checking: If Returns_Object is True, N should apply to a function
1884 -- body; otherwise N should apply to a procedure body, entry body,
1885 -- accept statement, or extended return statement.
1887 function Find_What_It_Applies_To
return Entity_Id
;
1888 -- Find the entity representing the innermost enclosing body, accept
1889 -- statement, or extended return statement. If the result is a callable
1890 -- construct or extended return statement, then this will be the value
1891 -- of the Return_Applies_To attribute. Otherwise, the program is
1892 -- illegal. See RM-6.5(4/2).
1894 -----------------------------
1895 -- Find_What_It_Applies_To --
1896 -----------------------------
1898 function Find_What_It_Applies_To
return Entity_Id
is
1899 Result
: Entity_Id
:= Empty
;
1902 -- Loop outward through the Scope_Stack, skipping blocks, and loops
1904 for J
in reverse 0 .. Scope_Stack
.Last
loop
1905 Result
:= Scope_Stack
.Table
(J
).Entity
;
1906 exit when Ekind
(Result
) not in E_Block | E_Loop
;
1909 pragma Assert
(Present
(Result
));
1911 end Find_What_It_Applies_To
;
1913 -- Local declarations
1915 Scope_Id
: constant Entity_Id
:= Find_What_It_Applies_To
;
1916 Kind
: constant Entity_Kind
:= Ekind
(Scope_Id
);
1917 Loc
: constant Source_Ptr
:= Sloc
(N
);
1918 Stm_Entity
: constant Entity_Id
:=
1920 (E_Return_Statement
, Current_Scope
, Loc
, 'R');
1922 -- Start of processing for Analyze_Return_Statement
1925 Set_Return_Statement_Entity
(N
, Stm_Entity
);
1927 Set_Etype
(Stm_Entity
, Standard_Void_Type
);
1928 Set_Return_Applies_To
(Stm_Entity
, Scope_Id
);
1930 -- Place Return entity on scope stack, to simplify enforcement of 6.5
1931 -- (4/2): an inner return statement will apply to this extended return.
1933 if Nkind
(N
) = N_Extended_Return_Statement
then
1934 Push_Scope
(Stm_Entity
);
1937 -- Check that pragma No_Return is obeyed. Don't complain about the
1938 -- implicitly-generated return that is placed at the end.
1940 if No_Return
(Scope_Id
)
1941 and then Kind
in E_Procedure | E_Generic_Procedure
1942 and then Comes_From_Source
(N
)
1945 ("RETURN statement not allowed in No_Return procedure", N
);
1948 -- Warn on any unassigned OUT parameters if in procedure
1950 if Ekind
(Scope_Id
) = E_Procedure
then
1951 Warn_On_Unassigned_Out_Parameter
(N
, Scope_Id
);
1954 -- Check that functions return objects, and other things do not
1956 if Kind
in E_Function | E_Generic_Function
then
1957 if not Returns_Object
then
1958 Error_Msg_N
("missing expression in return from function", N
);
1961 elsif Kind
in E_Procedure | E_Generic_Procedure
then
1962 if Returns_Object
then
1963 Error_Msg_N
("procedure cannot return value (use function)", N
);
1966 elsif Kind
in E_Entry | E_Entry_Family
then
1967 if Returns_Object
then
1968 if Is_Protected_Type
(Scope
(Scope_Id
)) then
1969 Error_Msg_N
("entry body cannot return value", N
);
1971 Error_Msg_N
("accept statement cannot return value", N
);
1975 elsif Kind
= E_Return_Statement
then
1977 -- We are nested within another return statement, which must be an
1978 -- extended_return_statement.
1980 if Returns_Object
then
1981 if Nkind
(N
) = N_Extended_Return_Statement
then
1983 ("extended return statement cannot be nested (use `RETURN;`)",
1986 -- Case of a simple return statement with a value inside extended
1987 -- return statement.
1991 ("return nested in extended return statement cannot return "
1992 & "value (use `RETURN;`)", N
);
1997 Error_Msg_N
("illegal context for return statement", N
);
2000 if Kind
in E_Function | E_Generic_Function
then
2001 Analyze_Function_Return
(N
);
2003 elsif Kind
in E_Procedure | E_Generic_Procedure
then
2004 Set_Return_Present
(Scope_Id
);
2007 if Nkind
(N
) = N_Extended_Return_Statement
then
2011 Kill_Current_Values
(Last_Assignment_Only
=> True);
2012 Check_Unreachable_Code
(N
);
2014 Analyze_Dimension
(N
);
2015 end Analyze_Return_Statement
;
2017 -----------------------------------
2018 -- Analyze_Return_When_Statement --
2019 -----------------------------------
2021 procedure Analyze_Return_When_Statement
(N
: Node_Id
) is
2023 -- Verify the condition is a Boolean expression
2025 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
2026 Check_Unset_Reference
(Condition
(N
));
2027 end Analyze_Return_When_Statement
;
2029 -------------------------------------
2030 -- Analyze_Simple_Return_Statement --
2031 -------------------------------------
2033 procedure Analyze_Simple_Return_Statement
(N
: Node_Id
) is
2035 if Present
(Expression
(N
)) then
2036 Mark_Coextensions
(N
, Expression
(N
));
2039 Analyze_Return_Statement
(N
);
2040 end Analyze_Simple_Return_Statement
;
2042 -------------------------
2043 -- Analyze_Return_Type --
2044 -------------------------
2046 procedure Analyze_Return_Type
(N
: Node_Id
) is
2047 Designator
: constant Entity_Id
:= Defining_Entity
(N
);
2051 -- Normal case where result definition does not indicate an error
2053 if Result_Definition
(N
) /= Error
then
2054 if Nkind
(Result_Definition
(N
)) = N_Access_Definition
then
2056 -- Ada 2005 (AI-254): Handle anonymous access to subprograms
2059 AD
: constant Node_Id
:=
2060 Access_To_Subprogram_Definition
(Result_Definition
(N
));
2062 if Present
(AD
) and then Protected_Present
(AD
) then
2063 Typ
:= Replace_Anonymous_Access_To_Protected_Subprogram
(N
);
2065 Typ
:= Access_Definition
(N
, Result_Definition
(N
));
2069 Set_Parent
(Typ
, Result_Definition
(N
));
2070 Set_Is_Local_Anonymous_Access
(Typ
);
2071 Set_Etype
(Designator
, Typ
);
2073 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
2075 Null_Exclusion_Static_Checks
(N
);
2077 -- Subtype_Mark case
2080 Find_Type
(Result_Definition
(N
));
2081 Typ
:= Entity
(Result_Definition
(N
));
2082 Set_Etype
(Designator
, Typ
);
2084 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
2086 Null_Exclusion_Static_Checks
(N
);
2088 -- If a null exclusion is imposed on the result type, then create
2089 -- a null-excluding itype (an access subtype) and use it as the
2090 -- function's Etype. Note that the null exclusion checks are done
2091 -- right before this, because they don't get applied to types that
2092 -- do not come from source.
2094 if Is_Access_Type
(Typ
) and then Null_Exclusion_Present
(N
) then
2095 Set_Etype
(Designator
,
2096 Create_Null_Excluding_Itype
2099 Scope_Id
=> Scope
(Current_Scope
)));
2101 -- The new subtype must be elaborated before use because
2102 -- it is visible outside of the function. However its base
2103 -- type may not be frozen yet, so the reference that will
2104 -- force elaboration must be attached to the freezing of
2107 -- If the return specification appears on a proper body,
2108 -- the subtype will have been created already on the spec.
2110 if Is_Frozen
(Typ
) then
2111 if Nkind
(Parent
(N
)) = N_Subprogram_Body
2112 and then Nkind
(Parent
(Parent
(N
))) = N_Subunit
2116 Build_Itype_Reference
(Etype
(Designator
), Parent
(N
));
2121 IR
: constant Node_Id
:= Make_Itype_Reference
(Sloc
(N
));
2123 Set_Itype
(IR
, Etype
(Designator
));
2124 Append_Freeze_Action
(Typ
, IR
);
2129 Set_Etype
(Designator
, Typ
);
2132 if Ekind
(Typ
) = E_Incomplete_Type
2133 or else (Is_Class_Wide_Type
(Typ
)
2134 and then Ekind
(Root_Type
(Typ
)) = E_Incomplete_Type
)
2136 -- AI05-0151: Tagged incomplete types are allowed in all formal
2137 -- parts. Untagged incomplete types are not allowed in bodies.
2138 -- As a consequence, limited views cannot appear in a basic
2139 -- declaration that is itself within a body, because there is
2140 -- no point at which the non-limited view will become visible.
2142 if Ada_Version
>= Ada_2012
then
2143 if From_Limited_With
(Typ
) and then In_Package_Body
then
2145 ("invalid use of incomplete type&",
2146 Result_Definition
(N
), Typ
);
2148 -- The return type of a subprogram body cannot be of a
2149 -- formal incomplete type.
2151 elsif Is_Generic_Type
(Typ
)
2152 and then Nkind
(Parent
(N
)) = N_Subprogram_Body
2155 ("return type cannot be a formal incomplete type",
2156 Result_Definition
(N
));
2158 elsif Is_Class_Wide_Type
(Typ
)
2159 and then Is_Generic_Type
(Root_Type
(Typ
))
2160 and then Nkind
(Parent
(N
)) = N_Subprogram_Body
2163 ("return type cannot be a formal incomplete type",
2164 Result_Definition
(N
));
2166 elsif Is_Tagged_Type
(Typ
) then
2169 -- Use is legal in a thunk generated for an operation
2170 -- inherited from a progenitor.
2172 elsif Is_Thunk
(Designator
)
2173 and then Present
(Non_Limited_View
(Typ
))
2177 elsif Nkind
(Parent
(N
)) = N_Subprogram_Body
2178 or else Nkind
(Parent
(Parent
(N
))) in
2179 N_Accept_Statement | N_Entry_Body
2182 ("invalid use of untagged incomplete type&",
2186 -- The type must be completed in the current package. This
2187 -- is checked at the end of the package declaration when
2188 -- Taft-amendment types are identified. If the return type
2189 -- is class-wide, there is no required check, the type can
2190 -- be a bona fide TAT.
2192 if Ekind
(Scope
(Current_Scope
)) = E_Package
2193 and then In_Private_Part
(Scope
(Current_Scope
))
2194 and then not Is_Class_Wide_Type
(Typ
)
2196 Append_Elmt
(Designator
, Private_Dependents
(Typ
));
2201 ("invalid use of incomplete type&", Designator
, Typ
);
2206 -- Case where result definition does indicate an error
2209 Set_Etype
(Designator
, Any_Type
);
2211 end Analyze_Return_Type
;
2213 --------------------------------------------
2214 -- Analyze_SPARK_Subprogram_Specification --
2215 --------------------------------------------
2217 procedure Analyze_SPARK_Subprogram_Specification
(N
: Node_Id
) is
2218 Spec_Id
: constant Entity_Id
:= Defining_Entity
(N
);
2222 if not Comes_From_Source
(Spec_Id
) then
2226 -- The following checks are relevant only when SPARK_Mode is On as
2227 -- these are not standard Ada legality rules.
2229 if No
(SPARK_Pragma
(Spec_Id
))
2230 or else Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Spec_Id
)) /= On
2235 Formal
:= First_Formal
(Spec_Id
);
2236 while Present
(Formal
) loop
2237 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
2238 and then not Is_Function_With_Side_Effects
(Spec_Id
)
2240 -- A function cannot have a parameter of mode IN OUT or OUT
2243 if Ekind
(Formal
) in E_In_Out_Parameter
2246 Error_Msg_Code
:= GEC_Out_Parameter_In_Function
;
2248 ("function cannot have parameter of mode `OUT` or "
2249 & "`IN OUT` in SPARK '[[]']", Formal
);
2253 Next_Formal
(Formal
);
2255 end Analyze_SPARK_Subprogram_Specification
;
2257 -----------------------------
2258 -- Analyze_Subprogram_Body --
2259 -----------------------------
2261 procedure Analyze_Subprogram_Body
(N
: Node_Id
) is
2262 Loc
: constant Source_Ptr
:= Sloc
(N
);
2263 Body_Spec
: constant Node_Id
:= Specification
(N
);
2264 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Spec
);
2267 if Debug_Flag_C
then
2268 Write_Str
("==> subprogram body ");
2269 Write_Name
(Chars
(Body_Id
));
2270 Write_Str
(" from ");
2271 Write_Location
(Loc
);
2276 Trace_Scope
(N
, Body_Id
, " Analyze subprogram: ");
2278 -- The real work is split out into the helper, so it can do "return;"
2279 -- without skipping the debug output:
2281 Analyze_Subprogram_Body_Helper
(N
);
2283 if Debug_Flag_C
then
2285 Write_Str
("<== subprogram body ");
2286 Write_Name
(Chars
(Body_Id
));
2287 Write_Str
(" from ");
2288 Write_Location
(Loc
);
2291 end Analyze_Subprogram_Body
;
2293 ------------------------------------
2294 -- Analyze_Subprogram_Body_Helper --
2295 ------------------------------------
2297 -- This procedure is called for regular subprogram bodies, generic bodies,
2298 -- and for subprogram stubs of both kinds. In the case of stubs, only the
2299 -- specification matters, and is used to create a proper declaration for
2300 -- the subprogram, or to perform conformance checks.
2302 -- WARNING: This routine manages Ghost regions. Return statements must be
2303 -- replaced by gotos that jump to the end of the routine and restore the
2306 procedure Analyze_Subprogram_Body_Helper
(N
: Node_Id
) is
2307 Body_Spec
: Node_Id
:= Specification
(N
);
2308 Body_Id
: Entity_Id
:= Defining_Entity
(Body_Spec
);
2309 Loc
: constant Source_Ptr
:= Sloc
(N
);
2310 Prev_Id
: constant Entity_Id
:= Current_Entity_In_Scope
(Body_Id
);
2312 Body_Nod
: Node_Id
:= Empty
;
2313 Minimum_Acc_Objs
: List_Id
:= No_List
;
2315 Conformant
: Boolean;
2316 Desig_View
: Entity_Id
:= Empty
;
2317 Exch_Views
: Elist_Id
:= No_Elist
;
2318 Mask_Types
: Elist_Id
:= No_Elist
;
2319 Prot_Typ
: Entity_Id
:= Empty
;
2320 Spec_Decl
: Node_Id
:= Empty
;
2321 Spec_Id
: Entity_Id
:= Empty
;
2323 Last_Real_Spec_Entity
: Entity_Id
:= Empty
;
2324 -- When we analyze a separate spec, the entity chain ends up containing
2325 -- the formals, as well as any itypes generated during analysis of the
2326 -- default expressions for parameters, or the arguments of associated
2327 -- precondition/postcondition pragmas (which are analyzed in the context
2328 -- of the spec since they have visibility on formals).
2330 -- These entities belong with the spec and not the body. However we do
2331 -- the analysis of the body in the context of the spec (again to obtain
2332 -- visibility to the formals), and all the entities generated during
2333 -- this analysis end up also chained to the entity chain of the spec.
2334 -- But they really belong to the body, and there is circuitry to move
2335 -- them from the spec to the body.
2337 -- However, when we do this move, we don't want to move the real spec
2338 -- entities (first para above) to the body. The Last_Real_Spec_Entity
2339 -- variable points to the last real spec entity, so we only move those
2340 -- chained beyond that point. It is initialized to Empty to deal with
2341 -- the case where there is no separate spec.
2343 function Body_Has_Contract
return Boolean;
2344 -- Check whether unanalyzed body has an aspect or pragma that may
2345 -- generate a SPARK contract.
2347 function Body_Has_SPARK_Mode_On
return Boolean;
2348 -- Check whether SPARK_Mode On applies to the subprogram body, either
2349 -- because it is specified directly on the body, or because it is
2350 -- inherited from the enclosing subprogram or package.
2352 function Build_Internal_Protected_Declaration
2353 (N
: Node_Id
) return Entity_Id
;
2354 -- A subprogram body without a previous spec that appears in a protected
2355 -- body must be expanded separately to create a subprogram declaration
2356 -- for it, in order to resolve internal calls to it from other protected
2359 -- Possibly factor this with Exp_Dist.Copy_Specification ???
2361 procedure Build_Subprogram_Declaration
;
2362 -- Create a matching subprogram declaration for subprogram body N
2364 procedure Check_Anonymous_Return
;
2365 -- Ada 2005: if a function returns an access type that denotes a task,
2366 -- or a type that contains tasks, we must create a master entity for
2367 -- the anonymous type, which typically will be used in an allocator
2368 -- in the body of the function.
2370 procedure Check_Inline_Pragma
(Spec
: in out Node_Id
);
2371 -- Look ahead to recognize a pragma that may appear after the body.
2372 -- If there is a previous spec, check that it appears in the same
2373 -- declarative part. If the pragma is Inline_Always, perform inlining
2374 -- unconditionally, otherwise only if Front_End_Inlining is requested.
2375 -- If the body acts as a spec, and inlining is required, we create a
2376 -- subprogram declaration for it, in order to attach the body to inline.
2377 -- If pragma does not appear after the body, check whether there is
2378 -- an inline pragma before any local declarations.
2380 procedure Check_Missing_Return
;
2381 -- Checks for a function with a no return statements, and also performs
2382 -- the warning checks implemented by Check_Returns.
2384 function Disambiguate_Spec
return Entity_Id
;
2385 -- When a primitive is declared between the private view and the full
2386 -- view of a concurrent type which implements an interface, a special
2387 -- mechanism is used to find the corresponding spec of the primitive
2390 function Exchange_Limited_Views
(Subp_Id
: Entity_Id
) return Elist_Id
;
2391 -- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains
2392 -- incomplete types coming from a limited context and replace their
2393 -- limited views with the non-limited ones. Return the list of changes
2394 -- to be used to undo the transformation.
2396 procedure Generate_Minimum_Accessibility
2397 (Extra_Access
: Entity_Id
;
2398 Related_Form
: Entity_Id
:= Empty
);
2399 -- Generate a minimum accessibility object for a given extra
2400 -- accessibility formal (Extra_Access) and its related formal if it
2403 function Is_Private_Concurrent_Primitive
2404 (Subp_Id
: Entity_Id
) return Boolean;
2405 -- Determine whether subprogram Subp_Id is a primitive of a concurrent
2406 -- type that implements an interface and has a private view.
2408 function Mask_Unfrozen_Types
(Spec_Id
: Entity_Id
) return Elist_Id
;
2409 -- N is the body generated for an expression function that is not a
2410 -- completion and Spec_Id the defining entity of its spec. Mark all
2411 -- the not-yet-frozen types referenced by the simple return statement
2412 -- of the function as formally frozen.
2414 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
);
2415 -- Find all suitable source pragmas at the top of subprogram body
2416 -- From's declarations and move them after arbitrary node To.
2417 -- One exception is pragma SPARK_Mode which is copied rather than moved,
2418 -- as it applies to the body too.
2420 procedure Restore_Limited_Views
(Restore_List
: Elist_Id
);
2421 -- Undo the transformation done by Exchange_Limited_Views.
2423 procedure Set_Trivial_Subprogram
(N
: Node_Id
);
2424 -- Sets the Is_Trivial_Subprogram flag in both spec and body of the
2425 -- subprogram whose body is being analyzed. N is the statement node
2426 -- causing the flag to be set, if the following statement is a return
2427 -- of an entity, we mark the entity as set in source to suppress any
2428 -- warning on the stylized use of function stubs with a dummy return.
2430 procedure Unmask_Unfrozen_Types
(Unmask_List
: Elist_Id
);
2431 -- Undo the transformation done by Mask_Unfrozen_Types
2433 procedure Verify_Overriding_Indicator
;
2434 -- If there was a previous spec, the entity has been entered in the
2435 -- current scope previously. If the body itself carries an overriding
2436 -- indicator, check that it is consistent with the known status of the
2439 -----------------------
2440 -- Body_Has_Contract --
2441 -----------------------
2443 function Body_Has_Contract
return Boolean is
2444 Decls
: constant List_Id
:= Declarations
(N
);
2448 -- Check for aspects that may generate a contract
2450 Item
:= First
(Aspect_Specifications
(N
));
2451 while Present
(Item
) loop
2452 if Is_Subprogram_Contract_Annotation
(Item
) then
2459 -- Check for pragmas that may generate a contract
2461 Item
:= First
(Decls
);
2462 while Present
(Item
) loop
2463 if Nkind
(Item
) = N_Pragma
2464 and then Is_Subprogram_Contract_Annotation
(Item
)
2473 end Body_Has_Contract
;
2475 ----------------------------
2476 -- Body_Has_SPARK_Mode_On --
2477 ----------------------------
2479 function Body_Has_SPARK_Mode_On
return Boolean is
2480 Decls
: constant List_Id
:= Declarations
(N
);
2484 -- Check for SPARK_Mode aspect
2486 Item
:= First
(Aspect_Specifications
(N
));
2487 while Present
(Item
) loop
2488 if Get_Aspect_Id
(Item
) = Aspect_SPARK_Mode
then
2489 return Get_SPARK_Mode_From_Annotation
(Item
) = On
;
2495 -- Check for SPARK_Mode pragma
2497 Item
:= First
(Decls
);
2498 while Present
(Item
) loop
2500 -- Pragmas that apply to a subprogram body are usually grouped
2501 -- together. Look for a potential pragma SPARK_Mode among them.
2503 if Nkind
(Item
) = N_Pragma
then
2504 if Get_Pragma_Id
(Item
) = Pragma_SPARK_Mode
then
2505 return Get_SPARK_Mode_From_Annotation
(Item
) = On
;
2508 -- Otherwise the first non-pragma declarative item terminates the
2509 -- region where pragma SPARK_Mode may appear.
2518 -- Otherwise, the applicable SPARK_Mode is inherited from the
2519 -- enclosing subprogram or package.
2521 return SPARK_Mode
= On
;
2522 end Body_Has_SPARK_Mode_On
;
2524 ------------------------------------------
2525 -- Build_Internal_Protected_Declaration --
2526 ------------------------------------------
2528 function Build_Internal_Protected_Declaration
2529 (N
: Node_Id
) return Entity_Id
2531 procedure Analyze_Pragmas
(From
: Node_Id
);
2532 -- Analyze all pragmas which follow arbitrary node From
2534 ---------------------
2535 -- Analyze_Pragmas --
2536 ---------------------
2538 procedure Analyze_Pragmas
(From
: Node_Id
) is
2542 Decl
:= Next
(From
);
2543 while Present
(Decl
) loop
2544 if Nkind
(Decl
) = N_Pragma
then
2545 Analyze_Pragma
(Decl
);
2547 -- No candidate pragmas are available for analysis
2555 end Analyze_Pragmas
;
2559 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
2560 Loc
: constant Source_Ptr
:= Sloc
(N
);
2565 Spec_Id
: Entity_Id
;
2567 -- Start of processing for Build_Internal_Protected_Declaration
2570 Formal
:= First_Formal
(Body_Id
);
2572 -- The protected operation always has at least one formal, namely the
2573 -- object itself, but it is only placed in the parameter list if
2574 -- expansion is enabled.
2576 if Present
(Formal
) or else Expander_Active
then
2577 Formals
:= Copy_Parameter_List
(Body_Id
);
2583 Make_Defining_Identifier
(Sloc
(Body_Id
),
2584 Chars
=> Chars
(Body_Id
));
2586 -- Indicate that the entity comes from source, to ensure that cross-
2587 -- reference information is properly generated. The body itself is
2588 -- rewritten during expansion, and the body entity will not appear in
2589 -- calls to the operation.
2591 Set_Comes_From_Source
(Spec_Id
, True);
2593 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
2595 Make_Procedure_Specification
(Loc
,
2596 Defining_Unit_Name
=> Spec_Id
,
2597 Parameter_Specifications
=> Formals
);
2600 Make_Function_Specification
(Loc
,
2601 Defining_Unit_Name
=> Spec_Id
,
2602 Parameter_Specifications
=> Formals
,
2603 Result_Definition
=>
2604 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
2607 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> Spec
);
2608 Set_Corresponding_Body
(Decl
, Body_Id
);
2609 Set_Corresponding_Spec
(N
, Spec_Id
);
2611 Insert_Before
(N
, Decl
);
2613 -- Associate all aspects and pragmas of the body with the spec. This
2614 -- ensures that these annotations apply to the initial declaration of
2615 -- the subprogram body.
2617 Move_Aspects
(From
=> N
, To
=> Decl
);
2618 Move_Pragmas
(From
=> N
, To
=> Decl
);
2622 -- The analysis of the spec may generate pragmas which require manual
2623 -- analysis. Since the generation of the spec and the relocation of
2624 -- the annotations is driven by the expansion of the stand-alone
2625 -- body, the pragmas will not be analyzed in a timely manner. Do this
2628 Analyze_Pragmas
(Decl
);
2630 -- This subprogram has convention Intrinsic as per RM 6.3.1(10/2)
2631 -- ensuring in particular that 'Access is illegal.
2633 Set_Convention
(Spec_Id
, Convention_Intrinsic
);
2634 Set_Has_Completion
(Spec_Id
);
2637 end Build_Internal_Protected_Declaration
;
2639 ----------------------------------
2640 -- Build_Subprogram_Declaration --
2641 ----------------------------------
2643 procedure Build_Subprogram_Declaration
is
2645 Subp_Decl
: Node_Id
;
2648 -- Create a matching subprogram spec using the profile of the body.
2649 -- The structure of the tree is identical, but has new entities for
2650 -- the defining unit name and formal parameters.
2653 Make_Subprogram_Declaration
(Loc
,
2654 Specification
=> Copy_Subprogram_Spec
(Body_Spec
));
2655 Set_Comes_From_Source
(Subp_Decl
, True);
2657 -- Also mark parameters as coming from source
2659 if Present
(Parameter_Specifications
(Specification
(Subp_Decl
))) then
2664 First
(Parameter_Specifications
(Specification
(Subp_Decl
)));
2666 while Present
(Form
) loop
2667 Set_Comes_From_Source
(Defining_Identifier
(Form
), True);
2673 -- Relocate the aspects and relevant pragmas from the subprogram body
2674 -- to the generated spec because it acts as the initial declaration.
2676 Insert_Before
(N
, Subp_Decl
);
2677 Move_Aspects
(N
, To
=> Subp_Decl
);
2678 Move_Pragmas
(N
, To
=> Subp_Decl
);
2680 -- Ensure that the generated corresponding spec and original body
2681 -- share the same SPARK_Mode pragma or aspect. As a result, both have
2682 -- the same SPARK_Mode attributes, and the global SPARK_Mode value is
2683 -- correctly set for local subprograms.
2685 Copy_SPARK_Mode_Aspect
(Subp_Decl
, To
=> N
);
2687 Analyze
(Subp_Decl
);
2689 -- Propagate the attributes Rewritten_For_C and Corresponding_Proc to
2690 -- the body since the expander may generate calls using that entity.
2691 -- Required to ensure that Expand_Call rewrites calls to this
2692 -- function by calls to the built procedure.
2694 if Transform_Function_Array
2695 and then Nkind
(Body_Spec
) = N_Function_Specification
2697 Rewritten_For_C
(Defining_Entity
(Specification
(Subp_Decl
)))
2699 Set_Rewritten_For_C
(Defining_Entity
(Body_Spec
));
2700 Set_Corresponding_Procedure
(Defining_Entity
(Body_Spec
),
2701 Corresponding_Procedure
2702 (Defining_Entity
(Specification
(Subp_Decl
))));
2705 -- Analyze any relocated source pragmas or pragmas created for aspect
2708 Decl
:= Next
(Subp_Decl
);
2709 while Present
(Decl
) loop
2711 -- Stop the search for pragmas once the body has been reached as
2712 -- this terminates the region where pragmas may appear.
2717 elsif Nkind
(Decl
) = N_Pragma
then
2724 Spec_Id
:= Defining_Entity
(Subp_Decl
);
2725 Set_Corresponding_Spec
(N
, Spec_Id
);
2727 -- Mark the generated spec as a source construct to ensure that all
2728 -- calls to it are properly registered in ALI files for GNATprove.
2730 Set_Comes_From_Source
(Spec_Id
, True);
2732 -- Ensure that the specs of the subprogram declaration and its body
2733 -- are identical, otherwise they will appear non-conformant due to
2734 -- rewritings in the default values of formal parameters.
2736 Body_Spec
:= Copy_Subprogram_Spec
(Body_Spec
);
2737 Set_Specification
(N
, Body_Spec
);
2738 Body_Id
:= Analyze_Subprogram_Specification
(Body_Spec
);
2739 end Build_Subprogram_Declaration
;
2741 ----------------------------
2742 -- Check_Anonymous_Return --
2743 ----------------------------
2745 procedure Check_Anonymous_Return
is
2751 if Present
(Spec_Id
) then
2757 if Ekind
(Scop
) = E_Function
2758 and then Ekind
(Etype
(Scop
)) = E_Anonymous_Access_Type
2759 and then not Is_Thunk
(Scop
)
2761 -- Skip internally built functions which handle the case of
2762 -- a null access (see Expand_Interface_Conversion)
2764 and then not (Is_Interface
(Designated_Type
(Etype
(Scop
)))
2765 and then not Comes_From_Source
(Parent
(Scop
)))
2767 and then (Has_Task
(Designated_Type
(Etype
(Scop
)))
2769 (Is_Class_Wide_Type
(Designated_Type
(Etype
(Scop
)))
2772 (Etype
(Designated_Type
(Etype
(Scop
))))))
2773 and then Expander_Active
2775 Decl
:= Build_Master_Declaration
(Loc
);
2777 if Present
(Declarations
(N
)) then
2778 Prepend
(Decl
, Declarations
(N
));
2780 Set_Declarations
(N
, New_List
(Decl
));
2783 Set_Master_Id
(Etype
(Scop
), Defining_Identifier
(Decl
));
2784 Set_Has_Master_Entity
(Scop
);
2786 -- Now mark the containing scope as a task master
2789 while Nkind
(Par
) /= N_Compilation_Unit
loop
2790 Par
:= Parent
(Par
);
2791 pragma Assert
(Present
(Par
));
2793 -- If we fall off the top, we are at the outer level, and
2794 -- the environment task is our effective master, so nothing
2798 in N_Task_Body | N_Block_Statement | N_Subprogram_Body
2800 Set_Is_Task_Master
(Par
, True);
2805 end Check_Anonymous_Return
;
2807 -------------------------
2808 -- Check_Inline_Pragma --
2809 -------------------------
2811 procedure Check_Inline_Pragma
(Spec
: in out Node_Id
) is
2815 function Is_Inline_Pragma
(N
: Node_Id
) return Boolean;
2816 -- True when N is a pragma Inline or Inline_Always that applies
2817 -- to this subprogram.
2819 -----------------------
2820 -- Is_Inline_Pragma --
2821 -----------------------
2823 function Is_Inline_Pragma
(N
: Node_Id
) return Boolean is
2825 if Nkind
(N
) = N_Pragma
2827 (Pragma_Name_Unmapped
(N
) = Name_Inline_Always
2828 or else (Pragma_Name_Unmapped
(N
) = Name_Inline
2830 (Front_End_Inlining
or else Optimization_Level
> 0)))
2831 and then Present
(Pragma_Argument_Associations
(N
))
2834 Pragma_Arg
: Node_Id
:=
2835 Expression
(First
(Pragma_Argument_Associations
(N
)));
2837 if Nkind
(Pragma_Arg
) = N_Selected_Component
then
2838 Pragma_Arg
:= Selector_Name
(Pragma_Arg
);
2841 return Chars
(Pragma_Arg
) = Chars
(Body_Id
);
2847 end Is_Inline_Pragma
;
2849 -- Start of processing for Check_Inline_Pragma
2852 if not Expander_Active
then
2856 if Is_List_Member
(N
)
2857 and then Present
(Next
(N
))
2858 and then Is_Inline_Pragma
(Next
(N
))
2862 elsif Nkind
(N
) /= N_Subprogram_Body_Stub
2863 and then Present
(Declarations
(N
))
2864 and then Is_Inline_Pragma
(First
(Declarations
(N
)))
2866 Prag
:= First
(Declarations
(N
));
2872 if Present
(Prag
) and then Is_List_Member
(N
) then
2873 if Present
(Spec_Id
) then
2874 if Is_List_Member
(Unit_Declaration_Node
(Spec_Id
))
2875 and then In_Same_List
(N
, Unit_Declaration_Node
(Spec_Id
))
2880 -- Create a subprogram declaration, to make treatment uniform.
2881 -- Make the sloc of the subprogram name that of the entity in
2882 -- the body, so that style checks find identical strings.
2885 Subp
: constant Entity_Id
:=
2886 Make_Defining_Identifier
2887 (Sloc
(Body_Id
), Chars
(Body_Id
));
2888 Decl
: constant Node_Id
:=
2889 Make_Subprogram_Declaration
(Loc
,
2891 New_Copy_Tree
(Specification
(N
)));
2894 -- Link the body and the generated spec
2896 Set_Corresponding_Body
(Decl
, Body_Id
);
2898 if Nkind
(N
) = N_Subprogram_Body_Stub
then
2899 Set_Corresponding_Spec_Of_Stub
(N
, Subp
);
2901 Set_Corresponding_Spec
(N
, Subp
);
2904 Set_Defining_Unit_Name
(Specification
(Decl
), Subp
);
2906 -- To ensure proper coverage when body is inlined, indicate
2907 -- whether the subprogram comes from source.
2909 Preserve_Comes_From_Source
(Subp
, N
);
2911 if Present
(First_Formal
(Body_Id
)) then
2912 Plist
:= Copy_Parameter_List
(Body_Id
);
2913 Set_Parameter_Specifications
2914 (Specification
(Decl
), Plist
);
2917 -- Move aspects to the new spec
2919 Move_Aspects
(N
, To
=> Decl
);
2921 Insert_Before
(N
, Decl
);
2924 Set_Has_Pragma_Inline
(Subp
);
2926 if Pragma_Name
(Prag
) = Name_Inline_Always
then
2927 Set_Is_Inlined
(Subp
);
2928 Set_Has_Pragma_Inline_Always
(Subp
);
2931 -- Prior to copying the subprogram body to create a template
2932 -- for it for subsequent inlining, remove the pragma from
2933 -- the current body so that the copy that will produce the
2934 -- new body will start from a completely unanalyzed tree.
2936 if Nkind
(Parent
(Prag
)) = N_Subprogram_Body
then
2937 Rewrite
(Prag
, Make_Null_Statement
(Sloc
(Prag
)));
2944 end Check_Inline_Pragma
;
2946 --------------------------
2947 -- Check_Missing_Return --
2948 --------------------------
2950 procedure Check_Missing_Return
is
2951 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
2954 Missing_Ret
: Boolean;
2957 if Nkind
(Body_Spec
) = N_Function_Specification
then
2958 if Present
(Spec_Id
) then
2964 -- A function body shall contain at least one return statement
2965 -- that applies to the function body, unless the function contains
2966 -- code_statements; RM 6.5(5).
2968 if Return_Present
(Id
) then
2969 Check_Returns
(HSS
, 'F', Missing_Ret
);
2972 Set_Has_Missing_Return
(Id
);
2975 -- Within a premature instantiation of a package with no body, we
2976 -- build completions of the functions therein, with a Raise
2977 -- statement. No point in complaining about a missing return in
2980 elsif Ekind
(Id
) = E_Function
2981 and then In_Instance
2982 and then Present
(Statements
(HSS
))
2983 and then Nkind
(First
(Statements
(HSS
))) = N_Raise_Program_Error
2987 elsif Is_Generic_Subprogram
(Id
)
2988 or else not Is_Machine_Code_Subprogram
(Id
)
2990 Error_Msg_N
("missing RETURN statement in function body", N
);
2993 -- If procedure with No_Return, check returns
2995 elsif Nkind
(Body_Spec
) = N_Procedure_Specification
then
2996 if Present
(Spec_Id
) then
3002 if No_Return
(Id
) then
3003 Check_Returns
(HSS
, 'P', Missing_Ret
, Id
);
3006 end Check_Missing_Return
;
3008 -----------------------
3009 -- Disambiguate_Spec --
3010 -----------------------
3012 function Disambiguate_Spec
return Entity_Id
is
3013 Priv_Spec
: Entity_Id
;
3016 procedure Replace_Types
(To_Corresponding
: Boolean);
3017 -- Depending on the flag, replace the type of formal parameters of
3018 -- Body_Id if it is a concurrent type implementing interfaces with
3019 -- the corresponding record type or the other way around.
3021 procedure Replace_Types
(To_Corresponding
: Boolean) is
3023 Formal_Typ
: Entity_Id
;
3026 Formal
:= First_Formal
(Body_Id
);
3027 while Present
(Formal
) loop
3028 Formal_Typ
:= Etype
(Formal
);
3030 if Is_Class_Wide_Type
(Formal_Typ
) then
3031 Formal_Typ
:= Root_Type
(Formal_Typ
);
3034 -- From concurrent type to corresponding record
3036 if To_Corresponding
then
3037 if Is_Concurrent_Type
(Formal_Typ
)
3038 and then Present
(Corresponding_Record_Type
(Formal_Typ
))
3041 (Corresponding_Record_Type
(Formal_Typ
)))
3044 Corresponding_Record_Type
(Formal_Typ
));
3047 -- From corresponding record to concurrent type
3050 if Is_Concurrent_Record_Type
(Formal_Typ
)
3051 and then Present
(Interfaces
(Formal_Typ
))
3054 Corresponding_Concurrent_Type
(Formal_Typ
));
3058 Next_Formal
(Formal
);
3062 -- Start of processing for Disambiguate_Spec
3065 -- Try to retrieve the specification of the body as is. All error
3066 -- messages are suppressed because the body may not have a spec in
3067 -- its current state.
3069 Spec_N
:= Find_Corresponding_Spec
(N
, False);
3071 -- It is possible that this is the body of a primitive declared
3072 -- between a private and a full view of a concurrent type. The
3073 -- controlling parameter of the spec carries the concurrent type,
3074 -- not the corresponding record type as transformed by Analyze_
3075 -- Subprogram_Specification. In such cases, we undo the change
3076 -- made by the analysis of the specification and try to find the
3079 -- Note that wrappers already have their corresponding specs and
3080 -- bodies set during their creation, so if the candidate spec is
3081 -- a wrapper, then we definitely need to swap all types to their
3082 -- original concurrent status.
3085 or else Is_Primitive_Wrapper
(Spec_N
)
3087 -- Restore all references of corresponding record types to the
3088 -- original concurrent types.
3090 Replace_Types
(To_Corresponding
=> False);
3091 Priv_Spec
:= Find_Corresponding_Spec
(N
, False);
3093 -- The current body truly belongs to a primitive declared between
3094 -- a private and a full view. We leave the modified body as is,
3095 -- and return the true spec.
3097 if Present
(Priv_Spec
)
3098 and then Is_Private_Primitive
(Priv_Spec
)
3103 -- In case that this is some sort of error, restore the original
3104 -- state of the body.
3106 Replace_Types
(To_Corresponding
=> True);
3110 end Disambiguate_Spec
;
3112 ----------------------------
3113 -- Exchange_Limited_Views --
3114 ----------------------------
3116 function Exchange_Limited_Views
(Subp_Id
: Entity_Id
) return Elist_Id
is
3117 Result
: Elist_Id
:= No_Elist
;
3119 procedure Detect_And_Exchange
(Id
: Entity_Id
);
3120 -- Determine whether Id's type denotes an incomplete type associated
3121 -- with a limited with clause and exchange the limited view with the
3122 -- non-limited one when available. Note that the non-limited view
3123 -- may exist because of a with_clause in another unit in the context,
3124 -- but cannot be used because the current view of the enclosing unit
3125 -- is still a limited view.
3127 -------------------------
3128 -- Detect_And_Exchange --
3129 -------------------------
3131 procedure Detect_And_Exchange
(Id
: Entity_Id
) is
3132 Typ
: constant Entity_Id
:= Etype
(Id
);
3135 if From_Limited_With
(Typ
)
3136 and then Has_Non_Limited_View
(Typ
)
3137 and then not From_Limited_With
(Scope
(Typ
))
3140 Result
:= New_Elmt_List
;
3143 Prepend_Elmt
(Typ
, Result
);
3144 Prepend_Elmt
(Id
, Result
);
3145 Set_Etype
(Id
, Non_Limited_View
(Typ
));
3147 end Detect_And_Exchange
;
3153 -- Start of processing for Exchange_Limited_Views
3156 -- Do not process subprogram bodies as they already use the non-
3157 -- limited view of types.
3159 if Ekind
(Subp_Id
) not in E_Function | E_Procedure
then
3163 -- Examine all formals and swap views when applicable
3165 Formal
:= First_Formal
(Subp_Id
);
3166 while Present
(Formal
) loop
3167 Detect_And_Exchange
(Formal
);
3169 Next_Formal
(Formal
);
3172 -- Process the return type of a function
3174 if Ekind
(Subp_Id
) = E_Function
then
3175 Detect_And_Exchange
(Subp_Id
);
3179 end Exchange_Limited_Views
;
3181 ------------------------------------
3182 -- Generate_Minimum_Accessibility --
3183 ------------------------------------
3185 procedure Generate_Minimum_Accessibility
3186 (Extra_Access
: Entity_Id
;
3187 Related_Form
: Entity_Id
:= Empty
)
3189 Loc
: constant Source_Ptr
:= Sloc
(Body_Nod
);
3193 -- When no related formal exists then we are dealing with an
3194 -- extra accessibility formal for a function result.
3196 if No
(Related_Form
) then
3197 Form
:= Extra_Access
;
3199 Form
:= Related_Form
;
3202 -- Create the minimum accessibility object
3205 Make_Object_Declaration
(Loc
,
3206 Defining_Identifier
=>
3208 (Loc
, 'A', Extra_Access
),
3209 Object_Definition
=> New_Occurrence_Of
3210 (Standard_Natural
, Loc
),
3212 Make_Attribute_Reference
(Loc
,
3213 Prefix
=> New_Occurrence_Of
3214 (Standard_Natural
, Loc
),
3215 Attribute_Name
=> Name_Min
,
3216 Expressions
=> New_List
(
3217 Make_Integer_Literal
(Loc
,
3218 Scope_Depth
(Body_Id
)),
3220 (Extra_Access
, Loc
))));
3222 -- Add the new local object to the Minimum_Acc_Obj to
3223 -- be later prepended to the subprogram's list of
3224 -- declarations after we are sure all expansion is
3227 if Present
(Minimum_Acc_Objs
) then
3228 Prepend
(Obj_Node
, Minimum_Acc_Objs
);
3230 Minimum_Acc_Objs
:= New_List
(Obj_Node
);
3233 -- Register the object and analyze it
3235 Set_Minimum_Accessibility
3236 (Form
, Defining_Identifier
(Obj_Node
));
3239 end Generate_Minimum_Accessibility
;
3241 -------------------------------------
3242 -- Is_Private_Concurrent_Primitive --
3243 -------------------------------------
3245 function Is_Private_Concurrent_Primitive
3246 (Subp_Id
: Entity_Id
) return Boolean
3248 Formal_Typ
: Entity_Id
;
3251 if Present
(First_Formal
(Subp_Id
)) then
3252 Formal_Typ
:= Etype
(First_Formal
(Subp_Id
));
3254 if Is_Concurrent_Record_Type
(Formal_Typ
) then
3255 if Is_Class_Wide_Type
(Formal_Typ
) then
3256 Formal_Typ
:= Root_Type
(Formal_Typ
);
3259 Formal_Typ
:= Corresponding_Concurrent_Type
(Formal_Typ
);
3262 -- The type of the first formal is a concurrent tagged type with
3266 Is_Concurrent_Type
(Formal_Typ
)
3267 and then Is_Tagged_Type
(Formal_Typ
)
3268 and then Has_Private_Declaration
(Formal_Typ
);
3272 end Is_Private_Concurrent_Primitive
;
3274 -------------------------
3275 -- Mask_Unfrozen_Types --
3276 -------------------------
3278 function Mask_Unfrozen_Types
(Spec_Id
: Entity_Id
) return Elist_Id
is
3279 Result
: Elist_Id
:= No_Elist
;
3281 function Mask_Type_Refs
(Node
: Node_Id
) return Traverse_Result
;
3282 -- Mask all types referenced in the subtree rooted at Node as
3285 --------------------
3286 -- Mask_Type_Refs --
3287 --------------------
3289 function Mask_Type_Refs
(Node
: Node_Id
) return Traverse_Result
is
3290 procedure Mask_Type
(Typ
: Entity_Id
);
3291 -- Mask a given type as formally frozen when outside the current
3292 -- scope, or else freeze the type.
3298 procedure Mask_Type
(Typ
: Entity_Id
) is
3300 -- Skip Itypes created by the preanalysis
3303 and then Scope_Within_Or_Same
(Scope
(Typ
), Spec_Id
)
3308 if not Is_Frozen
(Typ
) then
3309 if Scope
(Typ
) /= Current_Scope
then
3310 Set_Is_Frozen
(Typ
);
3311 Append_New_Elmt
(Typ
, Result
);
3313 Freeze_Before
(N
, Typ
);
3318 -- Start of processing for Mask_Type_Refs
3321 if Is_Entity_Name
(Node
) and then Present
(Entity
(Node
)) then
3322 Mask_Type
(Etype
(Entity
(Node
)));
3324 if Ekind
(Entity
(Node
)) in E_Component | E_Discriminant
then
3325 Mask_Type
(Scope
(Entity
(Node
)));
3328 elsif Nkind
(Node
) in N_Aggregate | N_Null | N_Type_Conversion
3329 and then Present
(Etype
(Node
))
3331 Mask_Type
(Etype
(Node
));
3337 procedure Mask_References
is new Traverse_Proc
(Mask_Type_Refs
);
3341 Return_Stmt
: constant Node_Id
:=
3342 First
(Statements
(Handled_Statement_Sequence
(N
)));
3344 -- Start of processing for Mask_Unfrozen_Types
3347 pragma Assert
(Nkind
(Return_Stmt
) = N_Simple_Return_Statement
);
3349 Mask_References
(Expression
(Return_Stmt
));
3352 end Mask_Unfrozen_Types
;
3358 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
) is
3360 Insert_Nod
: Node_Id
;
3361 Next_Decl
: Node_Id
;
3364 pragma Assert
(Nkind
(From
) = N_Subprogram_Body
);
3366 -- The pragmas are moved in an order-preserving fashion
3370 -- Inspect the declarations of the subprogram body and relocate all
3371 -- candidate pragmas.
3373 Decl
:= First
(Declarations
(From
));
3374 while Present
(Decl
) loop
3376 -- Preserve the following declaration for iteration purposes, due
3377 -- to possible relocation of a pragma.
3379 Next_Decl
:= Next
(Decl
);
3381 if Nkind
(Decl
) = N_Pragma
then
3382 -- Copy pragma SPARK_Mode if present in the declarative list
3383 -- of subprogram body From and insert it after node To. This
3384 -- pragma should not be moved, as it applies to the body too.
3386 if Pragma_Name_Unmapped
(Decl
) = Name_SPARK_Mode
then
3387 Insert_After
(Insert_Nod
, New_Copy_Tree
(Decl
));
3389 -- Move relevant pragmas to the spec
3392 Pragma_Significant_To_Subprograms
3393 (Get_Pragma_Id
(Decl
))
3396 Insert_After
(Insert_Nod
, Decl
);
3400 -- Skip internally generated code
3402 elsif not Comes_From_Source
(Decl
) then
3405 -- No candidate pragmas are available for relocation
3415 ---------------------------
3416 -- Restore_Limited_Views --
3417 ---------------------------
3419 procedure Restore_Limited_Views
(Restore_List
: Elist_Id
) is
3420 Elmt
: Elmt_Id
:= First_Elmt
(Restore_List
);
3424 while Present
(Elmt
) loop
3427 Set_Etype
(Id
, Node
(Elmt
));
3430 end Restore_Limited_Views
;
3432 ----------------------------
3433 -- Set_Trivial_Subprogram --
3434 ----------------------------
3436 procedure Set_Trivial_Subprogram
(N
: Node_Id
) is
3437 Nxt
: constant Node_Id
:= Next
(N
);
3440 Set_Is_Trivial_Subprogram
(Body_Id
);
3442 if Present
(Spec_Id
) then
3443 Set_Is_Trivial_Subprogram
(Spec_Id
);
3447 and then Nkind
(Nxt
) = N_Simple_Return_Statement
3448 and then No
(Next
(Nxt
))
3449 and then Present
(Expression
(Nxt
))
3450 and then Is_Entity_Name
(Expression
(Nxt
))
3452 Set_Never_Set_In_Source
(Entity
(Expression
(Nxt
)), False);
3454 end Set_Trivial_Subprogram
;
3456 ---------------------------
3457 -- Unmask_Unfrozen_Types --
3458 ---------------------------
3460 procedure Unmask_Unfrozen_Types
(Unmask_List
: Elist_Id
) is
3461 Elmt
: Elmt_Id
:= First_Elmt
(Unmask_List
);
3464 while Present
(Elmt
) loop
3465 Set_Is_Frozen
(Node
(Elmt
), False);
3468 end Unmask_Unfrozen_Types
;
3470 ---------------------------------
3471 -- Verify_Overriding_Indicator --
3472 ---------------------------------
3474 procedure Verify_Overriding_Indicator
is
3476 if Must_Override
(Body_Spec
) then
3477 if Nkind
(Spec_Id
) = N_Defining_Operator_Symbol
3478 and then Operator_Matches_Spec
(Spec_Id
, Spec_Id
)
3482 -- Overridden controlled primitives may have had their
3483 -- Overridden_Operation field cleared according to the setting of
3484 -- the Is_Hidden flag. An issue arises, however, when analyzing
3485 -- an instance that may have manipulated the flag during
3486 -- expansion. As a result, we add an exception for this case.
3488 elsif No
(Overridden_Operation
(Spec_Id
))
3489 and then not (Chars
(Spec_Id
) in Name_Adjust
3492 and then In_Instance
)
3495 ("subprogram& is not overriding", Body_Spec
, Spec_Id
);
3497 -- Overriding indicators aren't allowed for protected subprogram
3498 -- bodies (see the Confirmation in Ada Comment AC95-00213). Change
3499 -- this to a warning if -gnatd.E is enabled.
3501 elsif Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
3502 Error_Msg_Warn
:= Error_To_Warning
;
3504 ("<<overriding indicator not allowed for protected "
3505 & "subprogram body", Body_Spec
);
3508 elsif Must_Not_Override
(Body_Spec
) then
3509 if Present
(Overridden_Operation
(Spec_Id
)) then
3511 ("subprogram& overrides inherited operation",
3512 Body_Spec
, Spec_Id
);
3514 elsif Nkind
(Spec_Id
) = N_Defining_Operator_Symbol
3515 and then Operator_Matches_Spec
(Spec_Id
, Spec_Id
)
3518 ("subprogram& overrides predefined operator",
3519 Body_Spec
, Spec_Id
);
3521 -- Overriding indicators aren't allowed for protected subprogram
3522 -- bodies (see the Confirmation in Ada Comment AC95-00213). Change
3523 -- this to a warning if -gnatd.E is enabled.
3525 elsif Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
3526 Error_Msg_Warn
:= Error_To_Warning
;
3529 ("<<overriding indicator not allowed "
3530 & "for protected subprogram body", Body_Spec
);
3532 -- If this is not a primitive operation, then the overriding
3533 -- indicator is altogether illegal.
3535 elsif not Is_Primitive
(Spec_Id
) then
3537 ("overriding indicator only allowed "
3538 & "if subprogram is primitive", Body_Spec
);
3541 -- If checking the style rule and the operation overrides, then
3542 -- issue a warning about a missing overriding_indicator. Protected
3543 -- subprogram bodies are excluded from this style checking, since
3544 -- they aren't primitives (even though their declarations can
3545 -- override) and aren't allowed to have an overriding_indicator.
3548 and then Present
(Overridden_Operation
(Spec_Id
))
3549 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
3551 pragma Assert
(Unit_Declaration_Node
(Body_Id
) = N
);
3552 Style
.Missing_Overriding
(N
, Body_Id
);
3555 and then Can_Override_Operator
(Spec_Id
)
3556 and then not In_Predefined_Unit
(Spec_Id
)
3558 pragma Assert
(Unit_Declaration_Node
(Body_Id
) = N
);
3559 Style
.Missing_Overriding
(N
, Body_Id
);
3561 end Verify_Overriding_Indicator
;
3565 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
3566 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
3567 Saved_EA
: constant Boolean := Expander_Active
;
3568 Saved_ISMP
: constant Boolean :=
3569 Ignore_SPARK_Mode_Pragmas_In_Instance
;
3570 -- Save the Ghost and SPARK mode-related data to restore on exit
3572 -- Start of processing for Analyze_Subprogram_Body_Helper
3575 -- A [generic] subprogram body freezes the contract of the nearest
3576 -- enclosing package body and all other contracts encountered in the
3577 -- same declarative part up to and excluding the subprogram body:
3579 -- package body Nearest_Enclosing_Package
3580 -- with Refined_State => (State => Constit)
3584 -- procedure Freezes_Enclosing_Package_Body
3585 -- with Refined_Depends => (Input => Constit) ...
3587 -- This ensures that any annotations referenced by the contract of the
3588 -- [generic] subprogram body are available. This form of freezing is
3589 -- decoupled from the usual Freeze_xxx mechanism because it must also
3590 -- work in the context of generics where normal freezing is disabled.
3592 -- Only bodies coming from source should cause this type of freezing.
3593 -- Expression functions that act as bodies and complete an initial
3594 -- declaration must be included in this category, hence the use of
3597 if Comes_From_Source
(Original_Node
(N
)) then
3598 Freeze_Previous_Contracts
(N
);
3601 -- Generic subprograms are handled separately. They always have a
3602 -- generic specification. Determine whether current scope has a
3603 -- previous declaration.
3605 -- If the subprogram body is defined within an instance of the same
3606 -- name, the instance appears as a package renaming, and will be hidden
3607 -- within the subprogram.
3609 if Present
(Prev_Id
)
3610 and then not Is_Overloadable
(Prev_Id
)
3611 and then (Nkind
(Parent
(Prev_Id
)) /= N_Package_Renaming_Declaration
3612 or else Comes_From_Source
(Prev_Id
))
3614 if Is_Generic_Subprogram
(Prev_Id
) then
3617 -- A subprogram body is Ghost when it is stand-alone and subject
3618 -- to pragma Ghost or when the corresponding spec is Ghost. Set
3619 -- the mode now to ensure that any nodes generated during analysis
3620 -- and expansion are properly marked as Ghost.
3622 Mark_And_Set_Ghost_Body
(N
, Spec_Id
);
3624 -- If the body completes the initial declaration of a compilation
3625 -- unit which is subject to pragma Elaboration_Checks, set the
3626 -- model specified by the pragma because it applies to all parts
3629 Install_Elaboration_Model
(Spec_Id
);
3631 Set_Is_Compilation_Unit
(Body_Id
, Is_Compilation_Unit
(Spec_Id
));
3632 Set_Is_Child_Unit
(Body_Id
, Is_Child_Unit
(Spec_Id
));
3634 Analyze_Generic_Subprogram_Body
(N
, Spec_Id
);
3636 if Nkind
(N
) = N_Subprogram_Body
then
3637 Check_Missing_Return
;
3642 -- Otherwise a previous entity conflicts with the subprogram name.
3643 -- Attempting to enter name will post error.
3646 Enter_Name
(Body_Id
);
3650 -- Non-generic case, find the subprogram declaration, if one was seen,
3651 -- or enter new overloaded entity in the current scope. If the
3652 -- Current_Entity is the Body_Id itself, the unit is being analyzed as
3653 -- part of the context of one of its subunits. No need to redo the
3656 elsif Prev_Id
= Body_Id
and then Has_Completion
(Body_Id
) then
3660 Body_Id
:= Analyze_Subprogram_Specification
(Body_Spec
);
3662 if Nkind
(N
) = N_Subprogram_Body_Stub
3663 or else No
(Corresponding_Spec
(N
))
3665 if Is_Private_Concurrent_Primitive
(Body_Id
) then
3666 Spec_Id
:= Disambiguate_Spec
;
3668 -- A subprogram body is Ghost when it is stand-alone and
3669 -- subject to pragma Ghost or when the corresponding spec is
3670 -- Ghost. Set the mode now to ensure that any nodes generated
3671 -- during analysis and expansion are properly marked as Ghost.
3673 Mark_And_Set_Ghost_Body
(N
, Spec_Id
);
3675 -- If the body completes a compilation unit which is subject
3676 -- to pragma Elaboration_Checks, set the model specified by
3677 -- the pragma because it applies to all parts of the unit.
3679 Install_Elaboration_Model
(Spec_Id
);
3682 Spec_Id
:= Find_Corresponding_Spec
(N
);
3684 -- A subprogram body is Ghost when it is stand-alone and
3685 -- subject to pragma Ghost or when the corresponding spec is
3686 -- Ghost. Set the mode now to ensure that any nodes generated
3687 -- during analysis and expansion are properly marked as Ghost.
3689 Mark_And_Set_Ghost_Body
(N
, Spec_Id
);
3691 -- If the body completes a compilation unit which is subject
3692 -- to pragma Elaboration_Checks, set the model specified by
3693 -- the pragma because it applies to all parts of the unit.
3695 Install_Elaboration_Model
(Spec_Id
);
3697 -- In GNATprove mode, if the body has no previous spec, create
3698 -- one so that the inlining machinery can operate properly.
3699 -- Transfer aspects, if any, to the new spec, so that they
3700 -- are legal and can be processed ahead of the body.
3701 -- We make two copies of the given spec, one for the new
3702 -- declaration, and one for the body.
3703 -- ??? This should be conditioned on front-end inlining rather
3704 -- than GNATprove_Mode.
3706 if No
(Spec_Id
) and then GNATprove_Mode
3708 -- Inlining does not apply during preanalysis of code
3710 and then Full_Analysis
3712 -- Inlining only applies to full bodies, not stubs
3714 and then Nkind
(N
) /= N_Subprogram_Body_Stub
3716 -- Inlining only applies to bodies in the source code, not to
3717 -- those generated by the compiler. In particular, expression
3718 -- functions, whose body is generated by the compiler, are
3719 -- treated specially by GNATprove.
3721 and then Comes_From_Source
(Body_Id
)
3723 -- This cannot be done for a compilation unit, which is not
3724 -- in a context where we can insert a new spec.
3726 and then Is_List_Member
(N
)
3728 -- Inlining only applies to subprograms without contracts,
3729 -- as a contract is a sign that GNATprove should perform a
3730 -- modular analysis of the subprogram instead of a contextual
3731 -- analysis at each call site. The same test is performed in
3732 -- Inline.Can_Be_Inlined_In_GNATprove_Mode. It is repeated
3733 -- here in another form (because the contract has not been
3734 -- attached to the body) to avoid front-end errors in case
3735 -- pragmas are used instead of aspects, because the
3736 -- corresponding pragmas in the body would not be transferred
3737 -- to the spec, leading to legality errors.
3739 and then not Body_Has_Contract
3740 and then not Inside_A_Generic
3742 Build_Subprogram_Declaration
;
3744 -- If this is a function that returns a constrained array, and
3745 -- Transform_Function_Array is set, create subprogram
3746 -- declaration to simplify e.g. subsequent C generation.
3749 and then Transform_Function_Array
3750 and then Nkind
(Body_Spec
) = N_Function_Specification
3751 and then Is_Array_Type
(Etype
(Body_Id
))
3752 and then Is_Constrained
(Etype
(Body_Id
))
3754 Build_Subprogram_Declaration
;
3758 -- If this is a duplicate body, no point in analyzing it
3760 if Error_Posted
(N
) then
3764 -- A subprogram body should cause freezing of its own declaration,
3765 -- so, if the body and spec are compilation units, we must do it
3766 -- manually here. Moreover, if the return type is anonymous access
3767 -- to protected subprogram, it must be frozen before the body
3768 -- because its expansion has generated an equivalent type that is
3769 -- used when elaborating the body.
3771 if Present
(Spec_Id
)
3772 and then Nkind
(Parent
(N
)) = N_Compilation_Unit
3774 Freeze_Before
(N
, Spec_Id
);
3776 elsif Is_Access_Subprogram_Type
(Etype
(Body_Id
)) then
3777 Freeze_Before
(N
, Etype
(Body_Id
));
3781 Spec_Id
:= Corresponding_Spec
(N
);
3783 -- A subprogram body is Ghost when it is stand-alone and subject
3784 -- to pragma Ghost or when the corresponding spec is Ghost. Set
3785 -- the mode now to ensure that any nodes generated during analysis
3786 -- and expansion are properly marked as Ghost.
3788 Mark_And_Set_Ghost_Body
(N
, Spec_Id
);
3790 -- If the body completes the initial declaration of a compilation
3791 -- unit which is subject to pragma Elaboration_Checks, set the
3792 -- model specified by the pragma because it applies to all parts
3795 Install_Elaboration_Model
(Spec_Id
);
3799 -- Deactivate expansion inside the body of ignored Ghost entities,
3800 -- as this code will ultimately be ignored. This avoids requiring the
3801 -- presence of run-time units which are not needed. Only do this for
3802 -- user entities, as internally generated entitities might still need
3803 -- to be expanded (e.g. those generated for types).
3805 if Present
(Ignored_Ghost_Region
)
3806 and then Comes_From_Source
(Body_Id
)
3808 Expander_Active
:= False;
3811 -- Previously we scanned the body to look for nested subprograms, and
3812 -- rejected an inline directive if nested subprograms were present,
3813 -- because the back-end would generate conflicting symbols for the
3814 -- nested bodies. This is now unnecessary.
3816 -- Look ahead to recognize a pragma Inline that appears after the body
3818 Check_Inline_Pragma
(Spec_Id
);
3820 -- Deal with special case of a fully private operation in the body of
3821 -- the protected type. We must create a declaration for the subprogram,
3822 -- in order to attach the subprogram that will be used in internal
3823 -- calls. We exclude compiler generated bodies from the expander since
3824 -- the issue does not arise for those cases.
3827 and then Comes_From_Source
(N
)
3828 and then Is_Protected_Type
(Current_Scope
)
3830 Spec_Id
:= Build_Internal_Protected_Declaration
(N
);
3833 -- If Transform_Function_Array is set and this is a function returning a
3834 -- constrained array type for which we must create a procedure with an
3835 -- extra out parameter, build and analyze the body now. The procedure
3836 -- declaration has already been created. We reuse the source body of the
3837 -- function, because in an instance it may contain global references
3838 -- that cannot be reanalyzed. The source function itself is not used any
3839 -- further, so we mark it as having a completion. If the subprogram is a
3840 -- stub the transformation is done later, when the proper body is
3844 and then Transform_Function_Array
3845 and then Nkind
(N
) /= N_Subprogram_Body_Stub
3848 S
: constant Entity_Id
:=
3849 (if Present
(Spec_Id
)
3851 else Defining_Unit_Name
(Specification
(N
)));
3852 Proc_Body
: Node_Id
;
3855 if Ekind
(S
) = E_Function
and then Rewritten_For_C
(S
) then
3856 Set_Has_Completion
(S
);
3857 Proc_Body
:= Build_Procedure_Body_Form
(S
, N
);
3859 if Present
(Spec_Id
) then
3860 Rewrite
(N
, Proc_Body
);
3863 -- The entity for the created procedure must remain
3864 -- invisible, so it does not participate in resolution of
3865 -- subsequent references to the function.
3867 Set_Is_Immediately_Visible
(Corresponding_Spec
(N
), False);
3869 -- If we do not have a separate spec for N, build one and
3870 -- insert the new body right after.
3874 Make_Subprogram_Declaration
(Loc
,
3875 Specification
=> Relocate_Node
(Specification
(N
))));
3877 Insert_After_And_Analyze
(N
, Proc_Body
);
3878 Set_Is_Immediately_Visible
3879 (Corresponding_Spec
(Proc_Body
), False);
3887 -- If a separate spec is present, then deal with freezing issues
3889 if Present
(Spec_Id
) then
3890 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
3891 Verify_Overriding_Indicator
;
3893 -- For functions with separate spec, if their return type was visible
3894 -- through a limited-with context clause, their extra formals were
3895 -- not added when the spec was frozen. Now the full view must be
3896 -- available, and the extra formals can be created and Returns_By_Ref
3897 -- computed (required to generate its return statements).
3899 if Ekind
(Spec_Id
) = E_Function
3900 and then From_Limited_With
(Etype
(Spec_Id
))
3901 and then Is_Build_In_Place_Function
(Spec_Id
)
3902 and then not Has_BIP_Formals
(Spec_Id
)
3904 Create_Extra_Formals
(Spec_Id
);
3905 Compute_Returns_By_Ref
(Spec_Id
);
3908 -- In general, the spec will be frozen when we start analyzing the
3909 -- body. However, for internally generated operations, such as
3910 -- wrapper functions for inherited operations with controlling
3911 -- results, the spec may not have been frozen by the time we expand
3912 -- the freeze actions that include the bodies. In particular, extra
3913 -- formals for accessibility or for return-in-place may need to be
3914 -- generated. Freeze nodes, if any, are inserted before the current
3915 -- body. These freeze actions are also needed in Compile_Only mode to
3916 -- enable the proper back-end type annotations.
3917 -- They are necessary in any case to ensure proper elaboration order
3920 if Nkind
(N
) = N_Subprogram_Body
3921 and then Was_Expression_Function
(N
)
3922 and then not Has_Completion
(Spec_Id
)
3923 and then Serious_Errors_Detected
= 0
3924 and then (Expander_Active
3925 or else Operating_Mode
= Check_Semantics
3926 or else Is_Ignored_Ghost_Entity
(Spec_Id
))
3928 -- The body generated for an expression function that is not a
3929 -- completion is a freeze point neither for the profile nor for
3930 -- anything else. That's why, in order to prevent any freezing
3931 -- during analysis, we need to mask types declared outside the
3932 -- expression (and in an outer scope) that are not yet frozen.
3933 -- This also needs to be done in the case of an ignored Ghost
3934 -- expression function, where the expander isn't active.
3936 -- A further complication arises if the expression function is
3937 -- a primitive operation of a tagged type: in that case the
3938 -- function entity must be frozen before the dispatch table for
3939 -- the type is constructed, so it will be frozen like other local
3940 -- entities, at the end of the current scope.
3942 if not Is_Dispatching_Operation
(Spec_Id
) then
3943 Set_Is_Frozen
(Spec_Id
);
3946 Mask_Types
:= Mask_Unfrozen_Types
(Spec_Id
);
3948 elsif not Is_Frozen
(Spec_Id
)
3949 and then Serious_Errors_Detected
= 0
3951 Set_Has_Delayed_Freeze
(Spec_Id
);
3952 Create_Extra_Formals
(Spec_Id
);
3953 Freeze_Before
(N
, Spec_Id
);
3957 -- Place subprogram on scope stack, and make formals visible. If there
3958 -- is a spec, the visible entity remains that of the spec.
3960 if Present
(Spec_Id
) then
3961 Generate_Reference
(Spec_Id
, Body_Id
, 'b', Set_Ref
=> False);
3963 if Is_Child_Unit
(Spec_Id
) then
3964 Generate_Reference
(Spec_Id
, Scope
(Spec_Id
), 'k', False);
3968 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
3971 Set_Is_Compilation_Unit
(Body_Id
, Is_Compilation_Unit
(Spec_Id
));
3972 Set_Is_Child_Unit
(Body_Id
, Is_Child_Unit
(Spec_Id
));
3974 if Is_Abstract_Subprogram
(Spec_Id
) then
3975 Error_Msg_N
("an abstract subprogram cannot have a body", N
);
3979 Set_Convention
(Body_Id
, Convention
(Spec_Id
));
3980 Set_Has_Completion
(Spec_Id
);
3982 if Is_Protected_Type
(Scope
(Spec_Id
)) then
3983 Prot_Typ
:= Scope
(Spec_Id
);
3986 -- If this is a body generated for a renaming, do not check for
3987 -- full conformance. The check is redundant, because the spec of
3988 -- the body is a copy of the spec in the renaming declaration,
3989 -- and the test can lead to spurious errors on nested defaults.
3991 if Present
(Spec_Decl
)
3992 and then not Comes_From_Source
(N
)
3994 (Nkind
(Original_Node
(Spec_Decl
)) =
3995 N_Subprogram_Renaming_Declaration
3996 or else (Present
(Corresponding_Body
(Spec_Decl
))
3998 Nkind
(Unit_Declaration_Node
3999 (Corresponding_Body
(Spec_Decl
))) =
4000 N_Subprogram_Renaming_Declaration
))
4004 -- Conversely, the spec may have been generated for specless body
4005 -- with an inline pragma. The entity comes from source, which is
4006 -- both semantically correct and necessary for proper inlining.
4007 -- The subprogram declaration itself is not in the source.
4009 elsif Comes_From_Source
(N
)
4010 and then Present
(Spec_Decl
)
4011 and then not Comes_From_Source
(Spec_Decl
)
4012 and then Has_Pragma_Inline
(Spec_Id
)
4016 -- Finally, a body generated for an expression function copies
4017 -- the profile of the function and no check is needed either.
4018 -- If the body is the completion of a previous function
4019 -- declared elsewhere, the conformance check is required.
4021 elsif Nkind
(N
) = N_Subprogram_Body
4022 and then Was_Expression_Function
(N
)
4023 and then Sloc
(Spec_Id
) = Sloc
(Body_Id
)
4030 Fully_Conformant
, True, Conformant
, Body_Id
);
4033 -- If the body is not fully conformant, we have to decide if we
4034 -- should analyze it or not. If it has a really messed up profile
4035 -- then we probably should not analyze it, since we will get too
4036 -- many bogus messages.
4038 -- Our decision is to go ahead in the non-fully conformant case
4039 -- only if it is at least mode conformant with the spec. Note
4040 -- that the call to Check_Fully_Conformant has issued the proper
4041 -- error messages to complain about the lack of conformance.
4044 and then not Mode_Conformant
(Body_Id
, Spec_Id
)
4050 -- In the case we are dealing with an expression function we check
4051 -- the formals attached to the spec instead of the body - so we don't
4052 -- reference body formals.
4054 if Spec_Id
/= Body_Id
4055 and then not Is_Expression_Function
(Spec_Id
)
4057 Reference_Body_Formals
(Spec_Id
, Body_Id
);
4060 Reinit_Field_To_Zero
(Body_Id
, F_Has_Out_Or_In_Out_Parameter
,
4061 Old_Ekind
=> (E_Function | E_Procedure
=> True, others => False));
4062 Reinit_Field_To_Zero
(Body_Id
, F_Needs_No_Actuals
);
4063 Reinit_Field_To_Zero
(Body_Id
, F_Is_Predicate_Function
);
4064 Reinit_Field_To_Zero
(Body_Id
, F_Protected_Subprogram
);
4065 Reinit_Field_To_Zero
(Body_Id
, F_Is_Inlined_Always
);
4066 Reinit_Field_To_Zero
(Body_Id
, F_Is_Generic_Actual_Subprogram
);
4067 Reinit_Field_To_Zero
(Body_Id
, F_Is_Primitive_Wrapper
);
4068 Reinit_Field_To_Zero
(Body_Id
, F_Is_Private_Primitive
);
4069 Reinit_Field_To_Zero
(Body_Id
, F_Original_Protected_Subprogram
);
4070 Reinit_Field_To_Zero
(Body_Id
, F_Wrapped_Entity
);
4072 if Ekind
(Body_Id
) = E_Procedure
then
4073 Reinit_Field_To_Zero
(Body_Id
, F_Receiving_Entry
);
4076 Mutate_Ekind
(Body_Id
, E_Subprogram_Body
);
4078 if Nkind
(N
) = N_Subprogram_Body_Stub
then
4079 Set_Corresponding_Spec_Of_Stub
(N
, Spec_Id
);
4084 Set_Corresponding_Spec
(N
, Spec_Id
);
4086 -- Ada 2005 (AI-345): If the operation is a primitive operation
4087 -- of a concurrent type, the type of the first parameter has been
4088 -- replaced with the corresponding record, which is the proper
4089 -- run-time structure to use. However, within the body there may
4090 -- be uses of the formals that depend on primitive operations
4091 -- of the type (in particular calls in prefixed form) for which
4092 -- we need the original concurrent type. The operation may have
4093 -- several controlling formals, so the replacement must be done
4096 if Comes_From_Source
(Spec_Id
)
4097 and then Present
(First_Entity
(Spec_Id
))
4098 and then Ekind
(Etype
(First_Entity
(Spec_Id
))) = E_Record_Type
4099 and then Is_Tagged_Type
(Etype
(First_Entity
(Spec_Id
)))
4100 and then Present
(Interfaces
(Etype
(First_Entity
(Spec_Id
))))
4101 and then Present
(Corresponding_Concurrent_Type
4102 (Etype
(First_Entity
(Spec_Id
))))
4105 Typ
: constant Entity_Id
:= Etype
(First_Entity
(Spec_Id
));
4109 Form
:= First_Formal
(Spec_Id
);
4110 while Present
(Form
) loop
4111 if Etype
(Form
) = Typ
then
4112 Set_Etype
(Form
, Corresponding_Concurrent_Type
(Typ
));
4120 -- Make the formals visible, and place subprogram on scope stack.
4121 -- This is also the point at which we set Last_Real_Spec_Entity
4122 -- to mark the entities which will not be moved to the body.
4124 Install_Formals
(Spec_Id
);
4125 Last_Real_Spec_Entity
:= Last_Entity
(Spec_Id
);
4127 -- Within an instance, add local renaming declarations so that
4128 -- gdb can retrieve the values of actuals more easily. This is
4129 -- only relevant if generating code.
4131 if Is_Generic_Instance
(Spec_Id
)
4132 and then Is_Wrapper_Package
(Current_Scope
)
4133 and then Expander_Active
4135 Build_Subprogram_Instance_Renamings
(N
, Current_Scope
);
4138 Push_Scope
(Spec_Id
);
4140 -- Make sure that the subprogram is immediately visible. For
4141 -- child units that have no separate spec this is indispensable.
4142 -- Otherwise it is safe albeit redundant.
4144 Set_Is_Immediately_Visible
(Spec_Id
);
4147 Set_Corresponding_Body
(Unit_Declaration_Node
(Spec_Id
), Body_Id
);
4148 Set_Is_Obsolescent
(Body_Id
, Is_Obsolescent
(Spec_Id
));
4149 Set_Scope
(Body_Id
, Scope
(Spec_Id
));
4151 -- Case of subprogram body with no previous spec
4154 -- Check for style warning required
4158 -- Only apply check for source level subprograms for which checks
4159 -- have not been suppressed.
4161 and then Comes_From_Source
(Body_Id
)
4162 and then not Suppress_Style_Checks
(Body_Id
)
4164 -- No warnings within an instance
4166 and then not In_Instance
4168 -- No warnings for expression functions
4170 and then (Nkind
(N
) /= N_Subprogram_Body
4171 or else not Was_Expression_Function
(N
))
4173 Style
.Body_With_No_Spec
(N
);
4176 -- First set Acts_As_Spec if appropriate
4178 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
4179 Set_Acts_As_Spec
(N
);
4182 New_Overloaded_Entity
(Body_Id
);
4184 -- A subprogram body should cause freezing of its own declaration,
4185 -- but if there was no previous explicit declaration, then the
4186 -- subprogram will get frozen too late (there may be code within
4187 -- the body that depends on the subprogram having been frozen,
4188 -- such as uses of extra formals), so we force it to be frozen here.
4189 -- An exception in Ada 2012 is that the body created for expression
4190 -- functions does not freeze.
4192 if Nkind
(N
) /= N_Subprogram_Body
4193 or else not Was_Expression_Function
(N
)
4195 -- First clear the Is_Public flag on thunks since they are only
4196 -- referenced locally by dispatch tables and thus never inlined.
4198 if Is_Thunk
(Body_Id
) then
4199 Set_Is_Public
(Body_Id
, False);
4202 Freeze_Before
(N
, Body_Id
);
4205 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
4206 Generate_Definition
(Body_Id
);
4208 (Body_Id
, Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
4210 -- If the body is an entry wrapper created for an entry with
4211 -- preconditions, it must be compiled in the context of the
4212 -- enclosing synchronized object, because it may mention other
4213 -- operations of the type.
4215 if Is_Entry_Wrapper
(Body_Id
) then
4217 Prot
: constant Entity_Id
:= Etype
(First_Entity
(Body_Id
));
4220 Install_Declarations
(Prot
);
4224 Install_Formals
(Body_Id
);
4226 Push_Scope
(Body_Id
);
4229 -- For stubs and bodies with no previous spec, generate references to
4232 Generate_Reference_To_Formals
(Body_Id
);
4235 -- Entry barrier functions are generated outside the protected type and
4236 -- should not carry the SPARK_Mode of the enclosing context.
4238 if Nkind
(N
) = N_Subprogram_Body
4239 and then Is_Entry_Barrier_Function
(N
)
4243 -- The body is generated as part of expression function expansion. When
4244 -- the expression function appears in the visible declarations of a
4245 -- package, the body is added to the private declarations. Since both
4246 -- declarative lists may be subject to a different SPARK_Mode, inherit
4247 -- the mode of the spec.
4249 -- package P with SPARK_Mode is
4250 -- function Expr_Func ... is (...); -- original
4251 -- [function Expr_Func ...;] -- generated spec
4254 -- pragma SPARK_Mode (Off);
4255 -- [function Expr_Func ... is return ...;] -- generated body
4256 -- end P; -- mode is ON
4258 elsif not Comes_From_Source
(N
)
4259 and then Present
(Spec_Id
)
4260 and then Is_Expression_Function
(Spec_Id
)
4262 Set_SPARK_Pragma
(Body_Id
, SPARK_Pragma
(Spec_Id
));
4263 Set_SPARK_Pragma_Inherited
4264 (Body_Id
, SPARK_Pragma_Inherited
(Spec_Id
));
4266 -- Set the SPARK_Mode from the current context (may be overwritten later
4267 -- with explicit pragma). Exclude the case where the SPARK_Mode appears
4268 -- initially on a stand-alone subprogram body, but is then relocated to
4269 -- a generated corresponding spec. In this scenario the mode is shared
4270 -- between the spec and body.
4272 elsif No
(SPARK_Pragma
(Body_Id
)) then
4273 Set_SPARK_Pragma
(Body_Id
, SPARK_Mode_Pragma
);
4274 Set_SPARK_Pragma_Inherited
(Body_Id
);
4277 -- A subprogram body may be instantiated or inlined at a later pass.
4278 -- Restore the state of Ignore_SPARK_Mode_Pragmas_In_Instance when it
4279 -- applied to the initial declaration of the body.
4281 if Present
(Spec_Id
) then
4282 if Ignore_SPARK_Mode_Pragmas
(Spec_Id
) then
4283 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
4287 -- Save the state of flag Ignore_SPARK_Mode_Pragmas_In_Instance in
4288 -- case the body is instantiated or inlined later and out of context.
4289 -- The body uses this attribute to restore the value of the global
4292 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
4293 Set_Ignore_SPARK_Mode_Pragmas
(Body_Id
);
4295 elsif Ignore_SPARK_Mode_Pragmas
(Body_Id
) then
4296 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
4300 -- Preserve relevant elaboration-related attributes of the context which
4301 -- are no longer available or very expensive to recompute once analysis,
4302 -- resolution, and expansion are over.
4304 if No
(Spec_Id
) then
4305 Mark_Elaboration_Attributes
4311 -- If this is the proper body of a stub, we must verify that the stub
4312 -- conforms to the body, and to the previous spec if one was present.
4313 -- We know already that the body conforms to that spec. This test is
4314 -- only required for subprograms that come from source.
4316 if Nkind
(Parent
(N
)) = N_Subunit
4317 and then Comes_From_Source
(N
)
4318 and then not Error_Posted
(Body_Id
)
4319 and then Nkind
(Corresponding_Stub
(Parent
(N
))) =
4320 N_Subprogram_Body_Stub
4323 Old_Id
: constant Entity_Id
:=
4325 (Specification
(Corresponding_Stub
(Parent
(N
))));
4327 Conformant
: Boolean := False;
4330 if No
(Spec_Id
) then
4331 Check_Fully_Conformant
(Body_Id
, Old_Id
);
4335 (Body_Id
, Old_Id
, Fully_Conformant
, False, Conformant
);
4337 if not Conformant
then
4339 -- The stub was taken to be a new declaration. Indicate that
4342 Set_Has_Completion
(Old_Id
, False);
4348 Set_Has_Completion
(Body_Id
);
4349 Check_Eliminated
(Body_Id
);
4351 -- Analyze any aspect specifications that appear on the subprogram body
4352 -- stub. Stop the analysis now as the stub does not have a declarative
4353 -- or a statement part, and it cannot be inlined.
4355 if Nkind
(N
) = N_Subprogram_Body_Stub
then
4356 Analyze_Aspects_On_Subprogram_Body_Or_Stub
(N
);
4364 and then Serious_Errors_Detected
= 0
4365 and then Present
(Spec_Id
)
4366 and then Has_Pragma_Inline
(Spec_Id
)
4368 -- Legacy implementation (relying on front-end inlining)
4370 if not Back_End_Inlining
then
4371 if Has_Pragma_Inline_Always
(Spec_Id
)
4372 or else (Front_End_Inlining
4373 and then not Opt
.Disable_FE_Inline
)
4375 Build_Body_To_Inline
(N
, Spec_Id
);
4378 -- New implementation (relying on back-end inlining)
4381 if Has_Pragma_Inline_Always
(Spec_Id
)
4382 or else Optimization_Level
> 0
4384 -- Handle function returning an unconstrained type
4386 if Comes_From_Source
(Body_Id
)
4387 and then Ekind
(Spec_Id
) = E_Function
4388 and then Returns_Unconstrained_Type
(Spec_Id
)
4390 -- If function builds in place, i.e. returns a limited type,
4391 -- inlining cannot be done.
4393 and then not Is_Limited_Type
(Etype
(Spec_Id
))
4395 Check_And_Split_Unconstrained_Function
(N
, Spec_Id
, Body_Id
);
4399 Subp_Body
: constant Node_Id
:=
4400 Unit_Declaration_Node
(Body_Id
);
4401 Subp_Decl
: constant List_Id
:= Declarations
(Subp_Body
);
4404 -- Do not pass inlining to the backend if the subprogram
4405 -- has declarations or statements which cannot be inlined
4406 -- by the backend. This check is done here to emit an
4407 -- error instead of the generic warning message reported
4408 -- by the GCC backend (ie. "function might not be
4411 if Has_Excluded_Declaration
(Spec_Id
, Subp_Decl
) then
4414 elsif Has_Excluded_Statement
4417 (Handled_Statement_Sequence
(Subp_Body
)))
4421 -- If the backend inlining is available then at this
4422 -- stage we only have to mark the subprogram as inlined.
4423 -- The expander will take care of registering it in the
4424 -- table of subprograms inlined by the backend a part of
4425 -- processing calls to it (cf. Expand_Call)
4428 Set_Is_Inlined
(Spec_Id
);
4435 -- In GNATprove mode, inline only when there is a separate subprogram
4436 -- declaration for now, as inlining of subprogram bodies acting as
4437 -- declarations, or subprogram stubs, are not supported by front-end
4438 -- inlining. This inlining should occur after analysis of the body, so
4439 -- that it is known whether the value of SPARK_Mode, which can be
4440 -- defined by a pragma inside the body, is applicable to the body.
4441 -- Inlining can be disabled with switch -gnatdm
4443 elsif GNATprove_Mode
4444 and then Full_Analysis
4445 and then not Inside_A_Generic
4446 and then Present
(Spec_Id
)
4448 Nkind
(Unit_Declaration_Node
(Spec_Id
)) = N_Subprogram_Declaration
4449 and then Body_Has_SPARK_Mode_On
4450 and then Can_Be_Inlined_In_GNATprove_Mode
(Spec_Id
, Body_Id
)
4451 and then not Body_Has_Contract
4452 and then not Debug_Flag_M
4454 Build_Body_To_Inline
(N
, Spec_Id
);
4457 -- When generating code, inherited pre/postconditions are handled when
4458 -- expanding the corresponding contract.
4460 -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
4461 -- of the specification we have to install the private withed units.
4462 -- This holds for child units as well.
4464 if Is_Compilation_Unit
(Body_Id
)
4465 or else Nkind
(Parent
(N
)) = N_Compilation_Unit
4467 Install_Private_With_Clauses
(Body_Id
);
4470 Check_Anonymous_Return
;
4472 -- Set the Protected_Formal field of each extra formal of the protected
4473 -- subprogram to reference the corresponding extra formal of the
4474 -- subprogram that implements it. For regular formals this occurs when
4475 -- the protected subprogram's declaration is expanded, but the extra
4476 -- formals don't get created until the subprogram is frozen. We need to
4477 -- do this before analyzing the protected subprogram's body so that any
4478 -- references to the original subprogram's extra formals will be changed
4479 -- refer to the implementing subprogram's formals (see Expand_Formal).
4481 if Present
(Spec_Id
)
4482 and then Is_Protected_Type
(Scope
(Spec_Id
))
4483 and then Present
(Protected_Body_Subprogram
(Spec_Id
))
4486 Impl_Subp
: constant Entity_Id
:=
4487 Protected_Body_Subprogram
(Spec_Id
);
4488 Prot_Ext_Formal
: Entity_Id
:= Extra_Formals
(Spec_Id
);
4489 Impl_Ext_Formal
: Entity_Id
:= Extra_Formals
(Impl_Subp
);
4492 while Present
(Prot_Ext_Formal
) loop
4493 pragma Assert
(Present
(Impl_Ext_Formal
));
4494 pragma Assert
(not Is_Build_In_Place_Entity
(Prot_Ext_Formal
)
4495 or else BIP_Suffix_Kind
(Impl_Ext_Formal
)
4496 = BIP_Suffix_Kind
(Prot_Ext_Formal
));
4498 Set_Protected_Formal
(Prot_Ext_Formal
, Impl_Ext_Formal
);
4499 Next_Formal_With_Extras
(Prot_Ext_Formal
);
4500 Next_Formal_With_Extras
(Impl_Ext_Formal
);
4505 -- Generate minimum accessibility local objects to correspond with
4506 -- any extra formal added for anonymous access types. This new local
4507 -- object can then be used instead of the formal in case it is used
4508 -- in an actual to a call to a nested subprogram.
4510 -- This method is used to supplement our "small integer model" for
4511 -- accessibility-check generation (for more information see
4512 -- Accessibility_Level).
4514 -- Because we allow accessibility values greater than our expected value
4515 -- passing along the same extra accessibility formal as an actual
4516 -- to a nested subprogram becomes a problem because high values mean
4517 -- different things to the callee even though they are the same to the
4518 -- caller. So, as described in the first section, we create a local
4519 -- object representing the minimum of the accessibility level value that
4520 -- is passed in and the accessibility level of the callee's parameter
4521 -- and locals and use it in the case of a call to a nested subprogram.
4522 -- This generated object is referred to as a "minimum accessibility
4525 if Present
(Spec_Id
) or else Present
(Body_Id
) then
4526 Body_Nod
:= Unit_Declaration_Node
(Body_Id
);
4531 -- Grab the appropriate formal depending on whether there exists
4532 -- an actual spec for the subprogram or whether we are dealing
4533 -- with a protected subprogram.
4535 if Present
(Spec_Id
) then
4536 if Present
(Protected_Body_Subprogram
(Spec_Id
)) then
4537 Form
:= First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
4539 Form
:= First_Formal
(Spec_Id
);
4542 Form
:= First_Formal
(Body_Id
);
4545 -- Loop through formals if the subprogram is capable of accepting
4546 -- a generated local object. If it is not then it is also not
4547 -- capable of having local subprograms meaning it would not need
4548 -- a minimum accessibility level object anyway.
4550 if Present
(Body_Nod
)
4551 and then Has_Declarations
(Body_Nod
)
4552 and then Nkind
(Body_Nod
) /= N_Package_Specification
4554 while Present
(Form
) loop
4556 if Present
(Extra_Accessibility
(Form
))
4557 and then No
(Minimum_Accessibility
(Form
))
4559 -- Generate the minimum accessibility level object
4561 -- A60b : constant natural := natural'min(1, paramL);
4563 Generate_Minimum_Accessibility
4564 (Extra_Accessibility
(Form
), Form
);
4570 -- Generate the minimum accessibility level object for the
4571 -- function's Extra_Accessibility_Of_Result.
4573 -- A31b : constant natural := natural'min (2, funcL);
4575 if Ekind
(Body_Id
) = E_Function
4576 and then Present
(Extra_Accessibility_Of_Result
(Body_Id
))
4578 Generate_Minimum_Accessibility
4579 (Extra_Accessibility_Of_Result
(Body_Id
));
4581 -- Replace the Extra_Accessibility_Of_Result with the new
4582 -- minimum accessibility object.
4584 Set_Extra_Accessibility_Of_Result
4585 (Body_Id
, Minimum_Accessibility
4586 (Extra_Accessibility_Of_Result
(Body_Id
)));
4592 -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context
4593 -- may now appear in parameter and result profiles. Since the analysis
4594 -- of a subprogram body may use the parameter and result profile of the
4595 -- spec, swap any limited views with their non-limited counterpart.
4597 if Ada_Version
>= Ada_2012
and then Present
(Spec_Id
) then
4598 Exch_Views
:= Exchange_Limited_Views
(Spec_Id
);
4601 -- Analyze any aspect specifications that appear on the subprogram body
4603 Analyze_Aspects_On_Subprogram_Body_Or_Stub
(N
);
4605 -- Process the contract of the subprogram body after analyzing all the
4606 -- contract-related pragmas within the declarations.
4608 Analyze_Pragmas_In_Declarations
(Body_Id
);
4609 Analyze_Entry_Or_Subprogram_Body_Contract
(Body_Id
);
4611 -- Apply SPARK legality checks
4613 Analyze_SPARK_Subprogram_Specification
(Specification
(N
));
4615 -- A function with side effects shall not be an expression function
4616 -- (SPARK RM 6.1.11(6)).
4618 if Present
(Spec_Id
)
4619 and then (Is_Expression_Function
(Spec_Id
)
4620 or else Is_Expression_Function
(Body_Id
))
4621 and then Is_Function_With_Side_Effects
(Spec_Id
)
4623 if From_Aspect_Specification
4624 (Get_Pragma
(Spec_Id
, Pragma_Side_Effects
))
4626 Error_Msg_N
("aspect Side_Effects not allowed"
4627 & " on an expression function", N
);
4629 Error_Msg_N
("pragma Side_Effects not allowed"
4630 & " on an expression function", N
);
4634 Set_Actual_Subtypes
(N
, Current_Scope
);
4636 -- Add a declaration for the Protection object, renaming declarations
4637 -- for discriminals and privals and finally a declaration for the entry
4638 -- family index (if applicable). This form of early expansion is done
4639 -- when the Expander is active because Install_Private_Data_Declarations
4640 -- references entities which were created during regular expansion. The
4641 -- subprogram entity must come from source, and not be an internally
4642 -- generated subprogram.
4645 and then Present
(Prot_Typ
)
4646 and then Present
(Spec_Id
)
4647 and then Comes_From_Source
(Spec_Id
)
4648 and then not Is_Eliminated
(Spec_Id
)
4650 Install_Private_Data_Declarations
4651 (Sloc
(N
), Spec_Id
, Prot_Typ
, N
, Declarations
(N
));
4654 -- If the return type is an anonymous access type whose designated type
4655 -- is the limited view of a class-wide type and the non-limited view is
4656 -- available, update the return type accordingly.
4658 if Ada_Version
>= Ada_2005
4659 and then Present
(Spec_Id
)
4660 and then Ekind
(Etype
(Spec_Id
)) = E_Anonymous_Access_Type
4666 Etyp
:= Directly_Designated_Type
(Etype
(Spec_Id
));
4668 if Is_Class_Wide_Type
(Etyp
)
4669 and then From_Limited_With
(Etyp
)
4670 and then Has_Non_Limited_View
(Etyp
)
4673 Etyp
:= Non_Limited_View
(Etyp
);
4675 -- If the class-wide type has been created by the completion of
4676 -- an incomplete tagged type declaration, get the class-wide
4677 -- type of the incomplete tagged type to match Find_Type_Name.
4679 if Nkind
(Parent
(Etyp
)) = N_Full_Type_Declaration
4680 and then Present
(Incomplete_View
(Parent
(Etyp
)))
4682 Etyp
:= Class_Wide_Type
(Incomplete_View
(Parent
(Etyp
)));
4685 Set_Directly_Designated_Type
(Etype
(Spec_Id
), Etyp
);
4690 Analyze_Declarations
(Declarations
(N
));
4692 -- Verify that the SPARK_Mode of the body agrees with that of its spec
4694 if Present
(Spec_Id
) and then Present
(SPARK_Pragma
(Body_Id
)) then
4695 if Present
(SPARK_Pragma
(Spec_Id
)) then
4696 if Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Spec_Id
)) = Off
4698 Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Body_Id
)) = On
4700 Error_Msg_Sloc
:= Sloc
(SPARK_Pragma
(Body_Id
));
4701 Error_Msg_N
("incorrect application of SPARK_Mode#", N
);
4702 Error_Msg_Sloc
:= Sloc
(SPARK_Pragma
(Spec_Id
));
4704 ("\value Off was set for SPARK_Mode on & #", N
, Spec_Id
);
4707 elsif Nkind
(Parent
(Parent
(Spec_Id
))) = N_Subprogram_Body_Stub
then
4710 -- SPARK_Mode Off could complete no SPARK_Mode in a generic, either
4711 -- as specified in source code, or because SPARK_Mode On is ignored
4712 -- in an instance where the context is SPARK_Mode Off/Auto.
4714 elsif Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Body_Id
)) = Off
4715 and then (Is_Generic_Unit
(Spec_Id
) or else In_Instance
)
4720 Error_Msg_Sloc
:= Sloc
(SPARK_Pragma
(Body_Id
));
4721 Error_Msg_N
("incorrect application of SPARK_Mode #", N
);
4722 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
4724 ("\no value was set for SPARK_Mode on & #", N
, Spec_Id
);
4728 -- Check completion, and analyze the statements
4731 Inspect_Deferred_Constant_Completion
(Declarations
(N
));
4732 Analyze
(Handled_Statement_Sequence
(N
));
4734 -- Add the generated minimum accessibility objects to the subprogram
4735 -- body's list of declarations after analysis of the statements and
4738 while Is_Non_Empty_List
(Minimum_Acc_Objs
) loop
4739 if Present
(Declarations
(Body_Nod
)) then
4740 Prepend
(Remove_Head
(Minimum_Acc_Objs
), Declarations
(Body_Nod
));
4743 (Body_Nod
, New_List
(Remove_Head
(Minimum_Acc_Objs
)));
4747 -- Deal with end of scope processing for the body
4750 (Handled_Statement_Sequence
(N
), 't', Current_Scope
);
4751 Update_Use_Clause_Chain
;
4754 -- If we are compiling an entry wrapper, remove the enclosing
4755 -- synchronized object from the stack.
4757 if Is_Entry_Wrapper
(Body_Id
) then
4761 Check_Subprogram_Order
(N
);
4762 Set_Analyzed
(Body_Id
);
4764 -- If we have a separate spec, then the analysis of the declarations
4765 -- caused the entities in the body to be chained to the spec id, but
4766 -- we want them chained to the body id. Only the formal parameters
4767 -- end up chained to the spec id in this case.
4769 if Present
(Spec_Id
) then
4771 -- We must conform to the categorization of our spec
4773 Validate_Categorization_Dependency
(N
, Spec_Id
);
4775 -- And if this is a child unit, the parent units must conform
4777 if Is_Child_Unit
(Spec_Id
) then
4778 Validate_Categorization_Dependency
4779 (Unit_Declaration_Node
(Spec_Id
), Spec_Id
);
4782 -- Here is where we move entities from the spec to the body
4784 -- Case where there are entities that stay with the spec
4786 if Present
(Last_Real_Spec_Entity
) then
4788 -- No body entities (happens when the only real spec entities come
4789 -- from precondition and postcondition pragmas).
4791 if No
(Last_Entity
(Body_Id
)) then
4792 Set_First_Entity
(Body_Id
, Next_Entity
(Last_Real_Spec_Entity
));
4794 -- Body entities present (formals), so chain stuff past them
4798 (Last_Entity
(Body_Id
), Next_Entity
(Last_Real_Spec_Entity
));
4801 Set_Next_Entity
(Last_Real_Spec_Entity
, Empty
);
4802 Set_Last_Entity
(Body_Id
, Last_Entity
(Spec_Id
));
4803 Set_Last_Entity
(Spec_Id
, Last_Real_Spec_Entity
);
4805 -- Case where there are no spec entities, in this case there can be
4806 -- no body entities either, so just move everything.
4808 -- If the body is generated for an expression function, it may have
4809 -- been preanalyzed already, if 'access was applied to it.
4812 if Nkind
(Original_Node
(Unit_Declaration_Node
(Spec_Id
))) /=
4813 N_Expression_Function
4815 pragma Assert
(No
(Last_Entity
(Body_Id
)));
4819 Set_First_Entity
(Body_Id
, First_Entity
(Spec_Id
));
4820 Set_Last_Entity
(Body_Id
, Last_Entity
(Spec_Id
));
4821 Set_First_Entity
(Spec_Id
, Empty
);
4822 Set_Last_Entity
(Spec_Id
, Empty
);
4825 -- Otherwise the body does not complete a previous declaration. Check
4826 -- the categorization of the body against the units it withs.
4829 Validate_Categorization_Dependency
(N
, Body_Id
);
4832 Check_Missing_Return
;
4834 -- Now we are going to check for variables that are never modified in
4835 -- the body of the procedure. But first we deal with a special case
4836 -- where we want to modify this check. If the body of the subprogram
4837 -- starts with a raise statement or its equivalent, or if the body
4838 -- consists entirely of a null statement, then it is pretty obvious that
4839 -- it is OK to not reference the parameters. For example, this might be
4840 -- the following common idiom for a stubbed function: statement of the
4841 -- procedure raises an exception. In particular this deals with the
4842 -- common idiom of a stubbed function, which appears something like:
4844 -- function F (A : Integer) return Some_Type;
4847 -- raise Program_Error;
4851 -- Here the purpose of X is simply to satisfy the annoying requirement
4852 -- in Ada that there be at least one return, and we certainly do not
4853 -- want to go posting warnings on X that it is not initialized. On
4854 -- the other hand, if X is entirely unreferenced that should still
4857 -- What we do is to detect these cases, and if we find them, flag the
4858 -- subprogram as being Is_Trivial_Subprogram and then use that flag to
4859 -- suppress unwanted warnings. For the case of the function stub above
4860 -- we have a special test to set X as apparently assigned to suppress
4864 Stm
: Node_Id
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
4866 -- Skip call markers installed by the ABE mechanism, labels, and
4867 -- Push_xxx_Error_Label to find the first real statement.
4869 while Nkind
(Stm
) in N_Call_Marker | N_Label | N_Push_xxx_Label
loop
4873 -- Do the test on the original statement before expansion
4876 Ostm
: constant Node_Id
:= Original_Node
(Stm
);
4879 -- If explicit raise statement, turn on flag
4881 if Nkind
(Ostm
) = N_Raise_Statement
then
4882 Set_Trivial_Subprogram
(Stm
);
4884 -- If null statement, and no following statements, turn on flag
4886 elsif Nkind
(Stm
) = N_Null_Statement
4887 and then Comes_From_Source
(Stm
)
4888 and then No
(Next
(Stm
))
4890 Set_Trivial_Subprogram
(Stm
);
4892 -- Check for explicit call cases which likely raise an exception
4894 elsif Nkind
(Ostm
) = N_Procedure_Call_Statement
then
4895 if Is_Entity_Name
(Name
(Ostm
)) then
4897 Ent
: constant Entity_Id
:= Entity
(Name
(Ostm
));
4900 -- If the procedure is marked No_Return, then likely it
4901 -- raises an exception, but in any case it is not coming
4902 -- back here, so turn on the flag.
4905 and then Ekind
(Ent
) = E_Procedure
4906 and then No_Return
(Ent
)
4908 Set_Trivial_Subprogram
(Stm
);
4916 -- Check if a Body_To_Inline was created, but the subprogram has
4917 -- references to object renamings which will be replaced by the special
4918 -- SPARK expansion into nodes of a different kind, which is not expected
4919 -- by the inlining mechanism. In that case, the Body_To_Inline is
4920 -- deleted prior to being analyzed. This check needs to take place
4921 -- after analysis of the subprogram body.
4924 and then Present
(Spec_Id
)
4926 Nkind
(Unit_Declaration_Node
(Spec_Id
)) = N_Subprogram_Declaration
4927 and then Present
(Body_To_Inline
(Unit_Declaration_Node
(Spec_Id
)))
4929 Check_Object_Renaming_In_GNATprove_Mode
(Spec_Id
);
4932 -- Check for variables that are never modified
4939 -- If there is a separate spec, then transfer Never_Set_In_Source
4940 -- flags from out parameters to the corresponding entities in the
4941 -- body. The reason we do that is we want to post error flags on
4942 -- the body entities, not the spec entities.
4944 if Present
(Spec_Id
) then
4945 F1
:= First_Formal
(Spec_Id
);
4946 while Present
(F1
) loop
4947 if Ekind
(F1
) = E_Out_Parameter
then
4948 F2
:= First_Formal
(Body_Id
);
4949 while Present
(F2
) loop
4950 exit when Chars
(F1
) = Chars
(F2
);
4954 if Present
(F2
) then
4955 Set_Never_Set_In_Source
(F2
, Never_Set_In_Source
(F1
));
4963 -- Check references of the subprogram spec when we are dealing with
4964 -- an expression function due to it having a generated body.
4966 if Present
(Spec_Id
)
4967 and then Is_Expression_Function
(Spec_Id
)
4969 Check_References
(Spec_Id
);
4971 -- Skip the check for subprograms generated for protected subprograms
4972 -- because it is also done for the protected subprograms themselves.
4974 elsif Present
(Spec_Id
)
4975 and then Present
(Protected_Subprogram
(Spec_Id
))
4979 -- Otherwise, we simply check the formals of the subprogram body.
4982 Check_References
(Body_Id
);
4986 -- Check for nested subprogram, and mark outer level subprogram if so
4992 if Present
(Spec_Id
) then
4999 Ent
:= Enclosing_Subprogram
(Ent
);
5000 exit when No
(Ent
) or else Is_Subprogram
(Ent
);
5003 if Present
(Ent
) then
5004 Set_Has_Nested_Subprogram
(Ent
);
5008 -- Restore the limited views in the spec, if any, to let the back end
5009 -- process it without running into circularities.
5011 if Present
(Exch_Views
) then
5012 Restore_Limited_Views
(Exch_Views
);
5015 if Present
(Mask_Types
) then
5016 Unmask_Unfrozen_Types
(Mask_Types
);
5019 if Present
(Desig_View
) then
5020 Set_Directly_Designated_Type
(Etype
(Spec_Id
), Desig_View
);
5024 if Present
(Ignored_Ghost_Region
) then
5025 Expander_Active
:= Saved_EA
;
5028 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
5029 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
5030 end Analyze_Subprogram_Body_Helper
;
5032 ------------------------------------
5033 -- Analyze_Subprogram_Declaration --
5034 ------------------------------------
5036 procedure Analyze_Subprogram_Declaration
(N
: Node_Id
) is
5037 Scop
: constant Entity_Id
:= Current_Scope
;
5038 Designator
: Entity_Id
;
5040 Is_Completion
: Boolean;
5041 -- Indicates whether a null procedure declaration is a completion
5044 -- Null procedures are not allowed in SPARK
5046 if Nkind
(Specification
(N
)) = N_Procedure_Specification
5047 and then Null_Present
(Specification
(N
))
5049 -- Null procedures are allowed in protected types, following the
5050 -- recent AI12-0147.
5052 if Is_Protected_Type
(Current_Scope
)
5053 and then Ada_Version
< Ada_2012
5055 Error_Msg_N
("protected operation cannot be a null procedure", N
);
5058 Analyze_Null_Procedure
(N
, Is_Completion
);
5060 -- The null procedure acts as a body, nothing further is needed
5062 if Is_Completion
then
5067 Designator
:= Analyze_Subprogram_Specification
(Specification
(N
));
5069 -- A reference may already have been generated for the unit name, in
5070 -- which case the following call is redundant. However it is needed for
5071 -- declarations that are the rewriting of an expression function.
5073 Generate_Definition
(Designator
);
5075 -- Set the SPARK mode from the current context (may be overwritten later
5076 -- with explicit pragma). This is not done for entry barrier functions
5077 -- because they are generated outside the protected type and should not
5078 -- carry the mode of the enclosing context.
5080 if Nkind
(N
) = N_Subprogram_Declaration
5081 and then Is_Entry_Barrier_Function
(N
)
5086 Set_SPARK_Pragma
(Designator
, SPARK_Mode_Pragma
);
5087 Set_SPARK_Pragma_Inherited
(Designator
);
5090 -- Save the state of flag Ignore_SPARK_Mode_Pragmas_In_Instance in case
5091 -- the body of this subprogram is instantiated or inlined later and out
5092 -- of context. The body uses this attribute to restore the value of the
5095 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
5096 Set_Ignore_SPARK_Mode_Pragmas
(Designator
);
5099 -- Preserve relevant elaboration-related attributes of the context which
5100 -- are no longer available or very expensive to recompute once analysis,
5101 -- resolution, and expansion are over.
5103 Mark_Elaboration_Attributes
5104 (N_Id
=> Designator
,
5108 if Debug_Flag_C
then
5109 Write_Str
("==> subprogram spec ");
5110 Write_Name
(Chars
(Designator
));
5111 Write_Str
(" from ");
5112 Write_Location
(Sloc
(N
));
5117 Validate_RCI_Subprogram_Declaration
(N
);
5118 New_Overloaded_Entity
(Designator
);
5119 Check_Delayed_Subprogram
(Designator
);
5121 -- If the type of the first formal of the current subprogram is a non-
5122 -- generic tagged private type, mark the subprogram as being a private
5123 -- primitive. Ditto if this is a function with controlling result, and
5124 -- the return type is currently private. In both cases, the type of the
5125 -- controlling argument or result must be in the current scope for the
5126 -- operation to be primitive.
5128 if Has_Controlling_Result
(Designator
)
5129 and then Is_Private_Type
(Etype
(Designator
))
5130 and then Scope
(Etype
(Designator
)) = Current_Scope
5131 and then not Is_Generic_Actual_Type
(Etype
(Designator
))
5133 Set_Is_Private_Primitive
(Designator
);
5135 elsif Present
(First_Formal
(Designator
)) then
5137 Formal_Typ
: constant Entity_Id
:=
5138 Etype
(First_Formal
(Designator
));
5140 Set_Is_Private_Primitive
(Designator
,
5141 Is_Tagged_Type
(Formal_Typ
)
5142 and then Scope
(Formal_Typ
) = Current_Scope
5143 and then Is_Private_Type
(Formal_Typ
)
5144 and then not Is_Generic_Actual_Type
(Formal_Typ
));
5148 -- Ada 2005 (AI-251): Abstract interface primitives must be abstract
5151 if Ada_Version
>= Ada_2005
5152 and then Comes_From_Source
(N
)
5153 and then Is_Dispatching_Operation
(Designator
)
5160 if Has_Controlling_Result
(Designator
) then
5161 Etyp
:= Etype
(Designator
);
5164 E
:= First_Entity
(Designator
);
5166 and then Is_Formal
(E
)
5167 and then not Is_Controlling_Formal
(E
)
5175 if Is_Access_Type
(Etyp
) then
5176 Etyp
:= Directly_Designated_Type
(Etyp
);
5179 if Is_Interface
(Etyp
)
5180 and then not Is_Abstract_Subprogram
(Designator
)
5181 and then not (Ekind
(Designator
) = E_Procedure
5182 and then Null_Present
(Specification
(N
)))
5184 Error_Msg_Name_1
:= Chars
(Defining_Entity
(N
));
5186 -- Specialize error message based on procedures vs. functions,
5187 -- since functions can't be null subprograms.
5189 if Ekind
(Designator
) = E_Procedure
then
5191 ("interface procedure % must be abstract or null", N
);
5194 ("interface function % must be abstract", N
);
5200 -- For a compilation unit, set body required. This flag will only be
5201 -- reset if a valid Import or Interface pragma is processed later on.
5203 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5204 Set_Body_Required
(Parent
(N
), True);
5206 if Ada_Version
>= Ada_2005
5207 and then Nkind
(Specification
(N
)) = N_Procedure_Specification
5208 and then Null_Present
(Specification
(N
))
5211 ("null procedure cannot be declared at library level", N
);
5215 Generate_Reference_To_Formals
(Designator
);
5216 Check_Eliminated
(Designator
);
5218 if Debug_Flag_C
then
5220 Write_Str
("<== subprogram spec ");
5221 Write_Name
(Chars
(Designator
));
5222 Write_Str
(" from ");
5223 Write_Location
(Sloc
(N
));
5227 -- Indicate that this is a protected operation, because it may be used
5228 -- in subsequent declarations within the protected type.
5230 if Is_Protected_Type
(Current_Scope
) then
5231 Set_Convention
(Designator
, Convention_Protected
);
5234 List_Inherited_Pre_Post_Aspects
(Designator
);
5236 -- Process the aspects before establishing the proper categorization in
5237 -- case the subprogram is a compilation unit and one of its aspects is
5238 -- converted into a categorization pragma.
5240 Analyze_Aspect_Specifications
(N
, Designator
);
5242 -- The legality of a function specification in SPARK depends on whether
5243 -- the function is a function with or without side effects. Analyze the
5244 -- pragma in advance if present, before specific SPARK legality checks.
5246 Analyze_Pragmas_If_Present
(N
, Pragma_SPARK_Mode
);
5247 Analyze_Pragmas_If_Present
(N
, Pragma_Side_Effects
);
5248 Analyze_SPARK_Subprogram_Specification
(Specification
(N
));
5250 if Scop
/= Standard_Standard
and then not Is_Child_Unit
(Designator
) then
5251 Set_Categorization_From_Scope
(Designator
, Scop
);
5253 -- Otherwise the unit is a compilation unit and/or a child unit. Set the
5254 -- proper categorization of the unit based on its pragmas.
5257 Push_Scope
(Designator
);
5258 Set_Categorization_From_Pragmas
(N
);
5259 Validate_Categorization_Dependency
(N
, Designator
);
5262 end Analyze_Subprogram_Declaration
;
5264 --------------------------------------
5265 -- Analyze_Subprogram_Specification --
5266 --------------------------------------
5268 -- Reminder: N here really is a subprogram specification (not a subprogram
5269 -- declaration). This procedure is called to analyze the specification in
5270 -- both subprogram bodies and subprogram declarations (specs).
5272 function Analyze_Subprogram_Specification
(N
: Node_Id
) return Entity_Id
is
5273 function Is_Invariant_Procedure_Or_Body
(E
: Entity_Id
) return Boolean;
5274 -- Determine whether entity E denotes the spec or body of an invariant
5277 ------------------------------------
5278 -- Is_Invariant_Procedure_Or_Body --
5279 ------------------------------------
5281 function Is_Invariant_Procedure_Or_Body
(E
: Entity_Id
) return Boolean is
5282 Decl
: constant Node_Id
:= Unit_Declaration_Node
(E
);
5286 if Nkind
(Decl
) = N_Subprogram_Body
then
5287 Spec
:= Corresponding_Spec
(Decl
);
5294 and then Ekind
(Spec
) = E_Procedure
5295 and then (Is_Partial_Invariant_Procedure
(Spec
)
5296 or else Is_Invariant_Procedure
(Spec
));
5297 end Is_Invariant_Procedure_Or_Body
;
5301 Designator
: constant Entity_Id
:= Defining_Entity
(N
);
5302 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
5304 -- Start of processing for Analyze_Subprogram_Specification
5307 -- Proceed with analysis. Do not emit a cross-reference entry if the
5308 -- specification comes from an expression function, because it may be
5309 -- the completion of a previous declaration. If it is not, the cross-
5310 -- reference entry will be emitted for the new subprogram declaration.
5312 if Nkind
(Parent
(N
)) /= N_Expression_Function
then
5313 Generate_Definition
(Designator
);
5316 if Nkind
(N
) = N_Function_Specification
then
5317 Mutate_Ekind
(Designator
, E_Function
);
5318 Set_Mechanism
(Designator
, Default_Mechanism
);
5320 Mutate_Ekind
(Designator
, E_Procedure
);
5321 Set_Etype
(Designator
, Standard_Void_Type
);
5324 Set_Is_Not_Self_Hidden
(Designator
);
5326 -- Flag Is_Inlined_Always is True by default, and reversed to False for
5327 -- those subprograms which could be inlined in GNATprove mode (because
5328 -- Body_To_Inline is non-Empty) but should not be inlined. Flag
5329 -- Is_Inlined is True by default and reversed to False when inlining
5330 -- fails because the subprogram is detected to be recursive.
5332 if GNATprove_Mode
then
5333 Set_Is_Inlined_Always
(Designator
);
5334 Set_Is_Inlined
(Designator
);
5337 -- Introduce new scope for analysis of the formals and the return type
5339 Set_Scope
(Designator
, Current_Scope
);
5341 if Present
(Formals
) then
5342 Push_Scope
(Designator
);
5343 Process_Formals
(Formals
, N
);
5345 -- Check dimensions in N for formals with default expression
5347 Analyze_Dimension_Formals
(N
, Formals
);
5349 -- Ada 2005 (AI-345): If this is an overriding operation of an
5350 -- inherited interface operation, and the controlling type is
5351 -- a synchronized type, replace the type with its corresponding
5352 -- record, to match the proper signature of an overriding operation.
5353 -- Same processing for an access parameter whose designated type is
5354 -- derived from a synchronized interface.
5356 -- This modification is not done for invariant procedures because
5357 -- the corresponding record may not necessarely be visible when the
5358 -- concurrent type acts as the full view of a private type.
5361 -- type Prot is private with Type_Invariant => ...;
5362 -- procedure ConcInvariant (Obj : Prot);
5364 -- protected type Prot is ...;
5365 -- type Concurrent_Record_Prot is record ...;
5366 -- procedure ConcInvariant (Obj : Prot) is
5368 -- end ConcInvariant;
5371 -- In the example above, both the spec and body of the invariant
5372 -- procedure must utilize the private type as the controlling type.
5374 if Ada_Version
>= Ada_2005
5375 and then not Is_Invariant_Procedure_Or_Body
(Designator
)
5376 and then not Is_Init_Proc
(Designator
)
5380 Formal_Typ
: Entity_Id
;
5381 Rec_Typ
: Entity_Id
;
5382 Desig_Typ
: Entity_Id
;
5385 Formal
:= First_Formal
(Designator
);
5386 while Present
(Formal
) loop
5387 Formal_Typ
:= Etype
(Formal
);
5389 if Is_Concurrent_Type
(Formal_Typ
)
5390 and then Present
(Corresponding_Record_Type
(Formal_Typ
))
5392 Rec_Typ
:= Corresponding_Record_Type
(Formal_Typ
);
5394 if Present
(Interfaces
(Rec_Typ
)) then
5395 Set_Etype
(Formal
, Rec_Typ
);
5398 elsif Ekind
(Formal_Typ
) = E_Anonymous_Access_Type
then
5399 Desig_Typ
:= Designated_Type
(Formal_Typ
);
5401 if Is_Concurrent_Type
(Desig_Typ
)
5402 and then Present
(Corresponding_Record_Type
(Desig_Typ
))
5404 Rec_Typ
:= Corresponding_Record_Type
(Desig_Typ
);
5406 if Present
(Interfaces
(Rec_Typ
)) then
5407 Set_Directly_Designated_Type
(Formal_Typ
, Rec_Typ
);
5412 Next_Formal
(Formal
);
5419 -- The subprogram scope is pushed and popped around the processing of
5420 -- the return type for consistency with call above to Process_Formals
5421 -- (which itself can call Analyze_Return_Type), and to ensure that any
5422 -- itype created for the return type will be associated with the proper
5425 elsif Nkind
(N
) = N_Function_Specification
then
5426 Push_Scope
(Designator
);
5427 Analyze_Return_Type
(N
);
5433 if Nkind
(N
) = N_Function_Specification
then
5435 -- Deal with operator symbol case
5437 if Nkind
(Designator
) = N_Defining_Operator_Symbol
then
5438 Valid_Operator_Definition
(Designator
);
5441 May_Need_Actuals
(Designator
);
5443 -- Ada 2005 (AI-251): If the return type is abstract, verify that
5444 -- the subprogram is abstract also. This does not apply to renaming
5445 -- declarations, where abstractness is inherited, and to subprogram
5446 -- bodies generated for stream operations, which become renamings as
5447 -- bodies. We also skip the check for thunks.
5449 -- In case of primitives associated with abstract interface types
5450 -- the check is applied later (see Analyze_Subprogram_Declaration).
5452 if Nkind
(Original_Node
(Parent
(N
))) not in
5453 N_Abstract_Subprogram_Declaration |
5454 N_Formal_Abstract_Subprogram_Declaration |
5455 N_Subprogram_Renaming_Declaration
5456 and then not Is_Thunk
(Designator
)
5458 if Is_Abstract_Type
(Etype
(Designator
)) then
5460 ("function that returns abstract type must be abstract", N
);
5462 -- Ada 2012 (AI-0073): Extend this test to subprograms with an
5463 -- access result whose designated type is abstract.
5465 elsif Ada_Version
>= Ada_2012
5466 and then Nkind
(Result_Definition
(N
)) = N_Access_Definition
5468 not Is_Class_Wide_Type
(Designated_Type
(Etype
(Designator
)))
5469 and then Is_Abstract_Type
(Designated_Type
(Etype
(Designator
)))
5472 ("function whose access result designates abstract type "
5473 & "must be abstract", N
);
5479 end Analyze_Subprogram_Specification
;
5481 -----------------------
5482 -- Check_Conformance --
5483 -----------------------
5485 procedure Check_Conformance
5486 (New_Id
: Entity_Id
;
5488 Ctype
: Conformance_Type
;
5490 Conforms
: out Boolean;
5491 Err_Loc
: Node_Id
:= Empty
;
5492 Get_Inst
: Boolean := False;
5493 Skip_Controlling_Formals
: Boolean := False)
5495 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
);
5496 -- Sets Conforms to False. If Errmsg is False, then that's all it does.
5497 -- If Errmsg is True, then processing continues to post an error message
5498 -- for conformance error on given node. Two messages are output. The
5499 -- first message points to the previous declaration with a general "no
5500 -- conformance" message. The second is the detailed reason, supplied as
5501 -- Msg. The parameter N provide information for a possible & insertion
5502 -- in the message, and also provides the location for posting the
5503 -- message in the absence of a specified Err_Loc location.
5505 function Conventions_Match
(Id1
, Id2
: Entity_Id
) return Boolean;
5506 -- True if the conventions of entities Id1 and Id2 match.
5508 function Null_Exclusions_Match
(F1
, F2
: Entity_Id
) return Boolean;
5509 -- True if the null exclusions of two formals of anonymous access type
5512 function Subprogram_Subtypes_Have_Same_Declaration
5514 Decl_Subtype
: Entity_Id
;
5515 Body_Subtype
: Entity_Id
) return Boolean;
5516 -- Checks whether corresponding subtypes named within a subprogram
5517 -- declaration and body originate from the same declaration, and returns
5518 -- True when they do. In the case of anonymous access-to-object types,
5519 -- checks the designated types. Also returns True when GNAT_Mode is
5520 -- enabled, or when the subprogram is marked Is_Internal or occurs
5521 -- within a generic instantiation or internal unit (GNAT library unit).
5523 -----------------------
5524 -- Conformance_Error --
5525 -----------------------
5527 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
) is
5534 if No
(Err_Loc
) then
5540 Error_Msg_Sloc
:= Sloc
(Old_Id
);
5543 when Type_Conformant
=>
5544 Error_Msg_N
-- CODEFIX
5545 ("not type conformant with declaration#!", Enode
);
5547 when Mode_Conformant
=>
5548 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
5550 ("not mode conformant with operation inherited#!",
5554 ("not mode conformant with declaration#!", Enode
);
5557 when Subtype_Conformant
=>
5558 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
5560 ("not subtype conformant with operation inherited#!",
5564 ("not subtype conformant with declaration#!", Enode
);
5567 when Fully_Conformant
=>
5568 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
5569 Error_Msg_N
-- CODEFIX
5570 ("not fully conformant with operation inherited#!",
5573 Error_Msg_N
-- CODEFIX
5574 ("not fully conformant with declaration#!", Enode
);
5578 Error_Msg_NE
(Msg
, Enode
, N
);
5580 end Conformance_Error
;
5582 -----------------------
5583 -- Conventions_Match --
5584 -----------------------
5586 function Conventions_Match
5588 Id2
: Entity_Id
) return Boolean
5591 -- Ignore the conventions of anonymous access-to-subprogram types
5592 -- and subprogram types because these are internally generated and
5593 -- the only way these may receive a convention is if they inherit
5594 -- the convention of a related subprogram.
5596 if Ekind
(Id1
) in E_Anonymous_Access_Subprogram_Type
5599 Ekind
(Id2
) in E_Anonymous_Access_Subprogram_Type
5604 -- Otherwise compare the conventions directly
5607 return Convention
(Id1
) = Convention
(Id2
);
5609 end Conventions_Match
;
5611 ---------------------------
5612 -- Null_Exclusions_Match --
5613 ---------------------------
5615 function Null_Exclusions_Match
(F1
, F2
: Entity_Id
) return Boolean is
5617 if not Is_Anonymous_Access_Type
(Etype
(F1
))
5618 or else not Is_Anonymous_Access_Type
(Etype
(F2
))
5623 -- AI12-0289-1: Case of controlling access parameter; False if the
5624 -- partial view is untagged, the full view is tagged, and no explicit
5625 -- "not null". Note that at this point, we're processing the package
5626 -- body, so private/full types have been swapped. The Sloc test below
5627 -- is to detect the (legal) case where F1 comes after the full type
5628 -- declaration. This part is disabled pre-2005, because "not null" is
5629 -- not allowed on those language versions.
5631 if Ada_Version
>= Ada_2005
5632 and then Is_Controlling_Formal
(F1
)
5633 and then not Null_Exclusion_Present
(Parent
(F1
))
5634 and then not Null_Exclusion_Present
(Parent
(F2
))
5637 D
: constant Entity_Id
:= Directly_Designated_Type
(Etype
(F1
));
5638 Partial_View_Of_Desig
: constant Entity_Id
:=
5639 Incomplete_Or_Partial_View
(D
);
5641 return No
(Partial_View_Of_Desig
)
5642 or else Is_Tagged_Type
(Partial_View_Of_Desig
)
5643 or else Sloc
(D
) < Sloc
(F1
);
5646 -- Not a controlling parameter, or one or both views have an explicit
5650 return Null_Exclusion_Present
(Parent
(F1
)) =
5651 Null_Exclusion_Present
(Parent
(F2
));
5653 end Null_Exclusions_Match
;
5655 function Subprogram_Subtypes_Have_Same_Declaration
5657 Decl_Subtype
: Entity_Id
;
5658 Body_Subtype
: Entity_Id
) return Boolean
5661 function Nonlimited_View_Of_Subtype
5662 (Subt
: Entity_Id
) return Entity_Id
;
5663 -- Returns the nonlimited view of a type or subtype that is an
5664 -- incomplete or class-wide type that comes from a limited view of
5665 -- a package (From_Limited_With is True for the entity), or the
5666 -- full view when the subtype is an incomplete type. Otherwise
5667 -- returns the entity passed in.
5669 function Nonlimited_View_Of_Subtype
5670 (Subt
: Entity_Id
) return Entity_Id
5672 Subt_Temp
: Entity_Id
:= Subt
;
5674 if Ekind
(Subt
) in Incomplete_Kind | E_Class_Wide_Type
5675 and then From_Limited_With
(Subt
)
5677 Subt_Temp
:= Non_Limited_View
(Subt
);
5680 -- If the subtype is incomplete, return full view if present
5681 -- (and accounts for the case where a type from a limited view
5682 -- is itself an incomplete type).
5684 if Ekind
(Subt_Temp
) in Incomplete_Kind
5685 and then Present
(Full_View
(Subt_Temp
))
5687 Subt_Temp
:= Full_View
(Subt_Temp
);
5691 end Nonlimited_View_Of_Subtype
;
5693 -- Start of processing for Subprogram_Subtypes_Have_Same_Declaration
5697 and then not In_Internal_Unit
(Subp
)
5698 and then not Is_Internal
(Subp
)
5699 and then not GNAT_Mode
5701 Ekind
(Etype
(Decl_Subtype
)) not in Access_Subprogram_Kind
5703 if Ekind
(Etype
(Decl_Subtype
)) = E_Anonymous_Access_Type
then
5704 if Nonlimited_View_Of_Subtype
(Designated_Type
(Decl_Subtype
))
5705 /= Nonlimited_View_Of_Subtype
(Designated_Type
(Body_Subtype
))
5710 elsif Nonlimited_View_Of_Subtype
(Decl_Subtype
)
5711 /= Nonlimited_View_Of_Subtype
(Body_Subtype
)
5713 -- Avoid returning False (and a false-positive warning) for
5714 -- the case of "not null" itypes, which will appear to be
5715 -- different subtypes even when the subtype_marks denote
5716 -- the same subtype.
5718 if Ekind
(Decl_Subtype
) = E_Access_Subtype
5719 and then Ekind
(Body_Subtype
) = E_Access_Subtype
5720 and then Is_Itype
(Body_Subtype
)
5721 and then Can_Never_Be_Null
(Body_Subtype
)
5722 and then Etype
(Decl_Subtype
) = Etype
(Body_Subtype
)
5733 end Subprogram_Subtypes_Have_Same_Declaration
;
5737 Old_Type
: constant Entity_Id
:= Etype
(Old_Id
);
5738 New_Type
: constant Entity_Id
:= Etype
(New_Id
);
5739 Old_Formal
: Entity_Id
;
5740 New_Formal
: Entity_Id
;
5741 Old_Formal_Base
: Entity_Id
;
5742 New_Formal_Base
: Entity_Id
;
5744 -- Start of processing for Check_Conformance
5749 -- We need a special case for operators, since they don't appear
5752 if Ctype
= Type_Conformant
then
5753 if Ekind
(New_Id
) = E_Operator
5754 and then Operator_Matches_Spec
(New_Id
, Old_Id
)
5760 -- If both are functions/operators, check return types conform
5762 if Old_Type
/= Standard_Void_Type
5764 New_Type
/= Standard_Void_Type
5766 -- If we are checking interface conformance we omit controlling
5767 -- arguments and result, because we are only checking the conformance
5768 -- of the remaining parameters.
5770 if Has_Controlling_Result
(Old_Id
)
5771 and then Has_Controlling_Result
(New_Id
)
5772 and then Skip_Controlling_Formals
5776 elsif not Conforming_Types
(Old_Type
, New_Type
, Ctype
, Get_Inst
) then
5777 if Ctype
>= Subtype_Conformant
5778 and then not Predicates_Match
(Old_Type
, New_Type
)
5781 ("\predicate of return type does not match!", New_Id
);
5784 ("\return type does not match!", New_Id
);
5789 -- If the result subtypes conform and pedantic checks are enabled,
5790 -- check to see whether the subtypes originate from different
5791 -- declarations, and issue a warning when they do.
5793 elsif Ctype
= Fully_Conformant
5794 and then Warn_On_Pedantic_Checks
5795 and then not Subprogram_Subtypes_Have_Same_Declaration
5796 (Old_Id
, Old_Type
, New_Type
)
5798 Error_Msg_N
("result subtypes conform but come from different "
5799 & "declarations?_p?", New_Id
);
5802 -- Ada 2005 (AI-231): In case of anonymous access types check the
5803 -- null-exclusion and access-to-constant attributes match.
5805 if Ada_Version
>= Ada_2005
5806 and then Ekind
(Etype
(Old_Type
)) = E_Anonymous_Access_Type
5808 (Can_Never_Be_Null
(Old_Type
) /= Can_Never_Be_Null
(New_Type
)
5809 or else Is_Access_Constant
(Etype
(Old_Type
)) /=
5810 Is_Access_Constant
(Etype
(New_Type
)))
5812 Conformance_Error
("\return type does not match!", New_Id
);
5816 -- If either is a function/operator and the other isn't, error
5818 elsif Old_Type
/= Standard_Void_Type
5819 or else New_Type
/= Standard_Void_Type
5821 Conformance_Error
("\functions can only match functions!", New_Id
);
5825 -- In subtype conformant case, conventions must match (RM 6.3.1(16)).
5826 -- If this is a renaming as body, refine error message to indicate that
5827 -- the conflict is with the original declaration. If the entity is not
5828 -- frozen, the conventions don't have to match, the one of the renamed
5829 -- entity is inherited.
5831 if Ctype
>= Subtype_Conformant
then
5832 if not Conventions_Match
(Old_Id
, New_Id
) then
5833 if not Is_Frozen
(New_Id
) then
5836 elsif Present
(Err_Loc
)
5837 and then Nkind
(Err_Loc
) = N_Subprogram_Renaming_Declaration
5838 and then Present
(Corresponding_Spec
(Err_Loc
))
5840 Error_Msg_Name_1
:= Chars
(New_Id
);
5842 Name_Ada
+ Convention_Id
'Pos (Convention
(New_Id
));
5843 Conformance_Error
("\prior declaration for% has convention %!");
5847 Conformance_Error
("\calling conventions do not match!");
5851 Check_Formal_Subprogram_Conformance
5852 (New_Id
, Old_Id
, Err_Loc
, Errmsg
, Conforms
);
5854 if not Conforms
then
5860 -- Deal with parameters
5862 -- Note: we use the entity information, rather than going directly
5863 -- to the specification in the tree. This is not only simpler, but
5864 -- absolutely necessary for some cases of conformance tests between
5865 -- operators, where the declaration tree simply does not exist.
5867 Old_Formal
:= First_Formal
(Old_Id
);
5868 New_Formal
:= First_Formal
(New_Id
);
5869 while Present
(Old_Formal
) and then Present
(New_Formal
) loop
5870 if Is_Controlling_Formal
(Old_Formal
)
5871 and then Is_Controlling_Formal
(New_Formal
)
5872 and then Skip_Controlling_Formals
5874 -- The controlling formals will have different types when
5875 -- comparing an interface operation with its match, but both
5876 -- or neither must be access parameters.
5878 if Is_Access_Type
(Etype
(Old_Formal
))
5880 Is_Access_Type
(Etype
(New_Formal
))
5882 goto Skip_Controlling_Formal
;
5885 ("\access parameter does not match!", New_Formal
);
5889 -- Ada 2012: Mode conformance also requires that formal parameters
5890 -- be both aliased, or neither.
5892 if Ctype
>= Mode_Conformant
and then Ada_Version
>= Ada_2012
then
5893 if Is_Aliased
(Old_Formal
) /= Is_Aliased
(New_Formal
) then
5895 ("\aliased parameter mismatch!", New_Formal
);
5899 if Ctype
= Fully_Conformant
then
5901 -- Names must match. Error message is more accurate if we do
5902 -- this before checking that the types of the formals match.
5904 if Chars
(Old_Formal
) /= Chars
(New_Formal
) then
5905 Conformance_Error
("\name& does not match!", New_Formal
);
5907 -- Set error posted flag on new formal as well to stop
5908 -- junk cascaded messages in some cases.
5910 Set_Error_Posted
(New_Formal
);
5914 -- Null exclusion must match
5916 if not Relaxed_RM_Semantics
5917 and then not Null_Exclusions_Match
(Old_Formal
, New_Formal
)
5920 ("\null exclusion for& does not match", New_Formal
);
5922 -- Mark error posted on the new formal to avoid duplicated
5923 -- complaint about types not matching.
5925 Set_Error_Posted
(New_Formal
);
5929 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
5930 -- case occurs whenever a subprogram is being renamed and one of its
5931 -- parameters imposes a null exclusion. For example:
5933 -- type T is null record;
5934 -- type Acc_T is access T;
5935 -- subtype Acc_T_Sub is Acc_T;
5937 -- procedure P (Obj : not null Acc_T_Sub); -- itype
5938 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype
5941 Old_Formal_Base
:= Etype
(Old_Formal
);
5942 New_Formal_Base
:= Etype
(New_Formal
);
5945 Old_Formal_Base
:= Get_Instance_Of
(Old_Formal_Base
);
5946 New_Formal_Base
:= Get_Instance_Of
(New_Formal_Base
);
5949 -- Types must always match. In the visible part of an instance,
5950 -- usual overloading rules for dispatching operations apply, and
5951 -- we check base types (not the actual subtypes).
5953 if In_Instance_Visible_Part
5954 and then Is_Dispatching_Operation
(New_Id
)
5956 if not Conforming_Types
5957 (T1
=> Base_Type
(Etype
(Old_Formal
)),
5958 T2
=> Base_Type
(Etype
(New_Formal
)),
5960 Get_Inst
=> Get_Inst
)
5962 Conformance_Error
("\type of & does not match!", New_Formal
);
5966 elsif not Conforming_Types
5967 (T1
=> Old_Formal_Base
,
5968 T2
=> New_Formal_Base
,
5970 Get_Inst
=> Get_Inst
)
5972 -- Don't give error message if old type is Any_Type. This test
5973 -- avoids some cascaded errors, e.g. in case of a bad spec.
5975 if Errmsg
and then Old_Formal_Base
= Any_Type
then
5978 if Ctype
>= Subtype_Conformant
5980 not Predicates_Match
(Old_Formal_Base
, New_Formal_Base
)
5983 ("\predicate of & does not match!", New_Formal
);
5986 ("\type of & does not match!", New_Formal
);
5988 if not Dimensions_Match
(Old_Formal_Base
, New_Formal_Base
)
5990 Error_Msg_N
("\dimensions mismatch!", New_Formal
);
5997 -- If the formals' subtypes conform and pedantic checks are enabled,
5998 -- check to see whether the subtypes originate from different
5999 -- declarations, and issue a warning when they do.
6001 elsif Ctype
= Fully_Conformant
6002 and then Warn_On_Pedantic_Checks
6003 and then not Subprogram_Subtypes_Have_Same_Declaration
6004 (Old_Id
, Old_Formal_Base
, New_Formal_Base
)
6006 Error_Msg_N
("formal subtypes conform but come from "
6007 & "different declarations?_p?", New_Formal
);
6010 -- For mode conformance, mode must match
6012 if Ctype
>= Mode_Conformant
then
6013 if Parameter_Mode
(Old_Formal
) /= Parameter_Mode
(New_Formal
) then
6014 if Ekind
(New_Id
) not in E_Function | E_Procedure
6015 or else not Is_Primitive_Wrapper
(New_Id
)
6017 Conformance_Error
("\mode of & does not match!", New_Formal
);
6021 T
: constant Entity_Id
:= Find_Dispatching_Type
(New_Id
);
6023 if Is_Protected_Type
(Corresponding_Concurrent_Type
(T
))
6028 Error_Msg_PT
(New_Id
, Ultimate_Alias
(Old_Id
));
6032 ("\mode of & does not match!", New_Formal
);
6039 elsif Is_Access_Type
(Old_Formal_Base
)
6040 and then Is_Access_Type
(New_Formal_Base
)
6041 and then Is_Access_Constant
(Old_Formal_Base
) /=
6042 Is_Access_Constant
(New_Formal_Base
)
6045 ("\constant modifier does not match!", New_Formal
);
6050 if Ctype
>= Subtype_Conformant
then
6052 -- Ada 2005 (AI-231): In case of anonymous access types check
6053 -- the null-exclusion and access-to-constant attributes must
6054 -- match. For null exclusion, we test the types rather than the
6055 -- formals themselves, since the attribute is only set reliably
6056 -- on the formals in the Ada 95 case, and we exclude the case
6057 -- where Old_Formal is marked as controlling, to avoid errors
6058 -- when matching completing bodies with dispatching declarations
6059 -- (access formals in the bodies aren't marked Can_Never_Be_Null).
6061 if Ada_Version
>= Ada_2005
6062 and then Is_Anonymous_Access_Type
(Etype
(Old_Formal
))
6063 and then Is_Anonymous_Access_Type
(Etype
(New_Formal
))
6065 ((Can_Never_Be_Null
(Etype
(Old_Formal
)) /=
6066 Can_Never_Be_Null
(Etype
(New_Formal
))
6068 not Is_Controlling_Formal
(Old_Formal
))
6070 Is_Access_Constant
(Etype
(Old_Formal
)) /=
6071 Is_Access_Constant
(Etype
(New_Formal
)))
6073 -- Do not complain if error already posted on New_Formal. This
6074 -- avoids some redundant error messages.
6076 and then not Error_Posted
(New_Formal
)
6078 -- It is allowed to omit the null-exclusion in case of stream
6079 -- attribute subprograms. We recognize stream subprograms
6080 -- through their TSS-generated suffix.
6082 and then Get_TSS_Name
(New_Id
) not in TSS_Stream_Read
6087 -- Here we have a definite conformance error. It is worth
6088 -- special casing the error message for the case of a
6089 -- controlling formal (which excludes null).
6091 if Is_Controlling_Formal
(New_Formal
) then
6092 Error_Msg_Node_2
:= Scope
(New_Formal
);
6094 ("\controlling formal & of & excludes null, "
6095 & "declaration must exclude null as well",
6098 -- Normal case (couldn't we give more detail here???)
6102 ("\type of & does not match!", New_Formal
);
6109 -- Full conformance checks
6111 if Ctype
= Fully_Conformant
then
6113 -- We have checked already that names match
6115 if Parameter_Mode
(Old_Formal
) = E_In_Parameter
then
6117 -- Check default expressions for in parameters
6120 NewD
: constant Boolean :=
6121 Present
(Default_Value
(New_Formal
));
6122 OldD
: constant Boolean :=
6123 Present
(Default_Value
(Old_Formal
));
6125 if NewD
or OldD
then
6127 -- The old default value has been analyzed because the
6128 -- current full declaration will have frozen everything
6129 -- before. The new default value has not been analyzed,
6130 -- so analyze it now before we check for conformance.
6133 Push_Scope
(New_Id
);
6134 Preanalyze_Spec_Expression
6135 (Default_Value
(New_Formal
), Etype
(New_Formal
));
6139 if not (NewD
and OldD
)
6140 or else not Fully_Conformant_Expressions
6141 (Default_Value
(Old_Formal
),
6142 Default_Value
(New_Formal
))
6145 ("\default expression for & does not match!",
6154 -- A couple of special checks for Ada 83 mode. These checks are
6155 -- skipped if either entity is an operator in package Standard,
6156 -- or if either old or new instance is not from the source program.
6158 if Ada_Version
= Ada_83
6159 and then Sloc
(Old_Id
) > Standard_Location
6160 and then Sloc
(New_Id
) > Standard_Location
6161 and then Comes_From_Source
(Old_Id
)
6162 and then Comes_From_Source
(New_Id
)
6165 Old_Param
: constant Node_Id
:= Declaration_Node
(Old_Formal
);
6166 New_Param
: constant Node_Id
:= Declaration_Node
(New_Formal
);
6169 -- Explicit IN must be present or absent in both cases. This
6170 -- test is required only in the full conformance case.
6172 if In_Present
(Old_Param
) /= In_Present
(New_Param
)
6173 and then Ctype
= Fully_Conformant
6176 ("\(Ada 83) IN must appear in both declarations",
6181 -- Grouping (use of comma in param lists) must be the same
6182 -- This is where we catch a misconformance like:
6185 -- A : Integer; B : Integer
6187 -- which are represented identically in the tree except
6188 -- for the setting of the flags More_Ids and Prev_Ids.
6190 if More_Ids
(Old_Param
) /= More_Ids
(New_Param
)
6191 or else Prev_Ids
(Old_Param
) /= Prev_Ids
(New_Param
)
6194 ("\grouping of & does not match!", New_Formal
);
6200 -- This label is required when skipping controlling formals
6202 <<Skip_Controlling_Formal
>>
6204 Next_Formal
(Old_Formal
);
6205 Next_Formal
(New_Formal
);
6208 if Present
(Old_Formal
) then
6209 Conformance_Error
("\too few parameters!");
6212 elsif Present
(New_Formal
) then
6213 Conformance_Error
("\too many parameters!", New_Formal
);
6216 end Check_Conformance
;
6218 -----------------------
6219 -- Check_Conventions --
6220 -----------------------
6222 procedure Check_Conventions
(Typ
: Entity_Id
) is
6223 Ifaces_List
: Elist_Id
;
6225 procedure Check_Convention
(Op
: Entity_Id
);
6226 -- Verify that the convention of inherited dispatching operation Op is
6227 -- consistent among all subprograms it overrides. In order to minimize
6228 -- the search, Search_From is utilized to designate a specific point in
6229 -- the list rather than iterating over the whole list once more.
6231 ----------------------
6232 -- Check_Convention --
6233 ----------------------
6235 procedure Check_Convention
(Op
: Entity_Id
) is
6236 Op_Conv
: constant Convention_Id
:= Convention
(Op
);
6237 Iface_Conv
: Convention_Id
;
6238 Iface_Elmt
: Elmt_Id
;
6239 Iface_Prim_Elmt
: Elmt_Id
;
6240 Iface_Prim
: Entity_Id
;
6243 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
6244 while Present
(Iface_Elmt
) loop
6246 First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
6247 while Present
(Iface_Prim_Elmt
) loop
6248 Iface_Prim
:= Node
(Iface_Prim_Elmt
);
6249 Iface_Conv
:= Convention
(Iface_Prim
);
6251 if Is_Interface_Conformant
(Typ
, Iface_Prim
, Op
)
6252 and then Iface_Conv
/= Op_Conv
6255 ("inconsistent conventions in primitive operations", Typ
);
6257 Error_Msg_Name_1
:= Chars
(Op
);
6258 Error_Msg_Name_2
:= Get_Convention_Name
(Op_Conv
);
6259 Error_Msg_Sloc
:= Sloc
(Op
);
6261 if Comes_From_Source
(Op
) or else No
(Alias
(Op
)) then
6262 if No
(Overridden_Operation
(Op
)) then
6263 Error_Msg_N
("\\primitive % defined #", Typ
);
6266 ("\\overriding operation % with "
6267 & "convention % defined #", Typ
);
6270 else pragma Assert
(Present
(Alias
(Op
)));
6271 Error_Msg_Sloc
:= Sloc
(Alias
(Op
));
6272 Error_Msg_N
("\\inherited operation % with "
6273 & "convention % defined #", Typ
);
6276 Error_Msg_Name_1
:= Chars
(Op
);
6277 Error_Msg_Name_2
:= Get_Convention_Name
(Iface_Conv
);
6278 Error_Msg_Sloc
:= Sloc
(Iface_Prim
);
6279 Error_Msg_N
("\\overridden operation % with "
6280 & "convention % defined #", Typ
);
6282 -- Avoid cascading errors
6287 Next_Elmt
(Iface_Prim_Elmt
);
6290 Next_Elmt
(Iface_Elmt
);
6292 end Check_Convention
;
6296 Prim_Op
: Entity_Id
;
6297 Prim_Op_Elmt
: Elmt_Id
;
6299 -- Start of processing for Check_Conventions
6302 if not Has_Interfaces
(Typ
) then
6306 Collect_Interfaces
(Typ
, Ifaces_List
);
6308 -- The algorithm checks every overriding dispatching operation against
6309 -- all the corresponding overridden dispatching operations, detecting
6310 -- differences in conventions.
6312 Prim_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6313 while Present
(Prim_Op_Elmt
) loop
6314 Prim_Op
:= Node
(Prim_Op_Elmt
);
6316 -- A small optimization: skip the predefined dispatching operations
6317 -- since they always have the same convention.
6319 if not Is_Predefined_Dispatching_Operation
(Prim_Op
) then
6320 Check_Convention
(Prim_Op
);
6323 Next_Elmt
(Prim_Op_Elmt
);
6325 end Check_Conventions
;
6327 ------------------------------
6328 -- Check_Delayed_Subprogram --
6329 ------------------------------
6331 procedure Check_Delayed_Subprogram
(Designator
: Entity_Id
) is
6332 procedure Possible_Freeze
(T
: Entity_Id
);
6333 -- T is the type of either a formal parameter or of the return type. If
6334 -- T is not yet frozen and needs a delayed freeze, then the subprogram
6335 -- itself must be delayed.
6337 ---------------------
6338 -- Possible_Freeze --
6339 ---------------------
6341 procedure Possible_Freeze
(T
: Entity_Id
) is
6342 Scop
: constant Entity_Id
:= Scope
(Designator
);
6345 -- If the subprogram appears within a package instance (which may be
6346 -- the wrapper package of a subprogram instance) the freeze node for
6347 -- that package will freeze the subprogram at the proper place, so
6348 -- do not emit a freeze node for the subprogram, given that it may
6349 -- appear in the wrong scope.
6351 if Ekind
(Scop
) = E_Package
6352 and then not Comes_From_Source
(Scop
)
6353 and then Is_Generic_Instance
(Scop
)
6357 elsif Has_Delayed_Freeze
(T
) and then not Is_Frozen
(T
) then
6358 Set_Has_Delayed_Freeze
(Designator
);
6360 elsif Is_Access_Type
(T
)
6361 and then Has_Delayed_Freeze
(Designated_Type
(T
))
6362 and then not Is_Frozen
(Designated_Type
(T
))
6364 Set_Has_Delayed_Freeze
(Designator
);
6366 end Possible_Freeze
;
6372 -- Start of processing for Check_Delayed_Subprogram
6375 -- All subprograms, including abstract subprograms, may need a freeze
6376 -- node if some formal type or the return type needs one.
6378 Possible_Freeze
(Etype
(Designator
));
6379 Possible_Freeze
(Base_Type
(Etype
(Designator
))); -- needed ???
6381 -- Need delayed freeze if any of the formal types themselves need a
6382 -- delayed freeze and are not yet frozen.
6384 F
:= First_Formal
(Designator
);
6385 while Present
(F
) loop
6386 Possible_Freeze
(Etype
(F
));
6387 Possible_Freeze
(Base_Type
(Etype
(F
))); -- needed ???
6391 -- Mark functions that return by reference. Note that it cannot be done
6392 -- for delayed_freeze subprograms because the underlying returned type
6393 -- may not be known yet (for private types).
6395 if not Has_Delayed_Freeze
(Designator
) and then Expander_Active
then
6396 Compute_Returns_By_Ref
(Designator
);
6398 end Check_Delayed_Subprogram
;
6400 ------------------------------------
6401 -- Check_Discriminant_Conformance --
6402 ------------------------------------
6404 procedure Check_Discriminant_Conformance
6409 Old_Discr
: Entity_Id
:= First_Discriminant
(Prev
);
6410 New_Discr
: Node_Id
:= First
(Discriminant_Specifications
(N
));
6411 New_Discr_Id
: Entity_Id
;
6412 New_Discr_Type
: Entity_Id
;
6414 procedure Conformance_Error
(Msg
: String; N
: Node_Id
);
6415 -- Post error message for conformance error on given node. Two messages
6416 -- are output. The first points to the previous declaration with a
6417 -- general "no conformance" message. The second is the detailed reason,
6418 -- supplied as Msg. The parameter N provide information for a possible
6419 -- & insertion in the message.
6421 -----------------------
6422 -- Conformance_Error --
6423 -----------------------
6425 procedure Conformance_Error
(Msg
: String; N
: Node_Id
) is
6427 Error_Msg_Sloc
:= Sloc
(Prev_Loc
);
6428 Error_Msg_N
-- CODEFIX
6429 ("not fully conformant with declaration#!", N
);
6430 Error_Msg_NE
(Msg
, N
, N
);
6431 end Conformance_Error
;
6433 -- Start of processing for Check_Discriminant_Conformance
6436 while Present
(Old_Discr
) and then Present
(New_Discr
) loop
6437 New_Discr_Id
:= Defining_Identifier
(New_Discr
);
6439 -- The subtype mark of the discriminant on the full type has not
6440 -- been analyzed so we do it here. For an access discriminant a new
6443 if Nkind
(Discriminant_Type
(New_Discr
)) = N_Access_Definition
then
6445 Access_Definition
(N
, Discriminant_Type
(New_Discr
));
6448 Find_Type
(Discriminant_Type
(New_Discr
));
6449 New_Discr_Type
:= Etype
(Discriminant_Type
(New_Discr
));
6451 -- Ada 2005: if the discriminant definition carries a null
6452 -- exclusion, create an itype to check properly for consistency
6453 -- with partial declaration.
6455 if Is_Access_Type
(New_Discr_Type
)
6456 and then Null_Exclusion_Present
(New_Discr
)
6459 Create_Null_Excluding_Itype
6460 (T
=> New_Discr_Type
,
6461 Related_Nod
=> New_Discr
,
6462 Scope_Id
=> Current_Scope
);
6466 if not Conforming_Types
6467 (Etype
(Old_Discr
), New_Discr_Type
, Fully_Conformant
)
6469 Conformance_Error
("type of & does not match!", New_Discr_Id
);
6472 -- Treat the new discriminant as an occurrence of the old one,
6473 -- for navigation purposes, and fill in some semantic
6474 -- information, for completeness.
6476 Generate_Reference
(Old_Discr
, New_Discr_Id
, 'r');
6477 Set_Etype
(New_Discr_Id
, Etype
(Old_Discr
));
6478 Set_Scope
(New_Discr_Id
, Scope
(Old_Discr
));
6483 if Chars
(Old_Discr
) /= Chars
(Defining_Identifier
(New_Discr
)) then
6484 Conformance_Error
("name & does not match!", New_Discr_Id
);
6488 -- Default expressions must match
6491 NewD
: constant Boolean :=
6492 Present
(Expression
(New_Discr
));
6493 OldD
: constant Boolean :=
6494 Present
(Expression
(Parent
(Old_Discr
)));
6497 if NewD
or OldD
then
6499 -- The old default value has been analyzed and expanded,
6500 -- because the current full declaration will have frozen
6501 -- everything before. The new default values have not been
6502 -- expanded, so expand now to check conformance.
6505 Preanalyze_Spec_Expression
6506 (Expression
(New_Discr
), New_Discr_Type
);
6509 if not (NewD
and OldD
)
6510 or else not Fully_Conformant_Expressions
6511 (Expression
(Parent
(Old_Discr
)),
6512 Expression
(New_Discr
))
6516 ("default expression for & does not match!",
6523 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
6525 if Ada_Version
= Ada_83
then
6527 Old_Disc
: constant Node_Id
:= Declaration_Node
(Old_Discr
);
6530 -- Grouping (use of comma in param lists) must be the same
6531 -- This is where we catch a misconformance like:
6534 -- A : Integer; B : Integer
6536 -- which are represented identically in the tree except
6537 -- for the setting of the flags More_Ids and Prev_Ids.
6539 if More_Ids
(Old_Disc
) /= More_Ids
(New_Discr
)
6540 or else Prev_Ids
(Old_Disc
) /= Prev_Ids
(New_Discr
)
6543 ("grouping of & does not match!", New_Discr_Id
);
6549 Next_Discriminant
(Old_Discr
);
6553 if Present
(Old_Discr
) then
6554 Conformance_Error
("too few discriminants!", Defining_Identifier
(N
));
6557 elsif Present
(New_Discr
) then
6559 ("too many discriminants!", Defining_Identifier
(New_Discr
));
6562 end Check_Discriminant_Conformance
;
6564 -----------------------------------------
6565 -- Check_Formal_Subprogram_Conformance --
6566 -----------------------------------------
6568 procedure Check_Formal_Subprogram_Conformance
6569 (New_Id
: Entity_Id
;
6573 Conforms
: out Boolean)
6579 if Is_Formal_Subprogram
(Old_Id
)
6580 or else Is_Formal_Subprogram
(New_Id
)
6581 or else (Is_Subprogram
(New_Id
)
6582 and then Present
(Alias
(New_Id
))
6583 and then Is_Formal_Subprogram
(Alias
(New_Id
)))
6585 if Present
(Err_Loc
) then
6594 Error_Msg_Sloc
:= Sloc
(Old_Id
);
6595 Error_Msg_N
("not subtype conformant with declaration#!", N
);
6597 ("\formal subprograms are not subtype conformant "
6598 & "(RM 6.3.1 (17/3))", N
, New_Id
);
6601 end Check_Formal_Subprogram_Conformance
;
6603 procedure Check_Formal_Subprogram_Conformance
6604 (New_Id
: Entity_Id
;
6606 Err_Loc
: Node_Id
:= Empty
)
6610 Check_Formal_Subprogram_Conformance
6611 (New_Id
, Old_Id
, Err_Loc
, True, Ignore
);
6612 end Check_Formal_Subprogram_Conformance
;
6614 ----------------------------
6615 -- Check_Fully_Conformant --
6616 ----------------------------
6618 procedure Check_Fully_Conformant
6619 (New_Id
: Entity_Id
;
6621 Err_Loc
: Node_Id
:= Empty
)
6624 pragma Warnings
(Off
, Result
);
6627 (New_Id
, Old_Id
, Fully_Conformant
, True, Result
, Err_Loc
);
6628 end Check_Fully_Conformant
;
6630 --------------------------
6631 -- Check_Limited_Return --
6632 --------------------------
6634 procedure Check_Limited_Return
6640 -- Ada 2005 (AI-318-02): Return-by-reference types have been removed and
6641 -- replaced by anonymous access results. This is an incompatibility with
6642 -- Ada 95. Not clear whether this should be enforced yet or perhaps
6643 -- controllable with special switch. ???
6645 -- A limited interface that is not immutably limited is OK
6647 if Is_Limited_Interface
(R_Type
)
6648 and then not Is_Concurrent_Interface
(R_Type
)
6652 elsif Is_Limited_Type
(R_Type
)
6653 and then not Is_Interface
(R_Type
)
6654 and then not (Nkind
(N
) = N_Simple_Return_Statement
6655 and then Comes_From_Extended_Return_Statement
(N
))
6656 and then not In_Instance_Body
6657 and then not OK_For_Limited_Init_In_05
(R_Type
, Expr
)
6659 -- Error in Ada 2005
6661 if Ada_Version
>= Ada_2005
6662 and then not Debug_Flag_Dot_L
6663 and then not GNAT_Mode
6666 ("(Ada 2005) cannot copy object of a limited type "
6667 & "(RM-2005 6.5(5.5/2))", Expr
);
6669 if Is_Inherently_Limited_Type
(R_Type
) then
6671 ("\return by reference not permitted in Ada 2005", Expr
);
6674 -- Warn in Ada 95 mode, to give folks a heads up about this
6677 -- In GNAT mode, this is just a warning, to allow it to be evilly
6678 -- turned off. Otherwise it is a real error.
6680 -- In a generic context, simplify the warning because it makes no
6681 -- sense to discuss pass-by-reference or copy.
6683 elsif Warn_On_Ada_2005_Compatibility
or GNAT_Mode
then
6684 if Inside_A_Generic
then
6686 ("return of limited object not permitted in Ada 2005 "
6687 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
6689 elsif Is_Inherently_Limited_Type
(R_Type
) then
6691 ("return by reference not permitted in Ada 2005 "
6692 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
6695 ("cannot copy object of a limited type in Ada 2005 "
6696 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
6699 -- Ada 95 mode, and compatibility warnings disabled
6702 pragma Assert
(Ada_Version
<= Ada_95
);
6703 pragma Assert
(not (Warn_On_Ada_2005_Compatibility
or GNAT_Mode
));
6704 return; -- skip continuation messages below
6707 if not Inside_A_Generic
then
6709 ("\consider switching to return of access type", Expr
);
6710 Explain_Limited_Type
(R_Type
, Expr
);
6713 end Check_Limited_Return
;
6715 ---------------------------
6716 -- Check_Mode_Conformant --
6717 ---------------------------
6719 procedure Check_Mode_Conformant
6720 (New_Id
: Entity_Id
;
6722 Err_Loc
: Node_Id
:= Empty
;
6723 Get_Inst
: Boolean := False)
6726 pragma Warnings
(Off
, Result
);
6729 (New_Id
, Old_Id
, Mode_Conformant
, True, Result
, Err_Loc
, Get_Inst
);
6730 end Check_Mode_Conformant
;
6732 --------------------------------
6733 -- Check_Overriding_Indicator --
6734 --------------------------------
6736 procedure Check_Overriding_Indicator
6738 Overridden_Subp
: Entity_Id
;
6739 Is_Primitive
: Boolean)
6745 -- No overriding indicator for literals
6747 if Ekind
(Subp
) = E_Enumeration_Literal
then
6750 elsif Ekind
(Subp
) = E_Entry
then
6751 Decl
:= Parent
(Subp
);
6753 -- No point in analyzing a malformed operator
6755 elsif Nkind
(Subp
) = N_Defining_Operator_Symbol
6756 and then Error_Posted
(Subp
)
6761 Decl
:= Unit_Declaration_Node
(Subp
);
6764 if Nkind
(Decl
) in N_Subprogram_Body
6765 | N_Subprogram_Body_Stub
6766 | N_Subprogram_Declaration
6767 | N_Abstract_Subprogram_Declaration
6768 | N_Subprogram_Renaming_Declaration
6770 Spec
:= Specification
(Decl
);
6772 elsif Nkind
(Decl
) = N_Entry_Declaration
then
6779 -- An overriding indication is illegal on a subprogram declared
6780 -- in a protected body, where there is no operation to override.
6782 if (Must_Override
(Spec
) or else Must_Not_Override
(Spec
))
6783 and then Is_List_Member
(Decl
)
6784 and then Present
(Parent
(List_Containing
(Decl
)))
6785 and then Nkind
(Parent
(List_Containing
(Decl
))) = N_Protected_Body
6788 ("illegal overriding indication in protected body", Decl
);
6792 -- The overriding operation is type conformant with the overridden one,
6793 -- but the names of the formals are not required to match. If the names
6794 -- appear permuted in the overriding operation, this is a possible
6795 -- source of confusion that is worth diagnosing. Controlling formals
6796 -- often carry names that reflect the type, and it is not worthwhile
6797 -- requiring that their names match.
6799 if Present
(Overridden_Subp
)
6800 and then Nkind
(Subp
) /= N_Defining_Operator_Symbol
6807 Form1
:= First_Formal
(Subp
);
6808 Form2
:= First_Formal
(Overridden_Subp
);
6810 -- If the overriding operation is a synchronized operation, skip
6811 -- the first parameter of the overridden operation, which is
6812 -- implicit in the new one. If the operation is declared in the
6813 -- body it is not primitive and all formals must match.
6815 if Is_Concurrent_Type
(Scope
(Subp
))
6816 and then Is_Tagged_Type
(Scope
(Subp
))
6817 and then not Has_Completion
(Scope
(Subp
))
6819 Form2
:= Next_Formal
(Form2
);
6822 if Present
(Form1
) then
6823 Form1
:= Next_Formal
(Form1
);
6824 Form2
:= Next_Formal
(Form2
);
6827 while Present
(Form1
) loop
6828 if not Is_Controlling_Formal
(Form1
)
6829 and then Present
(Next_Formal
(Form2
))
6830 and then Chars
(Form1
) = Chars
(Next_Formal
(Form2
))
6832 Error_Msg_Node_2
:= Alias
(Overridden_Subp
);
6833 Error_Msg_Sloc
:= Sloc
(Error_Msg_Node_2
);
6835 ("& does not match corresponding formal of&#",
6840 Next_Formal
(Form1
);
6841 Next_Formal
(Form2
);
6846 -- If there is an overridden subprogram, then check that there is no
6847 -- "not overriding" indicator, and mark the subprogram as overriding.
6849 -- This is not done if the overridden subprogram is marked as hidden,
6850 -- which can occur for the case of inherited controlled operations
6851 -- (see Derive_Subprogram), unless the inherited subprogram's parent
6852 -- subprogram is not itself hidden or we are within a generic instance,
6853 -- in which case the hidden flag may have been modified for the
6854 -- expansion of the instance.
6856 -- (Note: This condition could probably be simplified, leaving out the
6857 -- testing for the specific controlled cases, but it seems safer and
6858 -- clearer this way, and echoes similar special-case tests of this
6859 -- kind in other places.)
6861 if Present
(Overridden_Subp
)
6862 and then (not Is_Hidden
(Overridden_Subp
)
6864 (Chars
(Overridden_Subp
) in Name_Initialize
6867 and then Present
(Alias
(Overridden_Subp
))
6868 and then (not Is_Hidden
(Alias
(Overridden_Subp
))
6869 or else In_Instance
)))
6871 if Must_Not_Override
(Spec
) then
6872 Error_Msg_Sloc
:= Sloc
(Overridden_Subp
);
6874 if Ekind
(Subp
) = E_Entry
then
6876 ("entry & overrides inherited operation #", Spec
, Subp
);
6879 ("subprogram & overrides inherited operation #", Spec
, Subp
);
6882 -- Special-case to fix a GNAT oddity: Limited_Controlled is declared
6883 -- as an extension of Root_Controlled, and thus has a useless Adjust
6884 -- operation. This operation should not be inherited by other limited
6885 -- controlled types. An explicit Adjust for them is not overriding.
6887 elsif Must_Override
(Spec
)
6888 and then Chars
(Overridden_Subp
) = Name_Adjust
6889 and then Is_Limited_Type
(Etype
(First_Formal
(Subp
)))
6890 and then Present
(Alias
(Overridden_Subp
))
6891 and then In_Predefined_Unit
(Alias
(Overridden_Subp
))
6894 (Unit_File_Name
(Get_Source_Unit
(Alias
(Overridden_Subp
))));
6895 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
6897 elsif Is_Subprogram
(Subp
) then
6898 if Is_Init_Proc
(Subp
) then
6901 elsif No
(Overridden_Operation
(Subp
)) then
6903 -- For entities generated by Derive_Subprograms the overridden
6904 -- operation is the inherited primitive (which is available
6905 -- through the attribute alias)
6907 if (Is_Dispatching_Operation
(Subp
)
6908 or else Is_Dispatching_Operation
(Overridden_Subp
))
6909 and then not Comes_From_Source
(Overridden_Subp
)
6910 and then Find_Dispatching_Type
(Overridden_Subp
) =
6911 Find_Dispatching_Type
(Subp
)
6912 and then Present
(Alias
(Overridden_Subp
))
6913 and then Comes_From_Source
(Alias
(Overridden_Subp
))
6915 Set_Overridden_Operation
(Subp
, Alias
(Overridden_Subp
));
6916 Inherit_Subprogram_Contract
(Subp
, Alias
(Overridden_Subp
));
6917 Set_Is_Ada_2022_Only
(Subp
,
6918 Is_Ada_2022_Only
(Alias
(Overridden_Subp
)));
6921 Set_Overridden_Operation
(Subp
, Overridden_Subp
);
6922 Inherit_Subprogram_Contract
(Subp
, Overridden_Subp
);
6923 Set_Is_Ada_2022_Only
(Subp
,
6924 Is_Ada_2022_Only
(Overridden_Subp
));
6929 -- If primitive flag is set or this is a protected operation, then
6930 -- the operation is overriding at the point of its declaration, so
6931 -- warn if necessary. Otherwise it may have been declared before the
6932 -- operation it overrides and no check is required.
6935 and then not Must_Override
(Spec
)
6936 and then (Is_Primitive
6937 or else Ekind
(Scope
(Subp
)) = E_Protected_Type
)
6939 Style
.Missing_Overriding
(Decl
, Subp
);
6942 -- If Subp is an operator, it may override a predefined operation, if
6943 -- it is defined in the same scope as the type to which it applies.
6944 -- In that case Overridden_Subp is empty because of our implicit
6945 -- representation for predefined operators. We have to check whether the
6946 -- signature of Subp matches that of a predefined operator. Note that
6947 -- first argument provides the name of the operator, and the second
6948 -- argument the signature that may match that of a standard operation.
6949 -- If the indicator is overriding, then the operator must match a
6950 -- predefined signature, because we know already that there is no
6951 -- explicit overridden operation.
6953 elsif Chars
(Subp
) in Any_Operator_Name
then
6954 if Must_Not_Override
(Spec
) then
6956 -- If this is not a primitive or a protected subprogram, then
6957 -- "not overriding" is illegal.
6960 and then Ekind
(Scope
(Subp
)) /= E_Protected_Type
6962 Error_Msg_N
("overriding indicator only allowed "
6963 & "if subprogram is primitive", Subp
);
6965 elsif Can_Override_Operator
(Subp
) then
6967 ("subprogram& overrides predefined operator", Spec
, Subp
);
6970 elsif Must_Override
(Spec
) then
6971 if No
(Overridden_Operation
(Subp
))
6972 and then not Can_Override_Operator
(Subp
)
6974 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
6977 elsif not Error_Posted
(Subp
)
6978 and then Style_Check
6979 and then Can_Override_Operator
(Subp
)
6980 and then not In_Predefined_Unit
(Subp
)
6982 -- If style checks are enabled, indicate that the indicator is
6983 -- missing. However, at the point of declaration, the type of
6984 -- which this is a primitive operation may be private, in which
6985 -- case the indicator would be premature.
6987 if Has_Private_Declaration
(Etype
(Subp
))
6988 or else Has_Private_Declaration
(Etype
(First_Formal
(Subp
)))
6992 Style
.Missing_Overriding
(Decl
, Subp
);
6996 elsif Must_Override
(Spec
) then
6997 if Ekind
(Subp
) = E_Entry
then
6998 Error_Msg_NE
("entry & is not overriding", Spec
, Subp
);
7000 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
7003 -- If the operation is marked "not overriding" and it's not primitive
7004 -- then an error is issued, unless this is an operation of a task or
7005 -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
7006 -- has been specified have already been checked above.
7008 elsif Must_Not_Override
(Spec
)
7009 and then not Is_Primitive
7010 and then Ekind
(Subp
) /= E_Entry
7011 and then Ekind
(Scope
(Subp
)) /= E_Protected_Type
7014 ("overriding indicator only allowed if subprogram is primitive",
7018 end Check_Overriding_Indicator
;
7024 -- Note: this procedure needs to know far too much about how the expander
7025 -- messes with exceptions. The use of the flag Exception_Junk and the
7026 -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
7027 -- works, but is not very clean. It would be better if the expansion
7028 -- routines would leave Original_Node working nicely, and we could use
7029 -- Original_Node here to ignore all the peculiar expander messing ???
7031 procedure Check_Returns
7035 Proc
: Entity_Id
:= Empty
)
7037 pragma Assert
(Mode
in 'F' |
'P');
7038 pragma Assert
(if Mode
= 'F' then No
(Proc
));
7041 procedure Check_Statement_Sequence
(L
: List_Id
);
7042 -- Internal recursive procedure to check a list of statements for proper
7043 -- termination by a return statement (or a transfer of control or a
7044 -- compound statement that is itself internally properly terminated).
7046 ------------------------------
7047 -- Check_Statement_Sequence --
7048 ------------------------------
7050 procedure Check_Statement_Sequence
(L
: List_Id
) is
7055 function Assert_False
return Boolean;
7056 -- Returns True if Last_Stm is a pragma Assert (False) that has been
7057 -- rewritten as a null statement when assertions are off. The assert
7058 -- is not active, but it is still enough to kill the warning.
7064 function Assert_False
return Boolean is
7065 Orig
: constant Node_Id
:= Original_Node
(Last_Stm
);
7068 if Nkind
(Orig
) = N_Pragma
7069 and then Pragma_Name
(Orig
) = Name_Assert
7070 and then not Error_Posted
(Orig
)
7073 Arg
: constant Node_Id
:=
7074 First
(Pragma_Argument_Associations
(Orig
));
7075 Exp
: constant Node_Id
:= Expression
(Arg
);
7077 return Nkind
(Exp
) = N_Identifier
7078 and then Chars
(Exp
) = Name_False
;
7088 Raise_Exception_Call
: Boolean := False;
7089 -- Set True if statement sequence terminated by Raise_Exception call
7090 -- or a Reraise_Occurrence call.
7092 -- Start of processing for Check_Statement_Sequence
7095 -- Get last real statement
7097 Last_Stm
:= Last
(L
);
7099 -- Deal with digging out exception handler statement sequences that
7100 -- have been transformed by the local raise to goto optimization.
7101 -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
7102 -- optimization has occurred, we are looking at something like:
7105 -- original stmts in block
7109 -- goto L1; | omitted if No_Exception_Propagation
7114 -- goto L3; -- skip handler when exception not raised
7116 -- <<L1>> -- target label for local exception
7130 -- and what we have to do is to dig out the estmts1 and estmts2
7131 -- sequences (which were the original sequences of statements in
7132 -- the exception handlers) and check them.
7134 if Nkind
(Last_Stm
) = N_Label
and then Exception_Junk
(Last_Stm
) then
7139 exit when Nkind
(Stm
) /= N_Block_Statement
;
7140 exit when not Exception_Junk
(Stm
);
7143 exit when Nkind
(Stm
) /= N_Label
;
7144 exit when not Exception_Junk
(Stm
);
7145 Check_Statement_Sequence
7146 (Statements
(Handled_Statement_Sequence
(Next
(Stm
))));
7151 exit when Nkind
(Stm
) /= N_Goto_Statement
;
7152 exit when not Exception_Junk
(Stm
);
7156 -- Don't count pragmas
7158 while Nkind
(Last_Stm
) = N_Pragma
7160 -- Don't count call to SS_Release (can happen after
7161 -- Raise_Exception).
7164 (Nkind
(Last_Stm
) = N_Procedure_Call_Statement
7166 Nkind
(Name
(Last_Stm
)) = N_Identifier
7168 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_SS_Release
))
7170 -- Don't count exception junk
7173 (Nkind
(Last_Stm
) in
7174 N_Goto_Statement | N_Label | N_Object_Declaration
7175 and then Exception_Junk
(Last_Stm
))
7176 or else Nkind
(Last_Stm
) in N_Push_xxx_Label | N_Pop_xxx_Label
7178 -- Inserted code, such as finalization calls, is irrelevant; we
7179 -- only need to check original source. If we see a transfer of
7180 -- control, we stop.
7182 or else (Is_Rewrite_Insertion
(Last_Stm
)
7183 and then not Is_Transfer
(Last_Stm
))
7188 -- Here we have the "real" last statement
7190 Kind
:= Nkind
(Last_Stm
);
7192 -- Transfer of control, OK. Note that in the No_Return procedure
7193 -- case, we already diagnosed any explicit return statements, so
7194 -- we can treat them as OK in this context.
7196 if Is_Transfer
(Last_Stm
) then
7199 -- Check cases of explicit non-indirect procedure calls
7201 elsif Kind
= N_Procedure_Call_Statement
7202 and then Is_Entity_Name
(Name
(Last_Stm
))
7204 -- Check call to Raise_Exception procedure which is treated
7205 -- specially, as is a call to Reraise_Occurrence.
7207 -- We suppress the warning in these cases since it is likely that
7208 -- the programmer really does not expect to deal with the case
7209 -- of Null_Occurrence, and thus would find a warning about a
7210 -- missing return curious, and raising Program_Error does not
7211 -- seem such a bad behavior if this does occur.
7213 -- Note that in the Ada 2005 case for Raise_Exception, the actual
7214 -- behavior will be to raise Constraint_Error (see AI-329).
7216 if Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Raise_Exception
)
7218 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Reraise_Occurrence
)
7220 Raise_Exception_Call
:= True;
7222 -- For Raise_Exception call, test first argument, if it is
7223 -- an attribute reference for a 'Identity call, then we know
7224 -- that the call cannot possibly return.
7227 Arg
: constant Node_Id
:=
7228 Original_Node
(First_Actual
(Last_Stm
));
7230 if Nkind
(Arg
) = N_Attribute_Reference
7231 and then Attribute_Name
(Arg
) = Name_Identity
7238 -- If statement, need to look inside if there is an else and check
7239 -- each constituent statement sequence for proper termination.
7241 elsif Kind
= N_If_Statement
7242 and then Present
(Else_Statements
(Last_Stm
))
7244 Check_Statement_Sequence
(Then_Statements
(Last_Stm
));
7245 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
7248 Elsif_Part
: Node_Id
:= First
(Elsif_Parts
(Last_Stm
));
7251 while Present
(Elsif_Part
) loop
7252 Check_Statement_Sequence
(Then_Statements
(Elsif_Part
));
7259 -- Case statement, check each case for proper termination
7261 elsif Kind
= N_Case_Statement
then
7265 Case_Alt
:= First_Non_Pragma
(Alternatives
(Last_Stm
));
7266 while Present
(Case_Alt
) loop
7267 Check_Statement_Sequence
(Statements
(Case_Alt
));
7268 Next_Non_Pragma
(Case_Alt
);
7274 -- Block statement, check its handled sequence of statements
7276 elsif Kind
= N_Block_Statement
then
7282 (Handled_Statement_Sequence
(Last_Stm
), Mode
, Err1
);
7291 -- Loop statement. If there is an iteration scheme, we can definitely
7292 -- fall out of the loop. Similarly if there is an exit statement, we
7293 -- can fall out. In either case we need a following return.
7295 elsif Kind
= N_Loop_Statement
then
7296 if Present
(Iteration_Scheme
(Last_Stm
))
7297 or else Has_Exit
(Entity
(Identifier
(Last_Stm
)))
7301 -- A loop with no exit statement or iteration scheme is either
7302 -- an infinite loop, or it has some other exit (raise/return).
7303 -- In either case, no warning is required.
7309 -- Timed entry call, check entry call and delay alternatives
7311 -- Note: in expanded code, the timed entry call has been converted
7312 -- to a set of expanded statements on which the check will work
7313 -- correctly in any case.
7315 elsif Kind
= N_Timed_Entry_Call
then
7317 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
7318 DCA
: constant Node_Id
:= Delay_Alternative
(Last_Stm
);
7321 -- If statement sequence of entry call alternative is missing,
7322 -- then we can definitely fall through, and we post the error
7323 -- message on the entry call alternative itself.
7325 if No
(Statements
(ECA
)) then
7328 -- If statement sequence of delay alternative is missing, then
7329 -- we can definitely fall through, and we post the error
7330 -- message on the delay alternative itself.
7332 -- Note: if both ECA and DCA are missing the return, then we
7333 -- post only one message, should be enough to fix the bugs.
7334 -- If not we will get a message next time on the DCA when the
7337 elsif No
(Statements
(DCA
)) then
7340 -- Else check both statement sequences
7343 Check_Statement_Sequence
(Statements
(ECA
));
7344 Check_Statement_Sequence
(Statements
(DCA
));
7349 -- Conditional entry call, check entry call and else part
7351 -- Note: in expanded code, the conditional entry call has been
7352 -- converted to a set of expanded statements on which the check
7353 -- will work correctly in any case.
7355 elsif Kind
= N_Conditional_Entry_Call
then
7357 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
7360 -- If statement sequence of entry call alternative is missing,
7361 -- then we can definitely fall through, and we post the error
7362 -- message on the entry call alternative itself.
7364 if No
(Statements
(ECA
)) then
7367 -- Else check statement sequence and else part
7370 Check_Statement_Sequence
(Statements
(ECA
));
7371 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
7377 -- If we fall through, issue appropriate message
7381 -- Kill warning if last statement is a raise exception call,
7382 -- or a pragma Assert (False). Note that with assertions enabled,
7383 -- such a pragma has been converted into a raise exception call
7384 -- already, so the Assert_False is for the assertions off case.
7386 if not Raise_Exception_Call
and then not Assert_False
then
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);
7565 and then Is_Subprogram (New_Id)
7566 and then Is_Subprogram (Old_Id)
7568 Local_Restrict.Check_Overriding
7569 (Overrider_Op => New_Id,
7570 Overridden_Op => Old_Id);
7572 end Check_Subtype_Conformant;
7574 -----------------------------------
7575 -- Check_Synchronized_Overriding --
7576 -----------------------------------
7578 procedure Check_Synchronized_Overriding
7579 (Def_Id : Entity_Id;
7580 Overridden_Subp : out Entity_Id)
7582 Ifaces_List : Elist_Id;
7586 function Is_Valid_Formal (F : Entity_Id) return Boolean;
7587 -- Predicate for legality rule in 9.4 (11.9/2): If an inherited
7588 -- subprogram is implemented by a protected procedure or entry,
7589 -- its first parameter must be out, in out, or access-to-variable.
7591 function Matches_Prefixed_View_Profile
7592 (Prim_Params : List_Id;
7593 Iface_Params : List_Id) return Boolean;
7594 -- Determine whether a subprogram's parameter profile Prim_Params
7595 -- matches that of a potentially overridden interface subprogram
7596 -- Iface_Params. Also determine if the type of first parameter of
7597 -- Iface_Params is an implemented interface.
7599 ----------------------
7600 -- Is_Valid_Formal --
7601 ----------------------
7603 function Is_Valid_Formal (F : Entity_Id) return Boolean is
7606 Ekind (F) in E_In_Out_Parameter | E_Out_Parameter
7608 (Nkind (Parameter_Type (Parent (F))) = N_Access_Definition
7609 and then not Constant_Present (Parameter_Type (Parent (F))));
7610 end Is_Valid_Formal;
7612 -----------------------------------
7613 -- Matches_Prefixed_View_Profile --
7614 -----------------------------------
7616 function Matches_Prefixed_View_Profile
7617 (Prim_Params : List_Id;
7618 Iface_Params : List_Id) return Boolean
7620 function Is_Implemented
7621 (Ifaces_List : Elist_Id;
7622 Iface : Entity_Id) return Boolean;
7623 -- Determine if Iface is implemented by the current task or
7626 --------------------
7627 -- Is_Implemented --
7628 --------------------
7630 function Is_Implemented
7631 (Ifaces_List : Elist_Id;
7632 Iface : Entity_Id) return Boolean
7634 Iface_Elmt : Elmt_Id;
7637 Iface_Elmt := First_Elmt (Ifaces_List);
7638 while Present (Iface_Elmt) loop
7639 if Node (Iface_Elmt) = Iface then
7643 Next_Elmt (Iface_Elmt);
7651 Iface_Id : Entity_Id;
7652 Iface_Param : Node_Id;
7653 Iface_Typ : Entity_Id;
7654 Prim_Id : Entity_Id;
7655 Prim_Param : Node_Id;
7656 Prim_Typ : Entity_Id;
7658 -- Start of processing for Matches_Prefixed_View_Profile
7661 Iface_Param := First (Iface_Params);
7662 Iface_Typ := Etype (Defining_Identifier (Iface_Param));
7664 if Is_Access_Type (Iface_Typ) then
7665 Iface_Typ := Designated_Type (Iface_Typ);
7668 Prim_Param := First (Prim_Params);
7670 -- The first parameter of the potentially overridden subprogram must
7671 -- be an interface implemented by Prim.
7673 if not Is_Interface (Iface_Typ)
7674 or else not Is_Implemented (Ifaces_List, Iface_Typ)
7679 -- The checks on the object parameters are done, so move on to the
7680 -- rest of the parameters.
7682 if not In_Scope then
7687 while Present (Iface_Param) and then Present (Prim_Param) loop
7688 Iface_Id := Defining_Identifier (Iface_Param);
7689 Iface_Typ := Find_Parameter_Type (Iface_Param);
7691 Prim_Id := Defining_Identifier (Prim_Param);
7692 Prim_Typ := Find_Parameter_Type (Prim_Param);
7694 if Ekind (Iface_Typ) = E_Anonymous_Access_Type
7695 and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
7696 and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
7698 Iface_Typ := Designated_Type (Iface_Typ);
7699 Prim_Typ := Designated_Type (Prim_Typ);
7702 -- Case of multiple interface types inside a parameter profile
7704 -- (Obj_Param : in out Iface; ...; Param : Iface)
7706 -- If the interface type is implemented, then the matching type in
7707 -- the primitive should be the implementing record type.
7709 if Ekind (Iface_Typ) = E_Record_Type
7710 and then Is_Interface (Iface_Typ)
7711 and then Is_Implemented (Ifaces_List, Iface_Typ)
7713 if Prim_Typ /= Typ then
7717 -- The two parameters must be both mode and subtype conformant
7719 elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
7721 Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
7730 -- One of the two lists contains more parameters than the other
7732 if Present (Iface_Param) or else Present (Prim_Param) then
7737 end Matches_Prefixed_View_Profile;
7739 -- Start of processing for Check_Synchronized_Overriding
7742 Overridden_Subp := Empty;
7744 -- Def_Id must be an entry or a subprogram. We should skip predefined
7745 -- primitives internally generated by the front end; however at this
7746 -- stage predefined primitives are still not fully decorated. As a
7747 -- minor optimization we skip here internally generated subprograms.
7749 if (Ekind (Def_Id) /= E_Entry
7750 and then Ekind (Def_Id) /= E_Function
7751 and then Ekind (Def_Id) /= E_Procedure)
7752 or else not Comes_From_Source (Def_Id)
7757 -- Search for the concurrent declaration since it contains the list of
7758 -- all implemented interfaces. In this case, the subprogram is declared
7759 -- within the scope of a protected or a task type.
7761 if Present (Scope (Def_Id))
7762 and then Is_Concurrent_Type (Scope (Def_Id))
7763 and then not Is_Generic_Actual_Type (Scope (Def_Id))
7765 Typ := Scope (Def_Id);
7768 -- The enclosing scope is not a synchronized type and the subprogram
7771 elsif No (First_Formal (Def_Id)) then
7774 -- The subprogram has formals and hence it may be a primitive of a
7778 Typ := Etype (First_Formal (Def_Id));
7780 if Is_Access_Type (Typ) then
7781 Typ := Directly_Designated_Type (Typ);
7784 if Is_Concurrent_Type (Typ)
7785 and then not Is_Generic_Actual_Type (Typ)
7789 -- This case occurs when the concurrent type is declared within a
7790 -- generic unit. As a result the corresponding record has been built
7791 -- and used as the type of the first formal, we just have to retrieve
7792 -- the corresponding concurrent type.
7794 elsif Is_Concurrent_Record_Type (Typ)
7795 and then not Is_Class_Wide_Type (Typ)
7796 and then Present (Corresponding_Concurrent_Type (Typ))
7798 Typ := Corresponding_Concurrent_Type (Typ);
7806 -- There is no overriding to check if this is an inherited operation in
7807 -- a type derivation for a generic actual.
7809 Collect_Interfaces (Typ, Ifaces_List);
7811 if Is_Empty_Elmt_List (Ifaces_List) then
7815 -- Determine whether entry or subprogram Def_Id overrides a primitive
7816 -- operation that belongs to one of the interfaces in Ifaces_List.
7819 Candidate : Entity_Id := Empty;
7820 Hom : Entity_Id := Empty;
7821 Subp : Entity_Id := Empty;
7824 -- Traverse the homonym chain, looking for a potentially overridden
7825 -- subprogram that belongs to an implemented interface.
7827 Hom := Current_Entity_In_Scope (Def_Id);
7828 while Present (Hom) loop
7832 or else not Is_Overloadable (Subp)
7833 or else not Is_Primitive (Subp)
7834 or else not Is_Dispatching_Operation (Subp)
7835 or else No (Find_Dispatching_Type (Subp))
7836 or else not Is_Interface (Find_Dispatching_Type (Subp))
7840 -- Entries and procedures can override abstract or null interface
7843 elsif Ekind (Def_Id) in E_Entry | E_Procedure
7844 and then Ekind (Subp) = E_Procedure
7845 and then Matches_Prefixed_View_Profile
7846 (Parameter_Specifications (Parent (Def_Id)),
7847 Parameter_Specifications (Parent (Subp)))
7851 -- For an overridden subprogram Subp, check whether the mode
7852 -- of its first parameter is correct depending on the kind of
7853 -- synchronized type.
7856 Formal : constant Node_Id := First_Formal (Candidate);
7859 -- In order for an entry or a protected procedure to
7860 -- override, the first parameter of the overridden routine
7861 -- must be of mode "out", "in out", or access-to-variable.
7863 if Ekind (Candidate) in E_Entry | E_Procedure
7864 and then Is_Protected_Type (Typ)
7865 and then not Is_Valid_Formal (Formal)
7869 -- All other cases are OK since a task entry or routine does
7870 -- not have a restriction on the mode of the first parameter
7871 -- of the overridden interface routine.
7874 Overridden_Subp := Candidate;
7879 -- Functions can override abstract interface functions. Return
7880 -- types must be subtype conformant.
7882 elsif Ekind (Def_Id) = E_Function
7883 and then Ekind (Subp) = E_Function
7884 and then Matches_Prefixed_View_Profile
7885 (Parameter_Specifications (Parent (Def_Id)),
7886 Parameter_Specifications (Parent (Subp)))
7887 and then Conforming_Types
7888 (Etype (Def_Id), Etype (Subp), Subtype_Conformant)
7892 -- If an inherited subprogram is implemented by a protected
7893 -- function, then the first parameter of the inherited
7894 -- subprogram shall be of mode in, but not an access-to-
7895 -- variable parameter (RM 9.4(11/9)).
7897 if Present (First_Formal (Subp))
7898 and then Ekind (First_Formal (Subp)) = E_In_Parameter
7900 (not Is_Access_Type (Etype (First_Formal (Subp)))
7902 Is_Access_Constant (Etype (First_Formal (Subp))))
7904 Overridden_Subp := Subp;
7909 Hom := Homonym (Hom);
7912 -- After examining all candidates for overriding, we are left with
7913 -- the best match, which is a mode-incompatible interface routine.
7915 if In_Scope and then Present (Candidate) then
7916 Error_Msg_PT (Def_Id, Candidate);
7919 Overridden_Subp := Candidate;
7922 end Check_Synchronized_Overriding;
7924 ---------------------------
7925 -- Check_Type_Conformant --
7926 ---------------------------
7928 procedure Check_Type_Conformant
7929 (New_Id : Entity_Id;
7931 Err_Loc : Node_Id := Empty)
7934 pragma Warnings (Off, Result);
7937 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
7938 end Check_Type_Conformant;
7940 -----------------------------
7941 -- Check_Untagged_Equality --
7942 -----------------------------
7944 procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
7945 Eq_Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
7946 Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
7948 procedure Freezing_Point_Warning (N : Node_Id; S : String);
7949 -- Output a warning about the freezing point N of Typ
7951 function Is_Actual_Of_Instantiation
7953 Inst : Node_Id) return Boolean;
7954 -- Return True if E is an actual parameter of instantiation Inst
7956 -----------------------------------
7957 -- Output_Freezing_Point_Warning --
7958 -----------------------------------
7960 procedure Freezing_Point_Warning (N : Node_Id; S : String) is
7962 Error_Msg_String (1 .. S'Length) := S;
7963 Error_Msg_Strlen := S'Length;
7965 if Ada_Version >= Ada_2012 then
7966 Error_Msg_NE ("type& is frozen by ~??", N, Typ);
7968 ("\an equality operator cannot be declared after this point??",
7972 Error_Msg_NE ("type& is frozen by ~ (Ada 2012)?y?", N, Typ);
7974 ("\an equality operator cannot be declared after this point"
7975 & " (Ada 2012)?y?", N);
7977 end Freezing_Point_Warning;
7979 --------------------------------
7980 -- Is_Actual_Of_Instantiation --
7981 --------------------------------
7983 function Is_Actual_Of_Instantiation
7985 Inst : Node_Id) return Boolean
7990 if Present (Generic_Associations (Inst)) then
7991 Assoc := First (Generic_Associations (Inst));
7993 while Present (Assoc) loop
7994 if Present (Explicit_Generic_Actual_Parameter (Assoc))
7996 Is_Entity_Name (Explicit_Generic_Actual_Parameter (Assoc))
7998 Entity (Explicit_Generic_Actual_Parameter (Assoc)) = E
8008 end Is_Actual_Of_Instantiation;
8014 -- Start of processing for Check_Untagged_Equality
8017 -- This check applies only if we have a subprogram declaration or a
8018 -- subprogram body that is not a completion, for an untagged record
8019 -- type, and that is conformant with the predefined operator.
8021 if (Nkind (Eq_Decl) /= N_Subprogram_Declaration
8022 and then not (Nkind (Eq_Decl) = N_Subprogram_Body
8023 and then Acts_As_Spec (Eq_Decl)))
8024 or else not Is_Record_Type (Typ)
8025 or else Is_Tagged_Type (Typ)
8026 or else not Is_User_Defined_Equality (Eq_Op)
8031 -- In Ada 2012 case, we will output errors or warnings depending on
8032 -- the setting of debug flag -gnatd.E.
8034 if Ada_Version >= Ada_2012 then
8035 Error_Msg_Warn := Debug_Flag_Dot_EE;
8037 -- In earlier versions of Ada, nothing to do unless we are warning on
8038 -- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set).
8041 if not Warn_On_Ada_2012_Compatibility then
8046 -- Cases where the type has already been frozen
8048 if Is_Frozen (Typ) then
8050 -- The check applies to a primitive operation, so check that type
8051 -- and equality operation are in the same scope.
8053 if Scope (Typ) /= Current_Scope then
8056 -- If the type is a generic actual (sub)type, the operation is not
8057 -- primitive either because the base type is declared elsewhere.
8059 elsif Is_Generic_Actual_Type (Typ) then
8062 -- Here we may have an error of declaration after freezing, but we
8063 -- must make sure not to flag the equality operator itself causing
8064 -- the freezing when it is a subprogram body.
8067 Decl := Next (Declaration_Node (Typ));
8069 while Present (Decl) and then Decl /= Eq_Decl loop
8071 -- The declaration of an object of the type
8073 if Nkind (Decl) = N_Object_Declaration
8074 and then Etype (Defining_Identifier (Decl)) = Typ
8076 Freezing_Point_Warning (Decl, "declaration");
8079 -- The instantiation of a generic on the type
8081 elsif Nkind (Decl) in N_Generic_Instantiation
8082 and then Is_Actual_Of_Instantiation (Typ, Decl)
8084 Freezing_Point_Warning (Decl, "instantiation");
8087 -- A noninstance proper body, body stub or entry body
8089 elsif Nkind (Decl) in N_Proper_Body
8092 and then not Is_Generic_Instance (Defining_Entity (Decl))
8094 Freezing_Point_Warning (Decl, "body");
8097 -- If we have reached the freeze node and immediately after we
8098 -- have the body or generated code for the body, then it is the
8099 -- body that caused the freezing and this is legal.
8101 elsif Nkind (Decl) = N_Freeze_Entity
8102 and then Entity (Decl) = Typ
8103 and then (Next (Decl) = Eq_Decl
8105 Sloc (Next (Decl)) = Sloc (Eq_Decl))
8113 -- Here we have a definite error of declaration after freezing
8115 if Ada_Version >= Ada_2012 then
8117 ("equality operator must be declared before type & is "
8118 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ);
8120 -- In Ada 2012 mode with error turned to warning, output one
8121 -- more warning to warn that the equality operation may not
8122 -- compose. This is the consequence of ignoring the error.
8124 if Error_Msg_Warn then
8125 Error_Msg_N ("\equality operation may not compose??", Eq_Op);
8130 ("equality operator must be declared before type& is "
8131 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ);
8134 -- If we have found no freezing point and the declaration of the
8135 -- operator could not be reached from that of the type and we are
8136 -- in a package body, this must be because the type is declared
8137 -- in the spec of the package. Add a message tailored to this.
8139 if No (Decl) and then In_Package_Body (Scope (Typ)) then
8140 if Ada_Version >= Ada_2012 then
8141 if Nkind (Eq_Decl) = N_Subprogram_Body then
8143 ("\put declaration in package spec<<", Eq_Op);
8146 ("\move declaration to package spec<<", Eq_Op);
8150 if Nkind (Eq_Decl) = N_Subprogram_Body then
8152 ("\put declaration in package spec (Ada 2012)?y?",
8156 ("\move declaration to package spec (Ada 2012)?y?",
8163 -- Now check for AI12-0352: the declaration of a user-defined primitive
8164 -- equality operation for a record type T is illegal if it occurs after
8165 -- a type has been derived from T.
8168 Decl := Next (Declaration_Node (Typ));
8170 while Present (Decl) and then Decl /= Eq_Decl loop
8171 if Nkind (Decl) = N_Full_Type_Declaration
8172 and then Etype (Defining_Identifier (Decl)) = Typ
8175 ("equality operator cannot appear after derivation", Eq_Op);
8177 ("an equality operator for& cannot be declared after "
8185 end Check_Untagged_Equality;
8187 ---------------------------
8188 -- Can_Override_Operator --
8189 ---------------------------
8191 function Can_Override_Operator (Subp : Entity_Id) return Boolean is
8195 -- Return False if not an operator. We test the name rather than testing
8196 -- that the Nkind is N_Defining_Operator_Symbol, because there are cases
8197 -- where an operator entity can be an N_Defining_Identifier (such as for
8198 -- function instantiations).
8200 if Chars (Subp) not in Any_Operator_Name then
8204 Typ := Base_Type (Etype (First_Formal (Subp)));
8206 -- Check explicitly that the operation is a primitive of the type
8208 return Operator_Matches_Spec (Subp, Subp)
8209 and then not Is_Generic_Type (Typ)
8210 and then Scope (Subp) = Scope (Typ)
8211 and then not Is_Class_Wide_Type (Typ);
8213 end Can_Override_Operator;
8215 ----------------------
8216 -- Conforming_Types --
8217 ----------------------
8219 function Conforming_Types
8222 Ctype : Conformance_Type;
8223 Get_Inst : Boolean := False) return Boolean
8225 function Base_Types_Match
8227 Typ_2 : Entity_Id) return Boolean;
8228 -- If neither Typ_1 nor Typ_2 are generic actual types, or if they are
8229 -- in different scopes (e.g. parent and child instances), then verify
8230 -- that the base types are equal. Otherwise Typ_1 and Typ_2 must be on
8231 -- the same subtype chain. The whole purpose of this procedure is to
8232 -- prevent spurious ambiguities in an instantiation that may arise if
8233 -- two distinct generic types are instantiated with the same actual.
8235 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id;
8236 -- An access parameter can designate an incomplete type. If the
8237 -- incomplete type is the limited view of a type from a limited_
8238 -- with_clause, check whether the non-limited view is available.
8239 -- If it is a (non-limited) incomplete type, get the full view.
8241 function Matches_Limited_With_View
8243 Typ_2 : Entity_Id) return Boolean;
8244 -- Returns True if and only if either Typ_1 denotes a limited view of
8245 -- Typ_2 or Typ_2 denotes a limited view of Typ_1. This can arise when
8246 -- the limited with view of a type is used in a subprogram declaration
8247 -- and the subprogram body is in the scope of a regular with clause for
8248 -- the same unit. In such a case, the two type entities are considered
8249 -- identical for purposes of conformance checking.
8251 ----------------------
8252 -- Base_Types_Match --
8253 ----------------------
8255 function Base_Types_Match
8257 Typ_2 : Entity_Id) return Boolean
8259 Base_1 : constant Entity_Id := Base_Type (Typ_1);
8260 Base_2 : constant Entity_Id := Base_Type (Typ_2);
8263 if Typ_1 = Typ_2 then
8266 elsif Base_1 = Base_2 then
8268 -- The following is too permissive. A more precise test should
8269 -- check that the generic actual is an ancestor subtype of the
8272 -- See code in Find_Corresponding_Spec that applies an additional
8273 -- filter to handle accidental amiguities in instances.
8276 not Is_Generic_Actual_Type (Typ_1)
8277 or else not Is_Generic_Actual_Type (Typ_2)
8278 or else Scope (Typ_1) /= Scope (Typ_2);
8280 -- If Typ_2 is a generic actual type it is declared as the subtype of
8281 -- the actual. If that actual is itself a subtype we need to use its
8282 -- own base type to check for compatibility.
8284 elsif Ekind (Base_2) = Ekind (Typ_2)
8285 and then Base_1 = Base_Type (Base_2)
8289 elsif Ekind (Base_1) = Ekind (Typ_1)
8290 and then Base_2 = Base_Type (Base_1)
8297 end Base_Types_Match;
8299 --------------------------
8300 -- Find_Designated_Type --
8301 --------------------------
8303 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id is
8307 Desig := Directly_Designated_Type (Typ);
8309 if Ekind (Desig) = E_Incomplete_Type then
8311 -- If regular incomplete type, get full view if available
8313 if Present (Full_View (Desig)) then
8314 Desig := Full_View (Desig);
8316 -- If limited view of a type, get non-limited view if available,
8317 -- and check again for a regular incomplete type.
8319 elsif Present (Non_Limited_View (Desig)) then
8320 Desig := Get_Full_View (Non_Limited_View (Desig));
8325 end Find_Designated_Type;
8327 -------------------------------
8328 -- Matches_Limited_With_View --
8329 -------------------------------
8331 function Matches_Limited_With_View
8333 Typ_2 : Entity_Id) return Boolean
8335 function Is_Matching_Limited_View
8337 View : Entity_Id) return Boolean;
8338 -- Determine whether non-limited view View denotes type Typ in some
8339 -- conformant fashion.
8341 ------------------------------
8342 -- Is_Matching_Limited_View --
8343 ------------------------------
8345 function Is_Matching_Limited_View
8347 View : Entity_Id) return Boolean
8349 Root_Typ : Entity_Id;
8350 Root_View : Entity_Id;
8353 -- The non-limited view directly denotes the type
8358 -- The type is a subtype of the non-limited view
8360 elsif Is_Subtype_Of (Typ, View) then
8363 -- Both the non-limited view and the type denote class-wide types
8365 elsif Is_Class_Wide_Type (Typ)
8366 and then Is_Class_Wide_Type (View)
8368 Root_Typ := Root_Type (Typ);
8369 Root_View := Root_Type (View);
8371 if Root_Typ = Root_View then
8374 -- An incomplete tagged type and its full view may receive two
8375 -- distinct class-wide types when the related package has not
8376 -- been analyzed yet.
8379 -- type T is tagged; -- CW_1
8380 -- type T is tagged null record; -- CW_2
8383 -- This is because the package lacks any semantic information
8384 -- that may eventually link both views of T. As a consequence,
8385 -- a client of the limited view of Pack will see CW_2 while a
8386 -- client of the non-limited view of Pack will see CW_1.
8388 elsif Is_Incomplete_Type (Root_Typ)
8389 and then Present (Full_View (Root_Typ))
8390 and then Full_View (Root_Typ) = Root_View
8394 elsif Is_Incomplete_Type (Root_View)
8395 and then Present (Full_View (Root_View))
8396 and then Full_View (Root_View) = Root_Typ
8403 end Is_Matching_Limited_View;
8405 -- Start of processing for Matches_Limited_With_View
8408 -- In some cases a type imported through a limited_with clause, and
8409 -- its non-limited view are both visible, for example in an anonymous
8410 -- access-to-class-wide type in a formal, or when building the body
8411 -- for a subprogram renaming after the subprogram has been frozen.
8412 -- In these cases both entities designate the same type. In addition,
8413 -- if one of them is an actual in an instance, it may be a subtype of
8414 -- the non-limited view of the other.
8416 if From_Limited_With (Typ_1)
8417 and then From_Limited_With (Typ_2)
8418 and then Available_View (Typ_1) = Available_View (Typ_2)
8422 elsif From_Limited_With (Typ_1) then
8423 return Is_Matching_Limited_View (Typ_2, Available_View (Typ_1));
8425 elsif From_Limited_With (Typ_2) then
8426 return Is_Matching_Limited_View (Typ_1, Available_View (Typ_2));
8431 end Matches_Limited_With_View;
8435 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
8437 Type_1 : Entity_Id := T1;
8438 Type_2 : Entity_Id := T2;
8440 -- Start of processing for Conforming_Types
8443 -- The context is an instance association for a formal access-to-
8444 -- subprogram type; the formal parameter types require mapping because
8445 -- they may denote other formal parameters of the generic unit.
8448 Type_1 := Get_Instance_Of (T1);
8449 Type_2 := Get_Instance_Of (T2);
8452 -- If one of the types is a view of the other introduced by a limited
8453 -- with clause, treat these as conforming for all purposes.
8455 if Matches_Limited_With_View (T1, T2) then
8458 elsif Base_Types_Match (Type_1, Type_2) then
8459 if Ctype <= Mode_Conformant then
8464 Subtypes_Statically_Match (Type_1, Type_2)
8465 and then Dimensions_Match (Type_1, Type_2);
8468 elsif Is_Incomplete_Or_Private_Type (Type_1)
8469 and then Present (Full_View (Type_1))
8470 and then Base_Types_Match (Full_View (Type_1), Type_2)
8473 Ctype <= Mode_Conformant
8474 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
8476 elsif Ekind (Type_2) = E_Incomplete_Type
8477 and then Present (Full_View (Type_2))
8478 and then Base_Types_Match (Type_1, Full_View (Type_2))
8481 Ctype <= Mode_Conformant
8482 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
8484 -- The subtype declared for the formal type in an instantiation and the
8485 -- actual type are conforming. Note that testing Is_Generic_Actual_Type
8486 -- here is not sufficient because the flag is only set in the bodies of
8487 -- instances, which is too late for formal subprograms.
8489 elsif Ekind (Type_2) = E_Private_Subtype
8490 and then Etype (Type_2) = Type_1
8491 and then Present (Generic_Parent_Type (Declaration_Node (Type_2)))
8495 -- In Ada 2012, incomplete types (including limited views) can appear
8496 -- as actuals in instantiations, where they are conformant to the
8497 -- corresponding incomplete formal.
8499 elsif Is_Incomplete_Type (Type_1)
8500 and then Is_Incomplete_Type (Type_2)
8501 and then In_Instance
8502 and then (Used_As_Generic_Actual (Type_1)
8503 or else Used_As_Generic_Actual (Type_2))
8508 -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
8509 -- treated recursively because they carry a signature. As far as
8510 -- conformance is concerned, convention plays no role, and either
8511 -- or both could be access to protected subprograms.
8513 Are_Anonymous_Access_To_Subprogram_Types :=
8514 Ekind (Type_1) in E_Anonymous_Access_Subprogram_Type
8515 | E_Anonymous_Access_Protected_Subprogram_Type
8517 Ekind (Type_2) in E_Anonymous_Access_Subprogram_Type
8518 | E_Anonymous_Access_Protected_Subprogram_Type;
8520 -- Test anonymous access type case. For this case, static subtype
8521 -- matching is required for mode conformance (RM 6.3.1(15)). We check
8522 -- the base types because we may have built internal subtype entities
8523 -- to handle null-excluding types (see Process_Formals).
8525 if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
8527 Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
8529 -- Ada 2005 (AI-254)
8531 or else Are_Anonymous_Access_To_Subprogram_Types
8534 Desig_1 : Entity_Id;
8535 Desig_2 : Entity_Id;
8538 -- In Ada 2005, access constant indicators must match for
8539 -- subtype conformance.
8541 if Ada_Version >= Ada_2005
8542 and then Ctype >= Subtype_Conformant
8544 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
8549 Desig_1 := Find_Designated_Type (Type_1);
8550 Desig_2 := Find_Designated_Type (Type_2);
8552 -- If the context is an instance association for a formal
8553 -- access-to-subprogram type; formal access parameter designated
8554 -- types require mapping because they may denote other formal
8555 -- parameters of the generic unit.
8558 Desig_1 := Get_Instance_Of (Desig_1);
8559 Desig_2 := Get_Instance_Of (Desig_2);
8562 -- It is possible for a Class_Wide_Type to be introduced for an
8563 -- incomplete type, in which case there is a separate class_ wide
8564 -- type for the full view. The types conform if their Etypes
8565 -- conform, i.e. one may be the full view of the other. This can
8566 -- only happen in the context of an access parameter, other uses
8567 -- of an incomplete Class_Wide_Type are illegal.
8569 if Is_Class_Wide_Type (Desig_1)
8571 Is_Class_Wide_Type (Desig_2)
8575 (Etype (Base_Type (Desig_1)),
8576 Etype (Base_Type (Desig_2)), Ctype);
8578 elsif Are_Anonymous_Access_To_Subprogram_Types then
8579 if Ada_Version < Ada_2005 then
8581 Ctype = Type_Conformant
8582 or else Subtypes_Statically_Match (Desig_1, Desig_2);
8584 -- We must check the conformance of the signatures themselves
8588 Conformant : Boolean;
8591 (Desig_1, Desig_2, Ctype, False, Conformant);
8596 -- A limited view of an actual matches the corresponding
8597 -- incomplete formal.
8599 elsif Ekind (Desig_2) = E_Incomplete_Subtype
8600 and then From_Limited_With (Desig_2)
8601 and then Used_As_Generic_Actual (Etype (Desig_2))
8606 return Base_Type (Desig_1) = Base_Type (Desig_2)
8607 and then (Ctype = Type_Conformant
8609 Subtypes_Statically_Match (Desig_1, Desig_2));
8613 -- Otherwise definitely no match
8616 if ((Ekind (Type_1) = E_Anonymous_Access_Type
8617 and then Is_Access_Type (Type_2))
8618 or else (Ekind (Type_2) = E_Anonymous_Access_Type
8619 and then Is_Access_Type (Type_1)))
8622 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
8624 May_Hide_Profile := True;
8629 end Conforming_Types;
8631 --------------------------
8632 -- Create_Extra_Formals --
8633 --------------------------
8635 procedure Create_Extra_Formals (E : Entity_Id) is
8636 First_Extra : Entity_Id := Empty;
8638 Last_Extra : Entity_Id := Empty;
8640 function Add_Extra_Formal
8641 (Assoc_Entity : Entity_Id;
8644 Suffix : String) return Entity_Id;
8645 -- Add an extra formal to the current list of formals and extra formals.
8646 -- The extra formal is added to the end of the list of extra formals,
8647 -- and also returned as the result. These formals are always of mode IN.
8648 -- The new formal has the type Typ, is declared in Scope, and its name
8649 -- is given by a concatenation of the name of Assoc_Entity and Suffix.
8650 -- The following suffixes are currently used. They should not be changed
8651 -- without coordinating with CodePeer, which makes use of these to
8652 -- provide better messages.
8654 -- O denotes the Constrained bit.
8655 -- L denotes the accessibility level.
8656 -- BIP_xxx denotes an extra formal for a build-in-place function. See
8657 -- the full list in exp_ch6.BIP_Formal_Kind.
8659 function Has_Extra_Formals (E : Entity_Id) return Boolean;
8660 -- Determines if E has its extra formals
8662 function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean;
8663 -- Determines if E is a dispatching primitive returning a limited tagged
8664 -- type object since some descendant might return an object with tasks
8665 -- (and therefore need the BIP task extra actuals).
8667 function Needs_Accessibility_Check_Extra
8669 Formal : Node_Id) return Boolean;
8670 -- Determines whether the given formal of E needs an extra formal for
8671 -- supporting accessibility checking. Returns True for both anonymous
8672 -- access formals and formals of named access types that are marked as
8673 -- controlling formals. The latter case can occur when the subprogram
8674 -- Expand_Dispatching_Call creates a subprogram-type and substitutes
8675 -- the types of access-to-class-wide actuals for the anonymous access-
8676 -- to-specific-type of controlling formals.
8678 function Parent_Subprogram (Subp_Id : Entity_Id) return Entity_Id;
8679 -- Subp_Id is a subprogram of a derived type; return its parent
8680 -- subprogram if Subp_Id overrides a parent primitive or derives
8681 -- from a parent primitive, and such parent primitive can have extra
8682 -- formals. Otherwise return Empty.
8684 ----------------------
8685 -- Add_Extra_Formal --
8686 ----------------------
8688 function Add_Extra_Formal
8689 (Assoc_Entity : Entity_Id;
8692 Suffix : String) return Entity_Id
8697 -- A little optimization. Never generate an extra formal for the
8698 -- _init operand of an initialization procedure, since it could
8701 if Chars (Formal) = Name_uInit then
8705 EF := Make_Defining_Identifier (Sloc (Assoc_Entity),
8706 Chars => New_External_Name (Chars (Assoc_Entity),
8709 Mutate_Ekind (EF, E_In_Parameter);
8710 Set_Actual_Subtype (EF, Typ);
8711 Set_Etype (EF, Typ);
8712 Set_Scope (EF, Scope);
8713 Set_Mechanism (EF, Default_Mechanism);
8714 Set_Formal_Validity (EF);
8716 if No (First_Extra) then
8718 Set_Extra_Formals (Scope, EF);
8721 if Present (Last_Extra) then
8722 Set_Extra_Formal (Last_Extra, EF);
8728 end Add_Extra_Formal;
8730 -----------------------
8731 -- Has_Extra_Formals --
8732 -----------------------
8734 function Has_Extra_Formals (E : Entity_Id) return Boolean is
8736 return Present (Extra_Formals (E))
8738 (Ekind (E) = E_Function
8739 and then Present (Extra_Accessibility_Of_Result (E)));
8740 end Has_Extra_Formals;
8742 ---------------------------------
8743 -- Might_Need_BIP_Task_Actuals --
8744 ---------------------------------
8746 function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean is
8747 Subp_Id : Entity_Id;
8748 Func_Typ : Entity_Id;
8751 if Global_No_Tasking or else No_Run_Time_Mode then
8755 -- No further check needed if we know that BIP task actuals are
8758 if Needs_BIP_Task_Actuals (E) then
8762 -- For thunks we must rely on their target entity
8764 if Is_Thunk (E) then
8765 Subp_Id := Thunk_Target (E);
8767 -- For protected subprograms we rely on the subprogram which
8768 -- implements the body of the operation (since it is the entity
8769 -- that may be a dispatching operation).
8771 elsif Is_Protected_Type (Scope (E))
8772 and then Present (Protected_Body_Subprogram (E))
8774 Subp_Id := Protected_Body_Subprogram (E);
8780 -- We check the root type of the return type since the same
8781 -- decision must be taken for all descendants overriding a
8782 -- dispatching operation.
8784 Func_Typ := Root_Type (Underlying_Type (Etype (Subp_Id)));
8786 return Ekind (Subp_Id) = E_Function
8787 and then not Has_Foreign_Convention (Func_Typ)
8788 and then Is_Dispatching_Operation (Subp_Id)
8789 and then Is_Tagged_Type (Func_Typ)
8790 and then Is_Limited_Type (Func_Typ)
8791 and then not Has_Aspect (Func_Typ, Aspect_No_Task_Parts);
8792 end Might_Need_BIP_Task_Actuals;
8794 -------------------------------------
8795 -- Needs_Accessibility_Check_Extra --
8796 -------------------------------------
8798 function Needs_Accessibility_Check_Extra
8800 Formal : Node_Id) return Boolean is
8803 -- For dispatching operations this extra formal is not suppressed
8804 -- since all the derivations must have matching formals.
8806 -- For nondispatching operations it is suppressed if we specifically
8807 -- suppress accessibility checks at the package level for either the
8808 -- subprogram, or the package in which it resides. However, we do
8809 -- not suppress it simply if the scope has accessibility checks
8810 -- suppressed, since this could cause trouble when clients are
8811 -- compiled with a different suppression setting. The explicit checks
8812 -- at the package level are safe from this point of view.
8814 if not Is_Dispatching_Operation (E)
8816 (Explicit_Suppress (E, Accessibility_Check)
8817 or else Explicit_Suppress (Scope (E), Accessibility_Check))
8822 -- Base_Type is applied to handle cases where there is a null
8823 -- exclusion the formal may have an access subtype.
8826 Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
8828 (Is_Controlling_Formal (Formal)
8829 and then Is_Access_Type (Base_Type (Etype (Formal))));
8830 end Needs_Accessibility_Check_Extra;
8832 -----------------------
8833 -- Parent_Subprogram --
8834 -----------------------
8836 function Parent_Subprogram (Subp_Id : Entity_Id) return Entity_Id is
8837 pragma Assert (not Is_Thunk (Subp_Id));
8838 Ovr_E : Entity_Id := Overridden_Operation (Subp_Id);
8839 Ovr_Alias : Entity_Id;
8843 and then Ekind (Ovr_E) = E_Enumeration_Literal
8847 elsif Present (Ovr_E) then
8848 Ovr_Alias := Ultimate_Alias (Ovr_E);
8850 -- There is no real overridden subprogram if there is a mutual
8851 -- reference between the E and its overridden operation. This
8852 -- weird scenery occurs in the following cases:
8854 -- 1) Controlling function wrappers internally built by
8855 -- Make_Controlling_Function_Wrappers.
8857 -- 2) Hidden overridden primitives of type extensions or private
8858 -- extensions (cf. Find_Hidden_Overridden_Primitive). These
8859 -- hidden primitives have suffix 'P
'.
8861 -- 3) Overriding primitives of stub types (see the subprogram
8862 -- Add_RACW_Primitive_Declarations_And_Bodies).
8864 if Ovr_Alias = Subp_Id then
8866 ((Is_Wrapper (Subp_Id)
8867 and then Has_Controlling_Result (Subp_Id))
8868 or else Has_Suffix (Ovr_E, 'P
')
8869 or else Is_RACW_Stub_Type
8870 (Find_Dispatching_Type (Subp_Id))
8871 or else No (Overridden_Operation (Ovr_E)));
8873 if Present (Overridden_Operation (Ovr_E)) then
8874 Ovr_E := Overridden_Operation (Ovr_E);
8876 -- Ovr_E is an internal entity built by Derive_Subprogram and
8877 -- we have no direct way to climb to the corresponding parent
8878 -- subprogram but this internal entity has the extra formals
8879 -- (if any) required for the purpose of checking the extra
8880 -- formals of Subp_Id.
8883 pragma Assert (not Comes_From_Source (Ovr_E));
8886 -- Use as our reference entity the ultimate renaming of the
8887 -- overridden subprogram.
8889 elsif Present (Alias (Ovr_E)) then
8890 pragma Assert (No (Overridden_Operation (Ovr_Alias))
8891 or else Overridden_Operation (Ovr_Alias) /= Ovr_E);
8897 if Present (Ovr_E) and then Has_Reliable_Extra_Formals (Ovr_E) then
8902 end Parent_Subprogram;
8906 Formal_Type : Entity_Id;
8907 May_Have_Alias : Boolean;
8908 Alias_Formal : Entity_Id := Empty;
8909 Alias_Subp : Entity_Id := Empty;
8910 Parent_Formal : Entity_Id := Empty;
8911 Parent_Subp : Entity_Id := Empty;
8914 -- Start of processing for Create_Extra_Formals
8917 pragma Assert (Is_Subprogram_Or_Entry (E)
8918 or else Ekind (E) in E_Subprogram_Type);
8920 -- We never generate extra formals if expansion is not active because we
8921 -- don't need them unless we are generating code.
8923 if not Expander_Active then
8926 -- Enumeration literals have no extra formal; this case occurs when
8927 -- a function renames it.
8929 elsif Ekind (E) = E_Function
8930 and then Ekind (Ultimate_Alias (E)) = E_Enumeration_Literal
8934 -- Extra formals of Initialization procedures are added by the function
8935 -- Exp_Ch3.Init_Formals
8937 elsif Is_Init_Proc (E) then
8940 -- No need to generate extra formals in thunks whose target has no extra
8941 -- formals, but we can have two of them chained (interface and stack).
8943 elsif Is_Thunk (E) and then No (Extra_Formals (Thunk_Target (E))) then
8946 -- If Extra_Formals were already created, don't do it again. This
8947 -- situation may arise for subprogram types created as part of
8948 -- dispatching calls (see Expand_Dispatching_Call).
8950 elsif Has_Extra_Formals (E) then
8953 -- Extra formals of renamings of generic actual subprograms and
8954 -- renamings of instances of generic subprograms are shared. The
8955 -- check performed on the last formal is required to ensure that
8956 -- this is the renaming built by Analyze_Instance_And_Renamings
8957 -- (which shares all the formals); otherwise this would be wrong.
8959 elsif Ekind (E) in E_Function | E_Procedure
8960 and then Is_Generic_Instance (E)
8961 and then Present (Alias (E))
8962 and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E)
8964 pragma Assert (Is_Generic_Instance (E)
8965 = Is_Generic_Instance (Ultimate_Alias (E)));
8967 Create_Extra_Formals (Ultimate_Alias (E));
8969 -- Share the extra formals
8971 Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
8973 if Ekind (E) = E_Function then
8974 Set_Extra_Accessibility_Of_Result (E,
8975 Extra_Accessibility_Of_Result (Ultimate_Alias (E)));
8978 pragma Assert (Extra_Formals_OK (E));
8982 -- Locate the last formal; required by Add_Extra_Formal.
8984 Formal := First_Formal (E);
8985 while Present (Formal) loop
8986 Last_Extra := Formal;
8987 Next_Formal (Formal);
8990 -- We rely on three entities to ensure consistency of extra formals of
8993 -- 1. A reference entity (Ref_E). For thunks it is their target
8994 -- primitive since this ensures that they have exactly the
8995 -- same extra formals; otherwise it is the identity.
8997 -- 2. The parent subprogram; only for derived types and references
8998 -- either the overridden subprogram or the internal entity built
8999 -- by Derive_Subprogram that has the extra formals of the parent
9000 -- subprogram; otherwise it is Empty. This entity ensures matching
9001 -- extra formals in derived types.
9003 -- 3. For renamings, their ultimate alias; this ensures taking the
9004 -- same decision in all the renamings (independently of the Ada
9005 -- mode on which they are compiled). For example:
9008 -- function Id_A (I : access Integer) return access Integer;
9011 -- function Id_B (I : access Integer) return access Integer
9014 if Is_Thunk (E) then
9015 Ref_E := Thunk_Target (E);
9020 if Is_Subprogram (Ref_E) then
9021 Parent_Subp := Parent_Subprogram (Ref_E);
9025 (Is_Subprogram (Ref_E) or else Ekind (Ref_E) = E_Subprogram_Type);
9027 -- If the parent subprogram is available then its ultimate alias of
9028 -- Ref_E is not needed since it will not be used to check its extra
9032 and then May_Have_Alias
9033 and then Present (Alias (Ref_E))
9034 and then Has_Reliable_Extra_Formals (Ultimate_Alias (Ref_E))
9036 Alias_Subp := Ultimate_Alias (Ref_E);
9039 -- Cannot add extra formals to subprograms and access types that have
9040 -- foreign convention nor to subprograms overriding primitives that
9041 -- have foreign convention since the foreign language does not know
9042 -- how to handle these extra formals; same for renamings of entities
9043 -- with foreign convention.
9045 if Has_Foreign_Convention (Ref_E)
9046 or else (Present (Alias_Subp)
9047 and then Has_Foreign_Convention (Alias_Subp))
9052 -- If the subprogram is a predefined dispatching subprogram then don't
9053 -- generate any extra constrained or accessibility level formals. In
9054 -- general we suppress these for internal subprograms (by not calling
9055 -- Freeze_Subprogram and Create_Extra_Formals at all), but internally
9056 -- generated stream attributes do get passed through because extra
9057 -- build-in-place formals are needed in some cases (limited 'Input
).
9059 if Is_Predefined_Internal_Operation
(E
) then
9060 goto Test_For_Func_Result_Extras
;
9063 -- Process the formals relying on the formals of our reference entities:
9064 -- Parent_Formal, Alias_Formal and Formal. Notice that we don't use the
9065 -- formal of Ref_E; we must use the formal of E which is the entity to
9066 -- which we are adding the extra formals.
9068 -- If this is a derived subprogram then the subtypes of the parent
9069 -- subprogram's formal parameters will be used to determine the need
9070 -- for extra formals.
9072 if Present
(Parent_Subp
) then
9074 -- Ensure that the parent subprogram has all its extra formals.
9075 -- Required because its return type may have been a private or
9076 -- an incomplete type, and the extra formals were not added. We
9077 -- protect this call against the weird cases where the parent subp
9078 -- renames this primitive (documented in the body of the local
9079 -- function Parent_Subprogram).
9081 if Ultimate_Alias
(Parent_Subp
) /= Ref_E
then
9082 Create_Extra_Formals
(Parent_Subp
);
9085 Parent_Formal
:= First_Formal
(Parent_Subp
);
9087 -- For concurrent types, the controlling argument of a dispatching
9088 -- primitive implementing an interface primitive is implicit. For
9091 -- type Iface is protected interface;
9094 -- Value : Integer) return Natural is abstract;
9096 -- protected type PO is new Iface with
9097 -- function Prim (Value : Integer) return Natural;
9100 if Convention
(Ref_E
) = Convention_Protected
9101 and then Is_Abstract_Subprogram
(Parent_Subp
)
9102 and then Is_Interface
(Find_Dispatching_Type
(Parent_Subp
))
9104 Parent_Formal
:= Next_Formal
(Parent_Formal
);
9106 -- This is the nondispatching subprogram of a concurrent type
9107 -- that overrides the interface primitive; the expander will
9108 -- create the dispatching primitive (without Convention_Protected)
9109 -- with all the matching formals (see exp_ch9.Build_Wrapper_Specs)
9111 pragma Assert
(not Is_Dispatching_Operation
(Ref_E
));
9114 -- Ensure that the ultimate alias has all its extra formals
9116 elsif Present
(Alias_Subp
) then
9117 Create_Extra_Formals
(Alias_Subp
);
9118 Alias_Formal
:= First_Formal
(Alias_Subp
);
9121 Formal
:= First_Formal
(E
);
9122 while Present
(Formal
) loop
9124 -- Here we establish our priority for deciding on the extra
9125 -- formals: 1) Parent primitive 2) Aliased primitive 3) Identity
9127 if Present
(Parent_Formal
) then
9128 Formal_Type
:= Etype
(Parent_Formal
);
9130 elsif Present
(Alias_Formal
) then
9131 Formal_Type
:= Etype
(Alias_Formal
);
9134 Formal_Type
:= Etype
(Formal
);
9137 -- Create extra formal for supporting the attribute 'Constrained.
9138 -- The case of a private type view without discriminants also
9139 -- requires the extra formal if the underlying type has defaulted
9142 if Ekind
(Formal
) /= E_In_Parameter
then
9144 -- Do not produce extra formals for Unchecked_Union parameters.
9145 -- Jump directly to the end of the loop.
9147 if Is_Unchecked_Union
(Base_Type
(Formal_Type
)) then
9148 goto Skip_Extra_Formal_Generation
;
9151 if not Has_Discriminants
(Formal_Type
)
9152 and then Is_Private_Type
(Formal_Type
)
9153 and then Present
(Underlying_Type
(Formal_Type
))
9155 Formal_Type
:= Underlying_Type
(Formal_Type
);
9158 -- Suppress the extra formal if formal's subtype is constrained or
9159 -- indefinite, or we're compiling for Ada 2012 and the underlying
9160 -- type is tagged and limited. In Ada 2012, a limited tagged type
9161 -- can have defaulted discriminants, but 'Constrained is required
9162 -- to return True, so the formal is never needed (see AI05-0214).
9163 -- Note that this ensures consistency of calling sequences for
9164 -- dispatching operations when some types in a class have defaults
9165 -- on discriminants and others do not (and requiring the extra
9166 -- formal would introduce distributed overhead).
9168 -- If the type does not have a completion yet, treat as prior to
9169 -- Ada 2012 for consistency.
9171 if Has_Discriminants
(Formal_Type
)
9172 and then not Is_Constrained
(Formal_Type
)
9173 and then Is_Definite_Subtype
(Formal_Type
)
9174 and then (Ada_Version
< Ada_2012
9175 or else No
(Underlying_Type
(Formal_Type
))
9177 (Is_Limited_Type
(Formal_Type
)
9180 (Underlying_Type
(Formal_Type
))))
9182 Set_Extra_Constrained
9183 (Formal
, Add_Extra_Formal
(Formal
, Standard_Boolean
, E
, "O"));
9187 -- Extra formal for supporting accessibility checking
9189 if Needs_Accessibility_Check_Extra
(Ref_E
, Formal
) then
9190 pragma Assert
(No
(Parent_Formal
)
9191 or else Present
(Extra_Accessibility
(Parent_Formal
)));
9192 pragma Assert
(No
(Alias_Formal
)
9193 or else Present
(Extra_Accessibility
(Alias_Formal
)));
9195 Set_Extra_Accessibility
9196 (Formal
, Add_Extra_Formal
(Formal
, Standard_Natural
, E
, "L"));
9199 pragma Assert
(No
(Parent_Formal
)
9200 or else No
(Extra_Accessibility
(Parent_Formal
)));
9201 pragma Assert
(No
(Alias_Formal
)
9202 or else No
(Extra_Accessibility
(Alias_Formal
)));
9205 -- This label is required when skipping extra formal generation for
9206 -- Unchecked_Union parameters.
9208 <<Skip_Extra_Formal_Generation
>>
9210 if Present
(Parent_Formal
) then
9211 Next_Formal
(Parent_Formal
);
9214 if Present
(Alias_Formal
) then
9215 Next_Formal
(Alias_Formal
);
9218 Next_Formal
(Formal
);
9221 <<Test_For_Func_Result_Extras
>>
9223 -- Assume the worst case (Ada 2022) to evaluate this extra formal;
9224 -- required to ensure matching of extra formals between subprograms
9225 -- and access-to-subprogram types in projects with mixed Ada dialects.
9228 Save_Ada_Version
: constant Ada_Version_Type
:= Ada_Version
;
9231 Ada_Version
:= Ada_2022
;
9233 if Needs_Result_Accessibility_Level
(Ref_E
)
9235 (Present
(Parent_Subp
)
9236 and then Needs_Result_Accessibility_Level
(Parent_Subp
))
9238 (Present
(Alias_Subp
)
9239 and then Needs_Result_Accessibility_Level
(Alias_Subp
))
9241 Set_Extra_Accessibility_Of_Result
(E
,
9242 Add_Extra_Formal
(E
, Standard_Natural
, E
, "L"));
9245 Ada_Version
:= Save_Ada_Version
;
9248 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
9249 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
9251 if (Present
(Parent_Subp
) and then Has_BIP_Formals
(Parent_Subp
))
9253 (Present
(Alias_Subp
) and then Has_BIP_Formals
(Alias_Subp
))
9255 (Is_Build_In_Place_Function
(Ref_E
)
9256 and then Has_Reliable_Extra_Formals
(Ref_E
))
9259 Result_Subt
: constant Entity_Id
:= Etype
(Ref_E
);
9260 Formal_Typ
: Entity_Id
;
9261 Subp_Decl
: Node_Id
;
9262 Discard
: Entity_Id
;
9265 -- In the case of functions with unconstrained result subtypes,
9266 -- add a 4-state formal indicating whether the return object is
9267 -- allocated by the caller (1), or should be allocated by the
9268 -- callee on the secondary stack (2), in the global heap (3), or
9269 -- in a user-defined storage pool (4). For the moment we just use
9270 -- Natural for the type of this formal. Note that this formal
9271 -- isn't usually needed in the case where the result subtype is
9272 -- constrained, but it is needed when the function has a tagged
9273 -- result, because generally such functions can be called in a
9274 -- dispatching context and such calls must be handled like calls
9275 -- to a class-wide function.
9277 if Needs_BIP_Alloc_Form
(Ref_E
)
9279 (Present
(Parent_Subp
)
9280 and then Has_BIP_Extra_Formal
(Parent_Subp
, BIP_Alloc_Form
,
9281 Must_Be_Frozen
=> False))
9283 (Present
(Alias_Subp
)
9284 and then Has_BIP_Extra_Formal
(Alias_Subp
, BIP_Alloc_Form
,
9285 Must_Be_Frozen
=> False))
9289 (E
, Standard_Natural
,
9290 E
, BIP_Formal_Suffix
(BIP_Alloc_Form
));
9292 -- Add BIP_Storage_Pool, in case BIP_Alloc_Form indicates to
9293 -- use a user-defined pool. This formal is not added on
9294 -- ZFP as those targets do not support pools.
9296 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
9299 (E
, RTE
(RE_Root_Storage_Pool_Ptr
),
9300 E
, BIP_Formal_Suffix
(BIP_Storage_Pool
));
9304 -- In the case of functions whose result type needs finalization,
9305 -- add an extra formal which represents the finalization master.
9307 if Needs_BIP_Finalization_Master
(Ref_E
)
9309 (Present
(Parent_Subp
)
9310 and then Has_BIP_Extra_Formal
(Parent_Subp
,
9311 Kind
=> BIP_Finalization_Master
,
9312 Must_Be_Frozen
=> False))
9314 (Present
(Alias_Subp
)
9315 and then Has_BIP_Extra_Formal
(Alias_Subp
,
9316 Kind
=> BIP_Finalization_Master
,
9317 Must_Be_Frozen
=> False))
9321 (E
, RTE
(RE_Finalization_Master_Ptr
),
9322 E
, BIP_Formal_Suffix
(BIP_Finalization_Master
));
9325 -- When the result type contains tasks, add two extra formals: the
9326 -- master of the tasks to be created, and the caller's activation
9329 if Needs_BIP_Task_Actuals
(Ref_E
)
9330 or else Might_Need_BIP_Task_Actuals
(Ref_E
)
9332 (Present
(Parent_Subp
)
9333 and then Has_BIP_Extra_Formal
(Parent_Subp
, BIP_Task_Master
,
9334 Must_Be_Frozen
=> False))
9336 (Present
(Alias_Subp
)
9337 and then Has_BIP_Extra_Formal
(Alias_Subp
, BIP_Task_Master
,
9338 Must_Be_Frozen
=> False))
9342 (E
, Standard_Integer
,
9343 E
, BIP_Formal_Suffix
(BIP_Task_Master
));
9345 if Needs_BIP_Task_Actuals
(Ref_E
) then
9346 Set_Has_Master_Entity
(E
);
9351 (E
, RTE
(RE_Activation_Chain_Access
),
9352 E
, BIP_Formal_Suffix
(BIP_Activation_Chain
));
9355 -- All build-in-place functions get an extra formal that will be
9356 -- passed the address of the return object within the caller.
9359 Create_Itype
(E_Anonymous_Access_Type
, E
, Scope_Id
=> Scope
(E
));
9361 -- Incomplete_View_From_Limited_With is needed here because
9362 -- gigi gets confused if the designated type is the full view
9363 -- coming from a limited-with'ed package. In the normal case,
9364 -- (no limited with) Incomplete_View_From_Limited_With
9365 -- returns Result_Subt.
9367 Set_Directly_Designated_Type
9368 (Formal_Typ
, Incomplete_View_From_Limited_With
(Result_Subt
));
9369 Set_Etype
(Formal_Typ
, Formal_Typ
);
9370 Set_Depends_On_Private
9371 (Formal_Typ
, Has_Private_Component
(Formal_Typ
));
9372 Set_Is_Public
(Formal_Typ
, Is_Public
(Scope
(Formal_Typ
)));
9373 Set_Is_Access_Constant
(Formal_Typ
, False);
9375 -- Ada 2005 (AI-50217): Propagate the attribute that indicates
9376 -- the designated type comes from the limited view (for back-end
9379 Set_From_Limited_With
9380 (Formal_Typ
, From_Limited_With
(Result_Subt
));
9382 Layout_Type
(Formal_Typ
);
9384 -- Force the definition of the Itype in case of internal function
9385 -- calls within the same or nested scope.
9387 if Is_Subprogram_Or_Generic_Subprogram
(E
)
9388 and then not Is_Compilation_Unit
(E
)
9390 Subp_Decl
:= Parent
(E
);
9392 -- The insertion point for an Itype reference should be after
9393 -- the unit declaration node of the subprogram. An exception
9394 -- to this are inherited operations from a parent type in which
9395 -- case the derived type acts as their parent.
9397 if Nkind
(Subp_Decl
) in N_Function_Specification
9398 | N_Procedure_Specification
9400 Subp_Decl
:= Parent
(Subp_Decl
);
9403 Build_Itype_Reference
(Formal_Typ
, Subp_Decl
);
9408 (E
, Formal_Typ
, E
, BIP_Formal_Suffix
(BIP_Object_Access
));
9412 -- If this is an instance of a generic, we need to have extra formals
9415 if Is_Generic_Instance
(E
) and then Present
(Alias
(E
)) then
9416 Set_Extra_Formals
(Alias
(E
), Extra_Formals
(E
));
9419 pragma Assert
(No
(Alias_Subp
)
9420 or else Extra_Formals_Match_OK
(E
, Alias_Subp
));
9422 pragma Assert
(No
(Parent_Subp
)
9423 or else Extra_Formals_Match_OK
(E
, Parent_Subp
));
9425 pragma Assert
(Extra_Formals_OK
(E
));
9426 end Create_Extra_Formals
;
9428 -----------------------------
9429 -- Enter_Overloaded_Entity --
9430 -----------------------------
9432 procedure Enter_Overloaded_Entity
(S
: Entity_Id
) is
9433 function Matches_Predefined_Op
return Boolean;
9434 -- This returns an approximation of whether S matches a predefined
9435 -- operator, based on the operator symbol, and the parameter and result
9436 -- types. The rules are scattered throughout chapter 4 of the Ada RM.
9438 ---------------------------
9439 -- Matches_Predefined_Op --
9440 ---------------------------
9442 function Matches_Predefined_Op
return Boolean is
9443 Formal_1
: constant Entity_Id
:= First_Formal
(S
);
9444 Formal_2
: constant Entity_Id
:= Next_Formal
(Formal_1
);
9445 Op
: constant Name_Id
:= Chars
(S
);
9446 Result_Type
: constant Entity_Id
:= Base_Type
(Etype
(S
));
9447 Type_1
: constant Entity_Id
:= Base_Type
(Etype
(Formal_1
));
9452 if Present
(Formal_2
) then
9454 Type_2
: constant Entity_Id
:= Base_Type
(Etype
(Formal_2
));
9457 -- All but "&" and "**" have same-types parameters
9466 if Type_1
/= Type_2
then
9471 -- Check parameter and result types
9479 Is_Boolean_Type
(Result_Type
)
9480 and then Result_Type
= Type_1
;
9486 Is_Integer_Type
(Result_Type
)
9487 and then Result_Type
= Type_1
;
9495 Is_Numeric_Type
(Result_Type
)
9496 and then Result_Type
= Type_1
;
9502 Is_Boolean_Type
(Result_Type
)
9503 and then not Is_Limited_Type
(Type_1
);
9511 Is_Boolean_Type
(Result_Type
)
9512 and then (Is_Array_Type
(Type_1
)
9513 or else Is_Scalar_Type
(Type_1
));
9515 when Name_Op_Concat
=>
9516 return Is_Array_Type
(Result_Type
);
9518 when Name_Op_Expon
=>
9520 (Is_Integer_Type
(Result_Type
)
9521 or else Is_Floating_Point_Type
(Result_Type
))
9522 and then Result_Type
= Type_1
9523 and then Type_2
= Standard_Integer
;
9526 raise Program_Error
;
9539 Is_Numeric_Type
(Result_Type
)
9540 and then Result_Type
= Type_1
;
9544 Is_Boolean_Type
(Result_Type
)
9545 and then Result_Type
= Type_1
;
9548 raise Program_Error
;
9551 end Matches_Predefined_Op
;
9555 E
: Entity_Id
:= Current_Entity_In_Scope
(S
);
9556 C_E
: Entity_Id
:= Current_Entity
(S
);
9558 -- Start of processing for Enter_Overloaded_Entity
9562 Set_Has_Homonym
(E
);
9563 Set_Has_Homonym
(S
);
9566 Set_Is_Immediately_Visible
(S
);
9567 Set_Scope
(S
, Current_Scope
);
9569 -- Chain new entity if front of homonym in current scope, so that
9570 -- homonyms are contiguous.
9572 if Present
(E
) and then E
/= C_E
then
9573 while Homonym
(C_E
) /= E
loop
9574 C_E
:= Homonym
(C_E
);
9577 Set_Homonym
(C_E
, S
);
9581 Set_Current_Entity
(S
);
9586 if Is_Inherited_Operation
(S
) then
9587 Append_Inherited_Subprogram
(S
);
9589 Append_Entity
(S
, Current_Scope
);
9592 Set_Public_Status
(S
);
9594 if Debug_Flag_E
then
9595 Write_Str
("New overloaded entity chain: ");
9596 Write_Name
(Chars
(S
));
9599 while Present
(E
) loop
9600 Write_Str
(" "); Write_Int
(Int
(E
));
9607 -- Generate warning for hiding
9610 and then Comes_From_Source
(S
)
9611 and then In_Extended_Main_Source_Unit
(S
)
9618 -- Warn unless genuine overloading. Do not emit warning on
9619 -- hiding predefined operators in Standard (these are either an
9620 -- artifact of our implicit declarations, or simple noise) but
9621 -- keep warning on a operator defined on a local subtype, because
9622 -- of the real danger that different operators may be applied in
9623 -- various parts of the program.
9625 -- Note that if E and S have the same scope, there is never any
9626 -- hiding. Either the two conflict, and the program is illegal,
9627 -- or S is overriding an implicit inherited subprogram.
9629 if Scope
(E
) /= Scope
(S
)
9630 and then (not Is_Overloadable
(E
)
9631 or else Subtype_Conformant
(E
, S
))
9632 and then (Is_Immediately_Visible
(E
)
9633 or else Is_Potentially_Use_Visible
(S
))
9635 if Scope
(E
) = Standard_Standard
then
9636 if Nkind
(S
) = N_Defining_Operator_Symbol
9637 and then Scope
(Base_Type
(Etype
(First_Formal
(S
)))) /=
9639 and then Matches_Predefined_Op
9642 ("declaration of & hides predefined operator?h?", S
);
9645 -- E not immediately within Standard
9648 Error_Msg_Sloc
:= Sloc
(E
);
9649 Error_Msg_N
("declaration of & hides one #?h?", S
);
9654 end Enter_Overloaded_Entity
;
9656 ----------------------------
9657 -- Extra_Formals_Match_OK --
9658 ----------------------------
9660 function Extra_Formals_Match_OK
9662 Ref_E
: Entity_Id
) return Boolean is
9664 pragma Assert
(Is_Subprogram
(E
));
9666 -- Cases where no check can be performed:
9667 -- 1) When expansion is not active (since we never generate extra
9668 -- formals if expansion is not active because we don't need them
9669 -- unless we are generating code).
9670 -- 2) On abstract predefined dispatching operations of Root_Controlled
9671 -- and predefined stream operations not emitted by the frontend.
9672 -- 3) On renamings of abstract predefined dispatching operations of
9673 -- interface types (since limitedness is not inherited in such
9675 -- 4) The controlling formal of the nondispatching subprogram of
9676 -- a concurrent type that overrides an interface primitive is
9677 -- implicit and hence we cannot check here if all its extra
9678 -- formals match; the expander will create the dispatching
9679 -- primitive (without Convention_Protected) with the matching
9680 -- formals (see exp_ch9.Build_Wrapper_Specs) which will be
9683 if Debug_Flag_Underscore_XX
9684 or else not Expander_Active
9686 (Is_Predefined_Dispatching_Operation
(E
)
9687 and then (not Has_Reliable_Extra_Formals
(E
)
9688 or else not Has_Reliable_Extra_Formals
(Ref_E
)))
9690 (Is_Predefined_Dispatching_Operation
(E
)
9691 and then Is_Abstract_Subprogram
(E
)
9692 and then Is_Interface
(Find_Dispatching_Type
(Ref_E
)))
9696 elsif Convention
(E
) = Convention_Protected
9697 and then not Is_Dispatching_Operation
(E
)
9698 and then Is_Abstract_Subprogram
(Ref_E
)
9699 and then Is_Interface
(Find_Dispatching_Type
(Ref_E
))
9704 -- Perform the checks
9706 if No
(Extra_Formals
(E
)) then
9707 return No
(Extra_Formals
(Ref_E
));
9710 if Ekind
(E
) in E_Function | E_Subprogram_Type
9711 and then Present
(Extra_Accessibility_Of_Result
(E
))
9712 /= Present
(Extra_Accessibility_Of_Result
(Ref_E
))
9718 Formal_1
: Entity_Id
:= Extra_Formals
(E
);
9719 Formal_2
: Entity_Id
:= Extra_Formals
(Ref_E
);
9722 while Present
(Formal_1
) and then Present
(Formal_2
) loop
9723 if Has_Suffix
(Formal_1
, 'L') then
9724 if not Has_Suffix
(Formal_2
, 'L') then
9728 elsif Has_Suffix
(Formal_1
, 'O') then
9729 if not Has_Suffix
(Formal_2
, 'O') then
9733 elsif BIP_Suffix_Kind
(Formal_1
) /= BIP_Suffix_Kind
(Formal_2
) then
9737 Formal_1
:= Next_Formal_With_Extras
(Formal_1
);
9738 Formal_2
:= Next_Formal_With_Extras
(Formal_2
);
9741 return No
(Formal_1
) and then No
(Formal_2
);
9743 end Extra_Formals_Match_OK
;
9745 ----------------------
9746 -- Extra_Formals_OK --
9747 ----------------------
9749 function Extra_Formals_OK
(E
: Entity_Id
) return Boolean is
9750 Last_Formal
: Entity_Id
:= Empty
;
9752 Has_Extra_Formals
: Boolean := False;
9755 -- No check required if explicitly disabled
9757 if Debug_Flag_Underscore_XX
then
9760 -- No check required if expansion is disabled because extra
9761 -- formals are only generated when we are generating code.
9762 -- See Create_Extra_Formals.
9764 elsif not Expander_Active
then
9768 -- Check attribute Extra_Formal: If available, it must be set only
9769 -- on the last formal of E.
9771 Formal
:= First_Formal
(E
);
9772 while Present
(Formal
) loop
9773 if Present
(Extra_Formal
(Formal
)) then
9774 if Has_Extra_Formals
then
9778 Has_Extra_Formals
:= True;
9781 Last_Formal
:= Formal
;
9782 Next_Formal
(Formal
);
9785 -- Check attribute Extra_Accessibility_Of_Result
9787 if Ekind
(E
) in E_Function | E_Subprogram_Type
9788 and then Needs_Result_Accessibility_Level
(E
)
9789 and then No
(Extra_Accessibility_Of_Result
(E
))
9794 -- Check attribute Extra_Formals: If E has extra formals, then this
9795 -- attribute must point to the first extra formal of E.
9797 if Has_Extra_Formals
then
9798 return Present
(Extra_Formals
(E
))
9799 and then Present
(Extra_Formal
(Last_Formal
))
9800 and then Extra_Formal
(Last_Formal
) = Extra_Formals
(E
);
9802 -- When E has no formals, the first extra formal is available through
9803 -- the Extra_Formals attribute.
9805 elsif Present
(Extra_Formals
(E
)) then
9806 return No
(First_Formal
(E
));
9811 end Extra_Formals_OK
;
9813 -----------------------------
9814 -- Find_Corresponding_Spec --
9815 -----------------------------
9817 function Find_Corresponding_Spec
9819 Post_Error
: Boolean := True) return Entity_Id
9821 Spec
: constant Node_Id
:= Specification
(N
);
9822 Designator
: constant Entity_Id
:= Defining_Entity
(Spec
);
9826 function Different_Generic_Profile
(E
: Entity_Id
) return Boolean;
9827 -- Even if fully conformant, a body may depend on a generic actual when
9828 -- the spec does not, or vice versa, in which case they were distinct
9829 -- entities in the generic.
9831 -------------------------------
9832 -- Different_Generic_Profile --
9833 -------------------------------
9835 function Different_Generic_Profile
(E
: Entity_Id
) return Boolean is
9838 function Same_Generic_Actual
(T1
, T2
: Entity_Id
) return Boolean;
9839 -- Check that the types of corresponding formals have the same
9840 -- generic actual if any. We have to account for subtypes of a
9841 -- generic formal, declared between a spec and a body, which may
9842 -- appear distinct in an instance but matched in the generic, and
9843 -- the subtype may be used either in the spec or the body of the
9844 -- subprogram being checked.
9846 -------------------------
9847 -- Same_Generic_Actual --
9848 -------------------------
9850 function Same_Generic_Actual
(T1
, T2
: Entity_Id
) return Boolean is
9852 function Is_Declared_Subtype
(S1
, S2
: Entity_Id
) return Boolean;
9853 -- Predicate to check whether S1 is a subtype of S2 in the source
9856 -------------------------
9857 -- Is_Declared_Subtype --
9858 -------------------------
9860 function Is_Declared_Subtype
(S1
, S2
: Entity_Id
) return Boolean is
9862 return Comes_From_Source
(Parent
(S1
))
9863 and then Nkind
(Parent
(S1
)) = N_Subtype_Declaration
9864 and then Is_Entity_Name
(Subtype_Indication
(Parent
(S1
)))
9865 and then Entity
(Subtype_Indication
(Parent
(S1
))) = S2
;
9866 end Is_Declared_Subtype
;
9868 -- Start of processing for Same_Generic_Actual
9871 return Is_Generic_Actual_Type
(T1
) = Is_Generic_Actual_Type
(T2
)
9872 or else Is_Declared_Subtype
(T1
, T2
)
9873 or else Is_Declared_Subtype
(T2
, T1
);
9874 end Same_Generic_Actual
;
9876 -- Start of processing for Different_Generic_Profile
9879 if not In_Instance
then
9882 elsif Ekind
(E
) = E_Function
9883 and then not Same_Generic_Actual
(Etype
(E
), Etype
(Designator
))
9888 F1
:= First_Formal
(Designator
);
9889 F2
:= First_Formal
(E
);
9890 while Present
(F1
) loop
9891 if not Same_Generic_Actual
(Etype
(F1
), Etype
(F2
)) then
9900 end Different_Generic_Profile
;
9902 -- Start of processing for Find_Corresponding_Spec
9905 E
:= Current_Entity
(Designator
);
9906 while Present
(E
) loop
9908 -- We are looking for a matching spec. It must have the same scope,
9909 -- and the same name, and either be type conformant, or be the case
9910 -- of a library procedure spec and its body (which belong to one
9911 -- another regardless of whether they are type conformant or not).
9913 if Scope
(E
) = Current_Scope
then
9914 if Current_Scope
= Standard_Standard
9915 or else (Ekind
(E
) = Ekind
(Designator
)
9916 and then Type_Conformant
(E
, Designator
))
9918 -- Within an instantiation, we know that spec and body are
9919 -- subtype conformant, because they were subtype conformant in
9920 -- the generic. We choose the subtype-conformant entity here as
9921 -- well, to resolve spurious ambiguities in the instance that
9922 -- were not present in the generic (i.e. when two different
9923 -- types are given the same actual). If we are looking for a
9924 -- spec to match a body, full conformance is expected.
9928 -- Inherit the convention and "ghostness" of the matching
9929 -- spec to ensure proper full and subtype conformance.
9931 Set_Convention
(Designator
, Convention
(E
));
9933 -- Skip past subprogram bodies and subprogram renamings that
9934 -- may appear to have a matching spec, but that aren't fully
9935 -- conformant with it. That can occur in cases where an
9936 -- actual type causes unrelated homographs in the instance.
9938 if Nkind
(N
) in N_Subprogram_Body
9939 | N_Subprogram_Renaming_Declaration
9940 and then Present
(Homonym
(E
))
9941 and then not Fully_Conformant
(Designator
, E
)
9945 elsif not Subtype_Conformant
(Designator
, E
) then
9948 elsif Different_Generic_Profile
(E
) then
9953 -- Ada 2012 (AI05-0165): For internally generated bodies of
9954 -- null procedures locate the internally generated spec. We
9955 -- enforce mode conformance since a tagged type may inherit
9956 -- from interfaces several null primitives which differ only
9957 -- in the mode of the formals.
9959 if not (Comes_From_Source
(E
))
9960 and then Is_Null_Procedure
(E
)
9961 and then not Mode_Conformant
(Designator
, E
)
9965 -- For null procedures coming from source that are completions,
9966 -- analysis of the generated body will establish the link.
9968 elsif Comes_From_Source
(E
)
9969 and then Nkind
(Spec
) = N_Procedure_Specification
9970 and then Null_Present
(Spec
)
9974 -- Expression functions can be completions, but cannot be
9975 -- completed by an explicit body.
9977 elsif Comes_From_Source
(E
)
9978 and then Comes_From_Source
(N
)
9979 and then Nkind
(N
) = N_Subprogram_Body
9980 and then Nkind
(Original_Node
(Unit_Declaration_Node
(E
))) =
9981 N_Expression_Function
9983 Error_Msg_Sloc
:= Sloc
(E
);
9984 Error_Msg_N
("body conflicts with expression function#", N
);
9987 elsif not Has_Completion
(E
) then
9988 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
9989 Set_Corresponding_Spec
(N
, E
);
9992 Set_Has_Completion
(E
);
9995 elsif Nkind
(Parent
(N
)) = N_Subunit
then
9997 -- If this is the proper body of a subunit, the completion
9998 -- flag is set when analyzing the stub.
10002 -- If E is an internal function with a controlling result that
10003 -- was created for an operation inherited by a null extension,
10004 -- it may be overridden by a body without a previous spec (one
10005 -- more reason why these should be shunned). In that case we
10006 -- remove the generated body if present, because the current
10007 -- one is the explicit overriding.
10009 elsif Ekind
(E
) = E_Function
10010 and then Ada_Version
>= Ada_2005
10011 and then not Comes_From_Source
(E
)
10012 and then Has_Controlling_Result
(E
)
10013 and then (not Is_Class_Wide_Type
(Etype
(E
))
10014 and then Is_Null_Extension
(Etype
(E
)))
10015 and then Comes_From_Source
(Spec
)
10017 Set_Has_Completion
(E
, False);
10020 and then Nkind
(Parent
(E
)) = N_Function_Specification
10023 (Unit_Declaration_Node
10024 (Corresponding_Body
(Unit_Declaration_Node
(E
))));
10028 -- If expansion is disabled, or if the wrapper function has
10029 -- not been generated yet, this a late body overriding an
10030 -- inherited operation, or it is an overriding by some other
10031 -- declaration before the controlling result is frozen. In
10032 -- either case this is a declaration of a new entity.
10038 -- If the body already exists, then this is an error unless
10039 -- the previous declaration is the implicit declaration of a
10040 -- derived subprogram. It is also legal for an instance to
10041 -- contain type conformant overloadable declarations (but the
10042 -- generic declaration may not), per 8.3(26/2).
10044 elsif No
(Alias
(E
))
10045 and then not Is_Intrinsic_Subprogram
(E
)
10046 and then not In_Instance
10047 and then Post_Error
10049 Error_Msg_Sloc
:= Sloc
(E
);
10051 if Is_Imported
(E
) then
10053 ("body not allowed for imported subprogram & declared#",
10056 Error_Msg_NE
("duplicate body for & declared#", N
, E
);
10060 -- Child units cannot be overloaded, so a conformance mismatch
10061 -- between body and a previous spec is an error.
10063 elsif Is_Child_Unit
(E
)
10065 Nkind
(Unit_Declaration_Node
(Designator
)) = N_Subprogram_Body
10067 Nkind
(Parent
(Unit_Declaration_Node
(Designator
))) =
10069 and then Post_Error
10072 ("body of child unit does not match previous declaration", N
);
10080 -- On exit, we know that no previous declaration of subprogram exists
10083 end Find_Corresponding_Spec
;
10085 ----------------------
10086 -- Fully_Conformant --
10087 ----------------------
10089 function Fully_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
10092 Check_Conformance
(New_Id
, Old_Id
, Fully_Conformant
, False, Result
);
10094 end Fully_Conformant
;
10096 ----------------------------------
10097 -- Fully_Conformant_Expressions --
10098 ----------------------------------
10100 function Fully_Conformant_Expressions
10101 (Given_E1
: Node_Id
;
10102 Given_E2
: Node_Id
;
10103 Report
: Boolean := False) return Boolean
10105 E1
: constant Node_Id
:= Original_Node
(Given_E1
);
10106 E2
: constant Node_Id
:= Original_Node
(Given_E2
);
10107 -- We always test conformance on original nodes, since it is possible
10108 -- for analysis and/or expansion to make things look as though they
10109 -- conform when they do not, e.g. by converting 1+2 into 3.
10111 function FCE
(Given_E1
: Node_Id
; Given_E2
: Node_Id
) return Boolean;
10112 -- Convenience function to abbreviate recursive calls to
10113 -- Fully_Conformant_Expressions without having to pass Report.
10115 function FCL
(L1
: List_Id
; L2
: List_Id
) return Boolean;
10116 -- Compare elements of two lists for conformance. Elements have to be
10117 -- conformant, and actuals inserted as default parameters do not match
10118 -- explicit actuals with the same value.
10120 function FCO
(Op_Node
: Node_Id
; Call_Node
: Node_Id
) return Boolean;
10121 -- Compare an operator node with a function call
10127 function FCE
(Given_E1
: Node_Id
; Given_E2
: Node_Id
) return Boolean is
10129 return Fully_Conformant_Expressions
(Given_E1
, Given_E2
, Report
);
10136 function FCL
(L1
: List_Id
; L2
: List_Id
) return Boolean is
10144 -- Compare two lists, skipping rewrite insertions (we want to compare
10145 -- the original trees, not the expanded versions).
10148 if Is_Rewrite_Insertion
(N1
) then
10150 elsif Is_Rewrite_Insertion
(N2
) then
10156 elsif not FCE
(N1
, N2
) then
10169 function FCO
(Op_Node
: Node_Id
; Call_Node
: Node_Id
) return Boolean is
10170 Actuals
: constant List_Id
:= Parameter_Associations
(Call_Node
);
10175 or else Entity
(Op_Node
) /= Entity
(Name
(Call_Node
))
10180 Act
:= First
(Actuals
);
10182 if Nkind
(Op_Node
) in N_Binary_Op
then
10183 if not FCE
(Left_Opnd
(Op_Node
), Act
) then
10190 return Present
(Act
)
10191 and then FCE
(Right_Opnd
(Op_Node
), Act
)
10192 and then No
(Next
(Act
));
10196 function User_Defined_Numeric_Literal_Mismatch
return Boolean;
10197 -- Usually literals with the same value like 12345 and 12_345
10198 -- or 123.0 and 123.00 conform, but not if they are
10199 -- user-defined literals.
10201 -------------------------------------------
10202 -- User_Defined_Numeric_Literal_Mismatch --
10203 -------------------------------------------
10205 function User_Defined_Numeric_Literal_Mismatch
return Boolean is
10206 E1_Is_User_Defined
: constant Boolean :=
10207 Nkind
(Given_E1
) not in N_Integer_Literal | N_Real_Literal
;
10208 E2_Is_User_Defined
: constant Boolean :=
10209 Nkind
(Given_E2
) not in N_Integer_Literal | N_Real_Literal
;
10212 pragma Assert
(E1_Is_User_Defined
= E2_Is_User_Defined
);
10214 return E1_Is_User_Defined
and then
10215 not String_Equal
(String_From_Numeric_Literal
(E1
),
10216 String_From_Numeric_Literal
(E2
));
10217 end User_Defined_Numeric_Literal_Mismatch
;
10223 -- Start of processing for Fully_Conformant_Expressions
10228 -- Nonconformant if paren count does not match. Note: if some idiot
10229 -- complains that we don't do this right for more than 3 levels of
10230 -- parentheses, they will be treated with the respect they deserve.
10232 if Paren_Count
(E1
) /= Paren_Count
(E2
) then
10235 -- If same entities are referenced, then they are conformant even if
10236 -- they have different forms (RM 8.3.1(19-20)).
10238 elsif Is_Entity_Name
(E1
) and then Is_Entity_Name
(E2
) then
10239 if Present
(Entity
(E1
)) then
10240 Result
:= Entity
(E1
) = Entity
(E2
)
10242 -- One may be a discriminant that has been replaced by the
10243 -- corresponding discriminal.
10246 (Chars
(Entity
(E1
)) = Chars
(Entity
(E2
))
10247 and then Ekind
(Entity
(E1
)) = E_Discriminant
10248 and then Ekind
(Entity
(E2
)) = E_In_Parameter
)
10250 -- The discriminant of a protected type is transformed into
10251 -- a local constant and then into a parameter of a protected
10255 (Ekind
(Entity
(E1
)) = E_Constant
10256 and then Ekind
(Entity
(E2
)) = E_In_Parameter
10257 and then Present
(Discriminal_Link
(Entity
(E1
)))
10258 and then Discriminal_Link
(Entity
(E1
)) =
10259 Discriminal_Link
(Entity
(E2
)))
10261 -- AI12-050: The entities of quantified expressions match if they
10262 -- have the same identifier, even if they may be distinct nodes.
10265 (Chars
(Entity
(E1
)) = Chars
(Entity
(E2
))
10266 and then Is_Entity_Of_Quantified_Expression
(Entity
(E1
))
10267 and then Is_Entity_Of_Quantified_Expression
(Entity
(E2
)))
10269 -- A call to an instantiation of Unchecked_Conversion is
10270 -- rewritten with the name of the generated function created for
10271 -- the instance, and this must be special-cased.
10274 (Ekind
(Entity
(E1
)) = E_Function
10275 and then Is_Intrinsic_Subprogram
(Entity
(E1
))
10276 and then Is_Generic_Instance
(Entity
(E1
))
10277 and then Entity
(E2
) = Alias
(Entity
(E1
)));
10278 if Report
and not Result
then
10280 Text_Ptr
'Max (Sloc
(Entity
(E1
)), Sloc
(Entity
(E2
)));
10282 ("meaning of& differs because of declaration#", E1
, E2
);
10287 elsif Nkind
(E1
) = N_Expanded_Name
10288 and then Nkind
(E2
) = N_Expanded_Name
10289 and then Nkind
(Selector_Name
(E1
)) = N_Character_Literal
10290 and then Nkind
(Selector_Name
(E2
)) = N_Character_Literal
10292 return Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
));
10295 -- Identifiers in component associations don't always have
10296 -- entities, but their names must conform.
10298 return Nkind
(E1
) = N_Identifier
10299 and then Nkind
(E2
) = N_Identifier
10300 and then Chars
(E1
) = Chars
(E2
);
10303 elsif Nkind
(E1
) = N_Character_Literal
10304 and then Nkind
(E2
) = N_Expanded_Name
10306 return Nkind
(Selector_Name
(E2
)) = N_Character_Literal
10307 and then Chars
(E1
) = Chars
(Selector_Name
(E2
));
10309 elsif Nkind
(E2
) = N_Character_Literal
10310 and then Nkind
(E1
) = N_Expanded_Name
10312 return Nkind
(Selector_Name
(E1
)) = N_Character_Literal
10313 and then Chars
(E2
) = Chars
(Selector_Name
(E1
));
10315 elsif Nkind
(E1
) in N_Op
and then Nkind
(E2
) = N_Function_Call
then
10316 return FCO
(E1
, E2
);
10318 elsif Nkind
(E2
) in N_Op
and then Nkind
(E1
) = N_Function_Call
then
10319 return FCO
(E2
, E1
);
10321 -- Otherwise we must have the same syntactic entity
10323 elsif Nkind
(E1
) /= Nkind
(E2
) then
10326 -- At this point, we specialize by node type
10330 when N_Aggregate
=>
10332 FCL
(Expressions
(E1
), Expressions
(E2
))
10334 FCL
(Component_Associations
(E1
),
10335 Component_Associations
(E2
));
10337 when N_Allocator
=>
10338 if Nkind
(Expression
(E1
)) = N_Qualified_Expression
10340 Nkind
(Expression
(E2
)) = N_Qualified_Expression
10342 return FCE
(Expression
(E1
), Expression
(E2
));
10344 -- Check that the subtype marks and any constraints
10349 Indic1
: constant Node_Id
:= Expression
(E1
);
10350 Indic2
: constant Node_Id
:= Expression
(E2
);
10355 if Nkind
(Indic1
) /= N_Subtype_Indication
then
10357 Nkind
(Indic2
) /= N_Subtype_Indication
10358 and then Entity
(Indic1
) = Entity
(Indic2
);
10360 elsif Nkind
(Indic2
) /= N_Subtype_Indication
then
10362 Nkind
(Indic1
) /= N_Subtype_Indication
10363 and then Entity
(Indic1
) = Entity
(Indic2
);
10366 if Entity
(Subtype_Mark
(Indic1
)) /=
10367 Entity
(Subtype_Mark
(Indic2
))
10372 Elt1
:= First
(Constraints
(Constraint
(Indic1
)));
10373 Elt2
:= First
(Constraints
(Constraint
(Indic2
)));
10374 while Present
(Elt1
) and then Present
(Elt2
) loop
10375 if not FCE
(Elt1
, Elt2
) then
10388 when N_Attribute_Reference
=>
10390 Attribute_Name
(E1
) = Attribute_Name
(E2
)
10391 and then FCL
(Expressions
(E1
), Expressions
(E2
));
10393 when N_Binary_Op
=>
10395 Entity
(E1
) = Entity
(E2
)
10396 and then FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
10397 and then FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
10399 when N_Membership_Test
10403 FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
10405 FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
10407 when N_Case_Expression
=>
10413 if not FCE
(Expression
(E1
), Expression
(E2
)) then
10417 Alt1
:= First
(Alternatives
(E1
));
10418 Alt2
:= First
(Alternatives
(E2
));
10420 if Present
(Alt1
) /= Present
(Alt2
) then
10422 elsif No
(Alt1
) then
10426 if not FCE
(Expression
(Alt1
), Expression
(Alt2
))
10427 or else not FCL
(Discrete_Choices
(Alt1
),
10428 Discrete_Choices
(Alt2
))
10439 when N_Character_Literal
=>
10441 Char_Literal_Value
(E1
) = Char_Literal_Value
(E2
);
10443 when N_Component_Association
=>
10445 FCL
(Choices
(E1
), Choices
(E2
))
10447 FCE
(Expression
(E1
), Expression
(E2
));
10449 when N_Explicit_Dereference
=>
10451 FCE
(Prefix
(E1
), Prefix
(E2
));
10453 when N_Extension_Aggregate
=>
10455 FCL
(Expressions
(E1
), Expressions
(E2
))
10456 and then Null_Record_Present
(E1
) =
10457 Null_Record_Present
(E2
)
10458 and then FCL
(Component_Associations
(E1
),
10459 Component_Associations
(E2
));
10461 when N_Function_Call
=>
10463 FCE
(Name
(E1
), Name
(E2
))
10465 FCL
(Parameter_Associations
(E1
),
10466 Parameter_Associations
(E2
));
10468 when N_If_Expression
=>
10470 FCL
(Expressions
(E1
), Expressions
(E2
));
10472 when N_Indexed_Component
=>
10474 FCE
(Prefix
(E1
), Prefix
(E2
))
10476 FCL
(Expressions
(E1
), Expressions
(E2
));
10478 when N_Integer_Literal
=>
10479 return Intval
(E1
) = Intval
(E2
)
10480 and then not User_Defined_Numeric_Literal_Mismatch
;
10485 when N_Operator_Symbol
=>
10487 Chars
(E1
) = Chars
(E2
);
10489 when N_Others_Choice
=>
10492 when N_Parameter_Association
=>
10494 Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
))
10495 and then FCE
(Explicit_Actual_Parameter
(E1
),
10496 Explicit_Actual_Parameter
(E2
));
10498 when N_Qualified_Expression
10499 | N_Type_Conversion
10500 | N_Unchecked_Type_Conversion
10503 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
10505 FCE
(Expression
(E1
), Expression
(E2
));
10507 when N_Quantified_Expression
=>
10508 if not FCE
(Condition
(E1
), Condition
(E2
)) then
10512 if Present
(Loop_Parameter_Specification
(E1
))
10513 and then Present
(Loop_Parameter_Specification
(E2
))
10516 L1
: constant Node_Id
:=
10517 Loop_Parameter_Specification
(E1
);
10518 L2
: constant Node_Id
:=
10519 Loop_Parameter_Specification
(E2
);
10523 Reverse_Present
(L1
) = Reverse_Present
(L2
)
10525 FCE
(Defining_Identifier
(L1
),
10526 Defining_Identifier
(L2
))
10528 FCE
(Discrete_Subtype_Definition
(L1
),
10529 Discrete_Subtype_Definition
(L2
));
10532 elsif Present
(Iterator_Specification
(E1
))
10533 and then Present
(Iterator_Specification
(E2
))
10536 I1
: constant Node_Id
:= Iterator_Specification
(E1
);
10537 I2
: constant Node_Id
:= Iterator_Specification
(E2
);
10541 FCE
(Defining_Identifier
(I1
),
10542 Defining_Identifier
(I2
))
10544 Of_Present
(I1
) = Of_Present
(I2
)
10546 Reverse_Present
(I1
) = Reverse_Present
(I2
)
10547 and then FCE
(Name
(I1
), Name
(I2
))
10548 and then FCE
(Subtype_Indication
(I1
),
10549 Subtype_Indication
(I2
));
10552 -- The quantified expressions used different specifications to
10553 -- walk their respective ranges.
10561 FCE
(Low_Bound
(E1
), Low_Bound
(E2
))
10563 FCE
(High_Bound
(E1
), High_Bound
(E2
));
10565 when N_Real_Literal
=>
10566 return Realval
(E1
) = Realval
(E2
)
10567 and then not User_Defined_Numeric_Literal_Mismatch
;
10569 when N_Selected_Component
=>
10571 FCE
(Prefix
(E1
), Prefix
(E2
))
10573 FCE
(Selector_Name
(E1
), Selector_Name
(E2
));
10577 FCE
(Prefix
(E1
), Prefix
(E2
))
10579 FCE
(Discrete_Range
(E1
), Discrete_Range
(E2
));
10581 when N_String_Literal
=>
10583 S1
: constant String_Id
:= Strval
(E1
);
10584 S2
: constant String_Id
:= Strval
(E2
);
10585 L1
: constant Nat
:= String_Length
(S1
);
10586 L2
: constant Nat
:= String_Length
(S2
);
10593 for J
in 1 .. L1
loop
10594 if Get_String_Char
(S1
, J
) /=
10595 Get_String_Char
(S2
, J
)
10607 Entity
(E1
) = Entity
(E2
)
10609 FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
10611 -- All other node types cannot appear in this context. Strictly
10612 -- we should raise a fatal internal error. Instead we just ignore
10613 -- the nodes. This means that if anyone makes a mistake in the
10614 -- expander and mucks an expression tree irretrievably, the result
10615 -- will be a failure to detect a (probably very obscure) case
10616 -- of non-conformance, which is better than bombing on some
10617 -- case where two expressions do in fact conform.
10623 end Fully_Conformant_Expressions
;
10625 ----------------------------------------
10626 -- Fully_Conformant_Discrete_Subtypes --
10627 ----------------------------------------
10629 function Fully_Conformant_Discrete_Subtypes
10630 (Given_S1
: Node_Id
;
10631 Given_S2
: Node_Id
) return Boolean
10633 S1
: constant Node_Id
:= Original_Node
(Given_S1
);
10634 S2
: constant Node_Id
:= Original_Node
(Given_S2
);
10636 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean;
10637 -- Special-case for a bound given by a discriminant, which in the body
10638 -- is replaced with the discriminal of the enclosing type.
10640 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean;
10641 -- Check both bounds
10643 -----------------------
10644 -- Conforming_Bounds --
10645 -----------------------
10647 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean is
10649 if Is_Entity_Name
(B1
)
10650 and then Is_Entity_Name
(B2
)
10651 and then Ekind
(Entity
(B1
)) = E_Discriminant
10653 return Chars
(B1
) = Chars
(B2
);
10656 return Fully_Conformant_Expressions
(B1
, B2
);
10658 end Conforming_Bounds
;
10660 -----------------------
10661 -- Conforming_Ranges --
10662 -----------------------
10664 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean is
10667 Conforming_Bounds
(Low_Bound
(R1
), Low_Bound
(R2
))
10669 Conforming_Bounds
(High_Bound
(R1
), High_Bound
(R2
));
10670 end Conforming_Ranges
;
10672 -- Start of processing for Fully_Conformant_Discrete_Subtypes
10675 if Nkind
(S1
) /= Nkind
(S2
) then
10678 elsif Is_Entity_Name
(S1
) then
10679 return Entity
(S1
) = Entity
(S2
);
10681 elsif Nkind
(S1
) = N_Range
then
10682 return Conforming_Ranges
(S1
, S2
);
10684 elsif Nkind
(S1
) = N_Subtype_Indication
then
10686 Entity
(Subtype_Mark
(S1
)) = Entity
(Subtype_Mark
(S2
))
10689 (Range_Expression
(Constraint
(S1
)),
10690 Range_Expression
(Constraint
(S2
)));
10694 end Fully_Conformant_Discrete_Subtypes
;
10696 ---------------------
10697 -- Has_BIP_Formals --
10698 ---------------------
10700 function Has_BIP_Formals
(E
: Entity_Id
) return Boolean is
10701 Formal
: Entity_Id
:= First_Formal_With_Extras
(E
);
10704 while Present
(Formal
) loop
10705 if Is_Build_In_Place_Entity
(Formal
) then
10709 Next_Formal_With_Extras
(Formal
);
10713 end Has_BIP_Formals
;
10715 --------------------------------
10716 -- Has_Reliable_Extra_Formals --
10717 --------------------------------
10719 function Has_Reliable_Extra_Formals
(E
: Entity_Id
) return Boolean is
10720 Alias_E
: Entity_Id
;
10723 -- Extra formals are not added if expansion is not active (and hence if
10724 -- available they are not reliable for extra formals check).
10726 if not Expander_Active
then
10729 -- Currently the unique cases where extra formals are not reliable
10730 -- are associated with predefined dispatching operations; otherwise
10731 -- they are properly added when required.
10733 elsif not Is_Predefined_Dispatching_Operation
(E
) then
10737 Alias_E
:= Ultimate_Alias
(E
);
10739 -- Abstract predefined primitives of Root_Controlled don't have
10740 -- extra formals; this is required to build the runtime.
10742 if Ekind
(Alias_E
) = E_Function
10743 and then Is_Abstract_Subprogram
(Alias_E
)
10744 and then Is_RTE
(Underlying_Type
(Etype
(Alias_E
)),
10745 RE_Root_Controlled
)
10749 -- Predefined stream dispatching operations that are not emitted by
10750 -- the frontend; they have a renaming of the corresponding primitive
10751 -- of their parent type and hence they don't have extra formals.
10755 TSS_Name
: constant TSS_Name_Type
:= Get_TSS_Name
(E
);
10756 Typ
: constant Entity_Id
:=
10757 Underlying_Type
(Find_Dispatching_Type
(Alias_E
));
10760 if TSS_Name
in TSS_Stream_Input
10761 | TSS_Stream_Output
10764 and then not Stream_Operation_OK
(Typ
, TSS_Name
)
10772 end Has_Reliable_Extra_Formals
;
10774 --------------------
10775 -- Install_Entity --
10776 --------------------
10778 procedure Install_Entity
(E
: Entity_Id
) is
10779 Prev
: constant Entity_Id
:= Current_Entity
(E
);
10781 Set_Is_Immediately_Visible
(E
);
10782 Set_Current_Entity
(E
);
10783 pragma Assert
(Prev
/= E
);
10784 Set_Homonym
(E
, Prev
);
10785 end Install_Entity
;
10787 ---------------------
10788 -- Install_Formals --
10789 ---------------------
10791 procedure Install_Formals
(Id
: Entity_Id
) is
10794 F
:= First_Formal
(Id
);
10795 while Present
(F
) loop
10796 Install_Entity
(F
);
10799 end Install_Formals
;
10801 -----------------------------
10802 -- Is_Interface_Conformant --
10803 -----------------------------
10805 function Is_Interface_Conformant
10806 (Tagged_Type
: Entity_Id
;
10807 Iface_Prim
: Entity_Id
;
10808 Prim
: Entity_Id
) return Boolean
10810 -- The operation may in fact be an inherited (implicit) operation
10811 -- rather than the original interface primitive, so retrieve the
10812 -- ultimate ancestor.
10814 Iface
: constant Entity_Id
:=
10815 Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
));
10816 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
10818 function Controlling_Formal
(Prim
: Entity_Id
) return Entity_Id
;
10819 -- Return the controlling formal of Prim
10821 ------------------------
10822 -- Controlling_Formal --
10823 ------------------------
10825 function Controlling_Formal
(Prim
: Entity_Id
) return Entity_Id
is
10829 E
:= First_Formal
(Prim
);
10830 while Present
(E
) loop
10831 if Is_Controlling_Formal
(E
) then
10839 end Controlling_Formal
;
10843 Iface_Ctrl_F
: constant Entity_Id
:= Controlling_Formal
(Iface_Prim
);
10844 Prim_Ctrl_F
: constant Entity_Id
:= Controlling_Formal
(Prim
);
10846 -- Start of processing for Is_Interface_Conformant
10849 pragma Assert
(Is_Subprogram
(Iface_Prim
)
10850 and then Is_Subprogram
(Prim
)
10851 and then Is_Dispatching_Operation
(Iface_Prim
)
10852 and then Is_Dispatching_Operation
(Prim
));
10854 pragma Assert
(Is_Interface
(Iface
)
10855 or else (Present
(Alias
(Iface_Prim
))
10858 (Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
)))));
10860 if Prim
= Iface_Prim
10861 or else not Is_Subprogram
(Prim
)
10862 or else Ekind
(Prim
) /= Ekind
(Iface_Prim
)
10863 or else not Is_Dispatching_Operation
(Prim
)
10864 or else Scope
(Prim
) /= Scope
(Tagged_Type
)
10866 or else Base_Type
(Typ
) /= Base_Type
(Tagged_Type
)
10867 or else not Primitive_Names_Match
(Iface_Prim
, Prim
)
10871 -- The mode of the controlling formals must match
10873 elsif Present
(Iface_Ctrl_F
)
10874 and then Present
(Prim_Ctrl_F
)
10875 and then Ekind
(Iface_Ctrl_F
) /= Ekind
(Prim_Ctrl_F
)
10879 -- Case of a procedure, or a function whose result type matches the
10880 -- result type of the interface primitive, or a function that has no
10881 -- controlling result (I or access I).
10883 elsif Ekind
(Iface_Prim
) = E_Procedure
10884 or else Etype
(Prim
) = Etype
(Iface_Prim
)
10885 or else not Has_Controlling_Result
(Prim
)
10887 return Type_Conformant
10888 (Iface_Prim
, Prim
, Skip_Controlling_Formals
=> True);
10890 -- Case of a function returning an interface, or an access to one. Check
10891 -- that the return types correspond.
10893 elsif Implements_Interface
(Typ
, Iface
) then
10894 if (Ekind
(Etype
(Prim
)) = E_Anonymous_Access_Type
)
10896 (Ekind
(Etype
(Iface_Prim
)) = E_Anonymous_Access_Type
)
10901 Type_Conformant
(Prim
, Ultimate_Alias
(Iface_Prim
),
10902 Skip_Controlling_Formals
=> True);
10908 end Is_Interface_Conformant
;
10910 ---------------------------------
10911 -- Is_Non_Overriding_Operation --
10912 ---------------------------------
10914 function Is_Non_Overriding_Operation
10915 (Prev_E
: Entity_Id
;
10916 New_E
: Entity_Id
) return Boolean
10918 Formal
: Entity_Id
;
10920 G_Typ
: Entity_Id
:= Empty
;
10922 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
;
10923 -- If F_Type is a derived type associated with a generic actual subtype,
10924 -- then return its Generic_Parent_Type attribute, else return Empty.
10926 function Types_Correspond
10927 (P_Type
: Entity_Id
;
10928 N_Type
: Entity_Id
) return Boolean;
10929 -- Returns true if and only if the types (or designated types in the
10930 -- case of anonymous access types) are the same or N_Type is derived
10931 -- directly or indirectly from P_Type.
10933 -----------------------------
10934 -- Get_Generic_Parent_Type --
10935 -----------------------------
10937 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
is
10943 if Is_Derived_Type
(F_Typ
)
10944 and then Nkind
(Parent
(F_Typ
)) = N_Full_Type_Declaration
10946 -- The tree must be traversed to determine the parent subtype in
10947 -- the generic unit, which unfortunately isn't always available
10948 -- via semantic attributes. ??? (Note: The use of Original_Node
10949 -- is needed for cases where a full derived type has been
10952 -- If the parent type is a scalar type, the derivation creates
10953 -- an anonymous base type for it, and the source type is its
10956 if Is_Scalar_Type
(F_Typ
)
10957 and then not Comes_From_Source
(F_Typ
)
10961 (Original_Node
(Parent
(First_Subtype
(F_Typ
))));
10963 Defn
:= Type_Definition
(Original_Node
(Parent
(F_Typ
)));
10965 if Nkind
(Defn
) = N_Derived_Type_Definition
then
10966 Indic
:= Subtype_Indication
(Defn
);
10968 if Nkind
(Indic
) = N_Subtype_Indication
then
10969 G_Typ
:= Entity
(Subtype_Mark
(Indic
));
10971 G_Typ
:= Entity
(Indic
);
10974 if Nkind
(Parent
(G_Typ
)) = N_Subtype_Declaration
10975 and then Present
(Generic_Parent_Type
(Parent
(G_Typ
)))
10977 return Generic_Parent_Type
(Parent
(G_Typ
));
10983 end Get_Generic_Parent_Type
;
10985 ----------------------
10986 -- Types_Correspond --
10987 ----------------------
10989 function Types_Correspond
10990 (P_Type
: Entity_Id
;
10991 N_Type
: Entity_Id
) return Boolean
10993 Prev_Type
: Entity_Id
:= Base_Type
(P_Type
);
10994 New_Type
: Entity_Id
:= Base_Type
(N_Type
);
10997 if Ekind
(Prev_Type
) = E_Anonymous_Access_Type
then
10998 Prev_Type
:= Designated_Type
(Prev_Type
);
11001 if Ekind
(New_Type
) = E_Anonymous_Access_Type
then
11002 New_Type
:= Designated_Type
(New_Type
);
11005 if Prev_Type
= New_Type
then
11008 elsif not Is_Class_Wide_Type
(New_Type
) then
11009 while Etype
(New_Type
) /= New_Type
loop
11010 New_Type
:= Etype
(New_Type
);
11012 if New_Type
= Prev_Type
then
11018 end Types_Correspond
;
11020 -- Start of processing for Is_Non_Overriding_Operation
11023 -- In the case where both operations are implicit derived subprograms
11024 -- then neither overrides the other. This can only occur in certain
11025 -- obscure cases (e.g., derivation from homographs created in a generic
11028 if Present
(Alias
(Prev_E
)) and then Present
(Alias
(New_E
)) then
11031 elsif Ekind
(Current_Scope
) = E_Package
11032 and then Is_Generic_Instance
(Current_Scope
)
11033 and then In_Private_Part
(Current_Scope
)
11034 and then Comes_From_Source
(New_E
)
11036 -- We examine the formals and result type of the inherited operation,
11037 -- to determine whether their type is derived from (the instance of)
11038 -- a generic type. The first such formal or result type is the one
11041 Formal
:= First_Formal
(Prev_E
);
11043 while Present
(Formal
) loop
11044 F_Typ
:= Base_Type
(Etype
(Formal
));
11046 if Ekind
(F_Typ
) = E_Anonymous_Access_Type
then
11047 F_Typ
:= Designated_Type
(F_Typ
);
11050 G_Typ
:= Get_Generic_Parent_Type
(F_Typ
);
11051 exit when Present
(G_Typ
);
11053 Next_Formal
(Formal
);
11056 -- If the function dispatches on result check the result type
11058 if No
(G_Typ
) and then Ekind
(Prev_E
) = E_Function
then
11059 G_Typ
:= Get_Generic_Parent_Type
(Base_Type
(Etype
(Prev_E
)));
11066 -- If the generic type is a private type, then the original operation
11067 -- was not overriding in the generic, because there was no primitive
11068 -- operation to override.
11070 if Nkind
(Parent
(G_Typ
)) = N_Formal_Type_Declaration
11071 and then Nkind
(Formal_Type_Definition
(Parent
(G_Typ
))) =
11072 N_Formal_Private_Type_Definition
11076 -- The generic parent type is the ancestor of a formal derived
11077 -- type declaration. We need to check whether it has a primitive
11078 -- operation that should be overridden by New_E in the generic.
11082 P_Formal
: Entity_Id
;
11083 N_Formal
: Entity_Id
;
11086 P_Prim
: Entity_Id
;
11087 Prim_Elt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(G_Typ
));
11090 while Present
(Prim_Elt
) loop
11091 P_Prim
:= Node
(Prim_Elt
);
11093 if Chars
(P_Prim
) = Chars
(New_E
)
11094 and then Ekind
(P_Prim
) = Ekind
(New_E
)
11096 P_Formal
:= First_Formal
(P_Prim
);
11097 N_Formal
:= First_Formal
(New_E
);
11098 while Present
(P_Formal
) and then Present
(N_Formal
) loop
11099 P_Typ
:= Etype
(P_Formal
);
11100 N_Typ
:= Etype
(N_Formal
);
11102 if not Types_Correspond
(P_Typ
, N_Typ
) then
11106 Next_Formal
(P_Formal
);
11107 Next_Formal
(N_Formal
);
11110 -- Found a matching primitive operation belonging to the
11111 -- formal ancestor type, so the new subprogram is
11115 and then No
(N_Formal
)
11116 and then (Ekind
(New_E
) /= E_Function
11119 (Etype
(P_Prim
), Etype
(New_E
)))
11125 Next_Elmt
(Prim_Elt
);
11128 -- If no match found, then the new subprogram does not override
11129 -- in the generic (nor in the instance).
11131 -- If the type in question is not abstract, and the subprogram
11132 -- is, this will be an error if the new operation is in the
11133 -- private part of the instance. Emit a warning now, which will
11134 -- make the subsequent error message easier to understand.
11136 if Present
(F_Typ
) and then not Is_Abstract_Type
(F_Typ
)
11137 and then Is_Abstract_Subprogram
(Prev_E
)
11138 and then In_Private_Part
(Current_Scope
)
11140 Error_Msg_Node_2
:= F_Typ
;
11142 ("private operation& in generic unit does not override "
11143 & "any primitive operation of& (RM 12.3(18))??",
11153 end Is_Non_Overriding_Operation
;
11155 -------------------------------------
11156 -- List_Inherited_Pre_Post_Aspects --
11157 -------------------------------------
11159 procedure List_Inherited_Pre_Post_Aspects
(E
: Entity_Id
) is
11161 if List_Inherited_Aspects
11162 and then Is_Subprogram_Or_Generic_Subprogram
(E
)
11165 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(E
);
11170 for Index
in Subps
'Range loop
11171 Items
:= Contract
(Subps
(Index
));
11173 if Present
(Items
) then
11174 Prag
:= Pre_Post_Conditions
(Items
);
11175 while Present
(Prag
) loop
11176 Error_Msg_Sloc
:= Sloc
(Prag
);
11178 if Class_Present
(Prag
)
11179 and then not Split_PPC
(Prag
)
11181 if Pragma_Name
(Prag
) = Name_Precondition
then
11183 ("info: & inherits `Pre''Class` aspect from "
11187 ("info: & inherits `Post''Class` aspect from "
11192 Prag
:= Next_Pragma
(Prag
);
11198 end List_Inherited_Pre_Post_Aspects
;
11200 ------------------------------
11201 -- Make_Inequality_Operator --
11202 ------------------------------
11204 -- S is the defining identifier of an equality operator. We build a
11205 -- subprogram declaration with the right signature. This operation is
11206 -- intrinsic, because it is always expanded as the negation of the
11207 -- call to the equality function.
11209 procedure Make_Inequality_Operator
(S
: Entity_Id
) is
11210 Loc
: constant Source_Ptr
:= Sloc
(S
);
11213 Op_Name
: Entity_Id
;
11215 FF
: constant Entity_Id
:= First_Formal
(S
);
11216 NF
: constant Entity_Id
:= Next_Formal
(FF
);
11219 -- Check that equality was properly defined, ignore call if not
11226 A
: constant Entity_Id
:=
11227 Make_Defining_Identifier
(Sloc
(FF
),
11228 Chars
=> Chars
(FF
));
11230 B
: constant Entity_Id
:=
11231 Make_Defining_Identifier
(Sloc
(NF
),
11232 Chars
=> Chars
(NF
));
11235 Op_Name
:= Make_Defining_Operator_Symbol
(Loc
, Name_Op_Ne
);
11237 Formals
:= New_List
(
11238 Make_Parameter_Specification
(Loc
,
11239 Defining_Identifier
=> A
,
11241 New_Occurrence_Of
(Etype
(First_Formal
(S
)),
11242 Sloc
(Etype
(First_Formal
(S
))))),
11244 Make_Parameter_Specification
(Loc
,
11245 Defining_Identifier
=> B
,
11247 New_Occurrence_Of
(Etype
(Next_Formal
(First_Formal
(S
))),
11248 Sloc
(Etype
(Next_Formal
(First_Formal
(S
)))))));
11251 Make_Subprogram_Declaration
(Loc
,
11253 Make_Function_Specification
(Loc
,
11254 Defining_Unit_Name
=> Op_Name
,
11255 Parameter_Specifications
=> Formals
,
11256 Result_Definition
=>
11257 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
11259 -- Insert inequality right after equality if it is explicit or after
11260 -- the derived type when implicit. These entities are created only
11261 -- for visibility purposes, and eventually replaced in the course
11262 -- of expansion, so they do not need to be attached to the tree and
11263 -- seen by the back-end. Keeping them internal also avoids spurious
11264 -- freezing problems. The declaration is inserted in the tree for
11265 -- analysis, and removed afterwards. If the equality operator comes
11266 -- from an explicit declaration, attach the inequality immediately
11267 -- after. Else the equality is inherited from a derived type
11268 -- declaration, so insert inequality after that declaration.
11270 if No
(Alias
(S
)) then
11271 Insert_After
(Unit_Declaration_Node
(S
), Decl
);
11272 elsif Is_List_Member
(Parent
(S
)) then
11273 Insert_After
(Parent
(S
), Decl
);
11275 Insert_After
(Parent
(Etype
(First_Formal
(S
))), Decl
);
11278 Mark_Rewrite_Insertion
(Decl
);
11279 Set_Is_Intrinsic_Subprogram
(Op_Name
);
11282 Set_Has_Completion
(Op_Name
);
11283 Set_Corresponding_Equality
(Op_Name
, S
);
11284 Set_Is_Abstract_Subprogram
(Op_Name
, Is_Abstract_Subprogram
(S
));
11286 end Make_Inequality_Operator
;
11288 ----------------------
11289 -- May_Need_Actuals --
11290 ----------------------
11292 procedure May_Need_Actuals
(Fun
: Entity_Id
) is
11297 F
:= First_Formal
(Fun
);
11299 while Present
(F
) loop
11300 if No
(Default_Value
(F
)) then
11308 Set_Needs_No_Actuals
(Fun
, B
);
11309 end May_Need_Actuals
;
11311 ---------------------
11312 -- Mode_Conformant --
11313 ---------------------
11315 function Mode_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
11318 Check_Conformance
(New_Id
, Old_Id
, Mode_Conformant
, False, Result
);
11320 end Mode_Conformant
;
11322 ---------------------------
11323 -- New_Overloaded_Entity --
11324 ---------------------------
11326 procedure New_Overloaded_Entity
11328 Derived_Type
: Entity_Id
:= Empty
)
11330 Overridden_Subp
: Entity_Id
:= Empty
;
11331 -- Set if the current scope has an operation that is type-conformant
11332 -- with S, and becomes hidden by S.
11334 Is_Primitive_Subp
: Boolean;
11335 -- Set to True if the new subprogram is primitive
11338 -- Entity that S overrides
11340 procedure Check_For_Primitive_Subprogram
11341 (Is_Primitive
: out Boolean;
11342 Is_Overriding
: Boolean := False);
11343 -- If the subprogram being analyzed is a primitive operation of the type
11344 -- of a formal or result, set the Has_Primitive_Operations flag on the
11345 -- type, and set Is_Primitive to True (otherwise set to False). Set the
11346 -- corresponding flag on the entity itself for later use.
11348 function Has_Matching_Entry_Or_Subprogram
(E
: Entity_Id
) return Boolean;
11349 -- True if a) E is a subprogram whose first formal is a concurrent type
11350 -- defined in the scope of E that has some entry or subprogram whose
11351 -- profile matches E, or b) E is an internally built dispatching
11352 -- subprogram of a protected type and there is a matching subprogram
11353 -- defined in the enclosing scope of the protected type, or c) E is
11354 -- an entry of a synchronized type and a matching procedure has been
11355 -- previously defined in the enclosing scope of the synchronized type.
11357 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean;
11358 -- Check that E is declared in the private part of the current package,
11359 -- or in the package body, where it may hide a previous declaration.
11360 -- We can't use In_Private_Part by itself because this flag is also
11361 -- set when freezing entities, so we must examine the place of the
11362 -- declaration in the tree, and recognize wrapper packages as well.
11364 function Is_Overriding_Alias
11365 (Old_E
: Entity_Id
;
11366 New_E
: Entity_Id
) return Boolean;
11367 -- Check whether new subprogram and old subprogram are both inherited
11368 -- from subprograms that have distinct dispatch table entries. This can
11369 -- occur with derivations from instances with accidental homonyms. The
11370 -- function is conservative given that the converse is only true within
11371 -- instances that contain accidental overloadings.
11373 procedure Report_Conflict
(S
: Entity_Id
; E
: Entity_Id
);
11374 -- Report conflict between entities S and E
11376 ------------------------------------
11377 -- Check_For_Primitive_Subprogram --
11378 ------------------------------------
11380 procedure Check_For_Primitive_Subprogram
11381 (Is_Primitive
: out Boolean;
11382 Is_Overriding
: Boolean := False)
11384 procedure Add_Or_Replace_Untagged_Primitive
(Typ
: Entity_Id
);
11385 -- Either add the new subprogram to the list of primitives for
11386 -- untagged type Typ, or if it overrides a primitive of Typ, then
11387 -- replace the overridden primitive in Typ's primitives list with
11388 -- the new subprogram.
11390 function Visible_Part_Type
(T
: Entity_Id
) return Boolean;
11391 -- Returns true if T is declared in the visible part of the current
11392 -- package scope; otherwise returns false. Assumes that T is declared
11395 procedure Check_Private_Overriding
(T
: Entity_Id
);
11396 -- Checks that if a primitive abstract subprogram of a visible
11397 -- abstract type is declared in a private part, then it must override
11398 -- an abstract subprogram declared in the visible part. Also checks
11399 -- that if a primitive function with a controlling result is declared
11400 -- in a private part, then it must override a function declared in
11401 -- the visible part.
11403 ---------------------------------------
11404 -- Add_Or_Replace_Untagged_Primitive --
11405 ---------------------------------------
11407 procedure Add_Or_Replace_Untagged_Primitive
(Typ
: Entity_Id
) is
11408 Replaced_Overridden_Subp
: Boolean := False;
11411 pragma Assert
(not Is_Tagged_Type
(Typ
));
11413 -- Anonymous access types don't have a primitives list. Normally
11414 -- such types wouldn't make it here, but the case of anonymous
11415 -- access-to-subprogram types can.
11417 if not Is_Anonymous_Access_Type
(Typ
) then
11419 -- If S overrides a subprogram that's a primitive of
11420 -- the formal's type, then replace the overridden
11421 -- subprogram with the new subprogram in the type's
11422 -- list of primitives.
11424 if Is_Overriding
then
11425 pragma Assert
(Present
(Overridden_Subp
)
11426 and then Overridden_Subp
= E
); -- Added for now
11429 Prim_Ops
: constant Elist_Id
:=
11430 Primitive_Operations
(Typ
);
11433 if Present
(Prim_Ops
) then
11434 Elmt
:= First_Elmt
(Prim_Ops
);
11436 while Present
(Elmt
)
11437 and then Node
(Elmt
) /= Overridden_Subp
11442 if Present
(Elmt
) then
11443 Replace_Elmt
(Elmt
, S
);
11444 Replaced_Overridden_Subp
:= True;
11450 -- If the new subprogram did not override an operation
11451 -- of the formal's type, then add it to the primitives
11452 -- list of the type.
11454 if not Replaced_Overridden_Subp
then
11455 Append_Unique_Elmt
(S
, Primitive_Operations
(Typ
));
11458 end Add_Or_Replace_Untagged_Primitive
;
11460 ------------------------------
11461 -- Check_Private_Overriding --
11462 ------------------------------
11464 procedure Check_Private_Overriding
(T
: Entity_Id
) is
11465 function Overrides_Private_Part_Op
return Boolean;
11466 -- This detects the special case where the overriding subprogram
11467 -- is overriding a subprogram that was declared in the same
11468 -- private part. That case is illegal by 3.9.3(10).
11470 function Overrides_Visible_Function
11471 (Partial_View
: Entity_Id
) return Boolean;
11472 -- True if S overrides a function in the visible part. The
11473 -- overridden function could be explicitly or implicitly declared.
11475 -------------------------------
11476 -- Overrides_Private_Part_Op --
11477 -------------------------------
11479 function Overrides_Private_Part_Op
return Boolean is
11480 Over_Decl
: constant Node_Id
:=
11481 Unit_Declaration_Node
11482 (Ultimate_Alias
(Overridden_Operation
(S
)));
11483 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(S
);
11486 pragma Assert
(Is_Overriding
);
11488 (Nkind
(Over_Decl
) = N_Abstract_Subprogram_Declaration
);
11490 (Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
);
11492 return In_Same_List
(Over_Decl
, Subp_Decl
);
11493 end Overrides_Private_Part_Op
;
11495 --------------------------------
11496 -- Overrides_Visible_Function --
11497 --------------------------------
11499 function Overrides_Visible_Function
11500 (Partial_View
: Entity_Id
) return Boolean
11503 if not Is_Overriding
or else not Has_Homonym
(S
) then
11507 if No
(Partial_View
) then
11511 -- Search through all the homonyms H of S in the current
11512 -- package spec, and return True if we find one that matches.
11513 -- Note that Parent (H) will be the declaration of the
11514 -- partial view of T for a match.
11517 H
: Entity_Id
:= S
;
11521 exit when No
(H
) or else Scope
(H
) /= Scope
(S
);
11523 if Nkind
(Parent
(H
)) in
11524 N_Private_Extension_Declaration |
11525 N_Private_Type_Declaration
11526 and then Defining_Identifier
(Parent
(H
)) = Partial_View
11534 end Overrides_Visible_Function
;
11536 -- Start of processing for Check_Private_Overriding
11539 if Is_Package_Or_Generic_Package
(Current_Scope
)
11540 and then In_Private_Part
(Current_Scope
)
11541 and then Visible_Part_Type
(T
)
11542 and then not In_Instance
11544 if Is_Abstract_Type
(T
)
11545 and then Is_Abstract_Subprogram
(S
)
11546 and then (not Is_Overriding
11547 or else not Is_Abstract_Subprogram
(E
)
11548 or else Overrides_Private_Part_Op
)
11551 ("abstract subprograms must be visible (RM 3.9.3(10))!",
11554 elsif Ekind
(S
) = E_Function
then
11556 Partial_View
: constant Entity_Id
:=
11557 Incomplete_Or_Partial_View
(T
);
11560 if not Overrides_Visible_Function
(Partial_View
) then
11562 -- Here, S is "function ... return T;" declared in
11563 -- the private part, not overriding some visible
11564 -- operation. That's illegal in the tagged case
11565 -- (but not if the private type is untagged).
11567 if ((Present
(Partial_View
)
11568 and then Is_Tagged_Type
(Partial_View
))
11569 or else (No
(Partial_View
)
11570 and then Is_Tagged_Type
(T
)))
11571 and then T
= Base_Type
(Etype
(S
))
11574 ("private function with tagged result must"
11575 & " override visible-part function", S
);
11577 ("\move subprogram to the visible part"
11578 & " (RM 3.9.3(10))", S
);
11580 -- Ada 2012 (AI05-0073): Extend this check to the case
11581 -- of a function whose result subtype is defined by an
11582 -- access_definition designating specific tagged type.
11584 elsif Ekind
(Etype
(S
)) = E_Anonymous_Access_Type
11585 and then Is_Tagged_Type
(Designated_Type
(Etype
(S
)))
11587 not Is_Class_Wide_Type
11588 (Designated_Type
(Etype
(S
)))
11589 and then Ada_Version
>= Ada_2012
11592 ("private function with controlling access "
11593 & "result must override visible-part function",
11596 ("\move subprogram to the visible part"
11597 & " (RM 3.9.3(10))", S
);
11603 end Check_Private_Overriding
;
11605 -----------------------
11606 -- Visible_Part_Type --
11607 -----------------------
11609 function Visible_Part_Type
(T
: Entity_Id
) return Boolean is
11610 P
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(T
));
11613 -- If the entity is a private type, then it must be declared in a
11616 if Is_Private_Type
(T
) then
11619 elsif Is_Type
(T
) and then Has_Private_Declaration
(T
) then
11622 elsif Is_List_Member
(Declaration_Node
(T
))
11623 and then List_Containing
(Declaration_Node
(T
)) =
11624 Visible_Declarations
(Specification
(P
))
11631 end Visible_Part_Type
;
11635 Formal
: Entity_Id
;
11639 -- Start of processing for Check_For_Primitive_Subprogram
11642 Is_Primitive
:= False;
11644 if not Comes_From_Source
(S
) then
11646 -- Add an inherited primitive for an untagged derived type to
11647 -- Derived_Type's list of primitives. Tagged primitives are
11648 -- dealt with in Check_Dispatching_Operation. Do this even when
11649 -- Extensions_Allowed is False to issue better error messages.
11651 if Present
(Derived_Type
)
11652 and then not Is_Tagged_Type
(Derived_Type
)
11654 Append_Unique_Elmt
(S
, Primitive_Operations
(Derived_Type
));
11657 -- If subprogram is at library level, it is not primitive operation
11659 elsif Current_Scope
= Standard_Standard
then
11662 elsif (Is_Package_Or_Generic_Package
(Current_Scope
)
11663 and then not In_Package_Body
(Current_Scope
))
11664 or else Is_Overriding
11666 -- For function, check return type
11668 if Ekind
(S
) = E_Function
then
11669 if Ekind
(Etype
(S
)) = E_Anonymous_Access_Type
then
11670 F_Typ
:= Designated_Type
(Etype
(S
));
11672 F_Typ
:= Etype
(S
);
11675 B_Typ
:= Base_Type
(F_Typ
);
11677 if Scope
(B_Typ
) = Current_Scope
11678 and then not Is_Class_Wide_Type
(B_Typ
)
11679 and then not Is_Generic_Type
(B_Typ
)
11681 Is_Primitive
:= True;
11682 Set_Has_Primitive_Operations
(B_Typ
);
11683 Set_Is_Primitive
(S
);
11685 -- Add a primitive for an untagged type to B_Typ's
11686 -- list of primitives. Tagged primitives are dealt with
11687 -- in Check_Dispatching_Operation. Do this even when
11688 -- Extensions_Allowed is False to issue better error
11691 if not Is_Tagged_Type
(B_Typ
) then
11692 Add_Or_Replace_Untagged_Primitive
(B_Typ
);
11695 Check_Private_Overriding
(B_Typ
);
11696 -- The Ghost policy in effect at the point of declaration
11697 -- or a tagged type and a primitive operation must match
11698 -- (SPARK RM 6.9(16)).
11700 Check_Ghost_Primitive
(S
, B_Typ
);
11704 -- For all subprograms, check formals
11706 Formal
:= First_Formal
(S
);
11707 while Present
(Formal
) loop
11708 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
11709 F_Typ
:= Designated_Type
(Etype
(Formal
));
11711 F_Typ
:= Etype
(Formal
);
11714 B_Typ
:= Base_Type
(F_Typ
);
11716 if Ekind
(B_Typ
) = E_Access_Subtype
then
11717 B_Typ
:= Base_Type
(B_Typ
);
11720 if Scope
(B_Typ
) = Current_Scope
11721 and then not Is_Class_Wide_Type
(B_Typ
)
11722 and then not Is_Generic_Type
(B_Typ
)
11724 Is_Primitive
:= True;
11725 Set_Is_Primitive
(S
);
11726 Set_Has_Primitive_Operations
(B_Typ
);
11728 -- Add a primitive for an untagged type to B_Typ's list
11729 -- of primitives. Tagged primitives are dealt with in
11730 -- Check_Dispatching_Operation. Do this even when
11731 -- Extensions_Allowed is False to issue better error
11734 if not Is_Tagged_Type
(B_Typ
) then
11735 Add_Or_Replace_Untagged_Primitive
(B_Typ
);
11738 Check_Private_Overriding
(B_Typ
);
11740 -- The Ghost policy in effect at the point of declaration
11741 -- of a tagged type and a primitive operation must match
11742 -- (SPARK RM 6.9(16)).
11744 Check_Ghost_Primitive
(S
, B_Typ
);
11747 Next_Formal
(Formal
);
11750 -- Special case: An equality function can be redefined for a type
11751 -- occurring in a declarative part, and won't otherwise be treated as
11752 -- a primitive because it doesn't occur in a package spec and doesn't
11753 -- override an inherited subprogram. It's important that we mark it
11754 -- primitive so it can be returned by Collect_Primitive_Operations
11755 -- and be used in composing the equality operation of later types
11756 -- that have a component of the type.
11758 elsif Chars
(S
) = Name_Op_Eq
11759 and then Etype
(S
) = Standard_Boolean
11761 B_Typ
:= Base_Type
(Etype
(First_Formal
(S
)));
11763 if Scope
(B_Typ
) = Current_Scope
11765 Base_Type
(Etype
(Next_Formal
(First_Formal
(S
)))) = B_Typ
11766 and then not Is_Limited_Type
(B_Typ
)
11768 Is_Primitive
:= True;
11769 Set_Is_Primitive
(S
);
11770 Set_Has_Primitive_Operations
(B_Typ
);
11771 Check_Private_Overriding
(B_Typ
);
11773 -- The Ghost policy in effect at the point of declaration of a
11774 -- tagged type and a primitive operation must match
11775 -- (SPARK RM 6.9(16)).
11777 Check_Ghost_Primitive
(S
, B_Typ
);
11780 end Check_For_Primitive_Subprogram
;
11782 --------------------------------------
11783 -- Has_Matching_Entry_Or_Subprogram --
11784 --------------------------------------
11786 function Has_Matching_Entry_Or_Subprogram
11787 (E
: Entity_Id
) return Boolean
11789 function Check_Conforming_Parameters
11790 (E1_Param
: Node_Id
;
11791 E2_Param
: Node_Id
;
11792 Ctype
: Conformance_Type
) return Boolean;
11793 -- Starting from the given parameters, check that all the parameters
11794 -- of two entries or subprograms are conformant. Used to skip
11795 -- the check on the controlling argument.
11797 function Matching_Entry_Or_Subprogram
11798 (Conc_Typ
: Entity_Id
;
11799 Subp
: Entity_Id
) return Entity_Id
;
11800 -- Return the first entry or subprogram of the given concurrent type
11801 -- whose name matches the name of Subp and has a profile conformant
11802 -- with Subp; return Empty if not found.
11804 function Matching_Dispatching_Subprogram
11805 (Conc_Typ
: Entity_Id
;
11806 Ent
: Entity_Id
) return Entity_Id
;
11807 -- Return the first dispatching primitive of Conc_Type defined in the
11808 -- enclosing scope of Conc_Type (i.e. before the full definition of
11809 -- this concurrent type) whose name matches the entry Ent and has a
11810 -- profile conformant with the profile of the corresponding (not yet
11811 -- built) dispatching primitive of Ent; return Empty if not found.
11813 function Matching_Original_Protected_Subprogram
11814 (Prot_Typ
: Entity_Id
;
11815 Subp
: Entity_Id
) return Entity_Id
;
11816 -- Return the first subprogram defined in the enclosing scope of
11817 -- Prot_Typ (before the full definition of this protected type)
11818 -- whose name matches the original name of Subp and has a profile
11819 -- conformant with the profile of Subp; return Empty if not found.
11821 function Normalized_First_Parameter_Type
11822 (E
: Entity_Id
) return Entity_Id
;
11823 -- Return the type of the first parameter unless that type
11824 -- is an anonymous access type, in which case return the
11825 -- designated type. Used to treat anonymous-access-to-synchronized
11826 -- the same as synchronized for purposes of checking for
11827 -- prefixed view profile conflicts.
11829 ---------------------------------
11830 -- Check_Conforming_Parameters --
11831 ---------------------------------
11833 function Check_Conforming_Parameters
11834 (E1_Param
: Node_Id
;
11835 E2_Param
: Node_Id
;
11836 Ctype
: Conformance_Type
) return Boolean
11838 Param_E1
: Node_Id
:= E1_Param
;
11839 Param_E2
: Node_Id
:= E2_Param
;
11842 while Present
(Param_E1
) and then Present
(Param_E2
) loop
11843 if Ctype
>= Mode_Conformant
and then
11844 Ekind
(Defining_Identifier
(Param_E1
)) /=
11845 Ekind
(Defining_Identifier
(Param_E2
))
11850 (Find_Parameter_Type
(Param_E1
),
11851 Find_Parameter_Type
(Param_E2
),
11861 -- The candidate is not valid if one of the two lists contains
11862 -- more parameters than the other
11864 return No
(Param_E1
) and then No
(Param_E2
);
11865 end Check_Conforming_Parameters
;
11867 ----------------------------------
11868 -- Matching_Entry_Or_Subprogram --
11869 ----------------------------------
11871 function Matching_Entry_Or_Subprogram
11872 (Conc_Typ
: Entity_Id
;
11873 Subp
: Entity_Id
) return Entity_Id
11878 E
:= First_Entity
(Conc_Typ
);
11879 while Present
(E
) loop
11880 if Chars
(Subp
) = Chars
(E
)
11881 and then (Ekind
(E
) = E_Entry
or else Is_Subprogram
(E
))
11883 Check_Conforming_Parameters
11884 (First
(Parameter_Specifications
(Parent
(E
))),
11885 Next
(First
(Parameter_Specifications
(Parent
(Subp
)))),
11895 end Matching_Entry_Or_Subprogram
;
11897 -------------------------------------
11898 -- Matching_Dispatching_Subprogram --
11899 -------------------------------------
11901 function Matching_Dispatching_Subprogram
11902 (Conc_Typ
: Entity_Id
;
11903 Ent
: Entity_Id
) return Entity_Id
11908 -- Search for entities in the enclosing scope of this synchronized
11911 pragma Assert
(Is_Concurrent_Type
(Conc_Typ
));
11912 Push_Scope
(Scope
(Conc_Typ
));
11913 E
:= Current_Entity_In_Scope
(Ent
);
11916 while Present
(E
) loop
11917 if Scope
(E
) = Scope
(Conc_Typ
)
11918 and then Comes_From_Source
(E
)
11919 and then Ekind
(E
) = E_Procedure
11920 and then Present
(First_Entity
(E
))
11921 and then Is_Controlling_Formal
(First_Entity
(E
))
11922 and then Etype
(First_Entity
(E
)) = Conc_Typ
11924 Check_Conforming_Parameters
11925 (First
(Parameter_Specifications
(Parent
(Ent
))),
11926 Next
(First
(Parameter_Specifications
(Parent
(E
)))),
11927 Subtype_Conformant
)
11936 end Matching_Dispatching_Subprogram
;
11938 --------------------------------------------
11939 -- Matching_Original_Protected_Subprogram --
11940 --------------------------------------------
11942 function Matching_Original_Protected_Subprogram
11943 (Prot_Typ
: Entity_Id
;
11944 Subp
: Entity_Id
) return Entity_Id
11946 ICF
: constant Boolean :=
11947 Is_Controlling_Formal
(First_Entity
(Subp
));
11951 -- Temporarily decorate the first parameter of Subp as controlling
11952 -- formal, required to invoke Subtype_Conformant.
11954 Set_Is_Controlling_Formal
(First_Entity
(Subp
));
11957 Current_Entity_In_Scope
(Original_Protected_Subprogram
(Subp
));
11959 while Present
(E
) loop
11960 if Scope
(E
) = Scope
(Prot_Typ
)
11961 and then Comes_From_Source
(E
)
11962 and then Ekind
(Subp
) = Ekind
(E
)
11963 and then Present
(First_Entity
(E
))
11964 and then Is_Controlling_Formal
(First_Entity
(E
))
11965 and then Etype
(First_Entity
(E
)) = Prot_Typ
11966 and then Subtype_Conformant
(Subp
, E
,
11967 Skip_Controlling_Formals
=> True)
11969 Set_Is_Controlling_Formal
(First_Entity
(Subp
), ICF
);
11976 Set_Is_Controlling_Formal
(First_Entity
(Subp
), ICF
);
11979 end Matching_Original_Protected_Subprogram
;
11981 -------------------------------------
11982 -- Normalized_First_Parameter_Type --
11983 -------------------------------------
11985 function Normalized_First_Parameter_Type
11986 (E
: Entity_Id
) return Entity_Id
11988 Result
: Entity_Id
:= Etype
(First_Entity
(E
));
11990 if Ekind
(Result
) = E_Anonymous_Access_Type
then
11991 Result
:= Designated_Type
(Result
);
11994 end Normalized_First_Parameter_Type
;
11996 -- Start of processing for Has_Matching_Entry_Or_Subprogram
11999 -- Case 1: E is a subprogram whose first formal is a concurrent type
12000 -- defined in the scope of E that has an entry or subprogram whose
12001 -- profile matches E.
12003 if Comes_From_Source
(E
)
12004 and then Is_Subprogram
(E
)
12005 and then Present
(First_Entity
(E
))
12006 and then Is_Concurrent_Record_Type
12007 (Normalized_First_Parameter_Type
(E
))
12010 Scope
(Corresponding_Concurrent_Type
12011 (Normalized_First_Parameter_Type
(E
)))
12014 (Matching_Entry_Or_Subprogram
12015 (Corresponding_Concurrent_Type
12016 (Normalized_First_Parameter_Type
(E
)),
12019 Report_Conflict
(E
,
12020 Matching_Entry_Or_Subprogram
12021 (Corresponding_Concurrent_Type
12022 (Normalized_First_Parameter_Type
(E
)),
12027 -- Case 2: E is an internally built dispatching subprogram of a
12028 -- protected type and there is a subprogram defined in the enclosing
12029 -- scope of the protected type that has the original name of E and
12030 -- its profile is conformant with the profile of E. We check the
12031 -- name of the original protected subprogram associated with E since
12032 -- the expander builds dispatching primitives of protected functions
12033 -- and procedures with other names (see Exp_Ch9.Build_Selected_Name).
12035 elsif not Comes_From_Source
(E
)
12036 and then Is_Subprogram
(E
)
12037 and then Present
(First_Entity
(E
))
12038 and then Is_Concurrent_Record_Type
(Etype
(First_Entity
(E
)))
12039 and then Present
(Original_Protected_Subprogram
(E
))
12042 (Matching_Original_Protected_Subprogram
12043 (Corresponding_Concurrent_Type
(Etype
(First_Entity
(E
))),
12046 Report_Conflict
(E
,
12047 Matching_Original_Protected_Subprogram
12048 (Corresponding_Concurrent_Type
(Etype
(First_Entity
(E
))),
12052 -- Case 3: E is an entry of a synchronized type and a matching
12053 -- procedure has been previously defined in the enclosing scope
12054 -- of the synchronized type.
12056 elsif Comes_From_Source
(E
)
12057 and then Ekind
(E
) = E_Entry
12059 Present
(Matching_Dispatching_Subprogram
(Current_Scope
, E
))
12061 Report_Conflict
(E
,
12062 Matching_Dispatching_Subprogram
(Current_Scope
, E
));
12067 end Has_Matching_Entry_Or_Subprogram
;
12069 ----------------------------
12070 -- Is_Private_Declaration --
12071 ----------------------------
12073 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean is
12074 Decl
: constant Node_Id
:= Unit_Declaration_Node
(E
);
12075 Priv_Decls
: List_Id
;
12078 if Is_Package_Or_Generic_Package
(Current_Scope
)
12079 and then In_Private_Part
(Current_Scope
)
12082 Private_Declarations
(Package_Specification
(Current_Scope
));
12084 return In_Package_Body
(Current_Scope
)
12086 (Is_List_Member
(Decl
)
12087 and then List_Containing
(Decl
) = Priv_Decls
)
12088 or else (Nkind
(Parent
(Decl
)) = N_Package_Specification
12090 Is_Compilation_Unit
12091 (Defining_Entity
(Parent
(Decl
)))
12092 and then List_Containing
(Parent
(Parent
(Decl
))) =
12097 end Is_Private_Declaration
;
12099 --------------------------
12100 -- Is_Overriding_Alias --
12101 --------------------------
12103 function Is_Overriding_Alias
12104 (Old_E
: Entity_Id
;
12105 New_E
: Entity_Id
) return Boolean
12107 AO
: constant Entity_Id
:= Alias
(Old_E
);
12108 AN
: constant Entity_Id
:= Alias
(New_E
);
12111 return Scope
(AO
) /= Scope
(AN
)
12112 or else No
(DTC_Entity
(AO
))
12113 or else No
(DTC_Entity
(AN
))
12114 or else DT_Position
(AO
) = DT_Position
(AN
);
12115 end Is_Overriding_Alias
;
12117 ---------------------
12118 -- Report_Conflict --
12119 ---------------------
12121 procedure Report_Conflict
(S
: Entity_Id
; E
: Entity_Id
) is
12123 Error_Msg_Sloc
:= Sloc
(E
);
12125 -- Generate message, with useful additional warning if in generic
12127 if Is_Generic_Unit
(E
) then
12128 Error_Msg_N
("previous generic unit cannot be overloaded", S
);
12129 Error_Msg_N
("\& conflicts with declaration#", S
);
12131 Error_Msg_N
("& conflicts with declaration#", S
);
12133 end Report_Conflict
;
12135 -- Start of processing for New_Overloaded_Entity
12138 -- We need to look for an entity that S may override. This must be a
12139 -- homonym in the current scope, so we look for the first homonym of
12140 -- S in the current scope as the starting point for the search.
12142 E
:= Current_Entity_In_Scope
(S
);
12144 -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
12145 -- They are directly added to the list of primitive operations of
12146 -- Derived_Type, unless this is a rederivation in the private part
12147 -- of an operation that was already derived in the visible part of
12148 -- the current package.
12150 if Ada_Version
>= Ada_2005
12151 and then Present
(Derived_Type
)
12152 and then Present
(Alias
(S
))
12153 and then Is_Dispatching_Operation
(Alias
(S
))
12154 and then Present
(Find_Dispatching_Type
(Alias
(S
)))
12155 and then Is_Interface
(Find_Dispatching_Type
(Alias
(S
)))
12157 -- For private types, when the full-view is processed we propagate to
12158 -- the full view the non-overridden entities whose attribute "alias"
12159 -- references an interface primitive. These entities were added by
12160 -- Derive_Subprograms to ensure that interface primitives are
12163 -- Inside_Freeze_Actions is non zero when S corresponds with an
12164 -- internal entity that links an interface primitive with its
12165 -- covering primitive through attribute Interface_Alias (see
12166 -- Add_Internal_Interface_Entities).
12168 if Inside_Freezing_Actions
= 0
12169 and then Is_Package_Or_Generic_Package
(Current_Scope
)
12170 and then In_Private_Part
(Current_Scope
)
12171 and then Parent_Kind
(E
) = N_Private_Extension_Declaration
12172 and then Nkind
(Parent
(S
)) = N_Full_Type_Declaration
12173 and then Full_View
(Defining_Identifier
(Parent
(E
)))
12174 = Defining_Identifier
(Parent
(S
))
12175 and then Alias
(E
) = Alias
(S
)
12177 Check_Operation_From_Private_View
(S
, E
);
12178 Set_Is_Dispatching_Operation
(S
);
12183 Enter_Overloaded_Entity
(S
);
12184 Check_Dispatching_Operation
(S
, Empty
);
12185 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
12191 -- For synchronized types check conflicts of this entity with previously
12192 -- defined entities.
12194 if Ada_Version
>= Ada_2005
12195 and then Has_Matching_Entry_Or_Subprogram
(S
)
12200 -- If there is no homonym then this is definitely not overriding
12203 Enter_Overloaded_Entity
(S
);
12204 Check_Dispatching_Operation
(S
, Empty
);
12205 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
12207 -- If subprogram has an explicit declaration, check whether it has an
12208 -- overriding indicator.
12210 if Comes_From_Source
(S
) then
12211 Check_Synchronized_Overriding
(S
, Overridden_Subp
);
12213 -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then
12214 -- it may have overridden some hidden inherited primitive. Update
12215 -- Overridden_Subp to avoid spurious errors when checking the
12216 -- overriding indicator.
12218 if Ada_Version
>= Ada_2012
12219 and then No
(Overridden_Subp
)
12220 and then Is_Dispatching_Operation
(S
)
12221 and then Present
(Overridden_Operation
(S
))
12223 Overridden_Subp
:= Overridden_Operation
(S
);
12226 Check_Overriding_Indicator
12227 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
12229 -- The Ghost policy in effect at the point of declaration of a
12230 -- parent subprogram and an overriding subprogram must match
12231 -- (SPARK RM 6.9(17)).
12233 Check_Ghost_Overriding
(S
, Overridden_Subp
);
12236 -- If there is a homonym that is not overloadable, then we have an
12237 -- error, except for the special cases checked explicitly below.
12239 elsif not Is_Overloadable
(E
) then
12241 -- Check for spurious conflict produced by a subprogram that has the
12242 -- same name as that of the enclosing generic package. The conflict
12243 -- occurs within an instance, between the subprogram and the renaming
12244 -- declaration for the package. After the subprogram, the package
12245 -- renaming declaration becomes hidden.
12247 if Ekind
(E
) = E_Package
12248 and then Present
(Renamed_Entity
(E
))
12249 and then Renamed_Entity
(E
) = Current_Scope
12250 and then Nkind
(Parent
(Renamed_Entity
(E
))) =
12251 N_Package_Specification
12252 and then Present
(Generic_Parent
(Parent
(Renamed_Entity
(E
))))
12255 Set_Is_Immediately_Visible
(E
, False);
12256 Enter_Overloaded_Entity
(S
);
12257 Set_Homonym
(S
, Homonym
(E
));
12258 Check_Dispatching_Operation
(S
, Empty
);
12259 Check_Overriding_Indicator
(S
, Empty
, Is_Primitive
=> False);
12261 -- If the subprogram is implicit it is hidden by the previous
12262 -- declaration. However if it is dispatching, it must appear in the
12263 -- dispatch table anyway, because it can be dispatched to even if it
12264 -- cannot be called directly.
12266 elsif Present
(Alias
(S
)) and then not Comes_From_Source
(S
) then
12267 Set_Scope
(S
, Current_Scope
);
12269 if Is_Dispatching_Operation
(Alias
(S
)) then
12270 Check_Dispatching_Operation
(S
, Empty
);
12276 Report_Conflict
(S
, E
);
12280 -- E exists and is overloadable
12283 Check_Synchronized_Overriding
(S
, Overridden_Subp
);
12285 -- Loop through E and its homonyms to determine if any of them is
12286 -- the candidate for overriding by S.
12288 while Present
(E
) loop
12290 -- Definitely not interesting if not in the current scope
12292 if Scope
(E
) /= Current_Scope
then
12295 -- A function can overload the name of an abstract state. The
12296 -- state can be viewed as a function with a profile that cannot
12297 -- be matched by anything.
12299 elsif Ekind
(S
) = E_Function
12300 and then Ekind
(E
) = E_Abstract_State
12302 Enter_Overloaded_Entity
(S
);
12305 -- Ada 2012 (AI05-0165): For internally generated bodies of null
12306 -- procedures locate the internally generated spec. We enforce
12307 -- mode conformance since a tagged type may inherit from
12308 -- interfaces several null primitives which differ only in
12309 -- the mode of the formals.
12311 elsif not Comes_From_Source
(S
)
12312 and then Is_Null_Procedure
(S
)
12313 and then not Mode_Conformant
(E
, S
)
12317 -- Check if we have type conformance
12319 elsif Type_Conformant
(E
, S
) then
12321 -- If the old and new entities have the same profile and one
12322 -- is not the body of the other, then this is an error, unless
12323 -- one of them is implicitly declared.
12325 -- There are some cases when both can be implicit, for example
12326 -- when both a literal and a function that overrides it are
12327 -- inherited in a derivation, or when an inherited operation
12328 -- of a tagged full type overrides the inherited operation of
12329 -- a private extension. Ada 83 had a special rule for the
12330 -- literal case. In Ada 95, the later implicit operation hides
12331 -- the former, and the literal is always the former. In the
12332 -- odd case where both are derived operations declared at the
12333 -- same point, both operations should be declared, and in that
12334 -- case we bypass the following test and proceed to the next
12335 -- part. This can only occur for certain obscure cases in
12336 -- instances, when an operation on a type derived from a formal
12337 -- private type does not override a homograph inherited from
12338 -- the actual. In subsequent derivations of such a type, the
12339 -- DT positions of these operations remain distinct, if they
12342 if Present
(Alias
(S
))
12343 and then (No
(Alias
(E
))
12344 or else Comes_From_Source
(E
)
12345 or else Is_Abstract_Subprogram
(S
)
12347 (Is_Dispatching_Operation
(E
)
12348 and then Is_Overriding_Alias
(E
, S
)))
12349 and then Ekind
(E
) /= E_Enumeration_Literal
12351 -- When an derived operation is overloaded it may be due to
12352 -- the fact that the full view of a private extension
12353 -- re-inherits. It has to be dealt with.
12355 if Is_Package_Or_Generic_Package
(Current_Scope
)
12356 and then In_Private_Part
(Current_Scope
)
12358 Check_Operation_From_Private_View
(S
, E
);
12361 -- In any case the implicit operation remains hidden by the
12362 -- existing declaration, which is overriding. Indicate that
12363 -- E overrides the operation from which S is inherited.
12365 if Present
(Alias
(S
)) then
12366 Set_Overridden_Operation
(E
, Alias
(S
));
12367 Inherit_Subprogram_Contract
(E
, Alias
(S
));
12368 Set_Is_Ada_2022_Only
(E
,
12369 Is_Ada_2022_Only
(Alias
(S
)));
12372 Set_Overridden_Operation
(E
, S
);
12373 Inherit_Subprogram_Contract
(E
, S
);
12374 Set_Is_Ada_2022_Only
(E
, Is_Ada_2022_Only
(S
));
12377 -- When a dispatching operation overrides an inherited
12378 -- subprogram, it shall be subtype conformant with the
12379 -- inherited subprogram (RM 3.9.2 (10.2)).
12381 if Comes_From_Source
(E
)
12382 and then Is_Dispatching_Operation
(E
)
12383 and then Find_Dispatching_Type
(S
)
12384 = Find_Dispatching_Type
(E
)
12386 Check_Subtype_Conformant
(E
, S
);
12389 if Comes_From_Source
(E
) then
12390 Check_Overriding_Indicator
(E
, S
, Is_Primitive
=> False);
12392 -- The Ghost policy in effect at the point of declaration
12393 -- of a parent subprogram and an overriding subprogram
12394 -- must match (SPARK RM 6.9(17)).
12396 Check_Ghost_Overriding
(E
, S
);
12401 -- Within an instance, the renaming declarations for actual
12402 -- subprograms may become ambiguous, but they do not hide each
12405 elsif Ekind
(E
) /= E_Entry
12406 and then not Comes_From_Source
(E
)
12407 and then not Is_Generic_Instance
(E
)
12408 and then (Present
(Alias
(E
))
12409 or else Is_Intrinsic_Subprogram
(E
))
12410 and then (not In_Instance
12411 or else No
(Parent
(E
))
12412 or else Nkind
(Unit_Declaration_Node
(E
)) /=
12413 N_Subprogram_Renaming_Declaration
)
12415 -- A subprogram child unit is not allowed to override an
12416 -- inherited subprogram (10.1.1(20)).
12418 if Is_Child_Unit
(S
) then
12420 ("child unit overrides inherited subprogram in parent",
12425 if Is_Non_Overriding_Operation
(E
, S
) then
12426 Enter_Overloaded_Entity
(S
);
12428 if No
(Derived_Type
)
12429 or else Is_Tagged_Type
(Derived_Type
)
12431 Check_Dispatching_Operation
(S
, Empty
);
12437 -- E is a derived operation or an internal operator which
12438 -- is being overridden. Remove E from further visibility.
12439 -- Furthermore, if E is a dispatching operation, it must be
12440 -- replaced in the list of primitive operations of its type
12441 -- (see Override_Dispatching_Operation).
12443 Overridden_Subp
:= E
;
12445 -- It is possible for E to be in the current scope and
12446 -- yet not in the entity chain. This can only occur in a
12447 -- generic context where E is an implicit concatenation
12448 -- in the formal part, because in a generic body the
12449 -- entity chain starts with the formals.
12451 -- In GNATprove mode, a wrapper for an operation with
12452 -- axiomatization may be a homonym of another declaration
12453 -- for an actual subprogram (needs refinement ???).
12455 if No
(Prev_Entity
(E
)) then
12457 and then GNATprove_Mode
12459 Nkind
(Original_Node
(Unit_Declaration_Node
(S
))) =
12460 N_Subprogram_Renaming_Declaration
12464 pragma Assert
(Chars
(E
) = Name_Op_Concat
);
12469 -- E must be removed both from the entity_list of the
12470 -- current scope, and from the visibility chain.
12472 if Debug_Flag_E
then
12473 Write_Str
("Override implicit operation ");
12474 Write_Int
(Int
(E
));
12478 -- If E is a predefined concatenation, it stands for four
12479 -- different operations. As a result, a single explicit
12480 -- declaration does not hide it. In a possible ambiguous
12481 -- situation, Disambiguate chooses the user-defined op,
12482 -- so it is correct to retain the previous internal one.
12484 if Chars
(E
) /= Name_Op_Concat
12485 or else Ekind
(E
) /= E_Operator
12487 -- For nondispatching derived operations that are
12488 -- overridden by a subprogram declared in the private
12489 -- part of a package, we retain the derived subprogram
12490 -- but mark it as not immediately visible. If the
12491 -- derived operation was declared in the visible part
12492 -- then this ensures that it will still be visible
12493 -- outside the package with the proper signature
12494 -- (calls from outside must also be directed to this
12495 -- version rather than the overriding one, unlike the
12496 -- dispatching case). Calls from inside the package
12497 -- will still resolve to the overriding subprogram
12498 -- since the derived one is marked as not visible
12499 -- within the package.
12501 -- If the private operation is dispatching, we achieve
12502 -- the overriding by keeping the implicit operation
12503 -- but setting its alias to be the overriding one. In
12504 -- this fashion the proper body is executed in all
12505 -- cases, but the original signature is used outside
12508 -- If the overriding is not in the private part, we
12509 -- remove the implicit operation altogether.
12511 if Is_Private_Declaration
(S
) then
12512 if not Is_Dispatching_Operation
(E
) then
12513 Set_Is_Immediately_Visible
(E
, False);
12515 -- Work done in Override_Dispatching_Operation, so
12516 -- nothing else needs to be done here.
12518 -- ??? Special case to keep supporting the hiding
12519 -- of the predefined "=" operator for a nonlimited
12520 -- tagged type by a user-defined "=" operator for
12521 -- its class-wide type when the type is private.
12523 if Chars
(E
) = Name_Op_Eq
then
12525 Typ
: constant Entity_Id
12526 := Etype
(First_Entity
(E
));
12527 H
: Entity_Id
:= Homonym
(E
);
12531 and then Scope
(H
) = Scope
(E
)
12533 if Is_User_Defined_Equality
(H
)
12534 and then Is_Immediately_Visible
(H
)
12535 and then Etype
(First_Entity
(H
))
12536 = Class_Wide_Type
(Typ
)
12538 Remove_Entity_And_Homonym
(E
);
12549 Remove_Entity_And_Homonym
(E
);
12553 Enter_Overloaded_Entity
(S
);
12555 -- For entities generated by Derive_Subprograms the
12556 -- overridden operation is the inherited primitive
12557 -- (which is available through the attribute alias).
12559 if not (Comes_From_Source
(E
))
12560 and then Is_Dispatching_Operation
(E
)
12561 and then Find_Dispatching_Type
(E
) =
12562 Find_Dispatching_Type
(S
)
12563 and then Present
(Alias
(E
))
12564 and then Comes_From_Source
(Alias
(E
))
12566 Set_Overridden_Operation
(S
, Alias
(E
));
12567 Inherit_Subprogram_Contract
(S
, Alias
(E
));
12568 Set_Is_Ada_2022_Only
(S
,
12569 Is_Ada_2022_Only
(Alias
(E
)));
12571 -- Normal case of setting entity as overridden
12573 -- Note: Static_Initialization and Overridden_Operation
12574 -- attributes use the same field in subprogram entities.
12575 -- Static_Initialization is only defined for internal
12576 -- initialization procedures, where Overridden_Operation
12577 -- is irrelevant. Therefore the setting of this attribute
12578 -- must check whether the target is an init_proc.
12580 elsif not Is_Init_Proc
(S
) then
12582 -- LSP wrappers must override the ultimate alias of their
12583 -- wrapped dispatching primitive E; required to traverse
12584 -- the chain of ancestor primitives (c.f. Map_Primitives)
12585 -- They don't inherit contracts.
12588 and then Present
(LSP_Subprogram
(S
))
12590 Set_Overridden_Operation
(S
, Ultimate_Alias
(E
));
12592 Set_Overridden_Operation
(S
, E
);
12593 Inherit_Subprogram_Contract
(S
, E
);
12596 Set_Is_Ada_2022_Only
(S
, Is_Ada_2022_Only
(E
));
12599 Check_Overriding_Indicator
(S
, E
, Is_Primitive
=> True);
12601 -- The Ghost policy in effect at the point of declaration
12602 -- of a parent subprogram and an overriding subprogram
12603 -- must match (SPARK RM 6.9(17)).
12605 Check_Ghost_Overriding
(S
, E
);
12607 -- If S is a user-defined subprogram or a null procedure
12608 -- expanded to override an inherited null procedure, or a
12609 -- predefined dispatching primitive then indicate that E
12610 -- overrides the operation from which S is inherited.
12612 if Comes_From_Source
(S
)
12614 (Present
(Parent
(S
))
12615 and then Nkind
(Parent
(S
)) = N_Procedure_Specification
12616 and then Null_Present
(Parent
(S
)))
12618 (Present
(Alias
(E
))
12620 Is_Predefined_Dispatching_Operation
(Alias
(E
)))
12622 if Present
(Alias
(E
)) then
12624 -- LSP wrappers must override the ultimate alias of
12625 -- their wrapped dispatching primitive E; required to
12626 -- traverse the chain of ancestor primitives (see
12627 -- Map_Primitives). They don't inherit contracts.
12630 and then Present
(LSP_Subprogram
(S
))
12632 Set_Overridden_Operation
(S
, Ultimate_Alias
(E
));
12634 Set_Overridden_Operation
(S
, Alias
(E
));
12635 Inherit_Subprogram_Contract
(S
, Alias
(E
));
12638 Set_Is_Ada_2022_Only
(S
, Is_Ada_2022_Only
(Alias
(E
)));
12642 if Is_Dispatching_Operation
(E
) then
12644 -- An overriding dispatching subprogram inherits the
12645 -- convention of the overridden subprogram (AI95-117).
12647 Set_Convention
(S
, Convention
(E
));
12648 Check_Dispatching_Operation
(S
, E
);
12651 Check_Dispatching_Operation
(S
, Empty
);
12654 Check_For_Primitive_Subprogram
12655 (Is_Primitive_Subp
, Is_Overriding
=> True);
12656 goto Check_Inequality
;
12658 -- Apparent redeclarations in instances can occur when two
12659 -- formal types get the same actual type. The subprograms in
12660 -- in the instance are legal, even if not callable from the
12661 -- outside. Calls from within are disambiguated elsewhere.
12662 -- For dispatching operations in the visible part, the usual
12663 -- rules apply, and operations with the same profile are not
12664 -- legal (B830001).
12666 elsif (In_Instance_Visible_Part
12667 and then not Is_Dispatching_Operation
(E
))
12668 or else In_Instance_Not_Visible
12672 -- Here we have a real error (identical profile)
12675 Error_Msg_Sloc
:= Sloc
(E
);
12677 -- Avoid cascaded errors if the entity appears in
12678 -- subsequent calls.
12680 Set_Scope
(S
, Current_Scope
);
12682 -- Generate error, with extra useful warning for the case
12683 -- of a generic instance with no completion.
12685 if Is_Generic_Instance
(S
)
12686 and then not Has_Completion
(E
)
12689 ("instantiation cannot provide body for&", S
);
12690 Error_Msg_N
("\& conflicts with declaration#", S
);
12692 Error_Msg_N
("& conflicts with declaration#", S
);
12699 -- If one subprogram has an access parameter and the other
12700 -- a parameter of an access type, calls to either might be
12701 -- ambiguous. Verify that parameters match except for the
12702 -- access parameter.
12704 if May_Hide_Profile
then
12710 F1
:= First_Formal
(S
);
12711 F2
:= First_Formal
(E
);
12712 while Present
(F1
) and then Present
(F2
) loop
12713 if Is_Access_Type
(Etype
(F1
)) then
12714 if not Is_Access_Type
(Etype
(F2
))
12715 or else not Conforming_Types
12716 (Designated_Type
(Etype
(F1
)),
12717 Designated_Type
(Etype
(F2
)),
12720 May_Hide_Profile
:= False;
12724 not Conforming_Types
12725 (Etype
(F1
), Etype
(F2
), Type_Conformant
)
12727 May_Hide_Profile
:= False;
12734 if May_Hide_Profile
12738 Error_Msg_NE
("calls to& may be ambiguous??", S
, S
);
12747 -- On exit, we know that S is a new entity
12749 Enter_Overloaded_Entity
(S
);
12750 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
12751 Check_Overriding_Indicator
12752 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
12754 -- The Ghost policy in effect at the point of declaration of a parent
12755 -- subprogram and an overriding subprogram must match
12756 -- (SPARK RM 6.9(17)).
12758 Check_Ghost_Overriding
(S
, Overridden_Subp
);
12760 -- If S is a derived operation for an untagged type then by
12761 -- definition it's not a dispatching operation (even if the parent
12762 -- operation was dispatching), so Check_Dispatching_Operation is not
12763 -- called in that case.
12765 if No
(Derived_Type
)
12766 or else Is_Tagged_Type
(Derived_Type
)
12768 Check_Dispatching_Operation
(S
, Empty
);
12772 -- If this is a user-defined equality operator that is not a derived
12773 -- subprogram, create the corresponding inequality. If the operation is
12774 -- dispatching, the expansion is done elsewhere, and we do not create
12775 -- an explicit inequality operation.
12777 <<Check_Inequality
>>
12778 if Chars
(S
) = Name_Op_Eq
12779 and then Etype
(S
) = Standard_Boolean
12780 and then Present
(Parent
(S
))
12781 and then not Is_Dispatching_Operation
(S
)
12783 Make_Inequality_Operator
(S
);
12784 Check_Untagged_Equality
(S
);
12786 end New_Overloaded_Entity
;
12788 ----------------------------------
12789 -- Preanalyze_Formal_Expression --
12790 ----------------------------------
12792 procedure Preanalyze_Formal_Expression
(N
: Node_Id
; T
: Entity_Id
) is
12793 Save_In_Spec_Expression
: constant Boolean := In_Spec_Expression
;
12795 In_Spec_Expression
:= True;
12796 Preanalyze_With_Freezing_And_Resolve
(N
, T
);
12797 In_Spec_Expression
:= Save_In_Spec_Expression
;
12798 end Preanalyze_Formal_Expression
;
12800 ---------------------
12801 -- Process_Formals --
12802 ---------------------
12804 procedure Process_Formals
12806 Related_Nod
: Node_Id
)
12808 function Designates_From_Limited_With
(Typ
: Entity_Id
) return Boolean;
12809 -- Determine whether an access type designates a type coming from a
12812 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean;
12813 -- Check whether the default has a class-wide type. After analysis the
12814 -- default has the type of the formal, so we must also check explicitly
12815 -- for an access attribute.
12817 ----------------------------------
12818 -- Designates_From_Limited_With --
12819 ----------------------------------
12821 function Designates_From_Limited_With
(Typ
: Entity_Id
) return Boolean is
12822 Desig
: Entity_Id
:= Typ
;
12825 if Is_Access_Type
(Desig
) then
12826 Desig
:= Directly_Designated_Type
(Desig
);
12829 if Is_Class_Wide_Type
(Desig
) then
12830 Desig
:= Root_Type
(Desig
);
12834 Ekind
(Desig
) = E_Incomplete_Type
12835 and then From_Limited_With
(Desig
);
12836 end Designates_From_Limited_With
;
12838 ---------------------------
12839 -- Is_Class_Wide_Default --
12840 ---------------------------
12842 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean is
12844 return Is_Class_Wide_Type
(Designated_Type
(Etype
(D
)))
12845 or else (Nkind
(D
) = N_Attribute_Reference
12846 and then Attribute_Name
(D
) = Name_Access
12847 and then Is_Class_Wide_Type
(Etype
(Prefix
(D
))));
12848 end Is_Class_Wide_Default
;
12852 Context
: constant Node_Id
:= Parent
(Parent
(T
));
12854 Formal
: Entity_Id
;
12855 Formal_Type
: Entity_Id
;
12856 Param_Spec
: Node_Id
;
12859 Num_Out_Params
: Nat
:= 0;
12860 First_Out_Param
: Entity_Id
:= Empty
;
12861 -- Used for setting Is_Only_Out_Parameter
12863 -- Start of processing for Process_Formals
12866 -- In order to prevent premature use of the formals in the same formal
12867 -- part, the Ekind is left undefined until all default expressions are
12868 -- analyzed. The Ekind is established in a separate loop at the end.
12870 Param_Spec
:= First
(T
);
12871 while Present
(Param_Spec
) loop
12872 Formal
:= Defining_Identifier
(Param_Spec
);
12873 Set_Never_Set_In_Source
(Formal
, True);
12874 Enter_Name
(Formal
);
12876 -- Case of ordinary parameters
12878 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
12879 Find_Type
(Parameter_Type
(Param_Spec
));
12880 Ptype
:= Parameter_Type
(Param_Spec
);
12882 if Ptype
= Error
then
12886 -- Protect against malformed parameter types
12888 if Nkind
(Ptype
) not in N_Has_Entity
then
12889 Formal_Type
:= Any_Type
;
12891 Formal_Type
:= Entity
(Ptype
);
12894 if Is_Incomplete_Type
(Formal_Type
)
12896 (Is_Class_Wide_Type
(Formal_Type
)
12897 and then Is_Incomplete_Type
(Root_Type
(Formal_Type
)))
12899 -- Ada 2005 (AI-326): Tagged incomplete types allowed in
12900 -- primitive operations, as long as their completion is
12901 -- in the same declarative part. If in the private part
12902 -- this means that the type cannot be a Taft-amendment type.
12903 -- Check is done on package exit. For access to subprograms,
12904 -- the use is legal for Taft-amendment types.
12906 -- Ada 2012: tagged incomplete types are allowed as generic
12907 -- formal types. They do not introduce dependencies and the
12908 -- corresponding generic subprogram does not have a delayed
12909 -- freeze, because it does not need a freeze node. However,
12910 -- it is still the case that untagged incomplete types cannot
12911 -- be Taft-amendment types and must be completed in private
12912 -- part, so the subprogram must appear in the list of private
12913 -- dependents of the type.
12915 if Is_Tagged_Type
(Formal_Type
)
12916 or else (Ada_Version
>= Ada_2012
12917 and then not From_Limited_With
(Formal_Type
)
12918 and then not Is_Generic_Type
(Formal_Type
))
12920 if Ekind
(Scope
(Current_Scope
)) = E_Package
12921 and then not Is_Generic_Type
(Formal_Type
)
12922 and then not Is_Class_Wide_Type
(Formal_Type
)
12924 if Nkind
(Parent
(T
)) not in
12925 N_Access_Function_Definition |
12926 N_Access_Procedure_Definition
12928 Append_Elmt
(Current_Scope
,
12929 Private_Dependents
(Base_Type
(Formal_Type
)));
12931 -- Freezing is delayed to ensure that Register_Prim
12932 -- will get called for this operation, which is needed
12933 -- in cases where static dispatch tables aren't built.
12934 -- (Note that the same is done for controlling access
12935 -- parameter cases in function Access_Definition.)
12937 if not Is_Thunk
(Current_Scope
) then
12938 Set_Has_Delayed_Freeze
(Current_Scope
);
12943 elsif Nkind
(Parent
(T
)) not in N_Access_Function_Definition
12944 | N_Access_Procedure_Definition
12946 -- AI05-0151: Tagged incomplete types are allowed in all
12947 -- formal parts. Untagged incomplete types are not allowed
12948 -- in bodies. Limited views of either kind are not allowed
12949 -- if there is no place at which the non-limited view can
12950 -- become available.
12952 -- Incomplete formal untagged types are not allowed in
12953 -- subprogram bodies (but are legal in their declarations).
12954 -- This excludes bodies created for null procedures, which
12955 -- are basic declarations.
12957 if Is_Generic_Type
(Formal_Type
)
12958 and then not Is_Tagged_Type
(Formal_Type
)
12959 and then Nkind
(Parent
(Related_Nod
)) = N_Subprogram_Body
12962 ("invalid use of formal incomplete type", Param_Spec
);
12964 elsif Ada_Version
>= Ada_2012
then
12965 if Is_Tagged_Type
(Formal_Type
)
12966 and then (not From_Limited_With
(Formal_Type
)
12967 or else not In_Package_Body
)
12971 elsif Nkind
(Context
) in N_Accept_Statement
12972 | N_Accept_Alternative
12974 or else (Nkind
(Context
) = N_Subprogram_Body
12975 and then Comes_From_Source
(Context
))
12978 ("invalid use of untagged incomplete type &",
12979 Ptype
, Formal_Type
);
12984 ("invalid use of incomplete type&",
12985 Param_Spec
, Formal_Type
);
12987 -- Further checks on the legality of incomplete types
12988 -- in formal parts are delayed until the freeze point
12989 -- of the enclosing subprogram or access to subprogram.
12993 elsif Ekind
(Formal_Type
) = E_Void
then
12995 ("premature use of&",
12996 Parameter_Type
(Param_Spec
), Formal_Type
);
12999 -- Ada 2012 (AI-142): Handle aliased parameters
13001 if Ada_Version
>= Ada_2012
13002 and then Aliased_Present
(Param_Spec
)
13004 Set_Is_Aliased
(Formal
);
13006 -- AI12-001: All aliased objects are considered to be specified
13007 -- as independently addressable (RM C.6(8.1/4)).
13009 Set_Is_Independent
(Formal
);
13012 -- Ada 2005 (AI-231): Create and decorate an internal subtype
13013 -- declaration corresponding to the null-excluding type of the
13014 -- formal in the enclosing scope. Finally, replace the parameter
13015 -- type of the formal with the internal subtype.
13017 if Ada_Version
>= Ada_2005
13018 and then Null_Exclusion_Present
(Param_Spec
)
13020 if not Is_Access_Type
(Formal_Type
) then
13022 ("`NOT NULL` allowed only for an access type", Param_Spec
);
13025 if Can_Never_Be_Null
(Formal_Type
)
13026 and then Comes_From_Source
(Related_Nod
)
13029 ("`NOT NULL` not allowed (& already excludes null)",
13030 Param_Spec
, Formal_Type
);
13034 Create_Null_Excluding_Itype
13036 Related_Nod
=> Related_Nod
,
13037 Scope_Id
=> Scope
(Current_Scope
));
13039 -- If the designated type of the itype is an itype that is
13040 -- not frozen yet, we set the Has_Delayed_Freeze attribute
13041 -- on the access subtype, to prevent order-of-elaboration
13042 -- issues in the backend.
13045 -- type T is access procedure;
13046 -- procedure Op (O : not null T);
13048 if Is_Itype
(Directly_Designated_Type
(Formal_Type
))
13050 not Is_Frozen
(Directly_Designated_Type
(Formal_Type
))
13052 Set_Has_Delayed_Freeze
(Formal_Type
);
13057 -- An access formal type
13061 Access_Definition
(Related_Nod
, Parameter_Type
(Param_Spec
));
13063 -- No need to continue if we already notified errors
13065 if No
(Formal_Type
) then
13069 -- Ada 2005 (AI-254)
13072 AD
: constant Node_Id
:=
13073 Access_To_Subprogram_Definition
13074 (Parameter_Type
(Param_Spec
));
13076 if Present
(AD
) and then Protected_Present
(AD
) then
13078 Replace_Anonymous_Access_To_Protected_Subprogram
13084 Set_Etype
(Formal
, Formal_Type
);
13086 -- Deal with default expression if present
13088 Default
:= Expression
(Param_Spec
);
13090 if Present
(Default
) then
13091 if Out_Present
(Param_Spec
) then
13093 ("default initialization only allowed for IN parameters",
13097 -- Do the special preanalysis of the expression (see section on
13098 -- "Handling of Default Expressions" in the spec of package Sem).
13100 Preanalyze_Formal_Expression
(Default
, Formal_Type
);
13102 -- An access to constant cannot be the default for
13103 -- an access parameter that is an access to variable.
13105 if Ekind
(Formal_Type
) = E_Anonymous_Access_Type
13106 and then not Is_Access_Constant
(Formal_Type
)
13107 and then Is_Access_Type
(Etype
(Default
))
13108 and then Is_Access_Constant
(Etype
(Default
))
13111 ("formal that is access to variable cannot be initialized "
13112 & "with an access-to-constant expression", Default
);
13115 -- Check that the designated type of an access parameter's default
13116 -- is not a class-wide type unless the parameter's designated type
13117 -- is also class-wide.
13119 if Ekind
(Formal_Type
) = E_Anonymous_Access_Type
13120 and then not Designates_From_Limited_With
(Formal_Type
)
13121 and then Is_Class_Wide_Default
(Default
)
13122 and then not Is_Class_Wide_Type
(Designated_Type
(Formal_Type
))
13125 ("access to class-wide expression not allowed here", Default
);
13128 -- Check incorrect use of dynamically tagged expressions
13130 if Is_Tagged_Type
(Formal_Type
) then
13131 Check_Dynamically_Tagged_Expression
13133 Typ
=> Formal_Type
,
13134 Related_Nod
=> Default
);
13138 -- Ada 2005 (AI-231): Static checks
13140 if Ada_Version
>= Ada_2005
13141 and then Is_Access_Type
(Etype
(Formal
))
13142 and then Can_Never_Be_Null
(Etype
(Formal
))
13144 Null_Exclusion_Static_Checks
(Param_Spec
);
13147 -- Deal with aspects on formal parameters. Only Unreferenced is
13148 -- supported for the time being.
13150 if Has_Aspects
(Param_Spec
) then
13152 Aspect
: Node_Id
:= First
(Aspect_Specifications
(Param_Spec
));
13154 while Present
(Aspect
) loop
13155 if Chars
(Identifier
(Aspect
)) = Name_Unreferenced
then
13156 Set_Has_Pragma_Unreferenced
(Formal
);
13159 ("unsupported aspect& on parameter",
13160 Aspect
, Identifier
(Aspect
));
13172 -- If this is the formal part of a function specification, analyze the
13173 -- subtype mark in the context where the formals are visible but not
13174 -- yet usable, and may hide outer homographs.
13176 if Nkind
(Related_Nod
) = N_Function_Specification
then
13177 Analyze_Return_Type
(Related_Nod
);
13180 -- Now set the kind (mode) of each formal
13182 Param_Spec
:= First
(T
);
13183 while Present
(Param_Spec
) loop
13184 Formal
:= Defining_Identifier
(Param_Spec
);
13185 Set_Formal_Mode
(Formal
);
13187 if Ekind
(Formal
) = E_In_Parameter
then
13188 Default
:= Expression
(Param_Spec
);
13190 if Present
(Default
) then
13191 Set_Default_Value
(Formal
, Default
);
13193 if Is_Scalar_Type
(Etype
(Default
)) then
13194 if Nkind
(Parameter_Type
(Param_Spec
)) /=
13195 N_Access_Definition
13197 Formal_Type
:= Entity
(Parameter_Type
(Param_Spec
));
13201 (Related_Nod
, Parameter_Type
(Param_Spec
));
13204 Apply_Scalar_Range_Check
(Default
, Formal_Type
);
13208 elsif Ekind
(Formal
) = E_Out_Parameter
then
13209 Num_Out_Params
:= Num_Out_Params
+ 1;
13211 if Num_Out_Params
= 1 then
13212 First_Out_Param
:= Formal
;
13215 elsif Ekind
(Formal
) = E_In_Out_Parameter
then
13216 Num_Out_Params
:= Num_Out_Params
+ 1;
13219 -- Skip remaining processing if formal type was in error
13221 if Etype
(Formal
) = Any_Type
or else Error_Posted
(Formal
) then
13222 goto Next_Parameter
;
13225 -- Force call by reference if aliased
13228 Conv
: constant Convention_Id
:= Convention
(Etype
(Formal
));
13230 if Is_Aliased
(Formal
) then
13231 Set_Mechanism
(Formal
, By_Reference
);
13233 -- Warn if user asked this to be passed by copy
13235 if Conv
= Convention_Ada_Pass_By_Copy
then
13237 ("cannot pass aliased parameter & by copy??", Formal
);
13240 -- Force mechanism if type has Convention Ada_Pass_By_Ref/Copy
13242 elsif Conv
= Convention_Ada_Pass_By_Copy
then
13243 Set_Mechanism
(Formal
, By_Copy
);
13245 elsif Conv
= Convention_Ada_Pass_By_Reference
then
13246 Set_Mechanism
(Formal
, By_Reference
);
13254 if Present
(First_Out_Param
) and then Num_Out_Params
= 1 then
13255 Set_Is_Only_Out_Parameter
(First_Out_Param
);
13257 end Process_Formals
;
13259 ----------------------------
13260 -- Reference_Body_Formals --
13261 ----------------------------
13263 procedure Reference_Body_Formals
(Spec
: Entity_Id
; Bod
: Entity_Id
) is
13268 if Error_Posted
(Spec
) then
13272 -- Iterate over both lists. They may be of different lengths if the two
13273 -- specs are not conformant.
13275 Fs
:= First_Formal
(Spec
);
13276 Fb
:= First_Formal
(Bod
);
13277 while Present
(Fs
) and then Present
(Fb
) loop
13278 Generate_Reference
(Fs
, Fb
, 'b');
13280 if Style_Check
then
13281 Style
.Check_Identifier
(Fb
, Fs
);
13284 Set_Spec_Entity
(Fb
, Fs
);
13285 Set_Referenced
(Fs
, False);
13289 end Reference_Body_Formals
;
13291 -------------------------
13292 -- Set_Actual_Subtypes --
13293 -------------------------
13295 procedure Set_Actual_Subtypes
(N
: Node_Id
; Subp
: Entity_Id
) is
13297 Formal
: Entity_Id
;
13299 First_Stmt
: Node_Id
:= Empty
;
13300 AS_Needed
: Boolean;
13303 -- If this is an empty initialization procedure, no need to create
13304 -- actual subtypes (small optimization).
13306 if Ekind
(Subp
) = E_Procedure
and then Is_Null_Init_Proc
(Subp
) then
13309 -- Within a predicate function we do not want to generate local
13310 -- subtypes that may generate nested predicate functions.
13312 elsif Is_Subprogram
(Subp
) and then Is_Predicate_Function
(Subp
) then
13316 -- The subtype declarations may freeze the formals. The body generated
13317 -- for an expression function is not a freeze point, so do not emit
13318 -- these declarations (small loss of efficiency in rare cases).
13320 if Nkind
(N
) = N_Subprogram_Body
13321 and then Was_Expression_Function
(N
)
13326 Formal
:= First_Formal
(Subp
);
13327 while Present
(Formal
) loop
13328 T
:= Etype
(Formal
);
13330 -- We never need an actual subtype for a constrained formal
13332 if Is_Constrained
(T
) then
13333 AS_Needed
:= False;
13335 -- If we have unknown discriminants, then we do not need an actual
13336 -- subtype, or more accurately we cannot figure it out. Note that
13337 -- all class-wide types have unknown discriminants.
13339 elsif Has_Unknown_Discriminants
(T
) then
13340 AS_Needed
:= False;
13342 -- At this stage we have an unconstrained type that may need an
13343 -- actual subtype. For sure the actual subtype is needed if we have
13344 -- an unconstrained array type. However, in an instance, the type
13345 -- may appear as a subtype of the full view, while the actual is
13346 -- in fact private (in which case no actual subtype is needed) so
13347 -- check the kind of the base type.
13349 elsif Is_Array_Type
(Base_Type
(T
)) then
13352 -- The only other case needing an actual subtype is an unconstrained
13353 -- record type which is an IN parameter (we cannot generate actual
13354 -- subtypes for the OUT or IN OUT case, since an assignment can
13355 -- change the discriminant values. However we exclude the case of
13356 -- initialization procedures, since discriminants are handled very
13357 -- specially in this context, see the section entitled "Handling of
13358 -- Discriminants" in Einfo.
13360 -- We also exclude the case of Discrim_SO_Functions (functions used
13361 -- in front-end layout mode for size/offset values), since in such
13362 -- functions only discriminants are referenced, and not only are such
13363 -- subtypes not needed, but they cannot always be generated, because
13364 -- of order of elaboration issues.
13366 elsif Is_Record_Type
(T
)
13367 and then Ekind
(Formal
) = E_In_Parameter
13368 and then Chars
(Formal
) /= Name_uInit
13369 and then not Is_Unchecked_Union
(T
)
13370 and then not Is_Discrim_SO_Function
(Subp
)
13374 -- All other cases do not need an actual subtype
13377 AS_Needed
:= False;
13380 -- Generate actual subtypes for unconstrained arrays and
13381 -- unconstrained discriminated records.
13384 if Nkind
(N
) = N_Accept_Statement
then
13386 -- If expansion is active, the formal is replaced by a local
13387 -- variable that renames the corresponding entry of the
13388 -- parameter block, and it is this local variable that may
13389 -- require an actual subtype.
13391 if Expander_Active
then
13392 Decl
:= Build_Actual_Subtype
(T
, Renamed_Object
(Formal
));
13394 Decl
:= Build_Actual_Subtype
(T
, Formal
);
13397 if Present
(Handled_Statement_Sequence
(N
)) then
13399 First
(Statements
(Handled_Statement_Sequence
(N
)));
13400 Prepend
(Decl
, Statements
(Handled_Statement_Sequence
(N
)));
13401 Mark_Rewrite_Insertion
(Decl
);
13403 -- If the accept statement has no body, there will be no
13404 -- reference to the actuals, so no need to compute actual
13411 Decl
:= Build_Actual_Subtype
(T
, Formal
);
13412 Prepend
(Decl
, Declarations
(N
));
13413 Mark_Rewrite_Insertion
(Decl
);
13416 -- The declaration uses the bounds of an existing object, and
13417 -- therefore needs no constraint checks.
13419 Analyze
(Decl
, Suppress
=> All_Checks
);
13420 Set_Is_Actual_Subtype
(Defining_Identifier
(Decl
));
13422 -- We need to freeze manually the generated type when it is
13423 -- inserted anywhere else than in a declarative part.
13425 if Present
(First_Stmt
) then
13426 Insert_List_Before_And_Analyze
(First_Stmt
,
13427 Freeze_Entity
(Defining_Identifier
(Decl
), N
));
13429 -- Ditto if the type has a dynamic predicate, because the
13430 -- generated function will mention the actual subtype. The
13431 -- predicate may come from an explicit aspect of be inherited.
13433 elsif Has_Predicates
(T
) then
13434 Insert_List_After_And_Analyze
(Decl
,
13435 Freeze_Entity
(Defining_Identifier
(Decl
), N
));
13438 if Nkind
(N
) = N_Accept_Statement
13439 and then Expander_Active
13441 Set_Actual_Subtype
(Renamed_Object
(Formal
),
13442 Defining_Identifier
(Decl
));
13444 Set_Actual_Subtype
(Formal
, Defining_Identifier
(Decl
));
13448 Next_Formal
(Formal
);
13450 end Set_Actual_Subtypes
;
13452 ---------------------
13453 -- Set_Formal_Mode --
13454 ---------------------
13456 procedure Set_Formal_Mode
(Formal_Id
: Entity_Id
) is
13457 Spec
: constant Node_Id
:= Parent
(Formal_Id
);
13458 Id
: constant Entity_Id
:= Scope
(Formal_Id
);
13461 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
13462 -- since we ensure that corresponding actuals are always valid at the
13463 -- point of the call.
13465 if Out_Present
(Spec
) then
13467 or else Is_Subprogram_Or_Generic_Subprogram
(Id
)
13469 Set_Has_Out_Or_In_Out_Parameter
(Id
, True);
13472 if Ekind
(Id
) in E_Function | E_Generic_Function
then
13474 -- [IN] OUT parameters allowed for functions in Ada 2012
13476 if Ada_Version
>= Ada_2012
then
13478 -- Even in Ada 2012 operators can only have IN parameters
13480 if Is_Operator_Symbol_Name
(Chars
(Scope
(Formal_Id
))) then
13481 Error_Msg_N
("operators can only have IN parameters", Spec
);
13484 if In_Present
(Spec
) then
13485 Mutate_Ekind
(Formal_Id
, E_In_Out_Parameter
);
13487 Mutate_Ekind
(Formal_Id
, E_Out_Parameter
);
13490 -- But not in earlier versions of Ada
13493 Error_Msg_N
("functions can only have IN parameters", Spec
);
13494 Mutate_Ekind
(Formal_Id
, E_In_Parameter
);
13497 elsif In_Present
(Spec
) then
13498 Mutate_Ekind
(Formal_Id
, E_In_Out_Parameter
);
13501 Mutate_Ekind
(Formal_Id
, E_Out_Parameter
);
13502 Set_Is_True_Constant
(Formal_Id
, False);
13503 Set_Current_Value
(Formal_Id
, Empty
);
13507 Mutate_Ekind
(Formal_Id
, E_In_Parameter
);
13510 Set_Is_Not_Self_Hidden
(Formal_Id
);
13512 -- Set Is_Known_Non_Null for access parameters since the language
13513 -- guarantees that access parameters are always non-null. We also set
13514 -- Can_Never_Be_Null, since there is no way to change the value.
13516 if Nkind
(Parameter_Type
(Spec
)) = N_Access_Definition
then
13518 -- Ada 2005 (AI-231): In Ada 95, access parameters are always non-
13519 -- null; In Ada 2005, only if then null_exclusion is explicit.
13521 if Ada_Version
< Ada_2005
13522 or else Can_Never_Be_Null
(Etype
(Formal_Id
))
13524 Set_Is_Known_Non_Null
(Formal_Id
);
13525 Set_Can_Never_Be_Null
(Formal_Id
);
13528 -- Ada 2005 (AI-231): Null-exclusion access subtype
13530 elsif Is_Access_Type
(Etype
(Formal_Id
))
13531 and then Can_Never_Be_Null
(Etype
(Formal_Id
))
13533 Set_Is_Known_Non_Null
(Formal_Id
);
13535 -- We can also set Can_Never_Be_Null (thus preventing some junk
13536 -- access checks) for the case of an IN parameter, which cannot
13537 -- be changed, or for an IN OUT parameter, which can be changed but
13538 -- not to a null value. But for an OUT parameter, the initial value
13539 -- passed in can be null, so we can't set this flag in that case.
13541 if Ekind
(Formal_Id
) /= E_Out_Parameter
then
13542 Set_Can_Never_Be_Null
(Formal_Id
);
13546 Set_Mechanism
(Formal_Id
, Default_Mechanism
);
13547 Set_Formal_Validity
(Formal_Id
);
13548 end Set_Formal_Mode
;
13550 -------------------------
13551 -- Set_Formal_Validity --
13552 -------------------------
13554 procedure Set_Formal_Validity
(Formal_Id
: Entity_Id
) is
13556 -- If no validity checking, then we cannot assume anything about the
13557 -- validity of parameters, since we do not know there is any checking
13558 -- of the validity on the call side.
13560 if not Validity_Checks_On
then
13563 -- If validity checking for parameters is enabled, this means we are
13564 -- not supposed to make any assumptions about argument values.
13566 elsif Validity_Check_Parameters
then
13569 -- If we are checking in parameters, we will assume that the caller is
13570 -- also checking parameters, so we can assume the parameter is valid.
13572 elsif Ekind
(Formal_Id
) = E_In_Parameter
13573 and then Validity_Check_In_Params
13575 Set_Is_Known_Valid
(Formal_Id
, True);
13577 -- Similar treatment for IN OUT parameters
13579 elsif Ekind
(Formal_Id
) = E_In_Out_Parameter
13580 and then Validity_Check_In_Out_Params
13582 Set_Is_Known_Valid
(Formal_Id
, True);
13584 end Set_Formal_Validity
;
13586 ------------------------
13587 -- Subtype_Conformant --
13588 ------------------------
13590 function Subtype_Conformant
13591 (New_Id
: Entity_Id
;
13592 Old_Id
: Entity_Id
;
13593 Skip_Controlling_Formals
: Boolean := False) return Boolean
13597 Check_Conformance
(New_Id
, Old_Id
, Subtype_Conformant
, False, Result
,
13598 Skip_Controlling_Formals
=> Skip_Controlling_Formals
);
13600 end Subtype_Conformant
;
13602 ---------------------
13603 -- Type_Conformant --
13604 ---------------------
13606 function Type_Conformant
13607 (New_Id
: Entity_Id
;
13608 Old_Id
: Entity_Id
;
13609 Skip_Controlling_Formals
: Boolean := False) return Boolean
13613 May_Hide_Profile
:= False;
13615 (New_Id
, Old_Id
, Type_Conformant
, False, Result
,
13616 Skip_Controlling_Formals
=> Skip_Controlling_Formals
);
13618 end Type_Conformant
;
13620 -------------------------------
13621 -- Valid_Operator_Definition --
13622 -------------------------------
13624 procedure Valid_Operator_Definition
(Designator
: Entity_Id
) is
13627 Id
: constant Name_Id
:= Chars
(Designator
);
13631 F
:= First_Formal
(Designator
);
13632 while Present
(F
) loop
13635 if Present
(Default_Value
(F
)) then
13637 ("default values not allowed for operator parameters",
13640 -- For function instantiations that are operators, we must check
13641 -- separately that the corresponding generic only has in-parameters.
13642 -- For subprogram declarations this is done in Set_Formal_Mode. Such
13643 -- an error could not arise in earlier versions of the language.
13645 elsif Ekind
(F
) /= E_In_Parameter
then
13646 Error_Msg_N
("operators can only have IN parameters", F
);
13652 -- Verify that user-defined operators have proper number of arguments
13653 -- First case of operators which can only be unary
13655 if Id
in Name_Op_Not | Name_Op_Abs
then
13658 -- Case of operators which can be unary or binary
13660 elsif Id
in Name_Op_Add | Name_Op_Subtract
then
13661 N_OK
:= (N
in 1 .. 2);
13663 -- All other operators can only be binary
13671 ("incorrect number of arguments for operator", Designator
);
13675 and then Base_Type
(Etype
(Designator
)) = Standard_Boolean
13676 and then not Is_Intrinsic_Subprogram
(Designator
)
13679 ("explicit definition of inequality not allowed", Designator
);
13681 end Valid_Operator_Definition
;