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.
5330 if GNATprove_Mode
then
5331 Set_Is_Inlined_Always
(Designator
);
5334 -- Introduce new scope for analysis of the formals and the return type
5336 Set_Scope
(Designator
, Current_Scope
);
5338 if Present
(Formals
) then
5339 Push_Scope
(Designator
);
5340 Process_Formals
(Formals
, N
);
5342 -- Check dimensions in N for formals with default expression
5344 Analyze_Dimension_Formals
(N
, Formals
);
5346 -- Ada 2005 (AI-345): If this is an overriding operation of an
5347 -- inherited interface operation, and the controlling type is
5348 -- a synchronized type, replace the type with its corresponding
5349 -- record, to match the proper signature of an overriding operation.
5350 -- Same processing for an access parameter whose designated type is
5351 -- derived from a synchronized interface.
5353 -- This modification is not done for invariant procedures because
5354 -- the corresponding record may not necessarely be visible when the
5355 -- concurrent type acts as the full view of a private type.
5358 -- type Prot is private with Type_Invariant => ...;
5359 -- procedure ConcInvariant (Obj : Prot);
5361 -- protected type Prot is ...;
5362 -- type Concurrent_Record_Prot is record ...;
5363 -- procedure ConcInvariant (Obj : Prot) is
5365 -- end ConcInvariant;
5368 -- In the example above, both the spec and body of the invariant
5369 -- procedure must utilize the private type as the controlling type.
5371 if Ada_Version
>= Ada_2005
5372 and then not Is_Invariant_Procedure_Or_Body
(Designator
)
5376 Formal_Typ
: Entity_Id
;
5377 Rec_Typ
: Entity_Id
;
5378 Desig_Typ
: Entity_Id
;
5381 Formal
:= First_Formal
(Designator
);
5382 while Present
(Formal
) loop
5383 Formal_Typ
:= Etype
(Formal
);
5385 if Is_Concurrent_Type
(Formal_Typ
)
5386 and then Present
(Corresponding_Record_Type
(Formal_Typ
))
5388 Rec_Typ
:= Corresponding_Record_Type
(Formal_Typ
);
5390 if Present
(Interfaces
(Rec_Typ
)) then
5391 Set_Etype
(Formal
, Rec_Typ
);
5394 elsif Ekind
(Formal_Typ
) = E_Anonymous_Access_Type
then
5395 Desig_Typ
:= Designated_Type
(Formal_Typ
);
5397 if Is_Concurrent_Type
(Desig_Typ
)
5398 and then Present
(Corresponding_Record_Type
(Desig_Typ
))
5400 Rec_Typ
:= Corresponding_Record_Type
(Desig_Typ
);
5402 if Present
(Interfaces
(Rec_Typ
)) then
5403 Set_Directly_Designated_Type
(Formal_Typ
, Rec_Typ
);
5408 Next_Formal
(Formal
);
5415 -- The subprogram scope is pushed and popped around the processing of
5416 -- the return type for consistency with call above to Process_Formals
5417 -- (which itself can call Analyze_Return_Type), and to ensure that any
5418 -- itype created for the return type will be associated with the proper
5421 elsif Nkind
(N
) = N_Function_Specification
then
5422 Push_Scope
(Designator
);
5423 Analyze_Return_Type
(N
);
5429 if Nkind
(N
) = N_Function_Specification
then
5431 -- Deal with operator symbol case
5433 if Nkind
(Designator
) = N_Defining_Operator_Symbol
then
5434 Valid_Operator_Definition
(Designator
);
5437 May_Need_Actuals
(Designator
);
5439 -- Ada 2005 (AI-251): If the return type is abstract, verify that
5440 -- the subprogram is abstract also. This does not apply to renaming
5441 -- declarations, where abstractness is inherited, and to subprogram
5442 -- bodies generated for stream operations, which become renamings as
5443 -- bodies. We also skip the check for thunks.
5445 -- In case of primitives associated with abstract interface types
5446 -- the check is applied later (see Analyze_Subprogram_Declaration).
5448 if Nkind
(Original_Node
(Parent
(N
))) not in
5449 N_Abstract_Subprogram_Declaration |
5450 N_Formal_Abstract_Subprogram_Declaration |
5451 N_Subprogram_Renaming_Declaration
5452 and then not Is_Thunk
(Designator
)
5454 if Is_Abstract_Type
(Etype
(Designator
)) then
5456 ("function that returns abstract type must be abstract", N
);
5458 -- Ada 2012 (AI-0073): Extend this test to subprograms with an
5459 -- access result whose designated type is abstract.
5461 elsif Ada_Version
>= Ada_2012
5462 and then Nkind
(Result_Definition
(N
)) = N_Access_Definition
5464 not Is_Class_Wide_Type
(Designated_Type
(Etype
(Designator
)))
5465 and then Is_Abstract_Type
(Designated_Type
(Etype
(Designator
)))
5468 ("function whose access result designates abstract type "
5469 & "must be abstract", N
);
5475 end Analyze_Subprogram_Specification
;
5477 -----------------------
5478 -- Check_Conformance --
5479 -----------------------
5481 procedure Check_Conformance
5482 (New_Id
: Entity_Id
;
5484 Ctype
: Conformance_Type
;
5486 Conforms
: out Boolean;
5487 Err_Loc
: Node_Id
:= Empty
;
5488 Get_Inst
: Boolean := False;
5489 Skip_Controlling_Formals
: Boolean := False)
5491 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
);
5492 -- Sets Conforms to False. If Errmsg is False, then that's all it does.
5493 -- If Errmsg is True, then processing continues to post an error message
5494 -- for conformance error on given node. Two messages are output. The
5495 -- first message points to the previous declaration with a general "no
5496 -- conformance" message. The second is the detailed reason, supplied as
5497 -- Msg. The parameter N provide information for a possible & insertion
5498 -- in the message, and also provides the location for posting the
5499 -- message in the absence of a specified Err_Loc location.
5501 function Conventions_Match
(Id1
, Id2
: Entity_Id
) return Boolean;
5502 -- True if the conventions of entities Id1 and Id2 match.
5504 function Null_Exclusions_Match
(F1
, F2
: Entity_Id
) return Boolean;
5505 -- True if the null exclusions of two formals of anonymous access type
5508 function Subprogram_Subtypes_Have_Same_Declaration
5510 Decl_Subtype
: Entity_Id
;
5511 Body_Subtype
: Entity_Id
) return Boolean;
5512 -- Checks whether corresponding subtypes named within a subprogram
5513 -- declaration and body originate from the same declaration, and returns
5514 -- True when they do. In the case of anonymous access-to-object types,
5515 -- checks the designated types. Also returns True when GNAT_Mode is
5516 -- enabled, or when the subprogram is marked Is_Internal or occurs
5517 -- within a generic instantiation or internal unit (GNAT library unit).
5519 -----------------------
5520 -- Conformance_Error --
5521 -----------------------
5523 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
) is
5530 if No
(Err_Loc
) then
5536 Error_Msg_Sloc
:= Sloc
(Old_Id
);
5539 when Type_Conformant
=>
5540 Error_Msg_N
-- CODEFIX
5541 ("not type conformant with declaration#!", Enode
);
5543 when Mode_Conformant
=>
5544 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
5546 ("not mode conformant with operation inherited#!",
5550 ("not mode conformant with declaration#!", Enode
);
5553 when Subtype_Conformant
=>
5554 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
5556 ("not subtype conformant with operation inherited#!",
5560 ("not subtype conformant with declaration#!", Enode
);
5563 when Fully_Conformant
=>
5564 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
5565 Error_Msg_N
-- CODEFIX
5566 ("not fully conformant with operation inherited#!",
5569 Error_Msg_N
-- CODEFIX
5570 ("not fully conformant with declaration#!", Enode
);
5574 Error_Msg_NE
(Msg
, Enode
, N
);
5576 end Conformance_Error
;
5578 -----------------------
5579 -- Conventions_Match --
5580 -----------------------
5582 function Conventions_Match
5584 Id2
: Entity_Id
) return Boolean
5587 -- Ignore the conventions of anonymous access-to-subprogram types
5588 -- and subprogram types because these are internally generated and
5589 -- the only way these may receive a convention is if they inherit
5590 -- the convention of a related subprogram.
5592 if Ekind
(Id1
) in E_Anonymous_Access_Subprogram_Type
5595 Ekind
(Id2
) in E_Anonymous_Access_Subprogram_Type
5600 -- Otherwise compare the conventions directly
5603 return Convention
(Id1
) = Convention
(Id2
);
5605 end Conventions_Match
;
5607 ---------------------------
5608 -- Null_Exclusions_Match --
5609 ---------------------------
5611 function Null_Exclusions_Match
(F1
, F2
: Entity_Id
) return Boolean is
5613 if not Is_Anonymous_Access_Type
(Etype
(F1
))
5614 or else not Is_Anonymous_Access_Type
(Etype
(F2
))
5619 -- AI12-0289-1: Case of controlling access parameter; False if the
5620 -- partial view is untagged, the full view is tagged, and no explicit
5621 -- "not null". Note that at this point, we're processing the package
5622 -- body, so private/full types have been swapped. The Sloc test below
5623 -- is to detect the (legal) case where F1 comes after the full type
5624 -- declaration. This part is disabled pre-2005, because "not null" is
5625 -- not allowed on those language versions.
5627 if Ada_Version
>= Ada_2005
5628 and then Is_Controlling_Formal
(F1
)
5629 and then not Null_Exclusion_Present
(Parent
(F1
))
5630 and then not Null_Exclusion_Present
(Parent
(F2
))
5633 D
: constant Entity_Id
:= Directly_Designated_Type
(Etype
(F1
));
5634 Partial_View_Of_Desig
: constant Entity_Id
:=
5635 Incomplete_Or_Partial_View
(D
);
5637 return No
(Partial_View_Of_Desig
)
5638 or else Is_Tagged_Type
(Partial_View_Of_Desig
)
5639 or else Sloc
(D
) < Sloc
(F1
);
5642 -- Not a controlling parameter, or one or both views have an explicit
5646 return Null_Exclusion_Present
(Parent
(F1
)) =
5647 Null_Exclusion_Present
(Parent
(F2
));
5649 end Null_Exclusions_Match
;
5651 function Subprogram_Subtypes_Have_Same_Declaration
5653 Decl_Subtype
: Entity_Id
;
5654 Body_Subtype
: Entity_Id
) return Boolean
5657 function Nonlimited_View_Of_Subtype
5658 (Subt
: Entity_Id
) return Entity_Id
;
5659 -- Returns the nonlimited view of a type or subtype that is an
5660 -- incomplete or class-wide type that comes from a limited view of
5661 -- a package (From_Limited_With is True for the entity), or the
5662 -- full view when the subtype is an incomplete type. Otherwise
5663 -- returns the entity passed in.
5665 function Nonlimited_View_Of_Subtype
5666 (Subt
: Entity_Id
) return Entity_Id
5668 Subt_Temp
: Entity_Id
:= Subt
;
5670 if Ekind
(Subt
) in Incomplete_Kind | E_Class_Wide_Type
5671 and then From_Limited_With
(Subt
)
5673 Subt_Temp
:= Non_Limited_View
(Subt
);
5676 -- If the subtype is incomplete, return full view if present
5677 -- (and accounts for the case where a type from a limited view
5678 -- is itself an incomplete type).
5680 if Ekind
(Subt_Temp
) in Incomplete_Kind
5681 and then Present
(Full_View
(Subt_Temp
))
5683 Subt_Temp
:= Full_View
(Subt_Temp
);
5687 end Nonlimited_View_Of_Subtype
;
5689 -- Start of processing for Subprogram_Subtypes_Have_Same_Declaration
5693 and then not In_Internal_Unit
(Subp
)
5694 and then not Is_Internal
(Subp
)
5695 and then not GNAT_Mode
5697 Ekind
(Etype
(Decl_Subtype
)) not in Access_Subprogram_Kind
5699 if Ekind
(Etype
(Decl_Subtype
)) = E_Anonymous_Access_Type
then
5700 if Nonlimited_View_Of_Subtype
(Designated_Type
(Decl_Subtype
))
5701 /= Nonlimited_View_Of_Subtype
(Designated_Type
(Body_Subtype
))
5706 elsif Nonlimited_View_Of_Subtype
(Decl_Subtype
)
5707 /= Nonlimited_View_Of_Subtype
(Body_Subtype
)
5709 -- Avoid returning False (and a false-positive warning) for
5710 -- the case of "not null" itypes, which will appear to be
5711 -- different subtypes even when the subtype_marks denote
5712 -- the same subtype.
5714 if Ekind
(Decl_Subtype
) = E_Access_Subtype
5715 and then Ekind
(Body_Subtype
) = E_Access_Subtype
5716 and then Is_Itype
(Body_Subtype
)
5717 and then Can_Never_Be_Null
(Body_Subtype
)
5718 and then Etype
(Decl_Subtype
) = Etype
(Body_Subtype
)
5729 end Subprogram_Subtypes_Have_Same_Declaration
;
5733 Old_Type
: constant Entity_Id
:= Etype
(Old_Id
);
5734 New_Type
: constant Entity_Id
:= Etype
(New_Id
);
5735 Old_Formal
: Entity_Id
;
5736 New_Formal
: Entity_Id
;
5737 Old_Formal_Base
: Entity_Id
;
5738 New_Formal_Base
: Entity_Id
;
5740 -- Start of processing for Check_Conformance
5745 -- We need a special case for operators, since they don't appear
5748 if Ctype
= Type_Conformant
then
5749 if Ekind
(New_Id
) = E_Operator
5750 and then Operator_Matches_Spec
(New_Id
, Old_Id
)
5756 -- If both are functions/operators, check return types conform
5758 if Old_Type
/= Standard_Void_Type
5760 New_Type
/= Standard_Void_Type
5762 -- If we are checking interface conformance we omit controlling
5763 -- arguments and result, because we are only checking the conformance
5764 -- of the remaining parameters.
5766 if Has_Controlling_Result
(Old_Id
)
5767 and then Has_Controlling_Result
(New_Id
)
5768 and then Skip_Controlling_Formals
5772 elsif not Conforming_Types
(Old_Type
, New_Type
, Ctype
, Get_Inst
) then
5773 if Ctype
>= Subtype_Conformant
5774 and then not Predicates_Match
(Old_Type
, New_Type
)
5777 ("\predicate of return type does not match!", New_Id
);
5780 ("\return type does not match!", New_Id
);
5785 -- If the result subtypes conform and pedantic checks are enabled,
5786 -- check to see whether the subtypes originate from different
5787 -- declarations, and issue a warning when they do.
5789 elsif Ctype
= Fully_Conformant
5790 and then Warn_On_Pedantic_Checks
5791 and then not Subprogram_Subtypes_Have_Same_Declaration
5792 (Old_Id
, Old_Type
, New_Type
)
5794 Error_Msg_N
("result subtypes conform but come from different "
5795 & "declarations?_p?", New_Id
);
5798 -- Ada 2005 (AI-231): In case of anonymous access types check the
5799 -- null-exclusion and access-to-constant attributes match.
5801 if Ada_Version
>= Ada_2005
5802 and then Ekind
(Etype
(Old_Type
)) = E_Anonymous_Access_Type
5804 (Can_Never_Be_Null
(Old_Type
) /= Can_Never_Be_Null
(New_Type
)
5805 or else Is_Access_Constant
(Etype
(Old_Type
)) /=
5806 Is_Access_Constant
(Etype
(New_Type
)))
5808 Conformance_Error
("\return type does not match!", New_Id
);
5812 -- If either is a function/operator and the other isn't, error
5814 elsif Old_Type
/= Standard_Void_Type
5815 or else New_Type
/= Standard_Void_Type
5817 Conformance_Error
("\functions can only match functions!", New_Id
);
5821 -- In subtype conformant case, conventions must match (RM 6.3.1(16)).
5822 -- If this is a renaming as body, refine error message to indicate that
5823 -- the conflict is with the original declaration. If the entity is not
5824 -- frozen, the conventions don't have to match, the one of the renamed
5825 -- entity is inherited.
5827 if Ctype
>= Subtype_Conformant
then
5828 if not Conventions_Match
(Old_Id
, New_Id
) then
5829 if not Is_Frozen
(New_Id
) then
5832 elsif Present
(Err_Loc
)
5833 and then Nkind
(Err_Loc
) = N_Subprogram_Renaming_Declaration
5834 and then Present
(Corresponding_Spec
(Err_Loc
))
5836 Error_Msg_Name_1
:= Chars
(New_Id
);
5838 Name_Ada
+ Convention_Id
'Pos (Convention
(New_Id
));
5839 Conformance_Error
("\prior declaration for% has convention %!");
5843 Conformance_Error
("\calling conventions do not match!");
5847 Check_Formal_Subprogram_Conformance
5848 (New_Id
, Old_Id
, Err_Loc
, Errmsg
, Conforms
);
5850 if not Conforms
then
5856 -- Deal with parameters
5858 -- Note: we use the entity information, rather than going directly
5859 -- to the specification in the tree. This is not only simpler, but
5860 -- absolutely necessary for some cases of conformance tests between
5861 -- operators, where the declaration tree simply does not exist.
5863 Old_Formal
:= First_Formal
(Old_Id
);
5864 New_Formal
:= First_Formal
(New_Id
);
5865 while Present
(Old_Formal
) and then Present
(New_Formal
) loop
5866 if Is_Controlling_Formal
(Old_Formal
)
5867 and then Is_Controlling_Formal
(New_Formal
)
5868 and then Skip_Controlling_Formals
5870 -- The controlling formals will have different types when
5871 -- comparing an interface operation with its match, but both
5872 -- or neither must be access parameters.
5874 if Is_Access_Type
(Etype
(Old_Formal
))
5876 Is_Access_Type
(Etype
(New_Formal
))
5878 goto Skip_Controlling_Formal
;
5881 ("\access parameter does not match!", New_Formal
);
5885 -- Ada 2012: Mode conformance also requires that formal parameters
5886 -- be both aliased, or neither.
5888 if Ctype
>= Mode_Conformant
and then Ada_Version
>= Ada_2012
then
5889 if Is_Aliased
(Old_Formal
) /= Is_Aliased
(New_Formal
) then
5891 ("\aliased parameter mismatch!", New_Formal
);
5895 if Ctype
= Fully_Conformant
then
5897 -- Names must match. Error message is more accurate if we do
5898 -- this before checking that the types of the formals match.
5900 if Chars
(Old_Formal
) /= Chars
(New_Formal
) then
5901 Conformance_Error
("\name& does not match!", New_Formal
);
5903 -- Set error posted flag on new formal as well to stop
5904 -- junk cascaded messages in some cases.
5906 Set_Error_Posted
(New_Formal
);
5910 -- Null exclusion must match
5912 if not Relaxed_RM_Semantics
5913 and then not Null_Exclusions_Match
(Old_Formal
, New_Formal
)
5916 ("\null exclusion for& does not match", New_Formal
);
5918 -- Mark error posted on the new formal to avoid duplicated
5919 -- complaint about types not matching.
5921 Set_Error_Posted
(New_Formal
);
5925 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
5926 -- case occurs whenever a subprogram is being renamed and one of its
5927 -- parameters imposes a null exclusion. For example:
5929 -- type T is null record;
5930 -- type Acc_T is access T;
5931 -- subtype Acc_T_Sub is Acc_T;
5933 -- procedure P (Obj : not null Acc_T_Sub); -- itype
5934 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype
5937 Old_Formal_Base
:= Etype
(Old_Formal
);
5938 New_Formal_Base
:= Etype
(New_Formal
);
5941 Old_Formal_Base
:= Get_Instance_Of
(Old_Formal_Base
);
5942 New_Formal_Base
:= Get_Instance_Of
(New_Formal_Base
);
5945 -- Types must always match. In the visible part of an instance,
5946 -- usual overloading rules for dispatching operations apply, and
5947 -- we check base types (not the actual subtypes).
5949 if In_Instance_Visible_Part
5950 and then Is_Dispatching_Operation
(New_Id
)
5952 if not Conforming_Types
5953 (T1
=> Base_Type
(Etype
(Old_Formal
)),
5954 T2
=> Base_Type
(Etype
(New_Formal
)),
5956 Get_Inst
=> Get_Inst
)
5958 Conformance_Error
("\type of & does not match!", New_Formal
);
5962 elsif not Conforming_Types
5963 (T1
=> Old_Formal_Base
,
5964 T2
=> New_Formal_Base
,
5966 Get_Inst
=> Get_Inst
)
5968 -- Don't give error message if old type is Any_Type. This test
5969 -- avoids some cascaded errors, e.g. in case of a bad spec.
5971 if Errmsg
and then Old_Formal_Base
= Any_Type
then
5974 if Ctype
>= Subtype_Conformant
5976 not Predicates_Match
(Old_Formal_Base
, New_Formal_Base
)
5979 ("\predicate of & does not match!", New_Formal
);
5982 ("\type of & does not match!", New_Formal
);
5984 if not Dimensions_Match
(Old_Formal_Base
, New_Formal_Base
)
5986 Error_Msg_N
("\dimensions mismatch!", New_Formal
);
5993 -- If the formals' subtypes conform and pedantic checks are enabled,
5994 -- check to see whether the subtypes originate from different
5995 -- declarations, and issue a warning when they do.
5997 elsif Ctype
= Fully_Conformant
5998 and then Warn_On_Pedantic_Checks
5999 and then not Subprogram_Subtypes_Have_Same_Declaration
6000 (Old_Id
, Old_Formal_Base
, New_Formal_Base
)
6002 Error_Msg_N
("formal subtypes conform but come from "
6003 & "different declarations?_p?", New_Formal
);
6006 -- For mode conformance, mode must match
6008 if Ctype
>= Mode_Conformant
then
6009 if Parameter_Mode
(Old_Formal
) /= Parameter_Mode
(New_Formal
) then
6010 if Ekind
(New_Id
) not in E_Function | E_Procedure
6011 or else not Is_Primitive_Wrapper
(New_Id
)
6013 Conformance_Error
("\mode of & does not match!", New_Formal
);
6017 T
: constant Entity_Id
:= Find_Dispatching_Type
(New_Id
);
6019 if Is_Protected_Type
(Corresponding_Concurrent_Type
(T
))
6024 Error_Msg_PT
(New_Id
, Ultimate_Alias
(Old_Id
));
6028 ("\mode of & does not match!", New_Formal
);
6035 elsif Is_Access_Type
(Old_Formal_Base
)
6036 and then Is_Access_Type
(New_Formal_Base
)
6037 and then Is_Access_Constant
(Old_Formal_Base
) /=
6038 Is_Access_Constant
(New_Formal_Base
)
6041 ("\constant modifier does not match!", New_Formal
);
6046 if Ctype
>= Subtype_Conformant
then
6048 -- Ada 2005 (AI-231): In case of anonymous access types check
6049 -- the null-exclusion and access-to-constant attributes must
6050 -- match. For null exclusion, we test the types rather than the
6051 -- formals themselves, since the attribute is only set reliably
6052 -- on the formals in the Ada 95 case, and we exclude the case
6053 -- where Old_Formal is marked as controlling, to avoid errors
6054 -- when matching completing bodies with dispatching declarations
6055 -- (access formals in the bodies aren't marked Can_Never_Be_Null).
6057 if Ada_Version
>= Ada_2005
6058 and then Is_Anonymous_Access_Type
(Etype
(Old_Formal
))
6059 and then Is_Anonymous_Access_Type
(Etype
(New_Formal
))
6061 ((Can_Never_Be_Null
(Etype
(Old_Formal
)) /=
6062 Can_Never_Be_Null
(Etype
(New_Formal
))
6064 not Is_Controlling_Formal
(Old_Formal
))
6066 Is_Access_Constant
(Etype
(Old_Formal
)) /=
6067 Is_Access_Constant
(Etype
(New_Formal
)))
6069 -- Do not complain if error already posted on New_Formal. This
6070 -- avoids some redundant error messages.
6072 and then not Error_Posted
(New_Formal
)
6074 -- It is allowed to omit the null-exclusion in case of stream
6075 -- attribute subprograms. We recognize stream subprograms
6076 -- through their TSS-generated suffix.
6078 and then Get_TSS_Name
(New_Id
) not in TSS_Stream_Read
6083 -- Here we have a definite conformance error. It is worth
6084 -- special casing the error message for the case of a
6085 -- controlling formal (which excludes null).
6087 if Is_Controlling_Formal
(New_Formal
) then
6088 Error_Msg_Node_2
:= Scope
(New_Formal
);
6090 ("\controlling formal & of & excludes null, "
6091 & "declaration must exclude null as well",
6094 -- Normal case (couldn't we give more detail here???)
6098 ("\type of & does not match!", New_Formal
);
6105 -- Full conformance checks
6107 if Ctype
= Fully_Conformant
then
6109 -- We have checked already that names match
6111 if Parameter_Mode
(Old_Formal
) = E_In_Parameter
then
6113 -- Check default expressions for in parameters
6116 NewD
: constant Boolean :=
6117 Present
(Default_Value
(New_Formal
));
6118 OldD
: constant Boolean :=
6119 Present
(Default_Value
(Old_Formal
));
6121 if NewD
or OldD
then
6123 -- The old default value has been analyzed because the
6124 -- current full declaration will have frozen everything
6125 -- before. The new default value has not been analyzed,
6126 -- so analyze it now before we check for conformance.
6129 Push_Scope
(New_Id
);
6130 Preanalyze_Spec_Expression
6131 (Default_Value
(New_Formal
), Etype
(New_Formal
));
6135 if not (NewD
and OldD
)
6136 or else not Fully_Conformant_Expressions
6137 (Default_Value
(Old_Formal
),
6138 Default_Value
(New_Formal
))
6141 ("\default expression for & does not match!",
6150 -- A couple of special checks for Ada 83 mode. These checks are
6151 -- skipped if either entity is an operator in package Standard,
6152 -- or if either old or new instance is not from the source program.
6154 if Ada_Version
= Ada_83
6155 and then Sloc
(Old_Id
) > Standard_Location
6156 and then Sloc
(New_Id
) > Standard_Location
6157 and then Comes_From_Source
(Old_Id
)
6158 and then Comes_From_Source
(New_Id
)
6161 Old_Param
: constant Node_Id
:= Declaration_Node
(Old_Formal
);
6162 New_Param
: constant Node_Id
:= Declaration_Node
(New_Formal
);
6165 -- Explicit IN must be present or absent in both cases. This
6166 -- test is required only in the full conformance case.
6168 if In_Present
(Old_Param
) /= In_Present
(New_Param
)
6169 and then Ctype
= Fully_Conformant
6172 ("\(Ada 83) IN must appear in both declarations",
6177 -- Grouping (use of comma in param lists) must be the same
6178 -- This is where we catch a misconformance like:
6181 -- A : Integer; B : Integer
6183 -- which are represented identically in the tree except
6184 -- for the setting of the flags More_Ids and Prev_Ids.
6186 if More_Ids
(Old_Param
) /= More_Ids
(New_Param
)
6187 or else Prev_Ids
(Old_Param
) /= Prev_Ids
(New_Param
)
6190 ("\grouping of & does not match!", New_Formal
);
6196 -- This label is required when skipping controlling formals
6198 <<Skip_Controlling_Formal
>>
6200 Next_Formal
(Old_Formal
);
6201 Next_Formal
(New_Formal
);
6204 if Present
(Old_Formal
) then
6205 Conformance_Error
("\too few parameters!");
6208 elsif Present
(New_Formal
) then
6209 Conformance_Error
("\too many parameters!", New_Formal
);
6212 end Check_Conformance
;
6214 -----------------------
6215 -- Check_Conventions --
6216 -----------------------
6218 procedure Check_Conventions
(Typ
: Entity_Id
) is
6219 Ifaces_List
: Elist_Id
;
6221 procedure Check_Convention
(Op
: Entity_Id
);
6222 -- Verify that the convention of inherited dispatching operation Op is
6223 -- consistent among all subprograms it overrides. In order to minimize
6224 -- the search, Search_From is utilized to designate a specific point in
6225 -- the list rather than iterating over the whole list once more.
6227 ----------------------
6228 -- Check_Convention --
6229 ----------------------
6231 procedure Check_Convention
(Op
: Entity_Id
) is
6232 Op_Conv
: constant Convention_Id
:= Convention
(Op
);
6233 Iface_Conv
: Convention_Id
;
6234 Iface_Elmt
: Elmt_Id
;
6235 Iface_Prim_Elmt
: Elmt_Id
;
6236 Iface_Prim
: Entity_Id
;
6239 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
6240 while Present
(Iface_Elmt
) loop
6242 First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
6243 while Present
(Iface_Prim_Elmt
) loop
6244 Iface_Prim
:= Node
(Iface_Prim_Elmt
);
6245 Iface_Conv
:= Convention
(Iface_Prim
);
6247 if Is_Interface_Conformant
(Typ
, Iface_Prim
, Op
)
6248 and then Iface_Conv
/= Op_Conv
6251 ("inconsistent conventions in primitive operations", Typ
);
6253 Error_Msg_Name_1
:= Chars
(Op
);
6254 Error_Msg_Name_2
:= Get_Convention_Name
(Op_Conv
);
6255 Error_Msg_Sloc
:= Sloc
(Op
);
6257 if Comes_From_Source
(Op
) or else No
(Alias
(Op
)) then
6258 if No
(Overridden_Operation
(Op
)) then
6259 Error_Msg_N
("\\primitive % defined #", Typ
);
6262 ("\\overriding operation % with "
6263 & "convention % defined #", Typ
);
6266 else pragma Assert
(Present
(Alias
(Op
)));
6267 Error_Msg_Sloc
:= Sloc
(Alias
(Op
));
6268 Error_Msg_N
("\\inherited operation % with "
6269 & "convention % defined #", Typ
);
6272 Error_Msg_Name_1
:= Chars
(Op
);
6273 Error_Msg_Name_2
:= Get_Convention_Name
(Iface_Conv
);
6274 Error_Msg_Sloc
:= Sloc
(Iface_Prim
);
6275 Error_Msg_N
("\\overridden operation % with "
6276 & "convention % defined #", Typ
);
6278 -- Avoid cascading errors
6283 Next_Elmt
(Iface_Prim_Elmt
);
6286 Next_Elmt
(Iface_Elmt
);
6288 end Check_Convention
;
6292 Prim_Op
: Entity_Id
;
6293 Prim_Op_Elmt
: Elmt_Id
;
6295 -- Start of processing for Check_Conventions
6298 if not Has_Interfaces
(Typ
) then
6302 Collect_Interfaces
(Typ
, Ifaces_List
);
6304 -- The algorithm checks every overriding dispatching operation against
6305 -- all the corresponding overridden dispatching operations, detecting
6306 -- differences in conventions.
6308 Prim_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6309 while Present
(Prim_Op_Elmt
) loop
6310 Prim_Op
:= Node
(Prim_Op_Elmt
);
6312 -- A small optimization: skip the predefined dispatching operations
6313 -- since they always have the same convention.
6315 if not Is_Predefined_Dispatching_Operation
(Prim_Op
) then
6316 Check_Convention
(Prim_Op
);
6319 Next_Elmt
(Prim_Op_Elmt
);
6321 end Check_Conventions
;
6323 ------------------------------
6324 -- Check_Delayed_Subprogram --
6325 ------------------------------
6327 procedure Check_Delayed_Subprogram
(Designator
: Entity_Id
) is
6328 procedure Possible_Freeze
(T
: Entity_Id
);
6329 -- T is the type of either a formal parameter or of the return type. If
6330 -- T is not yet frozen and needs a delayed freeze, then the subprogram
6331 -- itself must be delayed.
6333 ---------------------
6334 -- Possible_Freeze --
6335 ---------------------
6337 procedure Possible_Freeze
(T
: Entity_Id
) is
6338 Scop
: constant Entity_Id
:= Scope
(Designator
);
6341 -- If the subprogram appears within a package instance (which may be
6342 -- the wrapper package of a subprogram instance) the freeze node for
6343 -- that package will freeze the subprogram at the proper place, so
6344 -- do not emit a freeze node for the subprogram, given that it may
6345 -- appear in the wrong scope.
6347 if Ekind
(Scop
) = E_Package
6348 and then not Comes_From_Source
(Scop
)
6349 and then Is_Generic_Instance
(Scop
)
6353 elsif Has_Delayed_Freeze
(T
) and then not Is_Frozen
(T
) then
6354 Set_Has_Delayed_Freeze
(Designator
);
6356 elsif Is_Access_Type
(T
)
6357 and then Has_Delayed_Freeze
(Designated_Type
(T
))
6358 and then not Is_Frozen
(Designated_Type
(T
))
6360 Set_Has_Delayed_Freeze
(Designator
);
6362 end Possible_Freeze
;
6368 -- Start of processing for Check_Delayed_Subprogram
6371 -- All subprograms, including abstract subprograms, may need a freeze
6372 -- node if some formal type or the return type needs one.
6374 Possible_Freeze
(Etype
(Designator
));
6375 Possible_Freeze
(Base_Type
(Etype
(Designator
))); -- needed ???
6377 -- Need delayed freeze if any of the formal types themselves need a
6378 -- delayed freeze and are not yet frozen.
6380 F
:= First_Formal
(Designator
);
6381 while Present
(F
) loop
6382 Possible_Freeze
(Etype
(F
));
6383 Possible_Freeze
(Base_Type
(Etype
(F
))); -- needed ???
6387 -- Mark functions that return by reference. Note that it cannot be done
6388 -- for delayed_freeze subprograms because the underlying returned type
6389 -- may not be known yet (for private types).
6391 if not Has_Delayed_Freeze
(Designator
) and then Expander_Active
then
6392 Compute_Returns_By_Ref
(Designator
);
6394 end Check_Delayed_Subprogram
;
6396 ------------------------------------
6397 -- Check_Discriminant_Conformance --
6398 ------------------------------------
6400 procedure Check_Discriminant_Conformance
6405 Old_Discr
: Entity_Id
:= First_Discriminant
(Prev
);
6406 New_Discr
: Node_Id
:= First
(Discriminant_Specifications
(N
));
6407 New_Discr_Id
: Entity_Id
;
6408 New_Discr_Type
: Entity_Id
;
6410 procedure Conformance_Error
(Msg
: String; N
: Node_Id
);
6411 -- Post error message for conformance error on given node. Two messages
6412 -- are output. The first points to the previous declaration with a
6413 -- general "no conformance" message. The second is the detailed reason,
6414 -- supplied as Msg. The parameter N provide information for a possible
6415 -- & insertion in the message.
6417 -----------------------
6418 -- Conformance_Error --
6419 -----------------------
6421 procedure Conformance_Error
(Msg
: String; N
: Node_Id
) is
6423 Error_Msg_Sloc
:= Sloc
(Prev_Loc
);
6424 Error_Msg_N
-- CODEFIX
6425 ("not fully conformant with declaration#!", N
);
6426 Error_Msg_NE
(Msg
, N
, N
);
6427 end Conformance_Error
;
6429 -- Start of processing for Check_Discriminant_Conformance
6432 while Present
(Old_Discr
) and then Present
(New_Discr
) loop
6433 New_Discr_Id
:= Defining_Identifier
(New_Discr
);
6435 -- The subtype mark of the discriminant on the full type has not
6436 -- been analyzed so we do it here. For an access discriminant a new
6439 if Nkind
(Discriminant_Type
(New_Discr
)) = N_Access_Definition
then
6441 Access_Definition
(N
, Discriminant_Type
(New_Discr
));
6444 Find_Type
(Discriminant_Type
(New_Discr
));
6445 New_Discr_Type
:= Etype
(Discriminant_Type
(New_Discr
));
6447 -- Ada 2005: if the discriminant definition carries a null
6448 -- exclusion, create an itype to check properly for consistency
6449 -- with partial declaration.
6451 if Is_Access_Type
(New_Discr_Type
)
6452 and then Null_Exclusion_Present
(New_Discr
)
6455 Create_Null_Excluding_Itype
6456 (T
=> New_Discr_Type
,
6457 Related_Nod
=> New_Discr
,
6458 Scope_Id
=> Current_Scope
);
6462 if not Conforming_Types
6463 (Etype
(Old_Discr
), New_Discr_Type
, Fully_Conformant
)
6465 Conformance_Error
("type of & does not match!", New_Discr_Id
);
6468 -- Treat the new discriminant as an occurrence of the old one,
6469 -- for navigation purposes, and fill in some semantic
6470 -- information, for completeness.
6472 Generate_Reference
(Old_Discr
, New_Discr_Id
, 'r');
6473 Set_Etype
(New_Discr_Id
, Etype
(Old_Discr
));
6474 Set_Scope
(New_Discr_Id
, Scope
(Old_Discr
));
6479 if Chars
(Old_Discr
) /= Chars
(Defining_Identifier
(New_Discr
)) then
6480 Conformance_Error
("name & does not match!", New_Discr_Id
);
6484 -- Default expressions must match
6487 NewD
: constant Boolean :=
6488 Present
(Expression
(New_Discr
));
6489 OldD
: constant Boolean :=
6490 Present
(Expression
(Parent
(Old_Discr
)));
6493 if NewD
or OldD
then
6495 -- The old default value has been analyzed and expanded,
6496 -- because the current full declaration will have frozen
6497 -- everything before. The new default values have not been
6498 -- expanded, so expand now to check conformance.
6501 Preanalyze_Spec_Expression
6502 (Expression
(New_Discr
), New_Discr_Type
);
6505 if not (NewD
and OldD
)
6506 or else not Fully_Conformant_Expressions
6507 (Expression
(Parent
(Old_Discr
)),
6508 Expression
(New_Discr
))
6512 ("default expression for & does not match!",
6519 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
6521 if Ada_Version
= Ada_83
then
6523 Old_Disc
: constant Node_Id
:= Declaration_Node
(Old_Discr
);
6526 -- Grouping (use of comma in param lists) must be the same
6527 -- This is where we catch a misconformance like:
6530 -- A : Integer; B : Integer
6532 -- which are represented identically in the tree except
6533 -- for the setting of the flags More_Ids and Prev_Ids.
6535 if More_Ids
(Old_Disc
) /= More_Ids
(New_Discr
)
6536 or else Prev_Ids
(Old_Disc
) /= Prev_Ids
(New_Discr
)
6539 ("grouping of & does not match!", New_Discr_Id
);
6545 Next_Discriminant
(Old_Discr
);
6549 if Present
(Old_Discr
) then
6550 Conformance_Error
("too few discriminants!", Defining_Identifier
(N
));
6553 elsif Present
(New_Discr
) then
6555 ("too many discriminants!", Defining_Identifier
(New_Discr
));
6558 end Check_Discriminant_Conformance
;
6560 -----------------------------------------
6561 -- Check_Formal_Subprogram_Conformance --
6562 -----------------------------------------
6564 procedure Check_Formal_Subprogram_Conformance
6565 (New_Id
: Entity_Id
;
6569 Conforms
: out Boolean)
6575 if Is_Formal_Subprogram
(Old_Id
)
6576 or else Is_Formal_Subprogram
(New_Id
)
6577 or else (Is_Subprogram
(New_Id
)
6578 and then Present
(Alias
(New_Id
))
6579 and then Is_Formal_Subprogram
(Alias
(New_Id
)))
6581 if Present
(Err_Loc
) then
6590 Error_Msg_Sloc
:= Sloc
(Old_Id
);
6591 Error_Msg_N
("not subtype conformant with declaration#!", N
);
6593 ("\formal subprograms are not subtype conformant "
6594 & "(RM 6.3.1 (17/3))", N
, New_Id
);
6597 end Check_Formal_Subprogram_Conformance
;
6599 procedure Check_Formal_Subprogram_Conformance
6600 (New_Id
: Entity_Id
;
6602 Err_Loc
: Node_Id
:= Empty
)
6606 Check_Formal_Subprogram_Conformance
6607 (New_Id
, Old_Id
, Err_Loc
, True, Ignore
);
6608 end Check_Formal_Subprogram_Conformance
;
6610 ----------------------------
6611 -- Check_Fully_Conformant --
6612 ----------------------------
6614 procedure Check_Fully_Conformant
6615 (New_Id
: Entity_Id
;
6617 Err_Loc
: Node_Id
:= Empty
)
6620 pragma Warnings
(Off
, Result
);
6623 (New_Id
, Old_Id
, Fully_Conformant
, True, Result
, Err_Loc
);
6624 end Check_Fully_Conformant
;
6626 --------------------------
6627 -- Check_Limited_Return --
6628 --------------------------
6630 procedure Check_Limited_Return
6636 -- Ada 2005 (AI-318-02): Return-by-reference types have been removed and
6637 -- replaced by anonymous access results. This is an incompatibility with
6638 -- Ada 95. Not clear whether this should be enforced yet or perhaps
6639 -- controllable with special switch. ???
6641 -- A limited interface that is not immutably limited is OK
6643 if Is_Limited_Interface
(R_Type
)
6644 and then not Is_Concurrent_Interface
(R_Type
)
6648 elsif Is_Limited_Type
(R_Type
)
6649 and then not Is_Interface
(R_Type
)
6650 and then not (Nkind
(N
) = N_Simple_Return_Statement
6651 and then Comes_From_Extended_Return_Statement
(N
))
6652 and then not In_Instance_Body
6653 and then not OK_For_Limited_Init_In_05
(R_Type
, Expr
)
6655 -- Error in Ada 2005
6657 if Ada_Version
>= Ada_2005
6658 and then not Debug_Flag_Dot_L
6659 and then not GNAT_Mode
6662 ("(Ada 2005) cannot copy object of a limited type "
6663 & "(RM-2005 6.5(5.5/2))", Expr
);
6665 if Is_Inherently_Limited_Type
(R_Type
) then
6667 ("\return by reference not permitted in Ada 2005", Expr
);
6670 -- Warn in Ada 95 mode, to give folks a heads up about this
6673 -- In GNAT mode, this is just a warning, to allow it to be evilly
6674 -- turned off. Otherwise it is a real error.
6676 -- In a generic context, simplify the warning because it makes no
6677 -- sense to discuss pass-by-reference or copy.
6679 elsif Warn_On_Ada_2005_Compatibility
or GNAT_Mode
then
6680 if Inside_A_Generic
then
6682 ("return of limited object not permitted in Ada 2005 "
6683 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
6685 elsif Is_Inherently_Limited_Type
(R_Type
) then
6687 ("return by reference not permitted in Ada 2005 "
6688 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
6691 ("cannot copy object of a limited type in Ada 2005 "
6692 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
6695 -- Ada 95 mode, and compatibility warnings disabled
6698 pragma Assert
(Ada_Version
<= Ada_95
);
6699 pragma Assert
(not (Warn_On_Ada_2005_Compatibility
or GNAT_Mode
));
6700 return; -- skip continuation messages below
6703 if not Inside_A_Generic
then
6705 ("\consider switching to return of access type", Expr
);
6706 Explain_Limited_Type
(R_Type
, Expr
);
6709 end Check_Limited_Return
;
6711 ---------------------------
6712 -- Check_Mode_Conformant --
6713 ---------------------------
6715 procedure Check_Mode_Conformant
6716 (New_Id
: Entity_Id
;
6718 Err_Loc
: Node_Id
:= Empty
;
6719 Get_Inst
: Boolean := False)
6722 pragma Warnings
(Off
, Result
);
6725 (New_Id
, Old_Id
, Mode_Conformant
, True, Result
, Err_Loc
, Get_Inst
);
6726 end Check_Mode_Conformant
;
6728 --------------------------------
6729 -- Check_Overriding_Indicator --
6730 --------------------------------
6732 procedure Check_Overriding_Indicator
6734 Overridden_Subp
: Entity_Id
;
6735 Is_Primitive
: Boolean)
6741 -- No overriding indicator for literals
6743 if Ekind
(Subp
) = E_Enumeration_Literal
then
6746 elsif Ekind
(Subp
) = E_Entry
then
6747 Decl
:= Parent
(Subp
);
6749 -- No point in analyzing a malformed operator
6751 elsif Nkind
(Subp
) = N_Defining_Operator_Symbol
6752 and then Error_Posted
(Subp
)
6757 Decl
:= Unit_Declaration_Node
(Subp
);
6760 if Nkind
(Decl
) in N_Subprogram_Body
6761 | N_Subprogram_Body_Stub
6762 | N_Subprogram_Declaration
6763 | N_Abstract_Subprogram_Declaration
6764 | N_Subprogram_Renaming_Declaration
6766 Spec
:= Specification
(Decl
);
6768 elsif Nkind
(Decl
) = N_Entry_Declaration
then
6775 -- An overriding indication is illegal on a subprogram declared
6776 -- in a protected body, where there is no operation to override.
6778 if (Must_Override
(Spec
) or else Must_Not_Override
(Spec
))
6779 and then Is_List_Member
(Decl
)
6780 and then Present
(Parent
(List_Containing
(Decl
)))
6781 and then Nkind
(Parent
(List_Containing
(Decl
))) = N_Protected_Body
6784 ("illegal overriding indication in protected body", Decl
);
6788 -- The overriding operation is type conformant with the overridden one,
6789 -- but the names of the formals are not required to match. If the names
6790 -- appear permuted in the overriding operation, this is a possible
6791 -- source of confusion that is worth diagnosing. Controlling formals
6792 -- often carry names that reflect the type, and it is not worthwhile
6793 -- requiring that their names match.
6795 if Present
(Overridden_Subp
)
6796 and then Nkind
(Subp
) /= N_Defining_Operator_Symbol
6803 Form1
:= First_Formal
(Subp
);
6804 Form2
:= First_Formal
(Overridden_Subp
);
6806 -- If the overriding operation is a synchronized operation, skip
6807 -- the first parameter of the overridden operation, which is
6808 -- implicit in the new one. If the operation is declared in the
6809 -- body it is not primitive and all formals must match.
6811 if Is_Concurrent_Type
(Scope
(Subp
))
6812 and then Is_Tagged_Type
(Scope
(Subp
))
6813 and then not Has_Completion
(Scope
(Subp
))
6815 Form2
:= Next_Formal
(Form2
);
6818 if Present
(Form1
) then
6819 Form1
:= Next_Formal
(Form1
);
6820 Form2
:= Next_Formal
(Form2
);
6823 while Present
(Form1
) loop
6824 if not Is_Controlling_Formal
(Form1
)
6825 and then Present
(Next_Formal
(Form2
))
6826 and then Chars
(Form1
) = Chars
(Next_Formal
(Form2
))
6828 Error_Msg_Node_2
:= Alias
(Overridden_Subp
);
6829 Error_Msg_Sloc
:= Sloc
(Error_Msg_Node_2
);
6831 ("& does not match corresponding formal of&#",
6836 Next_Formal
(Form1
);
6837 Next_Formal
(Form2
);
6842 -- If there is an overridden subprogram, then check that there is no
6843 -- "not overriding" indicator, and mark the subprogram as overriding.
6845 -- This is not done if the overridden subprogram is marked as hidden,
6846 -- which can occur for the case of inherited controlled operations
6847 -- (see Derive_Subprogram), unless the inherited subprogram's parent
6848 -- subprogram is not itself hidden or we are within a generic instance,
6849 -- in which case the hidden flag may have been modified for the
6850 -- expansion of the instance.
6852 -- (Note: This condition could probably be simplified, leaving out the
6853 -- testing for the specific controlled cases, but it seems safer and
6854 -- clearer this way, and echoes similar special-case tests of this
6855 -- kind in other places.)
6857 if Present
(Overridden_Subp
)
6858 and then (not Is_Hidden
(Overridden_Subp
)
6860 (Chars
(Overridden_Subp
) in Name_Initialize
6863 and then Present
(Alias
(Overridden_Subp
))
6864 and then (not Is_Hidden
(Alias
(Overridden_Subp
))
6865 or else In_Instance
)))
6867 if Must_Not_Override
(Spec
) then
6868 Error_Msg_Sloc
:= Sloc
(Overridden_Subp
);
6870 if Ekind
(Subp
) = E_Entry
then
6872 ("entry & overrides inherited operation #", Spec
, Subp
);
6875 ("subprogram & overrides inherited operation #", Spec
, Subp
);
6878 -- Special-case to fix a GNAT oddity: Limited_Controlled is declared
6879 -- as an extension of Root_Controlled, and thus has a useless Adjust
6880 -- operation. This operation should not be inherited by other limited
6881 -- controlled types. An explicit Adjust for them is not overriding.
6883 elsif Must_Override
(Spec
)
6884 and then Chars
(Overridden_Subp
) = Name_Adjust
6885 and then Is_Limited_Type
(Etype
(First_Formal
(Subp
)))
6886 and then Present
(Alias
(Overridden_Subp
))
6887 and then In_Predefined_Unit
(Alias
(Overridden_Subp
))
6890 (Unit_File_Name
(Get_Source_Unit
(Alias
(Overridden_Subp
))));
6891 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
6893 elsif Is_Subprogram
(Subp
) then
6894 if Is_Init_Proc
(Subp
) then
6897 elsif No
(Overridden_Operation
(Subp
)) then
6899 -- For entities generated by Derive_Subprograms the overridden
6900 -- operation is the inherited primitive (which is available
6901 -- through the attribute alias)
6903 if (Is_Dispatching_Operation
(Subp
)
6904 or else Is_Dispatching_Operation
(Overridden_Subp
))
6905 and then not Comes_From_Source
(Overridden_Subp
)
6906 and then Find_Dispatching_Type
(Overridden_Subp
) =
6907 Find_Dispatching_Type
(Subp
)
6908 and then Present
(Alias
(Overridden_Subp
))
6909 and then Comes_From_Source
(Alias
(Overridden_Subp
))
6911 Set_Overridden_Operation
(Subp
, Alias
(Overridden_Subp
));
6912 Inherit_Subprogram_Contract
(Subp
, Alias
(Overridden_Subp
));
6913 Set_Is_Ada_2022_Only
(Subp
,
6914 Is_Ada_2022_Only
(Alias
(Overridden_Subp
)));
6917 Set_Overridden_Operation
(Subp
, Overridden_Subp
);
6918 Inherit_Subprogram_Contract
(Subp
, Overridden_Subp
);
6919 Set_Is_Ada_2022_Only
(Subp
,
6920 Is_Ada_2022_Only
(Overridden_Subp
));
6925 -- If primitive flag is set or this is a protected operation, then
6926 -- the operation is overriding at the point of its declaration, so
6927 -- warn if necessary. Otherwise it may have been declared before the
6928 -- operation it overrides and no check is required.
6931 and then not Must_Override
(Spec
)
6932 and then (Is_Primitive
6933 or else Ekind
(Scope
(Subp
)) = E_Protected_Type
)
6935 Style
.Missing_Overriding
(Decl
, Subp
);
6938 -- If Subp is an operator, it may override a predefined operation, if
6939 -- it is defined in the same scope as the type to which it applies.
6940 -- In that case Overridden_Subp is empty because of our implicit
6941 -- representation for predefined operators. We have to check whether the
6942 -- signature of Subp matches that of a predefined operator. Note that
6943 -- first argument provides the name of the operator, and the second
6944 -- argument the signature that may match that of a standard operation.
6945 -- If the indicator is overriding, then the operator must match a
6946 -- predefined signature, because we know already that there is no
6947 -- explicit overridden operation.
6949 elsif Chars
(Subp
) in Any_Operator_Name
then
6950 if Must_Not_Override
(Spec
) then
6952 -- If this is not a primitive or a protected subprogram, then
6953 -- "not overriding" is illegal.
6956 and then Ekind
(Scope
(Subp
)) /= E_Protected_Type
6958 Error_Msg_N
("overriding indicator only allowed "
6959 & "if subprogram is primitive", Subp
);
6961 elsif Can_Override_Operator
(Subp
) then
6963 ("subprogram& overrides predefined operator", Spec
, Subp
);
6966 elsif Must_Override
(Spec
) then
6967 if No
(Overridden_Operation
(Subp
))
6968 and then not Can_Override_Operator
(Subp
)
6970 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
6973 elsif not Error_Posted
(Subp
)
6974 and then Style_Check
6975 and then Can_Override_Operator
(Subp
)
6976 and then not In_Predefined_Unit
(Subp
)
6978 -- If style checks are enabled, indicate that the indicator is
6979 -- missing. However, at the point of declaration, the type of
6980 -- which this is a primitive operation may be private, in which
6981 -- case the indicator would be premature.
6983 if Has_Private_Declaration
(Etype
(Subp
))
6984 or else Has_Private_Declaration
(Etype
(First_Formal
(Subp
)))
6988 Style
.Missing_Overriding
(Decl
, Subp
);
6992 elsif Must_Override
(Spec
) then
6993 if Ekind
(Subp
) = E_Entry
then
6994 Error_Msg_NE
("entry & is not overriding", Spec
, Subp
);
6996 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
6999 -- If the operation is marked "not overriding" and it's not primitive
7000 -- then an error is issued, unless this is an operation of a task or
7001 -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
7002 -- has been specified have already been checked above.
7004 elsif Must_Not_Override
(Spec
)
7005 and then not Is_Primitive
7006 and then Ekind
(Subp
) /= E_Entry
7007 and then Ekind
(Scope
(Subp
)) /= E_Protected_Type
7010 ("overriding indicator only allowed if subprogram is primitive",
7014 end Check_Overriding_Indicator
;
7020 -- Note: this procedure needs to know far too much about how the expander
7021 -- messes with exceptions. The use of the flag Exception_Junk and the
7022 -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
7023 -- works, but is not very clean. It would be better if the expansion
7024 -- routines would leave Original_Node working nicely, and we could use
7025 -- Original_Node here to ignore all the peculiar expander messing ???
7027 procedure Check_Returns
7031 Proc
: Entity_Id
:= Empty
)
7033 pragma Assert
(Mode
in 'F' |
'P');
7034 pragma Assert
(if Mode
= 'F' then No
(Proc
));
7037 procedure Check_Statement_Sequence
(L
: List_Id
);
7038 -- Internal recursive procedure to check a list of statements for proper
7039 -- termination by a return statement (or a transfer of control or a
7040 -- compound statement that is itself internally properly terminated).
7042 ------------------------------
7043 -- Check_Statement_Sequence --
7044 ------------------------------
7046 procedure Check_Statement_Sequence
(L
: List_Id
) is
7051 function Assert_False
return Boolean;
7052 -- Returns True if Last_Stm is a pragma Assert (False) that has been
7053 -- rewritten as a null statement when assertions are off. The assert
7054 -- is not active, but it is still enough to kill the warning.
7060 function Assert_False
return Boolean is
7061 Orig
: constant Node_Id
:= Original_Node
(Last_Stm
);
7064 if Nkind
(Orig
) = N_Pragma
7065 and then Pragma_Name
(Orig
) = Name_Assert
7066 and then not Error_Posted
(Orig
)
7069 Arg
: constant Node_Id
:=
7070 First
(Pragma_Argument_Associations
(Orig
));
7071 Exp
: constant Node_Id
:= Expression
(Arg
);
7073 return Nkind
(Exp
) = N_Identifier
7074 and then Chars
(Exp
) = Name_False
;
7084 Raise_Exception_Call
: Boolean := False;
7085 -- Set True if statement sequence terminated by Raise_Exception call
7086 -- or a Reraise_Occurrence call.
7088 -- Start of processing for Check_Statement_Sequence
7091 -- Get last real statement
7093 Last_Stm
:= Last
(L
);
7095 -- Deal with digging out exception handler statement sequences that
7096 -- have been transformed by the local raise to goto optimization.
7097 -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
7098 -- optimization has occurred, we are looking at something like:
7101 -- original stmts in block
7105 -- goto L1; | omitted if No_Exception_Propagation
7110 -- goto L3; -- skip handler when exception not raised
7112 -- <<L1>> -- target label for local exception
7126 -- and what we have to do is to dig out the estmts1 and estmts2
7127 -- sequences (which were the original sequences of statements in
7128 -- the exception handlers) and check them.
7130 if Nkind
(Last_Stm
) = N_Label
and then Exception_Junk
(Last_Stm
) then
7135 exit when Nkind
(Stm
) /= N_Block_Statement
;
7136 exit when not Exception_Junk
(Stm
);
7139 exit when Nkind
(Stm
) /= N_Label
;
7140 exit when not Exception_Junk
(Stm
);
7141 Check_Statement_Sequence
7142 (Statements
(Handled_Statement_Sequence
(Next
(Stm
))));
7147 exit when Nkind
(Stm
) /= N_Goto_Statement
;
7148 exit when not Exception_Junk
(Stm
);
7152 -- Don't count pragmas
7154 while Nkind
(Last_Stm
) = N_Pragma
7156 -- Don't count call to SS_Release (can happen after
7157 -- Raise_Exception).
7160 (Nkind
(Last_Stm
) = N_Procedure_Call_Statement
7162 Nkind
(Name
(Last_Stm
)) = N_Identifier
7164 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_SS_Release
))
7166 -- Don't count exception junk
7169 (Nkind
(Last_Stm
) in
7170 N_Goto_Statement | N_Label | N_Object_Declaration
7171 and then Exception_Junk
(Last_Stm
))
7172 or else Nkind
(Last_Stm
) in N_Push_xxx_Label | N_Pop_xxx_Label
7174 -- Inserted code, such as finalization calls, is irrelevant; we
7175 -- only need to check original source. If we see a transfer of
7176 -- control, we stop.
7178 or else (Is_Rewrite_Insertion
(Last_Stm
)
7179 and then not Is_Transfer
(Last_Stm
))
7184 -- Here we have the "real" last statement
7186 Kind
:= Nkind
(Last_Stm
);
7188 -- Transfer of control, OK. Note that in the No_Return procedure
7189 -- case, we already diagnosed any explicit return statements, so
7190 -- we can treat them as OK in this context.
7192 if Is_Transfer
(Last_Stm
) then
7195 -- Check cases of explicit non-indirect procedure calls
7197 elsif Kind
= N_Procedure_Call_Statement
7198 and then Is_Entity_Name
(Name
(Last_Stm
))
7200 -- Check call to Raise_Exception procedure which is treated
7201 -- specially, as is a call to Reraise_Occurrence.
7203 -- We suppress the warning in these cases since it is likely that
7204 -- the programmer really does not expect to deal with the case
7205 -- of Null_Occurrence, and thus would find a warning about a
7206 -- missing return curious, and raising Program_Error does not
7207 -- seem such a bad behavior if this does occur.
7209 -- Note that in the Ada 2005 case for Raise_Exception, the actual
7210 -- behavior will be to raise Constraint_Error (see AI-329).
7212 if Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Raise_Exception
)
7214 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Reraise_Occurrence
)
7216 Raise_Exception_Call
:= True;
7218 -- For Raise_Exception call, test first argument, if it is
7219 -- an attribute reference for a 'Identity call, then we know
7220 -- that the call cannot possibly return.
7223 Arg
: constant Node_Id
:=
7224 Original_Node
(First_Actual
(Last_Stm
));
7226 if Nkind
(Arg
) = N_Attribute_Reference
7227 and then Attribute_Name
(Arg
) = Name_Identity
7234 -- If statement, need to look inside if there is an else and check
7235 -- each constituent statement sequence for proper termination.
7237 elsif Kind
= N_If_Statement
7238 and then Present
(Else_Statements
(Last_Stm
))
7240 Check_Statement_Sequence
(Then_Statements
(Last_Stm
));
7241 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
7244 Elsif_Part
: Node_Id
:= First
(Elsif_Parts
(Last_Stm
));
7247 while Present
(Elsif_Part
) loop
7248 Check_Statement_Sequence
(Then_Statements
(Elsif_Part
));
7255 -- Case statement, check each case for proper termination
7257 elsif Kind
= N_Case_Statement
then
7261 Case_Alt
:= First_Non_Pragma
(Alternatives
(Last_Stm
));
7262 while Present
(Case_Alt
) loop
7263 Check_Statement_Sequence
(Statements
(Case_Alt
));
7264 Next_Non_Pragma
(Case_Alt
);
7270 -- Block statement, check its handled sequence of statements
7272 elsif Kind
= N_Block_Statement
then
7278 (Handled_Statement_Sequence
(Last_Stm
), Mode
, Err1
);
7287 -- Loop statement. If there is an iteration scheme, we can definitely
7288 -- fall out of the loop. Similarly if there is an exit statement, we
7289 -- can fall out. In either case we need a following return.
7291 elsif Kind
= N_Loop_Statement
then
7292 if Present
(Iteration_Scheme
(Last_Stm
))
7293 or else Has_Exit
(Entity
(Identifier
(Last_Stm
)))
7297 -- A loop with no exit statement or iteration scheme is either
7298 -- an infinite loop, or it has some other exit (raise/return).
7299 -- In either case, no warning is required.
7305 -- Timed entry call, check entry call and delay alternatives
7307 -- Note: in expanded code, the timed entry call has been converted
7308 -- to a set of expanded statements on which the check will work
7309 -- correctly in any case.
7311 elsif Kind
= N_Timed_Entry_Call
then
7313 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
7314 DCA
: constant Node_Id
:= Delay_Alternative
(Last_Stm
);
7317 -- If statement sequence of entry call alternative is missing,
7318 -- then we can definitely fall through, and we post the error
7319 -- message on the entry call alternative itself.
7321 if No
(Statements
(ECA
)) then
7324 -- If statement sequence of delay alternative is missing, then
7325 -- we can definitely fall through, and we post the error
7326 -- message on the delay alternative itself.
7328 -- Note: if both ECA and DCA are missing the return, then we
7329 -- post only one message, should be enough to fix the bugs.
7330 -- If not we will get a message next time on the DCA when the
7333 elsif No
(Statements
(DCA
)) then
7336 -- Else check both statement sequences
7339 Check_Statement_Sequence
(Statements
(ECA
));
7340 Check_Statement_Sequence
(Statements
(DCA
));
7345 -- Conditional entry call, check entry call and else part
7347 -- Note: in expanded code, the conditional entry call has been
7348 -- converted to a set of expanded statements on which the check
7349 -- will work correctly in any case.
7351 elsif Kind
= N_Conditional_Entry_Call
then
7353 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
7356 -- If statement sequence of entry call alternative is missing,
7357 -- then we can definitely fall through, and we post the error
7358 -- message on the entry call alternative itself.
7360 if No
(Statements
(ECA
)) then
7363 -- Else check statement sequence and else part
7366 Check_Statement_Sequence
(Statements
(ECA
));
7367 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
7373 -- If we fall through, issue appropriate message
7377 -- Kill warning if last statement is a raise exception call,
7378 -- or a pragma Assert (False). Note that with assertions enabled,
7379 -- such a pragma has been converted into a raise exception call
7380 -- already, so the Assert_False is for the assertions off case.
7382 if not Raise_Exception_Call
and then not Assert_False
then
7384 ("RETURN statement missing following this statement??!",
7387 ("\Program_Error [??!", Last_Stm
);
7390 -- Note: we set Err even though we have not issued a warning
7391 -- because we still have a case of a missing return. This is
7392 -- an extremely marginal case, probably will never be noticed
7393 -- but we might as well get it right.
7397 -- Otherwise we have the case of a procedure marked No_Return
7400 if not Raise_Exception_Call
then
7401 if GNATprove_Mode
then
7403 ("implied return after this statement would have raised "
7404 & "Program_Error", Last_Stm
);
7406 -- In normal compilation mode, do not warn on a generated call
7407 -- (e.g. in the body of a renaming as completion).
7409 elsif Comes_From_Source
(Last_Stm
) then
7411 ("implied return after this statement will raise "
7412 & "Program_Error??", Last_Stm
);
7415 Error_Msg_Warn
:= SPARK_Mode
/= On
;
7417 ("\procedure & is marked as No_Return<<!", Last_Stm
, Proc
);
7421 RE
: constant Node_Id
:=
7422 Make_Raise_Program_Error
(Sloc
(Last_Stm
),
7423 Reason
=> PE_Implicit_Return
);
7425 Insert_After
(Last_Stm
, RE
);
7429 end Check_Statement_Sequence
;
7431 -- Start of processing for Check_Returns
7435 Check_Statement_Sequence
(Statements
(HSS
));
7437 if Present
(Exception_Handlers
(HSS
)) then
7438 Handler
:= First_Non_Pragma
(Exception_Handlers
(HSS
));
7439 while Present
(Handler
) loop
7440 Check_Statement_Sequence
(Statements
(Handler
));
7441 Next_Non_Pragma
(Handler
);
7446 ----------------------------
7447 -- Check_Subprogram_Order --
7448 ----------------------------
7450 procedure Check_Subprogram_Order
(N
: Node_Id
) is
7452 function Subprogram_Name_Greater
(S1
, S2
: String) return Boolean;
7453 -- This is used to check if S1 > S2 in the sense required by this test,
7454 -- for example nameab < namec, but name2 < name10.
7456 -----------------------------
7457 -- Subprogram_Name_Greater --
7458 -----------------------------
7460 function Subprogram_Name_Greater
(S1
, S2
: String) return Boolean is
7465 -- Deal with special case where names are identical except for a
7466 -- numerical suffix. These are handled specially, taking the numeric
7467 -- ordering from the suffix into account.
7470 while S1
(L1
) in '0' .. '9' loop
7475 while S2
(L2
) in '0' .. '9' loop
7479 -- If non-numeric parts non-equal, do straight compare
7481 if S1
(S1
'First .. L1
) /= S2
(S2
'First .. L2
) then
7484 -- If non-numeric parts equal, compare suffixed numeric parts. Note
7485 -- that a missing suffix is treated as numeric zero in this test.
7489 while L1
< S1
'Last loop
7491 N1
:= N1
* 10 + Character'Pos (S1
(L1
)) - Character'Pos ('0');
7495 while L2
< S2
'Last loop
7497 N2
:= N2
* 10 + Character'Pos (S2
(L2
)) - Character'Pos ('0');
7502 end Subprogram_Name_Greater
;
7504 -- Start of processing for Check_Subprogram_Order
7507 -- Check body in alpha order if this is option
7510 and then Style_Check_Order_Subprograms
7511 and then Nkind
(N
) = N_Subprogram_Body
7512 and then Comes_From_Source
(N
)
7513 and then In_Extended_Main_Source_Unit
(N
)
7517 renames Scope_Stack
.Table
7518 (Scope_Stack
.Last
).Last_Subprogram_Name
;
7520 Body_Id
: constant Entity_Id
:=
7521 Defining_Entity
(Specification
(N
));
7524 Get_Decoded_Name_String
(Chars
(Body_Id
));
7527 if Subprogram_Name_Greater
7528 (LSN
.all, Name_Buffer
(1 .. Name_Len
))
7530 Style
.Subprogram_Not_In_Alpha_Order
(Body_Id
);
7536 LSN
:= new String'(Name_Buffer (1 .. Name_Len));
7539 end Check_Subprogram_Order;
7541 ------------------------------
7542 -- Check_Subtype_Conformant --
7543 ------------------------------
7545 procedure Check_Subtype_Conformant
7546 (New_Id : Entity_Id;
7548 Err_Loc : Node_Id := Empty;
7549 Skip_Controlling_Formals : Boolean := False;
7550 Get_Inst : Boolean := False)
7553 pragma Warnings (Off, Result);
7556 (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
7557 Skip_Controlling_Formals => Skip_Controlling_Formals,
7558 Get_Inst => Get_Inst);
7561 and then Is_Subprogram (New_Id)
7562 and then Is_Subprogram (Old_Id)
7564 Local_Restrict.Check_Overriding
7565 (Overrider_Op => New_Id,
7566 Overridden_Op => Old_Id);
7568 end Check_Subtype_Conformant;
7570 -----------------------------------
7571 -- Check_Synchronized_Overriding --
7572 -----------------------------------
7574 procedure Check_Synchronized_Overriding
7575 (Def_Id : Entity_Id;
7576 Overridden_Subp : out Entity_Id)
7578 Ifaces_List : Elist_Id;
7582 function Is_Valid_Formal (F : Entity_Id) return Boolean;
7583 -- Predicate for legality rule in 9.4 (11.9/2): If an inherited
7584 -- subprogram is implemented by a protected procedure or entry,
7585 -- its first parameter must be out, in out, or access-to-variable.
7587 function Matches_Prefixed_View_Profile
7588 (Prim_Params : List_Id;
7589 Iface_Params : List_Id) return Boolean;
7590 -- Determine whether a subprogram's parameter profile Prim_Params
7591 -- matches that of a potentially overridden interface subprogram
7592 -- Iface_Params. Also determine if the type of first parameter of
7593 -- Iface_Params is an implemented interface.
7595 ----------------------
7596 -- Is_Valid_Formal --
7597 ----------------------
7599 function Is_Valid_Formal (F : Entity_Id) return Boolean is
7602 Ekind (F) in E_In_Out_Parameter | E_Out_Parameter
7604 (Nkind (Parameter_Type (Parent (F))) = N_Access_Definition
7605 and then not Constant_Present (Parameter_Type (Parent (F))));
7606 end Is_Valid_Formal;
7608 -----------------------------------
7609 -- Matches_Prefixed_View_Profile --
7610 -----------------------------------
7612 function Matches_Prefixed_View_Profile
7613 (Prim_Params : List_Id;
7614 Iface_Params : List_Id) return Boolean
7616 function Is_Implemented
7617 (Ifaces_List : Elist_Id;
7618 Iface : Entity_Id) return Boolean;
7619 -- Determine if Iface is implemented by the current task or
7622 --------------------
7623 -- Is_Implemented --
7624 --------------------
7626 function Is_Implemented
7627 (Ifaces_List : Elist_Id;
7628 Iface : Entity_Id) return Boolean
7630 Iface_Elmt : Elmt_Id;
7633 Iface_Elmt := First_Elmt (Ifaces_List);
7634 while Present (Iface_Elmt) loop
7635 if Node (Iface_Elmt) = Iface then
7639 Next_Elmt (Iface_Elmt);
7647 Iface_Id : Entity_Id;
7648 Iface_Param : Node_Id;
7649 Iface_Typ : Entity_Id;
7650 Prim_Id : Entity_Id;
7651 Prim_Param : Node_Id;
7652 Prim_Typ : Entity_Id;
7654 -- Start of processing for Matches_Prefixed_View_Profile
7657 Iface_Param := First (Iface_Params);
7658 Iface_Typ := Etype (Defining_Identifier (Iface_Param));
7660 if Is_Access_Type (Iface_Typ) then
7661 Iface_Typ := Designated_Type (Iface_Typ);
7664 Prim_Param := First (Prim_Params);
7666 -- The first parameter of the potentially overridden subprogram must
7667 -- be an interface implemented by Prim.
7669 if not Is_Interface (Iface_Typ)
7670 or else not Is_Implemented (Ifaces_List, Iface_Typ)
7675 -- The checks on the object parameters are done, so move on to the
7676 -- rest of the parameters.
7678 if not In_Scope then
7683 while Present (Iface_Param) and then Present (Prim_Param) loop
7684 Iface_Id := Defining_Identifier (Iface_Param);
7685 Iface_Typ := Find_Parameter_Type (Iface_Param);
7687 Prim_Id := Defining_Identifier (Prim_Param);
7688 Prim_Typ := Find_Parameter_Type (Prim_Param);
7690 if Ekind (Iface_Typ) = E_Anonymous_Access_Type
7691 and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
7692 and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
7694 Iface_Typ := Designated_Type (Iface_Typ);
7695 Prim_Typ := Designated_Type (Prim_Typ);
7698 -- Case of multiple interface types inside a parameter profile
7700 -- (Obj_Param : in out Iface; ...; Param : Iface)
7702 -- If the interface type is implemented, then the matching type in
7703 -- the primitive should be the implementing record type.
7705 if Ekind (Iface_Typ) = E_Record_Type
7706 and then Is_Interface (Iface_Typ)
7707 and then Is_Implemented (Ifaces_List, Iface_Typ)
7709 if Prim_Typ /= Typ then
7713 -- The two parameters must be both mode and subtype conformant
7715 elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
7717 Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
7726 -- One of the two lists contains more parameters than the other
7728 if Present (Iface_Param) or else Present (Prim_Param) then
7733 end Matches_Prefixed_View_Profile;
7735 -- Start of processing for Check_Synchronized_Overriding
7738 Overridden_Subp := Empty;
7740 -- Def_Id must be an entry or a subprogram. We should skip predefined
7741 -- primitives internally generated by the front end; however at this
7742 -- stage predefined primitives are still not fully decorated. As a
7743 -- minor optimization we skip here internally generated subprograms.
7745 if (Ekind (Def_Id) /= E_Entry
7746 and then Ekind (Def_Id) /= E_Function
7747 and then Ekind (Def_Id) /= E_Procedure)
7748 or else not Comes_From_Source (Def_Id)
7753 -- Search for the concurrent declaration since it contains the list of
7754 -- all implemented interfaces. In this case, the subprogram is declared
7755 -- within the scope of a protected or a task type.
7757 if Present (Scope (Def_Id))
7758 and then Is_Concurrent_Type (Scope (Def_Id))
7759 and then not Is_Generic_Actual_Type (Scope (Def_Id))
7761 Typ := Scope (Def_Id);
7764 -- The enclosing scope is not a synchronized type and the subprogram
7767 elsif No (First_Formal (Def_Id)) then
7770 -- The subprogram has formals and hence it may be a primitive of a
7774 Typ := Etype (First_Formal (Def_Id));
7776 if Is_Access_Type (Typ) then
7777 Typ := Directly_Designated_Type (Typ);
7780 if Is_Concurrent_Type (Typ)
7781 and then not Is_Generic_Actual_Type (Typ)
7785 -- This case occurs when the concurrent type is declared within a
7786 -- generic unit. As a result the corresponding record has been built
7787 -- and used as the type of the first formal, we just have to retrieve
7788 -- the corresponding concurrent type.
7790 elsif Is_Concurrent_Record_Type (Typ)
7791 and then not Is_Class_Wide_Type (Typ)
7792 and then Present (Corresponding_Concurrent_Type (Typ))
7794 Typ := Corresponding_Concurrent_Type (Typ);
7802 -- There is no overriding to check if this is an inherited operation in
7803 -- a type derivation for a generic actual.
7805 Collect_Interfaces (Typ, Ifaces_List);
7807 if Is_Empty_Elmt_List (Ifaces_List) then
7811 -- Determine whether entry or subprogram Def_Id overrides a primitive
7812 -- operation that belongs to one of the interfaces in Ifaces_List.
7815 Candidate : Entity_Id := Empty;
7816 Hom : Entity_Id := Empty;
7817 Subp : Entity_Id := Empty;
7820 -- Traverse the homonym chain, looking for a potentially overridden
7821 -- subprogram that belongs to an implemented interface.
7823 Hom := Current_Entity_In_Scope (Def_Id);
7824 while Present (Hom) loop
7828 or else not Is_Overloadable (Subp)
7829 or else not Is_Primitive (Subp)
7830 or else not Is_Dispatching_Operation (Subp)
7831 or else No (Find_Dispatching_Type (Subp))
7832 or else not Is_Interface (Find_Dispatching_Type (Subp))
7836 -- Entries and procedures can override abstract or null interface
7839 elsif Ekind (Def_Id) in E_Entry | E_Procedure
7840 and then Ekind (Subp) = E_Procedure
7841 and then Matches_Prefixed_View_Profile
7842 (Parameter_Specifications (Parent (Def_Id)),
7843 Parameter_Specifications (Parent (Subp)))
7847 -- For an overridden subprogram Subp, check whether the mode
7848 -- of its first parameter is correct depending on the kind of
7849 -- synchronized type.
7852 Formal : constant Node_Id := First_Formal (Candidate);
7855 -- In order for an entry or a protected procedure to
7856 -- override, the first parameter of the overridden routine
7857 -- must be of mode "out", "in out", or access-to-variable.
7859 if Ekind (Candidate) in E_Entry | E_Procedure
7860 and then Is_Protected_Type (Typ)
7861 and then not Is_Valid_Formal (Formal)
7865 -- All other cases are OK since a task entry or routine does
7866 -- not have a restriction on the mode of the first parameter
7867 -- of the overridden interface routine.
7870 Overridden_Subp := Candidate;
7875 -- Functions can override abstract interface functions. Return
7876 -- types must be subtype conformant.
7878 elsif Ekind (Def_Id) = E_Function
7879 and then Ekind (Subp) = E_Function
7880 and then Matches_Prefixed_View_Profile
7881 (Parameter_Specifications (Parent (Def_Id)),
7882 Parameter_Specifications (Parent (Subp)))
7883 and then Conforming_Types
7884 (Etype (Def_Id), Etype (Subp), Subtype_Conformant)
7888 -- If an inherited subprogram is implemented by a protected
7889 -- function, then the first parameter of the inherited
7890 -- subprogram shall be of mode in, but not an access-to-
7891 -- variable parameter (RM 9.4(11/9)).
7893 if Present (First_Formal (Subp))
7894 and then Ekind (First_Formal (Subp)) = E_In_Parameter
7896 (not Is_Access_Type (Etype (First_Formal (Subp)))
7898 Is_Access_Constant (Etype (First_Formal (Subp))))
7900 Overridden_Subp := Subp;
7905 Hom := Homonym (Hom);
7908 -- After examining all candidates for overriding, we are left with
7909 -- the best match, which is a mode-incompatible interface routine.
7911 if In_Scope and then Present (Candidate) then
7912 Error_Msg_PT (Def_Id, Candidate);
7915 Overridden_Subp := Candidate;
7918 end Check_Synchronized_Overriding;
7920 ---------------------------
7921 -- Check_Type_Conformant --
7922 ---------------------------
7924 procedure Check_Type_Conformant
7925 (New_Id : Entity_Id;
7927 Err_Loc : Node_Id := Empty)
7930 pragma Warnings (Off, Result);
7933 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
7934 end Check_Type_Conformant;
7936 -----------------------------
7937 -- Check_Untagged_Equality --
7938 -----------------------------
7940 procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
7941 Eq_Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
7942 Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
7944 procedure Freezing_Point_Warning (N : Node_Id; S : String);
7945 -- Output a warning about the freezing point N of Typ
7947 function Is_Actual_Of_Instantiation
7949 Inst : Node_Id) return Boolean;
7950 -- Return True if E is an actual parameter of instantiation Inst
7952 -----------------------------------
7953 -- Output_Freezing_Point_Warning --
7954 -----------------------------------
7956 procedure Freezing_Point_Warning (N : Node_Id; S : String) is
7958 Error_Msg_String (1 .. S'Length) := S;
7959 Error_Msg_Strlen := S'Length;
7961 if Ada_Version >= Ada_2012 then
7962 Error_Msg_NE ("type& is frozen by ~??", N, Typ);
7964 ("\an equality operator cannot be declared after this point??",
7968 Error_Msg_NE ("type& is frozen by ~ (Ada 2012)?y?", N, Typ);
7970 ("\an equality operator cannot be declared after this point"
7971 & " (Ada 2012)?y?", N);
7973 end Freezing_Point_Warning;
7975 --------------------------------
7976 -- Is_Actual_Of_Instantiation --
7977 --------------------------------
7979 function Is_Actual_Of_Instantiation
7981 Inst : Node_Id) return Boolean
7986 if Present (Generic_Associations (Inst)) then
7987 Assoc := First (Generic_Associations (Inst));
7989 while Present (Assoc) loop
7990 if Present (Explicit_Generic_Actual_Parameter (Assoc))
7992 Is_Entity_Name (Explicit_Generic_Actual_Parameter (Assoc))
7994 Entity (Explicit_Generic_Actual_Parameter (Assoc)) = E
8004 end Is_Actual_Of_Instantiation;
8010 -- Start of processing for Check_Untagged_Equality
8013 -- This check applies only if we have a subprogram declaration or a
8014 -- subprogram body that is not a completion, for an untagged record
8015 -- type, and that is conformant with the predefined operator.
8017 if (Nkind (Eq_Decl) /= N_Subprogram_Declaration
8018 and then not (Nkind (Eq_Decl) = N_Subprogram_Body
8019 and then Acts_As_Spec (Eq_Decl)))
8020 or else not Is_Record_Type (Typ)
8021 or else Is_Tagged_Type (Typ)
8022 or else not Is_User_Defined_Equality (Eq_Op)
8027 -- In Ada 2012 case, we will output errors or warnings depending on
8028 -- the setting of debug flag -gnatd.E.
8030 if Ada_Version >= Ada_2012 then
8031 Error_Msg_Warn := Debug_Flag_Dot_EE;
8033 -- In earlier versions of Ada, nothing to do unless we are warning on
8034 -- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set).
8037 if not Warn_On_Ada_2012_Compatibility then
8042 -- Cases where the type has already been frozen
8044 if Is_Frozen (Typ) then
8046 -- The check applies to a primitive operation, so check that type
8047 -- and equality operation are in the same scope.
8049 if Scope (Typ) /= Current_Scope then
8052 -- If the type is a generic actual (sub)type, the operation is not
8053 -- primitive either because the base type is declared elsewhere.
8055 elsif Is_Generic_Actual_Type (Typ) then
8058 -- Here we may have an error of declaration after freezing, but we
8059 -- must make sure not to flag the equality operator itself causing
8060 -- the freezing when it is a subprogram body.
8063 Decl := Next (Declaration_Node (Typ));
8065 while Present (Decl) and then Decl /= Eq_Decl loop
8067 -- The declaration of an object of the type
8069 if Nkind (Decl) = N_Object_Declaration
8070 and then Etype (Defining_Identifier (Decl)) = Typ
8072 Freezing_Point_Warning (Decl, "declaration");
8075 -- The instantiation of a generic on the type
8077 elsif Nkind (Decl) in N_Generic_Instantiation
8078 and then Is_Actual_Of_Instantiation (Typ, Decl)
8080 Freezing_Point_Warning (Decl, "instantiation");
8083 -- A noninstance proper body, body stub or entry body
8085 elsif Nkind (Decl) in N_Proper_Body
8088 and then not Is_Generic_Instance (Defining_Entity (Decl))
8090 Freezing_Point_Warning (Decl, "body");
8093 -- If we have reached the freeze node and immediately after we
8094 -- have the body or generated code for the body, then it is the
8095 -- body that caused the freezing and this is legal.
8097 elsif Nkind (Decl) = N_Freeze_Entity
8098 and then Entity (Decl) = Typ
8099 and then (Next (Decl) = Eq_Decl
8101 Sloc (Next (Decl)) = Sloc (Eq_Decl))
8109 -- Here we have a definite error of declaration after freezing
8111 if Ada_Version >= Ada_2012 then
8113 ("equality operator must be declared before type & is "
8114 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ);
8116 -- In Ada 2012 mode with error turned to warning, output one
8117 -- more warning to warn that the equality operation may not
8118 -- compose. This is the consequence of ignoring the error.
8120 if Error_Msg_Warn then
8121 Error_Msg_N ("\equality operation may not compose??", Eq_Op);
8126 ("equality operator must be declared before type& is "
8127 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ);
8130 -- If we have found no freezing point and the declaration of the
8131 -- operator could not be reached from that of the type and we are
8132 -- in a package body, this must be because the type is declared
8133 -- in the spec of the package. Add a message tailored to this.
8135 if No (Decl) and then In_Package_Body (Scope (Typ)) then
8136 if Ada_Version >= Ada_2012 then
8137 if Nkind (Eq_Decl) = N_Subprogram_Body then
8139 ("\put declaration in package spec<<", Eq_Op);
8142 ("\move declaration to package spec<<", Eq_Op);
8146 if Nkind (Eq_Decl) = N_Subprogram_Body then
8148 ("\put declaration in package spec (Ada 2012)?y?",
8152 ("\move declaration to package spec (Ada 2012)?y?",
8159 -- Now check for AI12-0352: the declaration of a user-defined primitive
8160 -- equality operation for a record type T is illegal if it occurs after
8161 -- a type has been derived from T.
8164 Decl := Next (Declaration_Node (Typ));
8166 while Present (Decl) and then Decl /= Eq_Decl loop
8167 if Nkind (Decl) = N_Full_Type_Declaration
8168 and then Etype (Defining_Identifier (Decl)) = Typ
8171 ("equality operator cannot appear after derivation", Eq_Op);
8173 ("an equality operator for& cannot be declared after "
8181 end Check_Untagged_Equality;
8183 ---------------------------
8184 -- Can_Override_Operator --
8185 ---------------------------
8187 function Can_Override_Operator (Subp : Entity_Id) return Boolean is
8191 -- Return False if not an operator. We test the name rather than testing
8192 -- that the Nkind is N_Defining_Operator_Symbol, because there are cases
8193 -- where an operator entity can be an N_Defining_Identifier (such as for
8194 -- function instantiations).
8196 if Chars (Subp) not in Any_Operator_Name then
8200 Typ := Base_Type (Etype (First_Formal (Subp)));
8202 -- Check explicitly that the operation is a primitive of the type
8204 return Operator_Matches_Spec (Subp, Subp)
8205 and then not Is_Generic_Type (Typ)
8206 and then Scope (Subp) = Scope (Typ)
8207 and then not Is_Class_Wide_Type (Typ);
8209 end Can_Override_Operator;
8211 ----------------------
8212 -- Conforming_Types --
8213 ----------------------
8215 function Conforming_Types
8218 Ctype : Conformance_Type;
8219 Get_Inst : Boolean := False) return Boolean
8221 function Base_Types_Match
8223 Typ_2 : Entity_Id) return Boolean;
8224 -- If neither Typ_1 nor Typ_2 are generic actual types, or if they are
8225 -- in different scopes (e.g. parent and child instances), then verify
8226 -- that the base types are equal. Otherwise Typ_1 and Typ_2 must be on
8227 -- the same subtype chain. The whole purpose of this procedure is to
8228 -- prevent spurious ambiguities in an instantiation that may arise if
8229 -- two distinct generic types are instantiated with the same actual.
8231 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id;
8232 -- An access parameter can designate an incomplete type. If the
8233 -- incomplete type is the limited view of a type from a limited_
8234 -- with_clause, check whether the non-limited view is available.
8235 -- If it is a (non-limited) incomplete type, get the full view.
8237 function Matches_Limited_With_View
8239 Typ_2 : Entity_Id) return Boolean;
8240 -- Returns True if and only if either Typ_1 denotes a limited view of
8241 -- Typ_2 or Typ_2 denotes a limited view of Typ_1. This can arise when
8242 -- the limited with view of a type is used in a subprogram declaration
8243 -- and the subprogram body is in the scope of a regular with clause for
8244 -- the same unit. In such a case, the two type entities are considered
8245 -- identical for purposes of conformance checking.
8247 ----------------------
8248 -- Base_Types_Match --
8249 ----------------------
8251 function Base_Types_Match
8253 Typ_2 : Entity_Id) return Boolean
8255 Base_1 : constant Entity_Id := Base_Type (Typ_1);
8256 Base_2 : constant Entity_Id := Base_Type (Typ_2);
8259 if Typ_1 = Typ_2 then
8262 elsif Base_1 = Base_2 then
8264 -- The following is too permissive. A more precise test should
8265 -- check that the generic actual is an ancestor subtype of the
8268 -- See code in Find_Corresponding_Spec that applies an additional
8269 -- filter to handle accidental amiguities in instances.
8272 not Is_Generic_Actual_Type (Typ_1)
8273 or else not Is_Generic_Actual_Type (Typ_2)
8274 or else Scope (Typ_1) /= Scope (Typ_2);
8276 -- If Typ_2 is a generic actual type it is declared as the subtype of
8277 -- the actual. If that actual is itself a subtype we need to use its
8278 -- own base type to check for compatibility.
8280 elsif Ekind (Base_2) = Ekind (Typ_2)
8281 and then Base_1 = Base_Type (Base_2)
8285 elsif Ekind (Base_1) = Ekind (Typ_1)
8286 and then Base_2 = Base_Type (Base_1)
8293 end Base_Types_Match;
8295 --------------------------
8296 -- Find_Designated_Type --
8297 --------------------------
8299 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id is
8303 Desig := Directly_Designated_Type (Typ);
8305 if Ekind (Desig) = E_Incomplete_Type then
8307 -- If regular incomplete type, get full view if available
8309 if Present (Full_View (Desig)) then
8310 Desig := Full_View (Desig);
8312 -- If limited view of a type, get non-limited view if available,
8313 -- and check again for a regular incomplete type.
8315 elsif Present (Non_Limited_View (Desig)) then
8316 Desig := Get_Full_View (Non_Limited_View (Desig));
8321 end Find_Designated_Type;
8323 -------------------------------
8324 -- Matches_Limited_With_View --
8325 -------------------------------
8327 function Matches_Limited_With_View
8329 Typ_2 : Entity_Id) return Boolean
8331 function Is_Matching_Limited_View
8333 View : Entity_Id) return Boolean;
8334 -- Determine whether non-limited view View denotes type Typ in some
8335 -- conformant fashion.
8337 ------------------------------
8338 -- Is_Matching_Limited_View --
8339 ------------------------------
8341 function Is_Matching_Limited_View
8343 View : Entity_Id) return Boolean
8345 Root_Typ : Entity_Id;
8346 Root_View : Entity_Id;
8349 -- The non-limited view directly denotes the type
8354 -- The type is a subtype of the non-limited view
8356 elsif Is_Subtype_Of (Typ, View) then
8359 -- Both the non-limited view and the type denote class-wide types
8361 elsif Is_Class_Wide_Type (Typ)
8362 and then Is_Class_Wide_Type (View)
8364 Root_Typ := Root_Type (Typ);
8365 Root_View := Root_Type (View);
8367 if Root_Typ = Root_View then
8370 -- An incomplete tagged type and its full view may receive two
8371 -- distinct class-wide types when the related package has not
8372 -- been analyzed yet.
8375 -- type T is tagged; -- CW_1
8376 -- type T is tagged null record; -- CW_2
8379 -- This is because the package lacks any semantic information
8380 -- that may eventually link both views of T. As a consequence,
8381 -- a client of the limited view of Pack will see CW_2 while a
8382 -- client of the non-limited view of Pack will see CW_1.
8384 elsif Is_Incomplete_Type (Root_Typ)
8385 and then Present (Full_View (Root_Typ))
8386 and then Full_View (Root_Typ) = Root_View
8390 elsif Is_Incomplete_Type (Root_View)
8391 and then Present (Full_View (Root_View))
8392 and then Full_View (Root_View) = Root_Typ
8399 end Is_Matching_Limited_View;
8401 -- Start of processing for Matches_Limited_With_View
8404 -- In some cases a type imported through a limited_with clause, and
8405 -- its non-limited view are both visible, for example in an anonymous
8406 -- access-to-class-wide type in a formal, or when building the body
8407 -- for a subprogram renaming after the subprogram has been frozen.
8408 -- In these cases both entities designate the same type. In addition,
8409 -- if one of them is an actual in an instance, it may be a subtype of
8410 -- the non-limited view of the other.
8412 if From_Limited_With (Typ_1)
8413 and then From_Limited_With (Typ_2)
8414 and then Available_View (Typ_1) = Available_View (Typ_2)
8418 elsif From_Limited_With (Typ_1) then
8419 return Is_Matching_Limited_View (Typ_2, Available_View (Typ_1));
8421 elsif From_Limited_With (Typ_2) then
8422 return Is_Matching_Limited_View (Typ_1, Available_View (Typ_2));
8427 end Matches_Limited_With_View;
8431 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
8433 Type_1 : Entity_Id := T1;
8434 Type_2 : Entity_Id := T2;
8436 -- Start of processing for Conforming_Types
8439 -- The context is an instance association for a formal access-to-
8440 -- subprogram type; the formal parameter types require mapping because
8441 -- they may denote other formal parameters of the generic unit.
8444 Type_1 := Get_Instance_Of (T1);
8445 Type_2 := Get_Instance_Of (T2);
8448 -- If one of the types is a view of the other introduced by a limited
8449 -- with clause, treat these as conforming for all purposes.
8451 if Matches_Limited_With_View (T1, T2) then
8454 elsif Base_Types_Match (Type_1, Type_2) then
8455 if Ctype <= Mode_Conformant then
8460 Subtypes_Statically_Match (Type_1, Type_2)
8461 and then Dimensions_Match (Type_1, Type_2);
8464 elsif Is_Incomplete_Or_Private_Type (Type_1)
8465 and then Present (Full_View (Type_1))
8466 and then Base_Types_Match (Full_View (Type_1), Type_2)
8469 Ctype <= Mode_Conformant
8470 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
8472 elsif Ekind (Type_2) = E_Incomplete_Type
8473 and then Present (Full_View (Type_2))
8474 and then Base_Types_Match (Type_1, Full_View (Type_2))
8477 Ctype <= Mode_Conformant
8478 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
8480 -- The subtype declared for the formal type in an instantiation and the
8481 -- actual type are conforming. Note that testing Is_Generic_Actual_Type
8482 -- here is not sufficient because the flag is only set in the bodies of
8483 -- instances, which is too late for formal subprograms.
8485 elsif Ekind (Type_2) = E_Private_Subtype
8486 and then Etype (Type_2) = Type_1
8487 and then Present (Generic_Parent_Type (Declaration_Node (Type_2)))
8491 -- In Ada 2012, incomplete types (including limited views) can appear
8492 -- as actuals in instantiations, where they are conformant to the
8493 -- corresponding incomplete formal.
8495 elsif Is_Incomplete_Type (Type_1)
8496 and then Is_Incomplete_Type (Type_2)
8497 and then In_Instance
8498 and then (Used_As_Generic_Actual (Type_1)
8499 or else Used_As_Generic_Actual (Type_2))
8504 -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
8505 -- treated recursively because they carry a signature. As far as
8506 -- conformance is concerned, convention plays no role, and either
8507 -- or both could be access to protected subprograms.
8509 Are_Anonymous_Access_To_Subprogram_Types :=
8510 Ekind (Type_1) in E_Anonymous_Access_Subprogram_Type
8511 | E_Anonymous_Access_Protected_Subprogram_Type
8513 Ekind (Type_2) in E_Anonymous_Access_Subprogram_Type
8514 | E_Anonymous_Access_Protected_Subprogram_Type;
8516 -- Test anonymous access type case. For this case, static subtype
8517 -- matching is required for mode conformance (RM 6.3.1(15)). We check
8518 -- the base types because we may have built internal subtype entities
8519 -- to handle null-excluding types (see Process_Formals).
8521 if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
8523 Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
8525 -- Ada 2005 (AI-254)
8527 or else Are_Anonymous_Access_To_Subprogram_Types
8530 Desig_1 : Entity_Id;
8531 Desig_2 : Entity_Id;
8534 -- In Ada 2005, access constant indicators must match for
8535 -- subtype conformance.
8537 if Ada_Version >= Ada_2005
8538 and then Ctype >= Subtype_Conformant
8540 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
8545 Desig_1 := Find_Designated_Type (Type_1);
8546 Desig_2 := Find_Designated_Type (Type_2);
8548 -- If the context is an instance association for a formal
8549 -- access-to-subprogram type; formal access parameter designated
8550 -- types require mapping because they may denote other formal
8551 -- parameters of the generic unit.
8554 Desig_1 := Get_Instance_Of (Desig_1);
8555 Desig_2 := Get_Instance_Of (Desig_2);
8558 -- It is possible for a Class_Wide_Type to be introduced for an
8559 -- incomplete type, in which case there is a separate class_ wide
8560 -- type for the full view. The types conform if their Etypes
8561 -- conform, i.e. one may be the full view of the other. This can
8562 -- only happen in the context of an access parameter, other uses
8563 -- of an incomplete Class_Wide_Type are illegal.
8565 if Is_Class_Wide_Type (Desig_1)
8567 Is_Class_Wide_Type (Desig_2)
8571 (Etype (Base_Type (Desig_1)),
8572 Etype (Base_Type (Desig_2)), Ctype);
8574 elsif Are_Anonymous_Access_To_Subprogram_Types then
8575 if Ada_Version < Ada_2005 then
8577 Ctype = Type_Conformant
8578 or else Subtypes_Statically_Match (Desig_1, Desig_2);
8580 -- We must check the conformance of the signatures themselves
8584 Conformant : Boolean;
8587 (Desig_1, Desig_2, Ctype, False, Conformant);
8592 -- A limited view of an actual matches the corresponding
8593 -- incomplete formal.
8595 elsif Ekind (Desig_2) = E_Incomplete_Subtype
8596 and then From_Limited_With (Desig_2)
8597 and then Used_As_Generic_Actual (Etype (Desig_2))
8602 return Base_Type (Desig_1) = Base_Type (Desig_2)
8603 and then (Ctype = Type_Conformant
8605 Subtypes_Statically_Match (Desig_1, Desig_2));
8609 -- Otherwise definitely no match
8612 if ((Ekind (Type_1) = E_Anonymous_Access_Type
8613 and then Is_Access_Type (Type_2))
8614 or else (Ekind (Type_2) = E_Anonymous_Access_Type
8615 and then Is_Access_Type (Type_1)))
8618 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
8620 May_Hide_Profile := True;
8625 end Conforming_Types;
8627 --------------------------
8628 -- Create_Extra_Formals --
8629 --------------------------
8631 procedure Create_Extra_Formals (E : Entity_Id) is
8632 First_Extra : Entity_Id := Empty;
8634 Last_Extra : Entity_Id := Empty;
8636 function Add_Extra_Formal
8637 (Assoc_Entity : Entity_Id;
8640 Suffix : String) return Entity_Id;
8641 -- Add an extra formal to the current list of formals and extra formals.
8642 -- The extra formal is added to the end of the list of extra formals,
8643 -- and also returned as the result. These formals are always of mode IN.
8644 -- The new formal has the type Typ, is declared in Scope, and its name
8645 -- is given by a concatenation of the name of Assoc_Entity and Suffix.
8646 -- The following suffixes are currently used. They should not be changed
8647 -- without coordinating with CodePeer, which makes use of these to
8648 -- provide better messages.
8650 -- O denotes the Constrained bit.
8651 -- L denotes the accessibility level.
8652 -- BIP_xxx denotes an extra formal for a build-in-place function. See
8653 -- the full list in exp_ch6.BIP_Formal_Kind.
8655 function Has_Extra_Formals (E : Entity_Id) return Boolean;
8656 -- Determines if E has its extra formals
8658 function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean;
8659 -- Determines if E is a dispatching primitive returning a limited tagged
8660 -- type object since some descendant might return an object with tasks
8661 -- (and therefore need the BIP task extra actuals).
8663 function Needs_Accessibility_Check_Extra
8665 Formal : Node_Id) return Boolean;
8666 -- Determines whether the given formal of E needs an extra formal for
8667 -- supporting accessibility checking. Returns True for both anonymous
8668 -- access formals and formals of named access types that are marked as
8669 -- controlling formals. The latter case can occur when the subprogram
8670 -- Expand_Dispatching_Call creates a subprogram-type and substitutes
8671 -- the types of access-to-class-wide actuals for the anonymous access-
8672 -- to-specific-type of controlling formals.
8674 function Parent_Subprogram (Subp_Id : Entity_Id) return Entity_Id;
8675 -- Subp_Id is a subprogram of a derived type; return its parent
8676 -- subprogram if Subp_Id overrides a parent primitive or derives
8677 -- from a parent primitive, and such parent primitive can have extra
8678 -- formals. Otherwise return Empty.
8680 ----------------------
8681 -- Add_Extra_Formal --
8682 ----------------------
8684 function Add_Extra_Formal
8685 (Assoc_Entity : Entity_Id;
8688 Suffix : String) return Entity_Id
8693 -- A little optimization. Never generate an extra formal for the
8694 -- _init operand of an initialization procedure, since it could
8697 if Chars (Formal) = Name_uInit then
8701 EF := Make_Defining_Identifier (Sloc (Assoc_Entity),
8702 Chars => New_External_Name (Chars (Assoc_Entity),
8705 Mutate_Ekind (EF, E_In_Parameter);
8706 Set_Actual_Subtype (EF, Typ);
8707 Set_Etype (EF, Typ);
8708 Set_Scope (EF, Scope);
8709 Set_Mechanism (EF, Default_Mechanism);
8710 Set_Formal_Validity (EF);
8712 if No (First_Extra) then
8714 Set_Extra_Formals (Scope, EF);
8717 if Present (Last_Extra) then
8718 Set_Extra_Formal (Last_Extra, EF);
8724 end Add_Extra_Formal;
8726 -----------------------
8727 -- Has_Extra_Formals --
8728 -----------------------
8730 function Has_Extra_Formals (E : Entity_Id) return Boolean is
8732 return Present (Extra_Formals (E))
8734 (Ekind (E) = E_Function
8735 and then Present (Extra_Accessibility_Of_Result (E)));
8736 end Has_Extra_Formals;
8738 ---------------------------------
8739 -- Might_Need_BIP_Task_Actuals --
8740 ---------------------------------
8742 function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean is
8743 Subp_Id : Entity_Id;
8744 Func_Typ : Entity_Id;
8747 if Global_No_Tasking or else No_Run_Time_Mode then
8751 -- No further check needed if we know that BIP task actuals are
8754 if Needs_BIP_Task_Actuals (E) then
8758 -- For thunks we must rely on their target entity
8760 if Is_Thunk (E) then
8761 Subp_Id := Thunk_Target (E);
8763 -- For protected subprograms we rely on the subprogram which
8764 -- implements the body of the operation (since it is the entity
8765 -- that may be a dispatching operation).
8767 elsif Is_Protected_Type (Scope (E))
8768 and then Present (Protected_Body_Subprogram (E))
8770 Subp_Id := Protected_Body_Subprogram (E);
8776 -- We check the root type of the return type since the same
8777 -- decision must be taken for all descendants overriding a
8778 -- dispatching operation.
8780 Func_Typ := Root_Type (Underlying_Type (Etype (Subp_Id)));
8782 return Ekind (Subp_Id) = E_Function
8783 and then not Has_Foreign_Convention (Func_Typ)
8784 and then Is_Dispatching_Operation (Subp_Id)
8785 and then Is_Tagged_Type (Func_Typ)
8786 and then Is_Limited_Type (Func_Typ)
8787 and then not Has_Aspect (Func_Typ, Aspect_No_Task_Parts);
8788 end Might_Need_BIP_Task_Actuals;
8790 -------------------------------------
8791 -- Needs_Accessibility_Check_Extra --
8792 -------------------------------------
8794 function Needs_Accessibility_Check_Extra
8796 Formal : Node_Id) return Boolean is
8799 -- For dispatching operations this extra formal is not suppressed
8800 -- since all the derivations must have matching formals.
8802 -- For nondispatching operations it is suppressed if we specifically
8803 -- suppress accessibility checks at the package level for either the
8804 -- subprogram, or the package in which it resides. However, we do
8805 -- not suppress it simply if the scope has accessibility checks
8806 -- suppressed, since this could cause trouble when clients are
8807 -- compiled with a different suppression setting. The explicit checks
8808 -- at the package level are safe from this point of view.
8810 if not Is_Dispatching_Operation (E)
8812 (Explicit_Suppress (E, Accessibility_Check)
8813 or else Explicit_Suppress (Scope (E), Accessibility_Check))
8818 -- Base_Type is applied to handle cases where there is a null
8819 -- exclusion the formal may have an access subtype.
8822 Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
8824 (Is_Controlling_Formal (Formal)
8825 and then Is_Access_Type (Base_Type (Etype (Formal))));
8826 end Needs_Accessibility_Check_Extra;
8828 -----------------------
8829 -- Parent_Subprogram --
8830 -----------------------
8832 function Parent_Subprogram (Subp_Id : Entity_Id) return Entity_Id is
8833 pragma Assert (not Is_Thunk (Subp_Id));
8834 Ovr_E : Entity_Id := Overridden_Operation (Subp_Id);
8835 Ovr_Alias : Entity_Id;
8839 and then Ekind (Ovr_E) = E_Enumeration_Literal
8843 elsif Present (Ovr_E) then
8844 Ovr_Alias := Ultimate_Alias (Ovr_E);
8846 -- There is no real overridden subprogram if there is a mutual
8847 -- reference between the E and its overridden operation. This
8848 -- weird scenery occurs in the following cases:
8850 -- 1) Controlling function wrappers internally built by
8851 -- Make_Controlling_Function_Wrappers.
8853 -- 2) Hidden overridden primitives of type extensions or private
8854 -- extensions (cf. Find_Hidden_Overridden_Primitive). These
8855 -- hidden primitives have suffix 'P
'.
8857 -- 3) Overriding primitives of stub types (see the subprogram
8858 -- Add_RACW_Primitive_Declarations_And_Bodies).
8860 if Ovr_Alias = Subp_Id then
8862 ((Is_Wrapper (Subp_Id)
8863 and then Has_Controlling_Result (Subp_Id))
8864 or else Has_Suffix (Ovr_E, 'P
')
8865 or else Is_RACW_Stub_Type
8866 (Find_Dispatching_Type (Subp_Id))
8867 or else No (Overridden_Operation (Ovr_E)));
8869 if Present (Overridden_Operation (Ovr_E)) then
8870 Ovr_E := Overridden_Operation (Ovr_E);
8872 -- Ovr_E is an internal entity built by Derive_Subprogram and
8873 -- we have no direct way to climb to the corresponding parent
8874 -- subprogram but this internal entity has the extra formals
8875 -- (if any) required for the purpose of checking the extra
8876 -- formals of Subp_Id.
8879 pragma Assert (not Comes_From_Source (Ovr_E));
8882 -- Use as our reference entity the ultimate renaming of the
8883 -- overridden subprogram.
8885 elsif Present (Alias (Ovr_E)) then
8886 pragma Assert (No (Overridden_Operation (Ovr_Alias))
8887 or else Overridden_Operation (Ovr_Alias) /= Ovr_E);
8893 if Present (Ovr_E) and then Has_Reliable_Extra_Formals (Ovr_E) then
8898 end Parent_Subprogram;
8902 Formal_Type : Entity_Id;
8903 May_Have_Alias : Boolean;
8904 Alias_Formal : Entity_Id := Empty;
8905 Alias_Subp : Entity_Id := Empty;
8906 Parent_Formal : Entity_Id := Empty;
8907 Parent_Subp : Entity_Id := Empty;
8910 -- Start of processing for Create_Extra_Formals
8913 pragma Assert (Is_Subprogram_Or_Entry (E)
8914 or else Ekind (E) in E_Subprogram_Type);
8916 -- We never generate extra formals if expansion is not active because we
8917 -- don't need them unless we are generating code.
8919 if not Expander_Active then
8922 -- Enumeration literals have no extra formal; this case occurs when
8923 -- a function renames it.
8925 elsif Ekind (E) = E_Function
8926 and then Ekind (Ultimate_Alias (E)) = E_Enumeration_Literal
8930 -- Extra formals of Initialization procedures are added by the function
8931 -- Exp_Ch3.Init_Formals
8933 elsif Is_Init_Proc (E) then
8936 -- No need to generate extra formals in thunks whose target has no extra
8937 -- formals, but we can have two of them chained (interface and stack).
8939 elsif Is_Thunk (E) and then No (Extra_Formals (Thunk_Target (E))) then
8942 -- If Extra_Formals were already created, don't do it again. This
8943 -- situation may arise for subprogram types created as part of
8944 -- dispatching calls (see Expand_Dispatching_Call).
8946 elsif Has_Extra_Formals (E) then
8949 -- Extra formals of renamings of generic actual subprograms and
8950 -- renamings of instances of generic subprograms are shared. The
8951 -- check performed on the last formal is required to ensure that
8952 -- this is the renaming built by Analyze_Instance_And_Renamings
8953 -- (which shares all the formals); otherwise this would be wrong.
8955 elsif Ekind (E) in E_Function | E_Procedure
8956 and then Is_Generic_Instance (E)
8957 and then Present (Alias (E))
8958 and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E)
8960 pragma Assert (Is_Generic_Instance (E)
8961 = Is_Generic_Instance (Ultimate_Alias (E)));
8963 Create_Extra_Formals (Ultimate_Alias (E));
8965 -- Share the extra formals
8967 Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
8969 if Ekind (E) = E_Function then
8970 Set_Extra_Accessibility_Of_Result (E,
8971 Extra_Accessibility_Of_Result (Ultimate_Alias (E)));
8974 pragma Assert (Extra_Formals_OK (E));
8978 -- Locate the last formal; required by Add_Extra_Formal.
8980 Formal := First_Formal (E);
8981 while Present (Formal) loop
8982 Last_Extra := Formal;
8983 Next_Formal (Formal);
8986 -- We rely on three entities to ensure consistency of extra formals of
8989 -- 1. A reference entity (Ref_E). For thunks it is their target
8990 -- primitive since this ensures that they have exactly the
8991 -- same extra formals; otherwise it is the identity.
8993 -- 2. The parent subprogram; only for derived types and references
8994 -- either the overridden subprogram or the internal entity built
8995 -- by Derive_Subprogram that has the extra formals of the parent
8996 -- subprogram; otherwise it is Empty. This entity ensures matching
8997 -- extra formals in derived types.
8999 -- 3. For renamings, their ultimate alias; this ensures taking the
9000 -- same decision in all the renamings (independently of the Ada
9001 -- mode on which they are compiled). For example:
9004 -- function Id_A (I : access Integer) return access Integer;
9007 -- function Id_B (I : access Integer) return access Integer
9010 if Is_Thunk (E) then
9011 Ref_E := Thunk_Target (E);
9016 if Is_Subprogram (Ref_E) then
9017 Parent_Subp := Parent_Subprogram (Ref_E);
9021 (Is_Subprogram (Ref_E) or else Ekind (Ref_E) = E_Subprogram_Type);
9023 -- If the parent subprogram is available then its ultimate alias of
9024 -- Ref_E is not needed since it will not be used to check its extra
9028 and then May_Have_Alias
9029 and then Present (Alias (Ref_E))
9030 and then Has_Reliable_Extra_Formals (Ultimate_Alias (Ref_E))
9032 Alias_Subp := Ultimate_Alias (Ref_E);
9035 -- Cannot add extra formals to subprograms and access types that have
9036 -- foreign convention nor to subprograms overriding primitives that
9037 -- have foreign convention since the foreign language does not know
9038 -- how to handle these extra formals; same for renamings of entities
9039 -- with foreign convention.
9041 if Has_Foreign_Convention (Ref_E)
9042 or else (Present (Alias_Subp)
9043 and then Has_Foreign_Convention (Alias_Subp))
9048 -- If the subprogram is a predefined dispatching subprogram then don't
9049 -- generate any extra constrained or accessibility level formals. In
9050 -- general we suppress these for internal subprograms (by not calling
9051 -- Freeze_Subprogram and Create_Extra_Formals at all), but internally
9052 -- generated stream attributes do get passed through because extra
9053 -- build-in-place formals are needed in some cases (limited 'Input
).
9055 if Is_Predefined_Internal_Operation
(E
) then
9056 goto Test_For_Func_Result_Extras
;
9059 -- Process the formals relying on the formals of our reference entities:
9060 -- Parent_Formal, Alias_Formal and Formal. Notice that we don't use the
9061 -- formal of Ref_E; we must use the formal of E which is the entity to
9062 -- which we are adding the extra formals.
9064 -- If this is a derived subprogram then the subtypes of the parent
9065 -- subprogram's formal parameters will be used to determine the need
9066 -- for extra formals.
9068 if Present
(Parent_Subp
) then
9070 -- Ensure that the parent subprogram has all its extra formals.
9071 -- Required because its return type may have been a private or
9072 -- an incomplete type, and the extra formals were not added. We
9073 -- protect this call against the weird cases where the parent subp
9074 -- renames this primitive (documented in the body of the local
9075 -- function Parent_Subprogram).
9077 if Ultimate_Alias
(Parent_Subp
) /= Ref_E
then
9078 Create_Extra_Formals
(Parent_Subp
);
9081 Parent_Formal
:= First_Formal
(Parent_Subp
);
9083 -- For concurrent types, the controlling argument of a dispatching
9084 -- primitive implementing an interface primitive is implicit. For
9087 -- type Iface is protected interface;
9090 -- Value : Integer) return Natural is abstract;
9092 -- protected type PO is new Iface with
9093 -- function Prim (Value : Integer) return Natural;
9096 if Convention
(Ref_E
) = Convention_Protected
9097 and then Is_Abstract_Subprogram
(Parent_Subp
)
9098 and then Is_Interface
(Find_Dispatching_Type
(Parent_Subp
))
9100 Parent_Formal
:= Next_Formal
(Parent_Formal
);
9102 -- This is the nondispatching subprogram of a concurrent type
9103 -- that overrides the interface primitive; the expander will
9104 -- create the dispatching primitive (without Convention_Protected)
9105 -- with all the matching formals (see exp_ch9.Build_Wrapper_Specs)
9107 pragma Assert
(not Is_Dispatching_Operation
(Ref_E
));
9110 -- Ensure that the ultimate alias has all its extra formals
9112 elsif Present
(Alias_Subp
) then
9113 Create_Extra_Formals
(Alias_Subp
);
9114 Alias_Formal
:= First_Formal
(Alias_Subp
);
9117 Formal
:= First_Formal
(E
);
9118 while Present
(Formal
) loop
9120 -- Here we establish our priority for deciding on the extra
9121 -- formals: 1) Parent primitive 2) Aliased primitive 3) Identity
9123 if Present
(Parent_Formal
) then
9124 Formal_Type
:= Etype
(Parent_Formal
);
9126 elsif Present
(Alias_Formal
) then
9127 Formal_Type
:= Etype
(Alias_Formal
);
9130 Formal_Type
:= Etype
(Formal
);
9133 -- Create extra formal for supporting the attribute 'Constrained.
9134 -- The case of a private type view without discriminants also
9135 -- requires the extra formal if the underlying type has defaulted
9138 if Ekind
(Formal
) /= E_In_Parameter
then
9140 -- Do not produce extra formals for Unchecked_Union parameters.
9141 -- Jump directly to the end of the loop.
9143 if Is_Unchecked_Union
(Base_Type
(Formal_Type
)) then
9144 goto Skip_Extra_Formal_Generation
;
9147 if not Has_Discriminants
(Formal_Type
)
9148 and then Is_Private_Type
(Formal_Type
)
9149 and then Present
(Underlying_Type
(Formal_Type
))
9151 Formal_Type
:= Underlying_Type
(Formal_Type
);
9154 -- Suppress the extra formal if formal's subtype is constrained or
9155 -- indefinite, or we're compiling for Ada 2012 and the underlying
9156 -- type is tagged and limited. In Ada 2012, a limited tagged type
9157 -- can have defaulted discriminants, but 'Constrained is required
9158 -- to return True, so the formal is never needed (see AI05-0214).
9159 -- Note that this ensures consistency of calling sequences for
9160 -- dispatching operations when some types in a class have defaults
9161 -- on discriminants and others do not (and requiring the extra
9162 -- formal would introduce distributed overhead).
9164 -- If the type does not have a completion yet, treat as prior to
9165 -- Ada 2012 for consistency.
9167 if Has_Discriminants
(Formal_Type
)
9168 and then not Is_Constrained
(Formal_Type
)
9169 and then Is_Definite_Subtype
(Formal_Type
)
9170 and then (Ada_Version
< Ada_2012
9171 or else No
(Underlying_Type
(Formal_Type
))
9173 (Is_Limited_Type
(Formal_Type
)
9176 (Underlying_Type
(Formal_Type
))))
9178 Set_Extra_Constrained
9179 (Formal
, Add_Extra_Formal
(Formal
, Standard_Boolean
, E
, "O"));
9183 -- Extra formal for supporting accessibility checking
9185 if Needs_Accessibility_Check_Extra
(Ref_E
, Formal
) then
9186 pragma Assert
(No
(Parent_Formal
)
9187 or else Present
(Extra_Accessibility
(Parent_Formal
)));
9188 pragma Assert
(No
(Alias_Formal
)
9189 or else Present
(Extra_Accessibility
(Alias_Formal
)));
9191 Set_Extra_Accessibility
9192 (Formal
, Add_Extra_Formal
(Formal
, Standard_Natural
, E
, "L"));
9195 pragma Assert
(No
(Parent_Formal
)
9196 or else No
(Extra_Accessibility
(Parent_Formal
)));
9197 pragma Assert
(No
(Alias_Formal
)
9198 or else No
(Extra_Accessibility
(Alias_Formal
)));
9201 -- This label is required when skipping extra formal generation for
9202 -- Unchecked_Union parameters.
9204 <<Skip_Extra_Formal_Generation
>>
9206 if Present
(Parent_Formal
) then
9207 Next_Formal
(Parent_Formal
);
9210 if Present
(Alias_Formal
) then
9211 Next_Formal
(Alias_Formal
);
9214 Next_Formal
(Formal
);
9217 <<Test_For_Func_Result_Extras
>>
9219 -- Assume the worst case (Ada 2022) to evaluate this extra formal;
9220 -- required to ensure matching of extra formals between subprograms
9221 -- and access-to-subprogram types in projects with mixed Ada dialects.
9224 Save_Ada_Version
: constant Ada_Version_Type
:= Ada_Version
;
9227 Ada_Version
:= Ada_2022
;
9229 if Needs_Result_Accessibility_Level
(Ref_E
)
9231 (Present
(Parent_Subp
)
9232 and then Needs_Result_Accessibility_Level
(Parent_Subp
))
9234 (Present
(Alias_Subp
)
9235 and then Needs_Result_Accessibility_Level
(Alias_Subp
))
9237 Set_Extra_Accessibility_Of_Result
(E
,
9238 Add_Extra_Formal
(E
, Standard_Natural
, E
, "L"));
9241 Ada_Version
:= Save_Ada_Version
;
9244 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
9245 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
9247 if (Present
(Parent_Subp
) and then Has_BIP_Formals
(Parent_Subp
))
9249 (Present
(Alias_Subp
) and then Has_BIP_Formals
(Alias_Subp
))
9251 (Is_Build_In_Place_Function
(Ref_E
)
9252 and then Has_Reliable_Extra_Formals
(Ref_E
))
9255 Result_Subt
: constant Entity_Id
:= Etype
(Ref_E
);
9256 Formal_Typ
: Entity_Id
;
9257 Subp_Decl
: Node_Id
;
9258 Discard
: Entity_Id
;
9261 -- In the case of functions with unconstrained result subtypes,
9262 -- add a 4-state formal indicating whether the return object is
9263 -- allocated by the caller (1), or should be allocated by the
9264 -- callee on the secondary stack (2), in the global heap (3), or
9265 -- in a user-defined storage pool (4). For the moment we just use
9266 -- Natural for the type of this formal. Note that this formal
9267 -- isn't usually needed in the case where the result subtype is
9268 -- constrained, but it is needed when the function has a tagged
9269 -- result, because generally such functions can be called in a
9270 -- dispatching context and such calls must be handled like calls
9271 -- to a class-wide function.
9273 if Needs_BIP_Alloc_Form
(Ref_E
)
9275 (Present
(Parent_Subp
)
9276 and then Has_BIP_Extra_Formal
(Parent_Subp
, BIP_Alloc_Form
,
9277 Must_Be_Frozen
=> False))
9279 (Present
(Alias_Subp
)
9280 and then Has_BIP_Extra_Formal
(Alias_Subp
, BIP_Alloc_Form
,
9281 Must_Be_Frozen
=> False))
9285 (E
, Standard_Natural
,
9286 E
, BIP_Formal_Suffix
(BIP_Alloc_Form
));
9288 -- Add BIP_Storage_Pool, in case BIP_Alloc_Form indicates to
9289 -- use a user-defined pool. This formal is not added on
9290 -- ZFP as those targets do not support pools.
9292 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
9295 (E
, RTE
(RE_Root_Storage_Pool_Ptr
),
9296 E
, BIP_Formal_Suffix
(BIP_Storage_Pool
));
9300 -- In the case of functions whose result type needs finalization,
9301 -- add an extra formal which represents the finalization master.
9303 if Needs_BIP_Finalization_Master
(Ref_E
)
9305 (Present
(Parent_Subp
)
9306 and then Has_BIP_Extra_Formal
(Parent_Subp
,
9307 Kind
=> BIP_Finalization_Master
,
9308 Must_Be_Frozen
=> False))
9310 (Present
(Alias_Subp
)
9311 and then Has_BIP_Extra_Formal
(Alias_Subp
,
9312 Kind
=> BIP_Finalization_Master
,
9313 Must_Be_Frozen
=> False))
9317 (E
, RTE
(RE_Finalization_Master_Ptr
),
9318 E
, BIP_Formal_Suffix
(BIP_Finalization_Master
));
9321 -- When the result type contains tasks, add two extra formals: the
9322 -- master of the tasks to be created, and the caller's activation
9325 if Needs_BIP_Task_Actuals
(Ref_E
)
9326 or else Might_Need_BIP_Task_Actuals
(Ref_E
)
9328 (Present
(Parent_Subp
)
9329 and then Has_BIP_Extra_Formal
(Parent_Subp
, BIP_Task_Master
,
9330 Must_Be_Frozen
=> False))
9332 (Present
(Alias_Subp
)
9333 and then Has_BIP_Extra_Formal
(Alias_Subp
, BIP_Task_Master
,
9334 Must_Be_Frozen
=> False))
9338 (E
, Standard_Integer
,
9339 E
, BIP_Formal_Suffix
(BIP_Task_Master
));
9341 if Needs_BIP_Task_Actuals
(Ref_E
) then
9342 Set_Has_Master_Entity
(E
);
9347 (E
, RTE
(RE_Activation_Chain_Access
),
9348 E
, BIP_Formal_Suffix
(BIP_Activation_Chain
));
9351 -- All build-in-place functions get an extra formal that will be
9352 -- passed the address of the return object within the caller.
9355 Create_Itype
(E_Anonymous_Access_Type
, E
, Scope_Id
=> Scope
(E
));
9357 -- Incomplete_View_From_Limited_With is needed here because
9358 -- gigi gets confused if the designated type is the full view
9359 -- coming from a limited-with'ed package. In the normal case,
9360 -- (no limited with) Incomplete_View_From_Limited_With
9361 -- returns Result_Subt.
9363 Set_Directly_Designated_Type
9364 (Formal_Typ
, Incomplete_View_From_Limited_With
(Result_Subt
));
9365 Set_Etype
(Formal_Typ
, Formal_Typ
);
9366 Set_Depends_On_Private
9367 (Formal_Typ
, Has_Private_Component
(Formal_Typ
));
9368 Set_Is_Public
(Formal_Typ
, Is_Public
(Scope
(Formal_Typ
)));
9369 Set_Is_Access_Constant
(Formal_Typ
, False);
9371 -- Ada 2005 (AI-50217): Propagate the attribute that indicates
9372 -- the designated type comes from the limited view (for back-end
9375 Set_From_Limited_With
9376 (Formal_Typ
, From_Limited_With
(Result_Subt
));
9378 Layout_Type
(Formal_Typ
);
9380 -- Force the definition of the Itype in case of internal function
9381 -- calls within the same or nested scope.
9383 if Is_Subprogram_Or_Generic_Subprogram
(E
)
9384 and then not Is_Compilation_Unit
(E
)
9386 Subp_Decl
:= Parent
(E
);
9388 -- The insertion point for an Itype reference should be after
9389 -- the unit declaration node of the subprogram. An exception
9390 -- to this are inherited operations from a parent type in which
9391 -- case the derived type acts as their parent.
9393 if Nkind
(Subp_Decl
) in N_Function_Specification
9394 | N_Procedure_Specification
9396 Subp_Decl
:= Parent
(Subp_Decl
);
9399 Build_Itype_Reference
(Formal_Typ
, Subp_Decl
);
9404 (E
, Formal_Typ
, E
, BIP_Formal_Suffix
(BIP_Object_Access
));
9408 -- If this is an instance of a generic, we need to have extra formals
9411 if Is_Generic_Instance
(E
) and then Present
(Alias
(E
)) then
9412 Set_Extra_Formals
(Alias
(E
), Extra_Formals
(E
));
9415 pragma Assert
(No
(Alias_Subp
)
9416 or else Extra_Formals_Match_OK
(E
, Alias_Subp
));
9418 pragma Assert
(No
(Parent_Subp
)
9419 or else Extra_Formals_Match_OK
(E
, Parent_Subp
));
9421 pragma Assert
(Extra_Formals_OK
(E
));
9422 end Create_Extra_Formals
;
9424 -----------------------------
9425 -- Enter_Overloaded_Entity --
9426 -----------------------------
9428 procedure Enter_Overloaded_Entity
(S
: Entity_Id
) is
9429 function Matches_Predefined_Op
return Boolean;
9430 -- This returns an approximation of whether S matches a predefined
9431 -- operator, based on the operator symbol, and the parameter and result
9432 -- types. The rules are scattered throughout chapter 4 of the Ada RM.
9434 ---------------------------
9435 -- Matches_Predefined_Op --
9436 ---------------------------
9438 function Matches_Predefined_Op
return Boolean is
9439 Formal_1
: constant Entity_Id
:= First_Formal
(S
);
9440 Formal_2
: constant Entity_Id
:= Next_Formal
(Formal_1
);
9441 Op
: constant Name_Id
:= Chars
(S
);
9442 Result_Type
: constant Entity_Id
:= Base_Type
(Etype
(S
));
9443 Type_1
: constant Entity_Id
:= Base_Type
(Etype
(Formal_1
));
9448 if Present
(Formal_2
) then
9450 Type_2
: constant Entity_Id
:= Base_Type
(Etype
(Formal_2
));
9453 -- All but "&" and "**" have same-types parameters
9462 if Type_1
/= Type_2
then
9467 -- Check parameter and result types
9475 Is_Boolean_Type
(Result_Type
)
9476 and then Result_Type
= Type_1
;
9482 Is_Integer_Type
(Result_Type
)
9483 and then Result_Type
= Type_1
;
9491 Is_Numeric_Type
(Result_Type
)
9492 and then Result_Type
= Type_1
;
9498 Is_Boolean_Type
(Result_Type
)
9499 and then not Is_Limited_Type
(Type_1
);
9507 Is_Boolean_Type
(Result_Type
)
9508 and then (Is_Array_Type
(Type_1
)
9509 or else Is_Scalar_Type
(Type_1
));
9511 when Name_Op_Concat
=>
9512 return Is_Array_Type
(Result_Type
);
9514 when Name_Op_Expon
=>
9516 (Is_Integer_Type
(Result_Type
)
9517 or else Is_Floating_Point_Type
(Result_Type
))
9518 and then Result_Type
= Type_1
9519 and then Type_2
= Standard_Integer
;
9522 raise Program_Error
;
9535 Is_Numeric_Type
(Result_Type
)
9536 and then Result_Type
= Type_1
;
9540 Is_Boolean_Type
(Result_Type
)
9541 and then Result_Type
= Type_1
;
9544 raise Program_Error
;
9547 end Matches_Predefined_Op
;
9551 E
: Entity_Id
:= Current_Entity_In_Scope
(S
);
9552 C_E
: Entity_Id
:= Current_Entity
(S
);
9554 -- Start of processing for Enter_Overloaded_Entity
9558 Set_Has_Homonym
(E
);
9559 Set_Has_Homonym
(S
);
9562 Set_Is_Immediately_Visible
(S
);
9563 Set_Scope
(S
, Current_Scope
);
9565 -- Chain new entity if front of homonym in current scope, so that
9566 -- homonyms are contiguous.
9568 if Present
(E
) and then E
/= C_E
then
9569 while Homonym
(C_E
) /= E
loop
9570 C_E
:= Homonym
(C_E
);
9573 Set_Homonym
(C_E
, S
);
9577 Set_Current_Entity
(S
);
9582 if Is_Inherited_Operation
(S
) then
9583 Append_Inherited_Subprogram
(S
);
9585 Append_Entity
(S
, Current_Scope
);
9588 Set_Public_Status
(S
);
9590 if Debug_Flag_E
then
9591 Write_Str
("New overloaded entity chain: ");
9592 Write_Name
(Chars
(S
));
9595 while Present
(E
) loop
9596 Write_Str
(" "); Write_Int
(Int
(E
));
9603 -- Generate warning for hiding
9606 and then Comes_From_Source
(S
)
9607 and then In_Extended_Main_Source_Unit
(S
)
9614 -- Warn unless genuine overloading. Do not emit warning on
9615 -- hiding predefined operators in Standard (these are either an
9616 -- artifact of our implicit declarations, or simple noise) but
9617 -- keep warning on a operator defined on a local subtype, because
9618 -- of the real danger that different operators may be applied in
9619 -- various parts of the program.
9621 -- Note that if E and S have the same scope, there is never any
9622 -- hiding. Either the two conflict, and the program is illegal,
9623 -- or S is overriding an implicit inherited subprogram.
9625 if Scope
(E
) /= Scope
(S
)
9626 and then (not Is_Overloadable
(E
)
9627 or else Subtype_Conformant
(E
, S
))
9628 and then (Is_Immediately_Visible
(E
)
9629 or else Is_Potentially_Use_Visible
(S
))
9631 if Scope
(E
) = Standard_Standard
then
9632 if Nkind
(S
) = N_Defining_Operator_Symbol
9633 and then Scope
(Base_Type
(Etype
(First_Formal
(S
)))) /=
9635 and then Matches_Predefined_Op
9638 ("declaration of & hides predefined operator?h?", S
);
9641 -- E not immediately within Standard
9644 Error_Msg_Sloc
:= Sloc
(E
);
9645 Error_Msg_N
("declaration of & hides one #?h?", S
);
9650 end Enter_Overloaded_Entity
;
9652 ----------------------------
9653 -- Extra_Formals_Match_OK --
9654 ----------------------------
9656 function Extra_Formals_Match_OK
9658 Ref_E
: Entity_Id
) return Boolean is
9660 pragma Assert
(Is_Subprogram
(E
));
9662 -- Cases where no check can be performed:
9663 -- 1) When expansion is not active (since we never generate extra
9664 -- formals if expansion is not active because we don't need them
9665 -- unless we are generating code).
9666 -- 2) On abstract predefined dispatching operations of Root_Controlled
9667 -- and predefined stream operations not emitted by the frontend.
9668 -- 3) On renamings of abstract predefined dispatching operations of
9669 -- interface types (since limitedness is not inherited in such
9671 -- 4) The controlling formal of the nondispatching subprogram of
9672 -- a concurrent type that overrides an interface primitive is
9673 -- implicit and hence we cannot check here if all its extra
9674 -- formals match; the expander will create the dispatching
9675 -- primitive (without Convention_Protected) with the matching
9676 -- formals (see exp_ch9.Build_Wrapper_Specs) which will be
9679 if Debug_Flag_Underscore_XX
9680 or else not Expander_Active
9682 (Is_Predefined_Dispatching_Operation
(E
)
9683 and then (not Has_Reliable_Extra_Formals
(E
)
9684 or else not Has_Reliable_Extra_Formals
(Ref_E
)))
9686 (Is_Predefined_Dispatching_Operation
(E
)
9687 and then Is_Abstract_Subprogram
(E
)
9688 and then Is_Interface
(Find_Dispatching_Type
(Ref_E
)))
9692 elsif Convention
(E
) = Convention_Protected
9693 and then not Is_Dispatching_Operation
(E
)
9694 and then Is_Abstract_Subprogram
(Ref_E
)
9695 and then Is_Interface
(Find_Dispatching_Type
(Ref_E
))
9700 -- Perform the checks
9702 if No
(Extra_Formals
(E
)) then
9703 return No
(Extra_Formals
(Ref_E
));
9706 if Ekind
(E
) in E_Function | E_Subprogram_Type
9707 and then Present
(Extra_Accessibility_Of_Result
(E
))
9708 /= Present
(Extra_Accessibility_Of_Result
(Ref_E
))
9714 Formal_1
: Entity_Id
:= Extra_Formals
(E
);
9715 Formal_2
: Entity_Id
:= Extra_Formals
(Ref_E
);
9718 while Present
(Formal_1
) and then Present
(Formal_2
) loop
9719 if Has_Suffix
(Formal_1
, 'L') then
9720 if not Has_Suffix
(Formal_2
, 'L') then
9724 elsif Has_Suffix
(Formal_1
, 'O') then
9725 if not Has_Suffix
(Formal_2
, 'O') then
9729 elsif BIP_Suffix_Kind
(Formal_1
) /= BIP_Suffix_Kind
(Formal_2
) then
9733 Formal_1
:= Next_Formal_With_Extras
(Formal_1
);
9734 Formal_2
:= Next_Formal_With_Extras
(Formal_2
);
9737 return No
(Formal_1
) and then No
(Formal_2
);
9739 end Extra_Formals_Match_OK
;
9741 ----------------------
9742 -- Extra_Formals_OK --
9743 ----------------------
9745 function Extra_Formals_OK
(E
: Entity_Id
) return Boolean is
9746 Last_Formal
: Entity_Id
:= Empty
;
9748 Has_Extra_Formals
: Boolean := False;
9751 -- No check required if explicitly disabled
9753 if Debug_Flag_Underscore_XX
then
9756 -- No check required if expansion is disabled because extra
9757 -- formals are only generated when we are generating code.
9758 -- See Create_Extra_Formals.
9760 elsif not Expander_Active
then
9764 -- Check attribute Extra_Formal: If available, it must be set only
9765 -- on the last formal of E.
9767 Formal
:= First_Formal
(E
);
9768 while Present
(Formal
) loop
9769 if Present
(Extra_Formal
(Formal
)) then
9770 if Has_Extra_Formals
then
9774 Has_Extra_Formals
:= True;
9777 Last_Formal
:= Formal
;
9778 Next_Formal
(Formal
);
9781 -- Check attribute Extra_Accessibility_Of_Result
9783 if Ekind
(E
) in E_Function | E_Subprogram_Type
9784 and then Needs_Result_Accessibility_Level
(E
)
9785 and then No
(Extra_Accessibility_Of_Result
(E
))
9790 -- Check attribute Extra_Formals: If E has extra formals, then this
9791 -- attribute must point to the first extra formal of E.
9793 if Has_Extra_Formals
then
9794 return Present
(Extra_Formals
(E
))
9795 and then Present
(Extra_Formal
(Last_Formal
))
9796 and then Extra_Formal
(Last_Formal
) = Extra_Formals
(E
);
9798 -- When E has no formals, the first extra formal is available through
9799 -- the Extra_Formals attribute.
9801 elsif Present
(Extra_Formals
(E
)) then
9802 return No
(First_Formal
(E
));
9807 end Extra_Formals_OK
;
9809 -----------------------------
9810 -- Find_Corresponding_Spec --
9811 -----------------------------
9813 function Find_Corresponding_Spec
9815 Post_Error
: Boolean := True) return Entity_Id
9817 Spec
: constant Node_Id
:= Specification
(N
);
9818 Designator
: constant Entity_Id
:= Defining_Entity
(Spec
);
9822 function Different_Generic_Profile
(E
: Entity_Id
) return Boolean;
9823 -- Even if fully conformant, a body may depend on a generic actual when
9824 -- the spec does not, or vice versa, in which case they were distinct
9825 -- entities in the generic.
9827 -------------------------------
9828 -- Different_Generic_Profile --
9829 -------------------------------
9831 function Different_Generic_Profile
(E
: Entity_Id
) return Boolean is
9834 function Same_Generic_Actual
(T1
, T2
: Entity_Id
) return Boolean;
9835 -- Check that the types of corresponding formals have the same
9836 -- generic actual if any. We have to account for subtypes of a
9837 -- generic formal, declared between a spec and a body, which may
9838 -- appear distinct in an instance but matched in the generic, and
9839 -- the subtype may be used either in the spec or the body of the
9840 -- subprogram being checked.
9842 -------------------------
9843 -- Same_Generic_Actual --
9844 -------------------------
9846 function Same_Generic_Actual
(T1
, T2
: Entity_Id
) return Boolean is
9848 function Is_Declared_Subtype
(S1
, S2
: Entity_Id
) return Boolean;
9849 -- Predicate to check whether S1 is a subtype of S2 in the source
9852 -------------------------
9853 -- Is_Declared_Subtype --
9854 -------------------------
9856 function Is_Declared_Subtype
(S1
, S2
: Entity_Id
) return Boolean is
9858 return Comes_From_Source
(Parent
(S1
))
9859 and then Nkind
(Parent
(S1
)) = N_Subtype_Declaration
9860 and then Is_Entity_Name
(Subtype_Indication
(Parent
(S1
)))
9861 and then Entity
(Subtype_Indication
(Parent
(S1
))) = S2
;
9862 end Is_Declared_Subtype
;
9864 -- Start of processing for Same_Generic_Actual
9867 return Is_Generic_Actual_Type
(T1
) = Is_Generic_Actual_Type
(T2
)
9868 or else Is_Declared_Subtype
(T1
, T2
)
9869 or else Is_Declared_Subtype
(T2
, T1
);
9870 end Same_Generic_Actual
;
9872 -- Start of processing for Different_Generic_Profile
9875 if not In_Instance
then
9878 elsif Ekind
(E
) = E_Function
9879 and then not Same_Generic_Actual
(Etype
(E
), Etype
(Designator
))
9884 F1
:= First_Formal
(Designator
);
9885 F2
:= First_Formal
(E
);
9886 while Present
(F1
) loop
9887 if not Same_Generic_Actual
(Etype
(F1
), Etype
(F2
)) then
9896 end Different_Generic_Profile
;
9898 -- Start of processing for Find_Corresponding_Spec
9901 E
:= Current_Entity
(Designator
);
9902 while Present
(E
) loop
9904 -- We are looking for a matching spec. It must have the same scope,
9905 -- and the same name, and either be type conformant, or be the case
9906 -- of a library procedure spec and its body (which belong to one
9907 -- another regardless of whether they are type conformant or not).
9909 if Scope
(E
) = Current_Scope
then
9910 if Current_Scope
= Standard_Standard
9911 or else (Ekind
(E
) = Ekind
(Designator
)
9912 and then Type_Conformant
(E
, Designator
))
9914 -- Within an instantiation, we know that spec and body are
9915 -- subtype conformant, because they were subtype conformant in
9916 -- the generic. We choose the subtype-conformant entity here as
9917 -- well, to resolve spurious ambiguities in the instance that
9918 -- were not present in the generic (i.e. when two different
9919 -- types are given the same actual). If we are looking for a
9920 -- spec to match a body, full conformance is expected.
9924 -- Inherit the convention and "ghostness" of the matching
9925 -- spec to ensure proper full and subtype conformance.
9927 Set_Convention
(Designator
, Convention
(E
));
9929 -- Skip past subprogram bodies and subprogram renamings that
9930 -- may appear to have a matching spec, but that aren't fully
9931 -- conformant with it. That can occur in cases where an
9932 -- actual type causes unrelated homographs in the instance.
9934 if Nkind
(N
) in N_Subprogram_Body
9935 | N_Subprogram_Renaming_Declaration
9936 and then Present
(Homonym
(E
))
9937 and then not Fully_Conformant
(Designator
, E
)
9941 elsif not Subtype_Conformant
(Designator
, E
) then
9944 elsif Different_Generic_Profile
(E
) then
9949 -- Ada 2012 (AI05-0165): For internally generated bodies of
9950 -- null procedures locate the internally generated spec. We
9951 -- enforce mode conformance since a tagged type may inherit
9952 -- from interfaces several null primitives which differ only
9953 -- in the mode of the formals.
9955 if not (Comes_From_Source
(E
))
9956 and then Is_Null_Procedure
(E
)
9957 and then not Mode_Conformant
(Designator
, E
)
9961 -- For null procedures coming from source that are completions,
9962 -- analysis of the generated body will establish the link.
9964 elsif Comes_From_Source
(E
)
9965 and then Nkind
(Spec
) = N_Procedure_Specification
9966 and then Null_Present
(Spec
)
9970 -- Expression functions can be completions, but cannot be
9971 -- completed by an explicit body.
9973 elsif Comes_From_Source
(E
)
9974 and then Comes_From_Source
(N
)
9975 and then Nkind
(N
) = N_Subprogram_Body
9976 and then Nkind
(Original_Node
(Unit_Declaration_Node
(E
))) =
9977 N_Expression_Function
9979 Error_Msg_Sloc
:= Sloc
(E
);
9980 Error_Msg_N
("body conflicts with expression function#", N
);
9983 elsif not Has_Completion
(E
) then
9984 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
9985 Set_Corresponding_Spec
(N
, E
);
9988 Set_Has_Completion
(E
);
9991 elsif Nkind
(Parent
(N
)) = N_Subunit
then
9993 -- If this is the proper body of a subunit, the completion
9994 -- flag is set when analyzing the stub.
9998 -- If E is an internal function with a controlling result that
9999 -- was created for an operation inherited by a null extension,
10000 -- it may be overridden by a body without a previous spec (one
10001 -- more reason why these should be shunned). In that case we
10002 -- remove the generated body if present, because the current
10003 -- one is the explicit overriding.
10005 elsif Ekind
(E
) = E_Function
10006 and then Ada_Version
>= Ada_2005
10007 and then not Comes_From_Source
(E
)
10008 and then Has_Controlling_Result
(E
)
10009 and then (not Is_Class_Wide_Type
(Etype
(E
))
10010 and then Is_Null_Extension
(Etype
(E
)))
10011 and then Comes_From_Source
(Spec
)
10013 Set_Has_Completion
(E
, False);
10016 and then Nkind
(Parent
(E
)) = N_Function_Specification
10019 (Unit_Declaration_Node
10020 (Corresponding_Body
(Unit_Declaration_Node
(E
))));
10024 -- If expansion is disabled, or if the wrapper function has
10025 -- not been generated yet, this a late body overriding an
10026 -- inherited operation, or it is an overriding by some other
10027 -- declaration before the controlling result is frozen. In
10028 -- either case this is a declaration of a new entity.
10034 -- If the body already exists, then this is an error unless
10035 -- the previous declaration is the implicit declaration of a
10036 -- derived subprogram. It is also legal for an instance to
10037 -- contain type conformant overloadable declarations (but the
10038 -- generic declaration may not), per 8.3(26/2).
10040 elsif No
(Alias
(E
))
10041 and then not Is_Intrinsic_Subprogram
(E
)
10042 and then not In_Instance
10043 and then Post_Error
10045 Error_Msg_Sloc
:= Sloc
(E
);
10047 if Is_Imported
(E
) then
10049 ("body not allowed for imported subprogram & declared#",
10052 Error_Msg_NE
("duplicate body for & declared#", N
, E
);
10056 -- Child units cannot be overloaded, so a conformance mismatch
10057 -- between body and a previous spec is an error.
10059 elsif Is_Child_Unit
(E
)
10061 Nkind
(Unit_Declaration_Node
(Designator
)) = N_Subprogram_Body
10063 Nkind
(Parent
(Unit_Declaration_Node
(Designator
))) =
10065 and then Post_Error
10068 ("body of child unit does not match previous declaration", N
);
10076 -- On exit, we know that no previous declaration of subprogram exists
10079 end Find_Corresponding_Spec
;
10081 ----------------------
10082 -- Fully_Conformant --
10083 ----------------------
10085 function Fully_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
10088 Check_Conformance
(New_Id
, Old_Id
, Fully_Conformant
, False, Result
);
10090 end Fully_Conformant
;
10092 ----------------------------------
10093 -- Fully_Conformant_Expressions --
10094 ----------------------------------
10096 function Fully_Conformant_Expressions
10097 (Given_E1
: Node_Id
;
10098 Given_E2
: Node_Id
;
10099 Report
: Boolean := False) return Boolean
10101 E1
: constant Node_Id
:= Original_Node
(Given_E1
);
10102 E2
: constant Node_Id
:= Original_Node
(Given_E2
);
10103 -- We always test conformance on original nodes, since it is possible
10104 -- for analysis and/or expansion to make things look as though they
10105 -- conform when they do not, e.g. by converting 1+2 into 3.
10107 function FCE
(Given_E1
: Node_Id
; Given_E2
: Node_Id
) return Boolean;
10108 -- Convenience function to abbreviate recursive calls to
10109 -- Fully_Conformant_Expressions without having to pass Report.
10111 function FCL
(L1
: List_Id
; L2
: List_Id
) return Boolean;
10112 -- Compare elements of two lists for conformance. Elements have to be
10113 -- conformant, and actuals inserted as default parameters do not match
10114 -- explicit actuals with the same value.
10116 function FCO
(Op_Node
: Node_Id
; Call_Node
: Node_Id
) return Boolean;
10117 -- Compare an operator node with a function call
10123 function FCE
(Given_E1
: Node_Id
; Given_E2
: Node_Id
) return Boolean is
10125 return Fully_Conformant_Expressions
(Given_E1
, Given_E2
, Report
);
10132 function FCL
(L1
: List_Id
; L2
: List_Id
) return Boolean is
10140 -- Compare two lists, skipping rewrite insertions (we want to compare
10141 -- the original trees, not the expanded versions).
10144 if Is_Rewrite_Insertion
(N1
) then
10146 elsif Is_Rewrite_Insertion
(N2
) then
10152 elsif not FCE
(N1
, N2
) then
10165 function FCO
(Op_Node
: Node_Id
; Call_Node
: Node_Id
) return Boolean is
10166 Actuals
: constant List_Id
:= Parameter_Associations
(Call_Node
);
10171 or else Entity
(Op_Node
) /= Entity
(Name
(Call_Node
))
10176 Act
:= First
(Actuals
);
10178 if Nkind
(Op_Node
) in N_Binary_Op
then
10179 if not FCE
(Left_Opnd
(Op_Node
), Act
) then
10186 return Present
(Act
)
10187 and then FCE
(Right_Opnd
(Op_Node
), Act
)
10188 and then No
(Next
(Act
));
10192 function User_Defined_Numeric_Literal_Mismatch
return Boolean;
10193 -- Usually literals with the same value like 12345 and 12_345
10194 -- or 123.0 and 123.00 conform, but not if they are
10195 -- user-defined literals.
10197 -------------------------------------------
10198 -- User_Defined_Numeric_Literal_Mismatch --
10199 -------------------------------------------
10201 function User_Defined_Numeric_Literal_Mismatch
return Boolean is
10202 E1_Is_User_Defined
: constant Boolean :=
10203 Nkind
(Given_E1
) not in N_Integer_Literal | N_Real_Literal
;
10204 E2_Is_User_Defined
: constant Boolean :=
10205 Nkind
(Given_E2
) not in N_Integer_Literal | N_Real_Literal
;
10208 pragma Assert
(E1_Is_User_Defined
= E2_Is_User_Defined
);
10210 return E1_Is_User_Defined
and then
10211 not String_Equal
(String_From_Numeric_Literal
(E1
),
10212 String_From_Numeric_Literal
(E2
));
10213 end User_Defined_Numeric_Literal_Mismatch
;
10219 -- Start of processing for Fully_Conformant_Expressions
10224 -- Nonconformant if paren count does not match. Note: if some idiot
10225 -- complains that we don't do this right for more than 3 levels of
10226 -- parentheses, they will be treated with the respect they deserve.
10228 if Paren_Count
(E1
) /= Paren_Count
(E2
) then
10231 -- If same entities are referenced, then they are conformant even if
10232 -- they have different forms (RM 8.3.1(19-20)).
10234 elsif Is_Entity_Name
(E1
) and then Is_Entity_Name
(E2
) then
10235 if Present
(Entity
(E1
)) then
10236 Result
:= Entity
(E1
) = Entity
(E2
)
10238 -- One may be a discriminant that has been replaced by the
10239 -- corresponding discriminal.
10242 (Chars
(Entity
(E1
)) = Chars
(Entity
(E2
))
10243 and then Ekind
(Entity
(E1
)) = E_Discriminant
10244 and then Ekind
(Entity
(E2
)) = E_In_Parameter
)
10246 -- The discriminant of a protected type is transformed into
10247 -- a local constant and then into a parameter of a protected
10251 (Ekind
(Entity
(E1
)) = E_Constant
10252 and then Ekind
(Entity
(E2
)) = E_In_Parameter
10253 and then Present
(Discriminal_Link
(Entity
(E1
)))
10254 and then Discriminal_Link
(Entity
(E1
)) =
10255 Discriminal_Link
(Entity
(E2
)))
10257 -- AI12-050: The entities of quantified expressions match if they
10258 -- have the same identifier, even if they may be distinct nodes.
10261 (Chars
(Entity
(E1
)) = Chars
(Entity
(E2
))
10262 and then Is_Entity_Of_Quantified_Expression
(Entity
(E1
))
10263 and then Is_Entity_Of_Quantified_Expression
(Entity
(E2
)))
10265 -- A call to an instantiation of Unchecked_Conversion is
10266 -- rewritten with the name of the generated function created for
10267 -- the instance, and this must be special-cased.
10270 (Ekind
(Entity
(E1
)) = E_Function
10271 and then Is_Intrinsic_Subprogram
(Entity
(E1
))
10272 and then Is_Generic_Instance
(Entity
(E1
))
10273 and then Entity
(E2
) = Alias
(Entity
(E1
)));
10274 if Report
and not Result
then
10276 Text_Ptr
'Max (Sloc
(Entity
(E1
)), Sloc
(Entity
(E2
)));
10278 ("meaning of& differs because of declaration#", E1
, E2
);
10283 elsif Nkind
(E1
) = N_Expanded_Name
10284 and then Nkind
(E2
) = N_Expanded_Name
10285 and then Nkind
(Selector_Name
(E1
)) = N_Character_Literal
10286 and then Nkind
(Selector_Name
(E2
)) = N_Character_Literal
10288 return Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
));
10291 -- Identifiers in component associations don't always have
10292 -- entities, but their names must conform.
10294 return Nkind
(E1
) = N_Identifier
10295 and then Nkind
(E2
) = N_Identifier
10296 and then Chars
(E1
) = Chars
(E2
);
10299 elsif Nkind
(E1
) = N_Character_Literal
10300 and then Nkind
(E2
) = N_Expanded_Name
10302 return Nkind
(Selector_Name
(E2
)) = N_Character_Literal
10303 and then Chars
(E1
) = Chars
(Selector_Name
(E2
));
10305 elsif Nkind
(E2
) = N_Character_Literal
10306 and then Nkind
(E1
) = N_Expanded_Name
10308 return Nkind
(Selector_Name
(E1
)) = N_Character_Literal
10309 and then Chars
(E2
) = Chars
(Selector_Name
(E1
));
10311 elsif Nkind
(E1
) in N_Op
and then Nkind
(E2
) = N_Function_Call
then
10312 return FCO
(E1
, E2
);
10314 elsif Nkind
(E2
) in N_Op
and then Nkind
(E1
) = N_Function_Call
then
10315 return FCO
(E2
, E1
);
10317 -- Otherwise we must have the same syntactic entity
10319 elsif Nkind
(E1
) /= Nkind
(E2
) then
10322 -- At this point, we specialize by node type
10326 when N_Aggregate
=>
10328 FCL
(Expressions
(E1
), Expressions
(E2
))
10330 FCL
(Component_Associations
(E1
),
10331 Component_Associations
(E2
));
10333 when N_Allocator
=>
10334 if Nkind
(Expression
(E1
)) = N_Qualified_Expression
10336 Nkind
(Expression
(E2
)) = N_Qualified_Expression
10338 return FCE
(Expression
(E1
), Expression
(E2
));
10340 -- Check that the subtype marks and any constraints
10345 Indic1
: constant Node_Id
:= Expression
(E1
);
10346 Indic2
: constant Node_Id
:= Expression
(E2
);
10351 if Nkind
(Indic1
) /= N_Subtype_Indication
then
10353 Nkind
(Indic2
) /= N_Subtype_Indication
10354 and then Entity
(Indic1
) = Entity
(Indic2
);
10356 elsif Nkind
(Indic2
) /= N_Subtype_Indication
then
10358 Nkind
(Indic1
) /= N_Subtype_Indication
10359 and then Entity
(Indic1
) = Entity
(Indic2
);
10362 if Entity
(Subtype_Mark
(Indic1
)) /=
10363 Entity
(Subtype_Mark
(Indic2
))
10368 Elt1
:= First
(Constraints
(Constraint
(Indic1
)));
10369 Elt2
:= First
(Constraints
(Constraint
(Indic2
)));
10370 while Present
(Elt1
) and then Present
(Elt2
) loop
10371 if not FCE
(Elt1
, Elt2
) then
10384 when N_Attribute_Reference
=>
10386 Attribute_Name
(E1
) = Attribute_Name
(E2
)
10387 and then FCL
(Expressions
(E1
), Expressions
(E2
));
10389 when N_Binary_Op
=>
10391 Entity
(E1
) = Entity
(E2
)
10392 and then FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
10393 and then FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
10395 when N_Membership_Test
10399 FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
10401 FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
10403 when N_Case_Expression
=>
10409 if not FCE
(Expression
(E1
), Expression
(E2
)) then
10413 Alt1
:= First
(Alternatives
(E1
));
10414 Alt2
:= First
(Alternatives
(E2
));
10416 if Present
(Alt1
) /= Present
(Alt2
) then
10418 elsif No
(Alt1
) then
10422 if not FCE
(Expression
(Alt1
), Expression
(Alt2
))
10423 or else not FCL
(Discrete_Choices
(Alt1
),
10424 Discrete_Choices
(Alt2
))
10435 when N_Character_Literal
=>
10437 Char_Literal_Value
(E1
) = Char_Literal_Value
(E2
);
10439 when N_Component_Association
=>
10441 FCL
(Choices
(E1
), Choices
(E2
))
10443 FCE
(Expression
(E1
), Expression
(E2
));
10445 when N_Explicit_Dereference
=>
10447 FCE
(Prefix
(E1
), Prefix
(E2
));
10449 when N_Extension_Aggregate
=>
10451 FCL
(Expressions
(E1
), Expressions
(E2
))
10452 and then Null_Record_Present
(E1
) =
10453 Null_Record_Present
(E2
)
10454 and then FCL
(Component_Associations
(E1
),
10455 Component_Associations
(E2
));
10457 when N_Function_Call
=>
10459 FCE
(Name
(E1
), Name
(E2
))
10461 FCL
(Parameter_Associations
(E1
),
10462 Parameter_Associations
(E2
));
10464 when N_If_Expression
=>
10466 FCL
(Expressions
(E1
), Expressions
(E2
));
10468 when N_Indexed_Component
=>
10470 FCE
(Prefix
(E1
), Prefix
(E2
))
10472 FCL
(Expressions
(E1
), Expressions
(E2
));
10474 when N_Integer_Literal
=>
10475 return Intval
(E1
) = Intval
(E2
)
10476 and then not User_Defined_Numeric_Literal_Mismatch
;
10481 when N_Operator_Symbol
=>
10483 Chars
(E1
) = Chars
(E2
);
10485 when N_Others_Choice
=>
10488 when N_Parameter_Association
=>
10490 Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
))
10491 and then FCE
(Explicit_Actual_Parameter
(E1
),
10492 Explicit_Actual_Parameter
(E2
));
10494 when N_Qualified_Expression
10495 | N_Type_Conversion
10496 | N_Unchecked_Type_Conversion
10499 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
10501 FCE
(Expression
(E1
), Expression
(E2
));
10503 when N_Quantified_Expression
=>
10504 if not FCE
(Condition
(E1
), Condition
(E2
)) then
10508 if Present
(Loop_Parameter_Specification
(E1
))
10509 and then Present
(Loop_Parameter_Specification
(E2
))
10512 L1
: constant Node_Id
:=
10513 Loop_Parameter_Specification
(E1
);
10514 L2
: constant Node_Id
:=
10515 Loop_Parameter_Specification
(E2
);
10519 Reverse_Present
(L1
) = Reverse_Present
(L2
)
10521 FCE
(Defining_Identifier
(L1
),
10522 Defining_Identifier
(L2
))
10524 FCE
(Discrete_Subtype_Definition
(L1
),
10525 Discrete_Subtype_Definition
(L2
));
10528 elsif Present
(Iterator_Specification
(E1
))
10529 and then Present
(Iterator_Specification
(E2
))
10532 I1
: constant Node_Id
:= Iterator_Specification
(E1
);
10533 I2
: constant Node_Id
:= Iterator_Specification
(E2
);
10537 FCE
(Defining_Identifier
(I1
),
10538 Defining_Identifier
(I2
))
10540 Of_Present
(I1
) = Of_Present
(I2
)
10542 Reverse_Present
(I1
) = Reverse_Present
(I2
)
10543 and then FCE
(Name
(I1
), Name
(I2
))
10544 and then FCE
(Subtype_Indication
(I1
),
10545 Subtype_Indication
(I2
));
10548 -- The quantified expressions used different specifications to
10549 -- walk their respective ranges.
10557 FCE
(Low_Bound
(E1
), Low_Bound
(E2
))
10559 FCE
(High_Bound
(E1
), High_Bound
(E2
));
10561 when N_Real_Literal
=>
10562 return Realval
(E1
) = Realval
(E2
)
10563 and then not User_Defined_Numeric_Literal_Mismatch
;
10565 when N_Selected_Component
=>
10567 FCE
(Prefix
(E1
), Prefix
(E2
))
10569 FCE
(Selector_Name
(E1
), Selector_Name
(E2
));
10573 FCE
(Prefix
(E1
), Prefix
(E2
))
10575 FCE
(Discrete_Range
(E1
), Discrete_Range
(E2
));
10577 when N_String_Literal
=>
10579 S1
: constant String_Id
:= Strval
(E1
);
10580 S2
: constant String_Id
:= Strval
(E2
);
10581 L1
: constant Nat
:= String_Length
(S1
);
10582 L2
: constant Nat
:= String_Length
(S2
);
10589 for J
in 1 .. L1
loop
10590 if Get_String_Char
(S1
, J
) /=
10591 Get_String_Char
(S2
, J
)
10603 Entity
(E1
) = Entity
(E2
)
10605 FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
10607 -- All other node types cannot appear in this context. Strictly
10608 -- we should raise a fatal internal error. Instead we just ignore
10609 -- the nodes. This means that if anyone makes a mistake in the
10610 -- expander and mucks an expression tree irretrievably, the result
10611 -- will be a failure to detect a (probably very obscure) case
10612 -- of non-conformance, which is better than bombing on some
10613 -- case where two expressions do in fact conform.
10619 end Fully_Conformant_Expressions
;
10621 ----------------------------------------
10622 -- Fully_Conformant_Discrete_Subtypes --
10623 ----------------------------------------
10625 function Fully_Conformant_Discrete_Subtypes
10626 (Given_S1
: Node_Id
;
10627 Given_S2
: Node_Id
) return Boolean
10629 S1
: constant Node_Id
:= Original_Node
(Given_S1
);
10630 S2
: constant Node_Id
:= Original_Node
(Given_S2
);
10632 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean;
10633 -- Special-case for a bound given by a discriminant, which in the body
10634 -- is replaced with the discriminal of the enclosing type.
10636 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean;
10637 -- Check both bounds
10639 -----------------------
10640 -- Conforming_Bounds --
10641 -----------------------
10643 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean is
10645 if Is_Entity_Name
(B1
)
10646 and then Is_Entity_Name
(B2
)
10647 and then Ekind
(Entity
(B1
)) = E_Discriminant
10649 return Chars
(B1
) = Chars
(B2
);
10652 return Fully_Conformant_Expressions
(B1
, B2
);
10654 end Conforming_Bounds
;
10656 -----------------------
10657 -- Conforming_Ranges --
10658 -----------------------
10660 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean is
10663 Conforming_Bounds
(Low_Bound
(R1
), Low_Bound
(R2
))
10665 Conforming_Bounds
(High_Bound
(R1
), High_Bound
(R2
));
10666 end Conforming_Ranges
;
10668 -- Start of processing for Fully_Conformant_Discrete_Subtypes
10671 if Nkind
(S1
) /= Nkind
(S2
) then
10674 elsif Is_Entity_Name
(S1
) then
10675 return Entity
(S1
) = Entity
(S2
);
10677 elsif Nkind
(S1
) = N_Range
then
10678 return Conforming_Ranges
(S1
, S2
);
10680 elsif Nkind
(S1
) = N_Subtype_Indication
then
10682 Entity
(Subtype_Mark
(S1
)) = Entity
(Subtype_Mark
(S2
))
10685 (Range_Expression
(Constraint
(S1
)),
10686 Range_Expression
(Constraint
(S2
)));
10690 end Fully_Conformant_Discrete_Subtypes
;
10692 ---------------------
10693 -- Has_BIP_Formals --
10694 ---------------------
10696 function Has_BIP_Formals
(E
: Entity_Id
) return Boolean is
10697 Formal
: Entity_Id
:= First_Formal_With_Extras
(E
);
10700 while Present
(Formal
) loop
10701 if Is_Build_In_Place_Entity
(Formal
) then
10705 Next_Formal_With_Extras
(Formal
);
10709 end Has_BIP_Formals
;
10711 --------------------------------
10712 -- Has_Reliable_Extra_Formals --
10713 --------------------------------
10715 function Has_Reliable_Extra_Formals
(E
: Entity_Id
) return Boolean is
10716 Alias_E
: Entity_Id
;
10719 -- Extra formals are not added if expansion is not active (and hence if
10720 -- available they are not reliable for extra formals check).
10722 if not Expander_Active
then
10725 -- Currently the unique cases where extra formals are not reliable
10726 -- are associated with predefined dispatching operations; otherwise
10727 -- they are properly added when required.
10729 elsif not Is_Predefined_Dispatching_Operation
(E
) then
10733 Alias_E
:= Ultimate_Alias
(E
);
10735 -- Abstract predefined primitives of Root_Controlled don't have
10736 -- extra formals; this is required to build the runtime.
10738 if Ekind
(Alias_E
) = E_Function
10739 and then Is_Abstract_Subprogram
(Alias_E
)
10740 and then Is_RTE
(Underlying_Type
(Etype
(Alias_E
)),
10741 RE_Root_Controlled
)
10745 -- Predefined stream dispatching operations that are not emitted by
10746 -- the frontend; they have a renaming of the corresponding primitive
10747 -- of their parent type and hence they don't have extra formals.
10751 TSS_Name
: constant TSS_Name_Type
:= Get_TSS_Name
(E
);
10752 Typ
: constant Entity_Id
:=
10753 Underlying_Type
(Find_Dispatching_Type
(Alias_E
));
10756 if TSS_Name
in TSS_Stream_Input
10757 | TSS_Stream_Output
10760 and then not Stream_Operation_OK
(Typ
, TSS_Name
)
10768 end Has_Reliable_Extra_Formals
;
10770 --------------------
10771 -- Install_Entity --
10772 --------------------
10774 procedure Install_Entity
(E
: Entity_Id
) is
10775 Prev
: constant Entity_Id
:= Current_Entity
(E
);
10777 Set_Is_Immediately_Visible
(E
);
10778 Set_Current_Entity
(E
);
10779 pragma Assert
(Prev
/= E
);
10780 Set_Homonym
(E
, Prev
);
10781 end Install_Entity
;
10783 ---------------------
10784 -- Install_Formals --
10785 ---------------------
10787 procedure Install_Formals
(Id
: Entity_Id
) is
10790 F
:= First_Formal
(Id
);
10791 while Present
(F
) loop
10792 Install_Entity
(F
);
10795 end Install_Formals
;
10797 -----------------------------
10798 -- Is_Interface_Conformant --
10799 -----------------------------
10801 function Is_Interface_Conformant
10802 (Tagged_Type
: Entity_Id
;
10803 Iface_Prim
: Entity_Id
;
10804 Prim
: Entity_Id
) return Boolean
10806 -- The operation may in fact be an inherited (implicit) operation
10807 -- rather than the original interface primitive, so retrieve the
10808 -- ultimate ancestor.
10810 Iface
: constant Entity_Id
:=
10811 Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
));
10812 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
10814 function Controlling_Formal
(Prim
: Entity_Id
) return Entity_Id
;
10815 -- Return the controlling formal of Prim
10817 ------------------------
10818 -- Controlling_Formal --
10819 ------------------------
10821 function Controlling_Formal
(Prim
: Entity_Id
) return Entity_Id
is
10825 E
:= First_Formal
(Prim
);
10826 while Present
(E
) loop
10827 if Is_Controlling_Formal
(E
) then
10835 end Controlling_Formal
;
10839 Iface_Ctrl_F
: constant Entity_Id
:= Controlling_Formal
(Iface_Prim
);
10840 Prim_Ctrl_F
: constant Entity_Id
:= Controlling_Formal
(Prim
);
10842 -- Start of processing for Is_Interface_Conformant
10845 pragma Assert
(Is_Subprogram
(Iface_Prim
)
10846 and then Is_Subprogram
(Prim
)
10847 and then Is_Dispatching_Operation
(Iface_Prim
)
10848 and then Is_Dispatching_Operation
(Prim
));
10850 pragma Assert
(Is_Interface
(Iface
)
10851 or else (Present
(Alias
(Iface_Prim
))
10854 (Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
)))));
10856 if Prim
= Iface_Prim
10857 or else not Is_Subprogram
(Prim
)
10858 or else Ekind
(Prim
) /= Ekind
(Iface_Prim
)
10859 or else not Is_Dispatching_Operation
(Prim
)
10860 or else Scope
(Prim
) /= Scope
(Tagged_Type
)
10862 or else Base_Type
(Typ
) /= Base_Type
(Tagged_Type
)
10863 or else not Primitive_Names_Match
(Iface_Prim
, Prim
)
10867 -- The mode of the controlling formals must match
10869 elsif Present
(Iface_Ctrl_F
)
10870 and then Present
(Prim_Ctrl_F
)
10871 and then Ekind
(Iface_Ctrl_F
) /= Ekind
(Prim_Ctrl_F
)
10875 -- Case of a procedure, or a function whose result type matches the
10876 -- result type of the interface primitive, or a function that has no
10877 -- controlling result (I or access I).
10879 elsif Ekind
(Iface_Prim
) = E_Procedure
10880 or else Etype
(Prim
) = Etype
(Iface_Prim
)
10881 or else not Has_Controlling_Result
(Prim
)
10883 return Type_Conformant
10884 (Iface_Prim
, Prim
, Skip_Controlling_Formals
=> True);
10886 -- Case of a function returning an interface, or an access to one. Check
10887 -- that the return types correspond.
10889 elsif Implements_Interface
(Typ
, Iface
) then
10890 if (Ekind
(Etype
(Prim
)) = E_Anonymous_Access_Type
)
10892 (Ekind
(Etype
(Iface_Prim
)) = E_Anonymous_Access_Type
)
10897 Type_Conformant
(Prim
, Ultimate_Alias
(Iface_Prim
),
10898 Skip_Controlling_Formals
=> True);
10904 end Is_Interface_Conformant
;
10906 ---------------------------------
10907 -- Is_Non_Overriding_Operation --
10908 ---------------------------------
10910 function Is_Non_Overriding_Operation
10911 (Prev_E
: Entity_Id
;
10912 New_E
: Entity_Id
) return Boolean
10914 Formal
: Entity_Id
;
10916 G_Typ
: Entity_Id
:= Empty
;
10918 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
;
10919 -- If F_Type is a derived type associated with a generic actual subtype,
10920 -- then return its Generic_Parent_Type attribute, else return Empty.
10922 function Types_Correspond
10923 (P_Type
: Entity_Id
;
10924 N_Type
: Entity_Id
) return Boolean;
10925 -- Returns true if and only if the types (or designated types in the
10926 -- case of anonymous access types) are the same or N_Type is derived
10927 -- directly or indirectly from P_Type.
10929 -----------------------------
10930 -- Get_Generic_Parent_Type --
10931 -----------------------------
10933 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
is
10939 if Is_Derived_Type
(F_Typ
)
10940 and then Nkind
(Parent
(F_Typ
)) = N_Full_Type_Declaration
10942 -- The tree must be traversed to determine the parent subtype in
10943 -- the generic unit, which unfortunately isn't always available
10944 -- via semantic attributes. ??? (Note: The use of Original_Node
10945 -- is needed for cases where a full derived type has been
10948 -- If the parent type is a scalar type, the derivation creates
10949 -- an anonymous base type for it, and the source type is its
10952 if Is_Scalar_Type
(F_Typ
)
10953 and then not Comes_From_Source
(F_Typ
)
10957 (Original_Node
(Parent
(First_Subtype
(F_Typ
))));
10959 Defn
:= Type_Definition
(Original_Node
(Parent
(F_Typ
)));
10961 if Nkind
(Defn
) = N_Derived_Type_Definition
then
10962 Indic
:= Subtype_Indication
(Defn
);
10964 if Nkind
(Indic
) = N_Subtype_Indication
then
10965 G_Typ
:= Entity
(Subtype_Mark
(Indic
));
10967 G_Typ
:= Entity
(Indic
);
10970 if Nkind
(Parent
(G_Typ
)) = N_Subtype_Declaration
10971 and then Present
(Generic_Parent_Type
(Parent
(G_Typ
)))
10973 return Generic_Parent_Type
(Parent
(G_Typ
));
10979 end Get_Generic_Parent_Type
;
10981 ----------------------
10982 -- Types_Correspond --
10983 ----------------------
10985 function Types_Correspond
10986 (P_Type
: Entity_Id
;
10987 N_Type
: Entity_Id
) return Boolean
10989 Prev_Type
: Entity_Id
:= Base_Type
(P_Type
);
10990 New_Type
: Entity_Id
:= Base_Type
(N_Type
);
10993 if Ekind
(Prev_Type
) = E_Anonymous_Access_Type
then
10994 Prev_Type
:= Designated_Type
(Prev_Type
);
10997 if Ekind
(New_Type
) = E_Anonymous_Access_Type
then
10998 New_Type
:= Designated_Type
(New_Type
);
11001 if Prev_Type
= New_Type
then
11004 elsif not Is_Class_Wide_Type
(New_Type
) then
11005 while Etype
(New_Type
) /= New_Type
loop
11006 New_Type
:= Etype
(New_Type
);
11008 if New_Type
= Prev_Type
then
11014 end Types_Correspond
;
11016 -- Start of processing for Is_Non_Overriding_Operation
11019 -- In the case where both operations are implicit derived subprograms
11020 -- then neither overrides the other. This can only occur in certain
11021 -- obscure cases (e.g., derivation from homographs created in a generic
11024 if Present
(Alias
(Prev_E
)) and then Present
(Alias
(New_E
)) then
11027 elsif Ekind
(Current_Scope
) = E_Package
11028 and then Is_Generic_Instance
(Current_Scope
)
11029 and then In_Private_Part
(Current_Scope
)
11030 and then Comes_From_Source
(New_E
)
11032 -- We examine the formals and result type of the inherited operation,
11033 -- to determine whether their type is derived from (the instance of)
11034 -- a generic type. The first such formal or result type is the one
11037 Formal
:= First_Formal
(Prev_E
);
11039 while Present
(Formal
) loop
11040 F_Typ
:= Base_Type
(Etype
(Formal
));
11042 if Ekind
(F_Typ
) = E_Anonymous_Access_Type
then
11043 F_Typ
:= Designated_Type
(F_Typ
);
11046 G_Typ
:= Get_Generic_Parent_Type
(F_Typ
);
11047 exit when Present
(G_Typ
);
11049 Next_Formal
(Formal
);
11052 -- If the function dispatches on result check the result type
11054 if No
(G_Typ
) and then Ekind
(Prev_E
) = E_Function
then
11055 G_Typ
:= Get_Generic_Parent_Type
(Base_Type
(Etype
(Prev_E
)));
11062 -- If the generic type is a private type, then the original operation
11063 -- was not overriding in the generic, because there was no primitive
11064 -- operation to override.
11066 if Nkind
(Parent
(G_Typ
)) = N_Formal_Type_Declaration
11067 and then Nkind
(Formal_Type_Definition
(Parent
(G_Typ
))) =
11068 N_Formal_Private_Type_Definition
11072 -- The generic parent type is the ancestor of a formal derived
11073 -- type declaration. We need to check whether it has a primitive
11074 -- operation that should be overridden by New_E in the generic.
11078 P_Formal
: Entity_Id
;
11079 N_Formal
: Entity_Id
;
11082 P_Prim
: Entity_Id
;
11083 Prim_Elt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(G_Typ
));
11086 while Present
(Prim_Elt
) loop
11087 P_Prim
:= Node
(Prim_Elt
);
11089 if Chars
(P_Prim
) = Chars
(New_E
)
11090 and then Ekind
(P_Prim
) = Ekind
(New_E
)
11092 P_Formal
:= First_Formal
(P_Prim
);
11093 N_Formal
:= First_Formal
(New_E
);
11094 while Present
(P_Formal
) and then Present
(N_Formal
) loop
11095 P_Typ
:= Etype
(P_Formal
);
11096 N_Typ
:= Etype
(N_Formal
);
11098 if not Types_Correspond
(P_Typ
, N_Typ
) then
11102 Next_Formal
(P_Formal
);
11103 Next_Formal
(N_Formal
);
11106 -- Found a matching primitive operation belonging to the
11107 -- formal ancestor type, so the new subprogram is
11111 and then No
(N_Formal
)
11112 and then (Ekind
(New_E
) /= E_Function
11115 (Etype
(P_Prim
), Etype
(New_E
)))
11121 Next_Elmt
(Prim_Elt
);
11124 -- If no match found, then the new subprogram does not override
11125 -- in the generic (nor in the instance).
11127 -- If the type in question is not abstract, and the subprogram
11128 -- is, this will be an error if the new operation is in the
11129 -- private part of the instance. Emit a warning now, which will
11130 -- make the subsequent error message easier to understand.
11132 if Present
(F_Typ
) and then not Is_Abstract_Type
(F_Typ
)
11133 and then Is_Abstract_Subprogram
(Prev_E
)
11134 and then In_Private_Part
(Current_Scope
)
11136 Error_Msg_Node_2
:= F_Typ
;
11138 ("private operation& in generic unit does not override "
11139 & "any primitive operation of& (RM 12.3(18))??",
11149 end Is_Non_Overriding_Operation
;
11151 -------------------------------------
11152 -- List_Inherited_Pre_Post_Aspects --
11153 -------------------------------------
11155 procedure List_Inherited_Pre_Post_Aspects
(E
: Entity_Id
) is
11157 if List_Inherited_Aspects
11158 and then Is_Subprogram_Or_Generic_Subprogram
(E
)
11161 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(E
);
11166 for Index
in Subps
'Range loop
11167 Items
:= Contract
(Subps
(Index
));
11169 if Present
(Items
) then
11170 Prag
:= Pre_Post_Conditions
(Items
);
11171 while Present
(Prag
) loop
11172 Error_Msg_Sloc
:= Sloc
(Prag
);
11174 if Class_Present
(Prag
)
11175 and then not Split_PPC
(Prag
)
11177 if Pragma_Name
(Prag
) = Name_Precondition
then
11179 ("info: & inherits `Pre''Class` aspect from "
11183 ("info: & inherits `Post''Class` aspect from "
11188 Prag
:= Next_Pragma
(Prag
);
11194 end List_Inherited_Pre_Post_Aspects
;
11196 ------------------------------
11197 -- Make_Inequality_Operator --
11198 ------------------------------
11200 -- S is the defining identifier of an equality operator. We build a
11201 -- subprogram declaration with the right signature. This operation is
11202 -- intrinsic, because it is always expanded as the negation of the
11203 -- call to the equality function.
11205 procedure Make_Inequality_Operator
(S
: Entity_Id
) is
11206 Loc
: constant Source_Ptr
:= Sloc
(S
);
11209 Op_Name
: Entity_Id
;
11211 FF
: constant Entity_Id
:= First_Formal
(S
);
11212 NF
: constant Entity_Id
:= Next_Formal
(FF
);
11215 -- Check that equality was properly defined, ignore call if not
11222 A
: constant Entity_Id
:=
11223 Make_Defining_Identifier
(Sloc
(FF
),
11224 Chars
=> Chars
(FF
));
11226 B
: constant Entity_Id
:=
11227 Make_Defining_Identifier
(Sloc
(NF
),
11228 Chars
=> Chars
(NF
));
11231 Op_Name
:= Make_Defining_Operator_Symbol
(Loc
, Name_Op_Ne
);
11233 Formals
:= New_List
(
11234 Make_Parameter_Specification
(Loc
,
11235 Defining_Identifier
=> A
,
11237 New_Occurrence_Of
(Etype
(First_Formal
(S
)),
11238 Sloc
(Etype
(First_Formal
(S
))))),
11240 Make_Parameter_Specification
(Loc
,
11241 Defining_Identifier
=> B
,
11243 New_Occurrence_Of
(Etype
(Next_Formal
(First_Formal
(S
))),
11244 Sloc
(Etype
(Next_Formal
(First_Formal
(S
)))))));
11247 Make_Subprogram_Declaration
(Loc
,
11249 Make_Function_Specification
(Loc
,
11250 Defining_Unit_Name
=> Op_Name
,
11251 Parameter_Specifications
=> Formals
,
11252 Result_Definition
=>
11253 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
11255 -- Insert inequality right after equality if it is explicit or after
11256 -- the derived type when implicit. These entities are created only
11257 -- for visibility purposes, and eventually replaced in the course
11258 -- of expansion, so they do not need to be attached to the tree and
11259 -- seen by the back-end. Keeping them internal also avoids spurious
11260 -- freezing problems. The declaration is inserted in the tree for
11261 -- analysis, and removed afterwards. If the equality operator comes
11262 -- from an explicit declaration, attach the inequality immediately
11263 -- after. Else the equality is inherited from a derived type
11264 -- declaration, so insert inequality after that declaration.
11266 if No
(Alias
(S
)) then
11267 Insert_After
(Unit_Declaration_Node
(S
), Decl
);
11268 elsif Is_List_Member
(Parent
(S
)) then
11269 Insert_After
(Parent
(S
), Decl
);
11271 Insert_After
(Parent
(Etype
(First_Formal
(S
))), Decl
);
11274 Mark_Rewrite_Insertion
(Decl
);
11275 Set_Is_Intrinsic_Subprogram
(Op_Name
);
11278 Set_Has_Completion
(Op_Name
);
11279 Set_Corresponding_Equality
(Op_Name
, S
);
11280 Set_Is_Abstract_Subprogram
(Op_Name
, Is_Abstract_Subprogram
(S
));
11282 end Make_Inequality_Operator
;
11284 ----------------------
11285 -- May_Need_Actuals --
11286 ----------------------
11288 procedure May_Need_Actuals
(Fun
: Entity_Id
) is
11293 F
:= First_Formal
(Fun
);
11295 while Present
(F
) loop
11296 if No
(Default_Value
(F
)) then
11304 Set_Needs_No_Actuals
(Fun
, B
);
11305 end May_Need_Actuals
;
11307 ---------------------
11308 -- Mode_Conformant --
11309 ---------------------
11311 function Mode_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
11314 Check_Conformance
(New_Id
, Old_Id
, Mode_Conformant
, False, Result
);
11316 end Mode_Conformant
;
11318 ---------------------------
11319 -- New_Overloaded_Entity --
11320 ---------------------------
11322 procedure New_Overloaded_Entity
11324 Derived_Type
: Entity_Id
:= Empty
)
11326 Overridden_Subp
: Entity_Id
:= Empty
;
11327 -- Set if the current scope has an operation that is type-conformant
11328 -- with S, and becomes hidden by S.
11330 Is_Primitive_Subp
: Boolean;
11331 -- Set to True if the new subprogram is primitive
11334 -- Entity that S overrides
11336 procedure Check_For_Primitive_Subprogram
11337 (Is_Primitive
: out Boolean;
11338 Is_Overriding
: Boolean := False);
11339 -- If the subprogram being analyzed is a primitive operation of the type
11340 -- of a formal or result, set the Has_Primitive_Operations flag on the
11341 -- type, and set Is_Primitive to True (otherwise set to False). Set the
11342 -- corresponding flag on the entity itself for later use.
11344 function Has_Matching_Entry_Or_Subprogram
(E
: Entity_Id
) return Boolean;
11345 -- True if a) E is a subprogram whose first formal is a concurrent type
11346 -- defined in the scope of E that has some entry or subprogram whose
11347 -- profile matches E, or b) E is an internally built dispatching
11348 -- subprogram of a protected type and there is a matching subprogram
11349 -- defined in the enclosing scope of the protected type, or c) E is
11350 -- an entry of a synchronized type and a matching procedure has been
11351 -- previously defined in the enclosing scope of the synchronized type.
11353 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean;
11354 -- Check that E is declared in the private part of the current package,
11355 -- or in the package body, where it may hide a previous declaration.
11356 -- We can't use In_Private_Part by itself because this flag is also
11357 -- set when freezing entities, so we must examine the place of the
11358 -- declaration in the tree, and recognize wrapper packages as well.
11360 function Is_Overriding_Alias
11361 (Old_E
: Entity_Id
;
11362 New_E
: Entity_Id
) return Boolean;
11363 -- Check whether new subprogram and old subprogram are both inherited
11364 -- from subprograms that have distinct dispatch table entries. This can
11365 -- occur with derivations from instances with accidental homonyms. The
11366 -- function is conservative given that the converse is only true within
11367 -- instances that contain accidental overloadings.
11369 procedure Report_Conflict
(S
: Entity_Id
; E
: Entity_Id
);
11370 -- Report conflict between entities S and E
11372 ------------------------------------
11373 -- Check_For_Primitive_Subprogram --
11374 ------------------------------------
11376 procedure Check_For_Primitive_Subprogram
11377 (Is_Primitive
: out Boolean;
11378 Is_Overriding
: Boolean := False)
11380 procedure Add_Or_Replace_Untagged_Primitive
(Typ
: Entity_Id
);
11381 -- Either add the new subprogram to the list of primitives for
11382 -- untagged type Typ, or if it overrides a primitive of Typ, then
11383 -- replace the overridden primitive in Typ's primitives list with
11384 -- the new subprogram.
11386 function Visible_Part_Type
(T
: Entity_Id
) return Boolean;
11387 -- Returns true if T is declared in the visible part of the current
11388 -- package scope; otherwise returns false. Assumes that T is declared
11391 procedure Check_Private_Overriding
(T
: Entity_Id
);
11392 -- Checks that if a primitive abstract subprogram of a visible
11393 -- abstract type is declared in a private part, then it must override
11394 -- an abstract subprogram declared in the visible part. Also checks
11395 -- that if a primitive function with a controlling result is declared
11396 -- in a private part, then it must override a function declared in
11397 -- the visible part.
11399 ---------------------------------------
11400 -- Add_Or_Replace_Untagged_Primitive --
11401 ---------------------------------------
11403 procedure Add_Or_Replace_Untagged_Primitive
(Typ
: Entity_Id
) is
11404 Replaced_Overridden_Subp
: Boolean := False;
11407 pragma Assert
(not Is_Tagged_Type
(Typ
));
11409 -- Anonymous access types don't have a primitives list. Normally
11410 -- such types wouldn't make it here, but the case of anonymous
11411 -- access-to-subprogram types can.
11413 if not Is_Anonymous_Access_Type
(Typ
) then
11415 -- If S overrides a subprogram that's a primitive of
11416 -- the formal's type, then replace the overridden
11417 -- subprogram with the new subprogram in the type's
11418 -- list of primitives.
11420 if Is_Overriding
then
11421 pragma Assert
(Present
(Overridden_Subp
)
11422 and then Overridden_Subp
= E
); -- Added for now
11425 Prim_Ops
: constant Elist_Id
:=
11426 Primitive_Operations
(Typ
);
11429 if Present
(Prim_Ops
) then
11430 Elmt
:= First_Elmt
(Prim_Ops
);
11432 while Present
(Elmt
)
11433 and then Node
(Elmt
) /= Overridden_Subp
11438 if Present
(Elmt
) then
11439 Replace_Elmt
(Elmt
, S
);
11440 Replaced_Overridden_Subp
:= True;
11446 -- If the new subprogram did not override an operation
11447 -- of the formal's type, then add it to the primitives
11448 -- list of the type.
11450 if not Replaced_Overridden_Subp
then
11451 Append_Unique_Elmt
(S
, Primitive_Operations
(Typ
));
11454 end Add_Or_Replace_Untagged_Primitive
;
11456 ------------------------------
11457 -- Check_Private_Overriding --
11458 ------------------------------
11460 procedure Check_Private_Overriding
(T
: Entity_Id
) is
11461 function Overrides_Private_Part_Op
return Boolean;
11462 -- This detects the special case where the overriding subprogram
11463 -- is overriding a subprogram that was declared in the same
11464 -- private part. That case is illegal by 3.9.3(10).
11466 function Overrides_Visible_Function
11467 (Partial_View
: Entity_Id
) return Boolean;
11468 -- True if S overrides a function in the visible part. The
11469 -- overridden function could be explicitly or implicitly declared.
11471 -------------------------------
11472 -- Overrides_Private_Part_Op --
11473 -------------------------------
11475 function Overrides_Private_Part_Op
return Boolean is
11476 Over_Decl
: constant Node_Id
:=
11477 Unit_Declaration_Node
11478 (Ultimate_Alias
(Overridden_Operation
(S
)));
11479 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(S
);
11482 pragma Assert
(Is_Overriding
);
11484 (Nkind
(Over_Decl
) = N_Abstract_Subprogram_Declaration
);
11486 (Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
);
11488 return In_Same_List
(Over_Decl
, Subp_Decl
);
11489 end Overrides_Private_Part_Op
;
11491 --------------------------------
11492 -- Overrides_Visible_Function --
11493 --------------------------------
11495 function Overrides_Visible_Function
11496 (Partial_View
: Entity_Id
) return Boolean
11499 if not Is_Overriding
or else not Has_Homonym
(S
) then
11503 if No
(Partial_View
) then
11507 -- Search through all the homonyms H of S in the current
11508 -- package spec, and return True if we find one that matches.
11509 -- Note that Parent (H) will be the declaration of the
11510 -- partial view of T for a match.
11513 H
: Entity_Id
:= S
;
11517 exit when No
(H
) or else Scope
(H
) /= Scope
(S
);
11519 if Nkind
(Parent
(H
)) in
11520 N_Private_Extension_Declaration |
11521 N_Private_Type_Declaration
11522 and then Defining_Identifier
(Parent
(H
)) = Partial_View
11530 end Overrides_Visible_Function
;
11532 -- Start of processing for Check_Private_Overriding
11535 if Is_Package_Or_Generic_Package
(Current_Scope
)
11536 and then In_Private_Part
(Current_Scope
)
11537 and then Visible_Part_Type
(T
)
11538 and then not In_Instance
11540 if Is_Abstract_Type
(T
)
11541 and then Is_Abstract_Subprogram
(S
)
11542 and then (not Is_Overriding
11543 or else not Is_Abstract_Subprogram
(E
)
11544 or else Overrides_Private_Part_Op
)
11547 ("abstract subprograms must be visible (RM 3.9.3(10))!",
11550 elsif Ekind
(S
) = E_Function
then
11552 Partial_View
: constant Entity_Id
:=
11553 Incomplete_Or_Partial_View
(T
);
11556 if not Overrides_Visible_Function
(Partial_View
) then
11558 -- Here, S is "function ... return T;" declared in
11559 -- the private part, not overriding some visible
11560 -- operation. That's illegal in the tagged case
11561 -- (but not if the private type is untagged).
11563 if ((Present
(Partial_View
)
11564 and then Is_Tagged_Type
(Partial_View
))
11565 or else (No
(Partial_View
)
11566 and then Is_Tagged_Type
(T
)))
11567 and then T
= Base_Type
(Etype
(S
))
11570 ("private function with tagged result must"
11571 & " override visible-part function", S
);
11573 ("\move subprogram to the visible part"
11574 & " (RM 3.9.3(10))", S
);
11576 -- Ada 2012 (AI05-0073): Extend this check to the case
11577 -- of a function whose result subtype is defined by an
11578 -- access_definition designating specific tagged type.
11580 elsif Ekind
(Etype
(S
)) = E_Anonymous_Access_Type
11581 and then Is_Tagged_Type
(Designated_Type
(Etype
(S
)))
11583 not Is_Class_Wide_Type
11584 (Designated_Type
(Etype
(S
)))
11585 and then Ada_Version
>= Ada_2012
11588 ("private function with controlling access "
11589 & "result must override visible-part function",
11592 ("\move subprogram to the visible part"
11593 & " (RM 3.9.3(10))", S
);
11599 end Check_Private_Overriding
;
11601 -----------------------
11602 -- Visible_Part_Type --
11603 -----------------------
11605 function Visible_Part_Type
(T
: Entity_Id
) return Boolean is
11606 P
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(T
));
11609 -- If the entity is a private type, then it must be declared in a
11612 if Is_Private_Type
(T
) then
11615 elsif Is_Type
(T
) and then Has_Private_Declaration
(T
) then
11618 elsif Is_List_Member
(Declaration_Node
(T
))
11619 and then List_Containing
(Declaration_Node
(T
)) =
11620 Visible_Declarations
(Specification
(P
))
11627 end Visible_Part_Type
;
11631 Formal
: Entity_Id
;
11635 -- Start of processing for Check_For_Primitive_Subprogram
11638 Is_Primitive
:= False;
11640 if not Comes_From_Source
(S
) then
11642 -- Add an inherited primitive for an untagged derived type to
11643 -- Derived_Type's list of primitives. Tagged primitives are
11644 -- dealt with in Check_Dispatching_Operation. Do this even when
11645 -- Extensions_Allowed is False to issue better error messages.
11647 if Present
(Derived_Type
)
11648 and then not Is_Tagged_Type
(Derived_Type
)
11650 Append_Unique_Elmt
(S
, Primitive_Operations
(Derived_Type
));
11653 -- If subprogram is at library level, it is not primitive operation
11655 elsif Current_Scope
= Standard_Standard
then
11658 elsif (Is_Package_Or_Generic_Package
(Current_Scope
)
11659 and then not In_Package_Body
(Current_Scope
))
11660 or else Is_Overriding
11662 -- For function, check return type
11664 if Ekind
(S
) = E_Function
then
11665 if Ekind
(Etype
(S
)) = E_Anonymous_Access_Type
then
11666 F_Typ
:= Designated_Type
(Etype
(S
));
11668 F_Typ
:= Etype
(S
);
11671 B_Typ
:= Base_Type
(F_Typ
);
11673 if Scope
(B_Typ
) = Current_Scope
11674 and then not Is_Class_Wide_Type
(B_Typ
)
11675 and then not Is_Generic_Type
(B_Typ
)
11677 Is_Primitive
:= True;
11678 Set_Has_Primitive_Operations
(B_Typ
);
11679 Set_Is_Primitive
(S
);
11681 -- Add a primitive for an untagged type to B_Typ's
11682 -- list of primitives. Tagged primitives are dealt with
11683 -- in Check_Dispatching_Operation. Do this even when
11684 -- Extensions_Allowed is False to issue better error
11687 if not Is_Tagged_Type
(B_Typ
) then
11688 Add_Or_Replace_Untagged_Primitive
(B_Typ
);
11691 Check_Private_Overriding
(B_Typ
);
11692 -- The Ghost policy in effect at the point of declaration
11693 -- or a tagged type and a primitive operation must match
11694 -- (SPARK RM 6.9(16)).
11696 Check_Ghost_Primitive
(S
, B_Typ
);
11700 -- For all subprograms, check formals
11702 Formal
:= First_Formal
(S
);
11703 while Present
(Formal
) loop
11704 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
11705 F_Typ
:= Designated_Type
(Etype
(Formal
));
11707 F_Typ
:= Etype
(Formal
);
11710 B_Typ
:= Base_Type
(F_Typ
);
11712 if Ekind
(B_Typ
) = E_Access_Subtype
then
11713 B_Typ
:= Base_Type
(B_Typ
);
11716 if Scope
(B_Typ
) = Current_Scope
11717 and then not Is_Class_Wide_Type
(B_Typ
)
11718 and then not Is_Generic_Type
(B_Typ
)
11720 Is_Primitive
:= True;
11721 Set_Is_Primitive
(S
);
11722 Set_Has_Primitive_Operations
(B_Typ
);
11724 -- Add a primitive for an untagged type to B_Typ's list
11725 -- of primitives. Tagged primitives are dealt with in
11726 -- Check_Dispatching_Operation. Do this even when
11727 -- Extensions_Allowed is False to issue better error
11730 if not Is_Tagged_Type
(B_Typ
) then
11731 Add_Or_Replace_Untagged_Primitive
(B_Typ
);
11734 Check_Private_Overriding
(B_Typ
);
11736 -- The Ghost policy in effect at the point of declaration
11737 -- of a tagged type and a primitive operation must match
11738 -- (SPARK RM 6.9(16)).
11740 Check_Ghost_Primitive
(S
, B_Typ
);
11743 Next_Formal
(Formal
);
11746 -- Special case: An equality function can be redefined for a type
11747 -- occurring in a declarative part, and won't otherwise be treated as
11748 -- a primitive because it doesn't occur in a package spec and doesn't
11749 -- override an inherited subprogram. It's important that we mark it
11750 -- primitive so it can be returned by Collect_Primitive_Operations
11751 -- and be used in composing the equality operation of later types
11752 -- that have a component of the type.
11754 elsif Chars
(S
) = Name_Op_Eq
11755 and then Etype
(S
) = Standard_Boolean
11757 B_Typ
:= Base_Type
(Etype
(First_Formal
(S
)));
11759 if Scope
(B_Typ
) = Current_Scope
11761 Base_Type
(Etype
(Next_Formal
(First_Formal
(S
)))) = B_Typ
11762 and then not Is_Limited_Type
(B_Typ
)
11764 Is_Primitive
:= True;
11765 Set_Is_Primitive
(S
);
11766 Set_Has_Primitive_Operations
(B_Typ
);
11767 Check_Private_Overriding
(B_Typ
);
11769 -- The Ghost policy in effect at the point of declaration of a
11770 -- tagged type and a primitive operation must match
11771 -- (SPARK RM 6.9(16)).
11773 Check_Ghost_Primitive
(S
, B_Typ
);
11776 end Check_For_Primitive_Subprogram
;
11778 --------------------------------------
11779 -- Has_Matching_Entry_Or_Subprogram --
11780 --------------------------------------
11782 function Has_Matching_Entry_Or_Subprogram
11783 (E
: Entity_Id
) return Boolean
11785 function Check_Conforming_Parameters
11786 (E1_Param
: Node_Id
;
11787 E2_Param
: Node_Id
;
11788 Ctype
: Conformance_Type
) return Boolean;
11789 -- Starting from the given parameters, check that all the parameters
11790 -- of two entries or subprograms are conformant. Used to skip
11791 -- the check on the controlling argument.
11793 function Matching_Entry_Or_Subprogram
11794 (Conc_Typ
: Entity_Id
;
11795 Subp
: Entity_Id
) return Entity_Id
;
11796 -- Return the first entry or subprogram of the given concurrent type
11797 -- whose name matches the name of Subp and has a profile conformant
11798 -- with Subp; return Empty if not found.
11800 function Matching_Dispatching_Subprogram
11801 (Conc_Typ
: Entity_Id
;
11802 Ent
: Entity_Id
) return Entity_Id
;
11803 -- Return the first dispatching primitive of Conc_Type defined in the
11804 -- enclosing scope of Conc_Type (i.e. before the full definition of
11805 -- this concurrent type) whose name matches the entry Ent and has a
11806 -- profile conformant with the profile of the corresponding (not yet
11807 -- built) dispatching primitive of Ent; return Empty if not found.
11809 function Matching_Original_Protected_Subprogram
11810 (Prot_Typ
: Entity_Id
;
11811 Subp
: Entity_Id
) return Entity_Id
;
11812 -- Return the first subprogram defined in the enclosing scope of
11813 -- Prot_Typ (before the full definition of this protected type)
11814 -- whose name matches the original name of Subp and has a profile
11815 -- conformant with the profile of Subp; return Empty if not found.
11817 function Normalized_First_Parameter_Type
11818 (E
: Entity_Id
) return Entity_Id
;
11819 -- Return the type of the first parameter unless that type
11820 -- is an anonymous access type, in which case return the
11821 -- designated type. Used to treat anonymous-access-to-synchronized
11822 -- the same as synchronized for purposes of checking for
11823 -- prefixed view profile conflicts.
11825 ---------------------------------
11826 -- Check_Conforming_Parameters --
11827 ---------------------------------
11829 function Check_Conforming_Parameters
11830 (E1_Param
: Node_Id
;
11831 E2_Param
: Node_Id
;
11832 Ctype
: Conformance_Type
) return Boolean
11834 Param_E1
: Node_Id
:= E1_Param
;
11835 Param_E2
: Node_Id
:= E2_Param
;
11838 while Present
(Param_E1
) and then Present
(Param_E2
) loop
11839 if Ctype
>= Mode_Conformant
and then
11840 Ekind
(Defining_Identifier
(Param_E1
)) /=
11841 Ekind
(Defining_Identifier
(Param_E2
))
11846 (Find_Parameter_Type
(Param_E1
),
11847 Find_Parameter_Type
(Param_E2
),
11857 -- The candidate is not valid if one of the two lists contains
11858 -- more parameters than the other
11860 return No
(Param_E1
) and then No
(Param_E2
);
11861 end Check_Conforming_Parameters
;
11863 ----------------------------------
11864 -- Matching_Entry_Or_Subprogram --
11865 ----------------------------------
11867 function Matching_Entry_Or_Subprogram
11868 (Conc_Typ
: Entity_Id
;
11869 Subp
: Entity_Id
) return Entity_Id
11874 E
:= First_Entity
(Conc_Typ
);
11875 while Present
(E
) loop
11876 if Chars
(Subp
) = Chars
(E
)
11877 and then (Ekind
(E
) = E_Entry
or else Is_Subprogram
(E
))
11879 Check_Conforming_Parameters
11880 (First
(Parameter_Specifications
(Parent
(E
))),
11881 Next
(First
(Parameter_Specifications
(Parent
(Subp
)))),
11891 end Matching_Entry_Or_Subprogram
;
11893 -------------------------------------
11894 -- Matching_Dispatching_Subprogram --
11895 -------------------------------------
11897 function Matching_Dispatching_Subprogram
11898 (Conc_Typ
: Entity_Id
;
11899 Ent
: Entity_Id
) return Entity_Id
11904 -- Search for entities in the enclosing scope of this synchronized
11907 pragma Assert
(Is_Concurrent_Type
(Conc_Typ
));
11908 Push_Scope
(Scope
(Conc_Typ
));
11909 E
:= Current_Entity_In_Scope
(Ent
);
11912 while Present
(E
) loop
11913 if Scope
(E
) = Scope
(Conc_Typ
)
11914 and then Comes_From_Source
(E
)
11915 and then Ekind
(E
) = E_Procedure
11916 and then Present
(First_Entity
(E
))
11917 and then Is_Controlling_Formal
(First_Entity
(E
))
11918 and then Etype
(First_Entity
(E
)) = Conc_Typ
11920 Check_Conforming_Parameters
11921 (First
(Parameter_Specifications
(Parent
(Ent
))),
11922 Next
(First
(Parameter_Specifications
(Parent
(E
)))),
11923 Subtype_Conformant
)
11932 end Matching_Dispatching_Subprogram
;
11934 --------------------------------------------
11935 -- Matching_Original_Protected_Subprogram --
11936 --------------------------------------------
11938 function Matching_Original_Protected_Subprogram
11939 (Prot_Typ
: Entity_Id
;
11940 Subp
: Entity_Id
) return Entity_Id
11942 ICF
: constant Boolean :=
11943 Is_Controlling_Formal
(First_Entity
(Subp
));
11947 -- Temporarily decorate the first parameter of Subp as controlling
11948 -- formal, required to invoke Subtype_Conformant.
11950 Set_Is_Controlling_Formal
(First_Entity
(Subp
));
11953 Current_Entity_In_Scope
(Original_Protected_Subprogram
(Subp
));
11955 while Present
(E
) loop
11956 if Scope
(E
) = Scope
(Prot_Typ
)
11957 and then Comes_From_Source
(E
)
11958 and then Ekind
(Subp
) = Ekind
(E
)
11959 and then Present
(First_Entity
(E
))
11960 and then Is_Controlling_Formal
(First_Entity
(E
))
11961 and then Etype
(First_Entity
(E
)) = Prot_Typ
11962 and then Subtype_Conformant
(Subp
, E
,
11963 Skip_Controlling_Formals
=> True)
11965 Set_Is_Controlling_Formal
(First_Entity
(Subp
), ICF
);
11972 Set_Is_Controlling_Formal
(First_Entity
(Subp
), ICF
);
11975 end Matching_Original_Protected_Subprogram
;
11977 -------------------------------------
11978 -- Normalized_First_Parameter_Type --
11979 -------------------------------------
11981 function Normalized_First_Parameter_Type
11982 (E
: Entity_Id
) return Entity_Id
11984 Result
: Entity_Id
:= Etype
(First_Entity
(E
));
11986 if Ekind
(Result
) = E_Anonymous_Access_Type
then
11987 Result
:= Designated_Type
(Result
);
11990 end Normalized_First_Parameter_Type
;
11992 -- Start of processing for Has_Matching_Entry_Or_Subprogram
11995 -- Case 1: E is a subprogram whose first formal is a concurrent type
11996 -- defined in the scope of E that has an entry or subprogram whose
11997 -- profile matches E.
11999 if Comes_From_Source
(E
)
12000 and then Is_Subprogram
(E
)
12001 and then Present
(First_Entity
(E
))
12002 and then Is_Concurrent_Record_Type
12003 (Normalized_First_Parameter_Type
(E
))
12006 Scope
(Corresponding_Concurrent_Type
12007 (Normalized_First_Parameter_Type
(E
)))
12010 (Matching_Entry_Or_Subprogram
12011 (Corresponding_Concurrent_Type
12012 (Normalized_First_Parameter_Type
(E
)),
12015 Report_Conflict
(E
,
12016 Matching_Entry_Or_Subprogram
12017 (Corresponding_Concurrent_Type
12018 (Normalized_First_Parameter_Type
(E
)),
12023 -- Case 2: E is an internally built dispatching subprogram of a
12024 -- protected type and there is a subprogram defined in the enclosing
12025 -- scope of the protected type that has the original name of E and
12026 -- its profile is conformant with the profile of E. We check the
12027 -- name of the original protected subprogram associated with E since
12028 -- the expander builds dispatching primitives of protected functions
12029 -- and procedures with other names (see Exp_Ch9.Build_Selected_Name).
12031 elsif not Comes_From_Source
(E
)
12032 and then Is_Subprogram
(E
)
12033 and then Present
(First_Entity
(E
))
12034 and then Is_Concurrent_Record_Type
(Etype
(First_Entity
(E
)))
12035 and then Present
(Original_Protected_Subprogram
(E
))
12038 (Matching_Original_Protected_Subprogram
12039 (Corresponding_Concurrent_Type
(Etype
(First_Entity
(E
))),
12042 Report_Conflict
(E
,
12043 Matching_Original_Protected_Subprogram
12044 (Corresponding_Concurrent_Type
(Etype
(First_Entity
(E
))),
12048 -- Case 3: E is an entry of a synchronized type and a matching
12049 -- procedure has been previously defined in the enclosing scope
12050 -- of the synchronized type.
12052 elsif Comes_From_Source
(E
)
12053 and then Ekind
(E
) = E_Entry
12055 Present
(Matching_Dispatching_Subprogram
(Current_Scope
, E
))
12057 Report_Conflict
(E
,
12058 Matching_Dispatching_Subprogram
(Current_Scope
, E
));
12063 end Has_Matching_Entry_Or_Subprogram
;
12065 ----------------------------
12066 -- Is_Private_Declaration --
12067 ----------------------------
12069 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean is
12070 Decl
: constant Node_Id
:= Unit_Declaration_Node
(E
);
12071 Priv_Decls
: List_Id
;
12074 if Is_Package_Or_Generic_Package
(Current_Scope
)
12075 and then In_Private_Part
(Current_Scope
)
12078 Private_Declarations
(Package_Specification
(Current_Scope
));
12080 return In_Package_Body
(Current_Scope
)
12082 (Is_List_Member
(Decl
)
12083 and then List_Containing
(Decl
) = Priv_Decls
)
12084 or else (Nkind
(Parent
(Decl
)) = N_Package_Specification
12086 Is_Compilation_Unit
12087 (Defining_Entity
(Parent
(Decl
)))
12088 and then List_Containing
(Parent
(Parent
(Decl
))) =
12093 end Is_Private_Declaration
;
12095 --------------------------
12096 -- Is_Overriding_Alias --
12097 --------------------------
12099 function Is_Overriding_Alias
12100 (Old_E
: Entity_Id
;
12101 New_E
: Entity_Id
) return Boolean
12103 AO
: constant Entity_Id
:= Alias
(Old_E
);
12104 AN
: constant Entity_Id
:= Alias
(New_E
);
12107 return Scope
(AO
) /= Scope
(AN
)
12108 or else No
(DTC_Entity
(AO
))
12109 or else No
(DTC_Entity
(AN
))
12110 or else DT_Position
(AO
) = DT_Position
(AN
);
12111 end Is_Overriding_Alias
;
12113 ---------------------
12114 -- Report_Conflict --
12115 ---------------------
12117 procedure Report_Conflict
(S
: Entity_Id
; E
: Entity_Id
) is
12119 Error_Msg_Sloc
:= Sloc
(E
);
12121 -- Generate message, with useful additional warning if in generic
12123 if Is_Generic_Unit
(E
) then
12124 Error_Msg_N
("previous generic unit cannot be overloaded", S
);
12125 Error_Msg_N
("\& conflicts with declaration#", S
);
12127 Error_Msg_N
("& conflicts with declaration#", S
);
12129 end Report_Conflict
;
12131 -- Start of processing for New_Overloaded_Entity
12134 -- We need to look for an entity that S may override. This must be a
12135 -- homonym in the current scope, so we look for the first homonym of
12136 -- S in the current scope as the starting point for the search.
12138 E
:= Current_Entity_In_Scope
(S
);
12140 -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
12141 -- They are directly added to the list of primitive operations of
12142 -- Derived_Type, unless this is a rederivation in the private part
12143 -- of an operation that was already derived in the visible part of
12144 -- the current package.
12146 if Ada_Version
>= Ada_2005
12147 and then Present
(Derived_Type
)
12148 and then Present
(Alias
(S
))
12149 and then Is_Dispatching_Operation
(Alias
(S
))
12150 and then Present
(Find_Dispatching_Type
(Alias
(S
)))
12151 and then Is_Interface
(Find_Dispatching_Type
(Alias
(S
)))
12153 -- For private types, when the full-view is processed we propagate to
12154 -- the full view the non-overridden entities whose attribute "alias"
12155 -- references an interface primitive. These entities were added by
12156 -- Derive_Subprograms to ensure that interface primitives are
12159 -- Inside_Freeze_Actions is non zero when S corresponds with an
12160 -- internal entity that links an interface primitive with its
12161 -- covering primitive through attribute Interface_Alias (see
12162 -- Add_Internal_Interface_Entities).
12164 if Inside_Freezing_Actions
= 0
12165 and then Is_Package_Or_Generic_Package
(Current_Scope
)
12166 and then In_Private_Part
(Current_Scope
)
12167 and then Parent_Kind
(E
) = N_Private_Extension_Declaration
12168 and then Nkind
(Parent
(S
)) = N_Full_Type_Declaration
12169 and then Full_View
(Defining_Identifier
(Parent
(E
)))
12170 = Defining_Identifier
(Parent
(S
))
12171 and then Alias
(E
) = Alias
(S
)
12173 Check_Operation_From_Private_View
(S
, E
);
12174 Set_Is_Dispatching_Operation
(S
);
12179 Enter_Overloaded_Entity
(S
);
12180 Check_Dispatching_Operation
(S
, Empty
);
12181 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
12187 -- For synchronized types check conflicts of this entity with previously
12188 -- defined entities.
12190 if Ada_Version
>= Ada_2005
12191 and then Has_Matching_Entry_Or_Subprogram
(S
)
12196 -- If there is no homonym then this is definitely not overriding
12199 Enter_Overloaded_Entity
(S
);
12200 Check_Dispatching_Operation
(S
, Empty
);
12201 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
12203 -- If subprogram has an explicit declaration, check whether it has an
12204 -- overriding indicator.
12206 if Comes_From_Source
(S
) then
12207 Check_Synchronized_Overriding
(S
, Overridden_Subp
);
12209 -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then
12210 -- it may have overridden some hidden inherited primitive. Update
12211 -- Overridden_Subp to avoid spurious errors when checking the
12212 -- overriding indicator.
12214 if Ada_Version
>= Ada_2012
12215 and then No
(Overridden_Subp
)
12216 and then Is_Dispatching_Operation
(S
)
12217 and then Present
(Overridden_Operation
(S
))
12219 Overridden_Subp
:= Overridden_Operation
(S
);
12222 Check_Overriding_Indicator
12223 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
12225 -- The Ghost policy in effect at the point of declaration of a
12226 -- parent subprogram and an overriding subprogram must match
12227 -- (SPARK RM 6.9(17)).
12229 Check_Ghost_Overriding
(S
, Overridden_Subp
);
12232 -- If there is a homonym that is not overloadable, then we have an
12233 -- error, except for the special cases checked explicitly below.
12235 elsif not Is_Overloadable
(E
) then
12237 -- Check for spurious conflict produced by a subprogram that has the
12238 -- same name as that of the enclosing generic package. The conflict
12239 -- occurs within an instance, between the subprogram and the renaming
12240 -- declaration for the package. After the subprogram, the package
12241 -- renaming declaration becomes hidden.
12243 if Ekind
(E
) = E_Package
12244 and then Present
(Renamed_Entity
(E
))
12245 and then Renamed_Entity
(E
) = Current_Scope
12246 and then Nkind
(Parent
(Renamed_Entity
(E
))) =
12247 N_Package_Specification
12248 and then Present
(Generic_Parent
(Parent
(Renamed_Entity
(E
))))
12251 Set_Is_Immediately_Visible
(E
, False);
12252 Enter_Overloaded_Entity
(S
);
12253 Set_Homonym
(S
, Homonym
(E
));
12254 Check_Dispatching_Operation
(S
, Empty
);
12255 Check_Overriding_Indicator
(S
, Empty
, Is_Primitive
=> False);
12257 -- If the subprogram is implicit it is hidden by the previous
12258 -- declaration. However if it is dispatching, it must appear in the
12259 -- dispatch table anyway, because it can be dispatched to even if it
12260 -- cannot be called directly.
12262 elsif Present
(Alias
(S
)) and then not Comes_From_Source
(S
) then
12263 Set_Scope
(S
, Current_Scope
);
12265 if Is_Dispatching_Operation
(Alias
(S
)) then
12266 Check_Dispatching_Operation
(S
, Empty
);
12272 Report_Conflict
(S
, E
);
12276 -- E exists and is overloadable
12279 Check_Synchronized_Overriding
(S
, Overridden_Subp
);
12281 -- Loop through E and its homonyms to determine if any of them is
12282 -- the candidate for overriding by S.
12284 while Present
(E
) loop
12286 -- Definitely not interesting if not in the current scope
12288 if Scope
(E
) /= Current_Scope
then
12291 -- A function can overload the name of an abstract state. The
12292 -- state can be viewed as a function with a profile that cannot
12293 -- be matched by anything.
12295 elsif Ekind
(S
) = E_Function
12296 and then Ekind
(E
) = E_Abstract_State
12298 Enter_Overloaded_Entity
(S
);
12301 -- Ada 2012 (AI05-0165): For internally generated bodies of null
12302 -- procedures locate the internally generated spec. We enforce
12303 -- mode conformance since a tagged type may inherit from
12304 -- interfaces several null primitives which differ only in
12305 -- the mode of the formals.
12307 elsif not Comes_From_Source
(S
)
12308 and then Is_Null_Procedure
(S
)
12309 and then not Mode_Conformant
(E
, S
)
12313 -- Check if we have type conformance
12315 elsif Type_Conformant
(E
, S
) then
12317 -- If the old and new entities have the same profile and one
12318 -- is not the body of the other, then this is an error, unless
12319 -- one of them is implicitly declared.
12321 -- There are some cases when both can be implicit, for example
12322 -- when both a literal and a function that overrides it are
12323 -- inherited in a derivation, or when an inherited operation
12324 -- of a tagged full type overrides the inherited operation of
12325 -- a private extension. Ada 83 had a special rule for the
12326 -- literal case. In Ada 95, the later implicit operation hides
12327 -- the former, and the literal is always the former. In the
12328 -- odd case where both are derived operations declared at the
12329 -- same point, both operations should be declared, and in that
12330 -- case we bypass the following test and proceed to the next
12331 -- part. This can only occur for certain obscure cases in
12332 -- instances, when an operation on a type derived from a formal
12333 -- private type does not override a homograph inherited from
12334 -- the actual. In subsequent derivations of such a type, the
12335 -- DT positions of these operations remain distinct, if they
12338 if Present
(Alias
(S
))
12339 and then (No
(Alias
(E
))
12340 or else Comes_From_Source
(E
)
12341 or else Is_Abstract_Subprogram
(S
)
12343 (Is_Dispatching_Operation
(E
)
12344 and then Is_Overriding_Alias
(E
, S
)))
12345 and then Ekind
(E
) /= E_Enumeration_Literal
12347 -- When an derived operation is overloaded it may be due to
12348 -- the fact that the full view of a private extension
12349 -- re-inherits. It has to be dealt with.
12351 if Is_Package_Or_Generic_Package
(Current_Scope
)
12352 and then In_Private_Part
(Current_Scope
)
12354 Check_Operation_From_Private_View
(S
, E
);
12357 -- In any case the implicit operation remains hidden by the
12358 -- existing declaration, which is overriding. Indicate that
12359 -- E overrides the operation from which S is inherited.
12361 if Present
(Alias
(S
)) then
12362 Set_Overridden_Operation
(E
, Alias
(S
));
12363 Inherit_Subprogram_Contract
(E
, Alias
(S
));
12364 Set_Is_Ada_2022_Only
(E
,
12365 Is_Ada_2022_Only
(Alias
(S
)));
12368 Set_Overridden_Operation
(E
, S
);
12369 Inherit_Subprogram_Contract
(E
, S
);
12370 Set_Is_Ada_2022_Only
(E
, Is_Ada_2022_Only
(S
));
12373 -- When a dispatching operation overrides an inherited
12374 -- subprogram, it shall be subtype conformant with the
12375 -- inherited subprogram (RM 3.9.2 (10.2)).
12377 if Comes_From_Source
(E
)
12378 and then Is_Dispatching_Operation
(E
)
12379 and then Find_Dispatching_Type
(S
)
12380 = Find_Dispatching_Type
(E
)
12382 Check_Subtype_Conformant
(E
, S
);
12385 if Comes_From_Source
(E
) then
12386 Check_Overriding_Indicator
(E
, S
, Is_Primitive
=> False);
12388 -- The Ghost policy in effect at the point of declaration
12389 -- of a parent subprogram and an overriding subprogram
12390 -- must match (SPARK RM 6.9(17)).
12392 Check_Ghost_Overriding
(E
, S
);
12397 -- Within an instance, the renaming declarations for actual
12398 -- subprograms may become ambiguous, but they do not hide each
12401 elsif Ekind
(E
) /= E_Entry
12402 and then not Comes_From_Source
(E
)
12403 and then not Is_Generic_Instance
(E
)
12404 and then (Present
(Alias
(E
))
12405 or else Is_Intrinsic_Subprogram
(E
))
12406 and then (not In_Instance
12407 or else No
(Parent
(E
))
12408 or else Nkind
(Unit_Declaration_Node
(E
)) /=
12409 N_Subprogram_Renaming_Declaration
)
12411 -- A subprogram child unit is not allowed to override an
12412 -- inherited subprogram (10.1.1(20)).
12414 if Is_Child_Unit
(S
) then
12416 ("child unit overrides inherited subprogram in parent",
12421 if Is_Non_Overriding_Operation
(E
, S
) then
12422 Enter_Overloaded_Entity
(S
);
12424 if No
(Derived_Type
)
12425 or else Is_Tagged_Type
(Derived_Type
)
12427 Check_Dispatching_Operation
(S
, Empty
);
12433 -- E is a derived operation or an internal operator which
12434 -- is being overridden. Remove E from further visibility.
12435 -- Furthermore, if E is a dispatching operation, it must be
12436 -- replaced in the list of primitive operations of its type
12437 -- (see Override_Dispatching_Operation).
12439 Overridden_Subp
:= E
;
12441 -- It is possible for E to be in the current scope and
12442 -- yet not in the entity chain. This can only occur in a
12443 -- generic context where E is an implicit concatenation
12444 -- in the formal part, because in a generic body the
12445 -- entity chain starts with the formals.
12447 -- In GNATprove mode, a wrapper for an operation with
12448 -- axiomatization may be a homonym of another declaration
12449 -- for an actual subprogram (needs refinement ???).
12451 if No
(Prev_Entity
(E
)) then
12453 and then GNATprove_Mode
12455 Nkind
(Original_Node
(Unit_Declaration_Node
(S
))) =
12456 N_Subprogram_Renaming_Declaration
12460 pragma Assert
(Chars
(E
) = Name_Op_Concat
);
12465 -- E must be removed both from the entity_list of the
12466 -- current scope, and from the visibility chain.
12468 if Debug_Flag_E
then
12469 Write_Str
("Override implicit operation ");
12470 Write_Int
(Int
(E
));
12474 -- If E is a predefined concatenation, it stands for four
12475 -- different operations. As a result, a single explicit
12476 -- declaration does not hide it. In a possible ambiguous
12477 -- situation, Disambiguate chooses the user-defined op,
12478 -- so it is correct to retain the previous internal one.
12480 if Chars
(E
) /= Name_Op_Concat
12481 or else Ekind
(E
) /= E_Operator
12483 -- For nondispatching derived operations that are
12484 -- overridden by a subprogram declared in the private
12485 -- part of a package, we retain the derived subprogram
12486 -- but mark it as not immediately visible. If the
12487 -- derived operation was declared in the visible part
12488 -- then this ensures that it will still be visible
12489 -- outside the package with the proper signature
12490 -- (calls from outside must also be directed to this
12491 -- version rather than the overriding one, unlike the
12492 -- dispatching case). Calls from inside the package
12493 -- will still resolve to the overriding subprogram
12494 -- since the derived one is marked as not visible
12495 -- within the package.
12497 -- If the private operation is dispatching, we achieve
12498 -- the overriding by keeping the implicit operation
12499 -- but setting its alias to be the overriding one. In
12500 -- this fashion the proper body is executed in all
12501 -- cases, but the original signature is used outside
12504 -- If the overriding is not in the private part, we
12505 -- remove the implicit operation altogether.
12507 if Is_Private_Declaration
(S
) then
12508 if not Is_Dispatching_Operation
(E
) then
12509 Set_Is_Immediately_Visible
(E
, False);
12511 -- Work done in Override_Dispatching_Operation, so
12512 -- nothing else needs to be done here.
12514 -- ??? Special case to keep supporting the hiding
12515 -- of the predefined "=" operator for a nonlimited
12516 -- tagged type by a user-defined "=" operator for
12517 -- its class-wide type when the type is private.
12519 if Chars
(E
) = Name_Op_Eq
then
12521 Typ
: constant Entity_Id
12522 := Etype
(First_Entity
(E
));
12523 H
: Entity_Id
:= Homonym
(E
);
12527 and then Scope
(H
) = Scope
(E
)
12529 if Is_User_Defined_Equality
(H
)
12530 and then Is_Immediately_Visible
(H
)
12531 and then Etype
(First_Entity
(H
))
12532 = Class_Wide_Type
(Typ
)
12534 Remove_Entity_And_Homonym
(E
);
12545 Remove_Entity_And_Homonym
(E
);
12549 Enter_Overloaded_Entity
(S
);
12551 -- For entities generated by Derive_Subprograms the
12552 -- overridden operation is the inherited primitive
12553 -- (which is available through the attribute alias).
12555 if not (Comes_From_Source
(E
))
12556 and then Is_Dispatching_Operation
(E
)
12557 and then Find_Dispatching_Type
(E
) =
12558 Find_Dispatching_Type
(S
)
12559 and then Present
(Alias
(E
))
12560 and then Comes_From_Source
(Alias
(E
))
12562 Set_Overridden_Operation
(S
, Alias
(E
));
12563 Inherit_Subprogram_Contract
(S
, Alias
(E
));
12564 Set_Is_Ada_2022_Only
(S
,
12565 Is_Ada_2022_Only
(Alias
(E
)));
12567 -- Normal case of setting entity as overridden
12569 -- Note: Static_Initialization and Overridden_Operation
12570 -- attributes use the same field in subprogram entities.
12571 -- Static_Initialization is only defined for internal
12572 -- initialization procedures, where Overridden_Operation
12573 -- is irrelevant. Therefore the setting of this attribute
12574 -- must check whether the target is an init_proc.
12576 elsif not Is_Init_Proc
(S
) then
12578 -- LSP wrappers must override the ultimate alias of their
12579 -- wrapped dispatching primitive E; required to traverse
12580 -- the chain of ancestor primitives (c.f. Map_Primitives)
12581 -- They don't inherit contracts.
12584 and then Present
(LSP_Subprogram
(S
))
12586 Set_Overridden_Operation
(S
, Ultimate_Alias
(E
));
12588 Set_Overridden_Operation
(S
, E
);
12589 Inherit_Subprogram_Contract
(S
, E
);
12592 Set_Is_Ada_2022_Only
(S
, Is_Ada_2022_Only
(E
));
12595 Check_Overriding_Indicator
(S
, E
, Is_Primitive
=> True);
12597 -- The Ghost policy in effect at the point of declaration
12598 -- of a parent subprogram and an overriding subprogram
12599 -- must match (SPARK RM 6.9(17)).
12601 Check_Ghost_Overriding
(S
, E
);
12603 -- If S is a user-defined subprogram or a null procedure
12604 -- expanded to override an inherited null procedure, or a
12605 -- predefined dispatching primitive then indicate that E
12606 -- overrides the operation from which S is inherited.
12608 if Comes_From_Source
(S
)
12610 (Present
(Parent
(S
))
12611 and then Nkind
(Parent
(S
)) = N_Procedure_Specification
12612 and then Null_Present
(Parent
(S
)))
12614 (Present
(Alias
(E
))
12616 Is_Predefined_Dispatching_Operation
(Alias
(E
)))
12618 if Present
(Alias
(E
)) then
12620 -- LSP wrappers must override the ultimate alias of
12621 -- their wrapped dispatching primitive E; required to
12622 -- traverse the chain of ancestor primitives (see
12623 -- Map_Primitives). They don't inherit contracts.
12626 and then Present
(LSP_Subprogram
(S
))
12628 Set_Overridden_Operation
(S
, Ultimate_Alias
(E
));
12630 Set_Overridden_Operation
(S
, Alias
(E
));
12631 Inherit_Subprogram_Contract
(S
, Alias
(E
));
12634 Set_Is_Ada_2022_Only
(S
, Is_Ada_2022_Only
(Alias
(E
)));
12638 if Is_Dispatching_Operation
(E
) then
12640 -- An overriding dispatching subprogram inherits the
12641 -- convention of the overridden subprogram (AI95-117).
12643 Set_Convention
(S
, Convention
(E
));
12644 Check_Dispatching_Operation
(S
, E
);
12647 Check_Dispatching_Operation
(S
, Empty
);
12650 Check_For_Primitive_Subprogram
12651 (Is_Primitive_Subp
, Is_Overriding
=> True);
12652 goto Check_Inequality
;
12654 -- Apparent redeclarations in instances can occur when two
12655 -- formal types get the same actual type. The subprograms in
12656 -- in the instance are legal, even if not callable from the
12657 -- outside. Calls from within are disambiguated elsewhere.
12658 -- For dispatching operations in the visible part, the usual
12659 -- rules apply, and operations with the same profile are not
12660 -- legal (B830001).
12662 elsif (In_Instance_Visible_Part
12663 and then not Is_Dispatching_Operation
(E
))
12664 or else In_Instance_Not_Visible
12668 -- Here we have a real error (identical profile)
12671 Error_Msg_Sloc
:= Sloc
(E
);
12673 -- Avoid cascaded errors if the entity appears in
12674 -- subsequent calls.
12676 Set_Scope
(S
, Current_Scope
);
12678 -- Generate error, with extra useful warning for the case
12679 -- of a generic instance with no completion.
12681 if Is_Generic_Instance
(S
)
12682 and then not Has_Completion
(E
)
12685 ("instantiation cannot provide body for&", S
);
12686 Error_Msg_N
("\& conflicts with declaration#", S
);
12688 Error_Msg_N
("& conflicts with declaration#", S
);
12695 -- If one subprogram has an access parameter and the other
12696 -- a parameter of an access type, calls to either might be
12697 -- ambiguous. Verify that parameters match except for the
12698 -- access parameter.
12700 if May_Hide_Profile
then
12706 F1
:= First_Formal
(S
);
12707 F2
:= First_Formal
(E
);
12708 while Present
(F1
) and then Present
(F2
) loop
12709 if Is_Access_Type
(Etype
(F1
)) then
12710 if not Is_Access_Type
(Etype
(F2
))
12711 or else not Conforming_Types
12712 (Designated_Type
(Etype
(F1
)),
12713 Designated_Type
(Etype
(F2
)),
12716 May_Hide_Profile
:= False;
12720 not Conforming_Types
12721 (Etype
(F1
), Etype
(F2
), Type_Conformant
)
12723 May_Hide_Profile
:= False;
12730 if May_Hide_Profile
12734 Error_Msg_NE
("calls to& may be ambiguous??", S
, S
);
12743 -- On exit, we know that S is a new entity
12745 Enter_Overloaded_Entity
(S
);
12746 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
12747 Check_Overriding_Indicator
12748 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
12750 -- The Ghost policy in effect at the point of declaration of a parent
12751 -- subprogram and an overriding subprogram must match
12752 -- (SPARK RM 6.9(17)).
12754 Check_Ghost_Overriding
(S
, Overridden_Subp
);
12756 -- If S is a derived operation for an untagged type then by
12757 -- definition it's not a dispatching operation (even if the parent
12758 -- operation was dispatching), so Check_Dispatching_Operation is not
12759 -- called in that case.
12761 if No
(Derived_Type
)
12762 or else Is_Tagged_Type
(Derived_Type
)
12764 Check_Dispatching_Operation
(S
, Empty
);
12768 -- If this is a user-defined equality operator that is not a derived
12769 -- subprogram, create the corresponding inequality. If the operation is
12770 -- dispatching, the expansion is done elsewhere, and we do not create
12771 -- an explicit inequality operation.
12773 <<Check_Inequality
>>
12774 if Chars
(S
) = Name_Op_Eq
12775 and then Etype
(S
) = Standard_Boolean
12776 and then Present
(Parent
(S
))
12777 and then not Is_Dispatching_Operation
(S
)
12779 Make_Inequality_Operator
(S
);
12780 Check_Untagged_Equality
(S
);
12782 end New_Overloaded_Entity
;
12784 ----------------------------------
12785 -- Preanalyze_Formal_Expression --
12786 ----------------------------------
12788 procedure Preanalyze_Formal_Expression
(N
: Node_Id
; T
: Entity_Id
) is
12789 Save_In_Spec_Expression
: constant Boolean := In_Spec_Expression
;
12791 In_Spec_Expression
:= True;
12792 Preanalyze_With_Freezing_And_Resolve
(N
, T
);
12793 In_Spec_Expression
:= Save_In_Spec_Expression
;
12794 end Preanalyze_Formal_Expression
;
12796 ---------------------
12797 -- Process_Formals --
12798 ---------------------
12800 procedure Process_Formals
12802 Related_Nod
: Node_Id
)
12804 function Designates_From_Limited_With
(Typ
: Entity_Id
) return Boolean;
12805 -- Determine whether an access type designates a type coming from a
12808 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean;
12809 -- Check whether the default has a class-wide type. After analysis the
12810 -- default has the type of the formal, so we must also check explicitly
12811 -- for an access attribute.
12813 ----------------------------------
12814 -- Designates_From_Limited_With --
12815 ----------------------------------
12817 function Designates_From_Limited_With
(Typ
: Entity_Id
) return Boolean is
12818 Desig
: Entity_Id
:= Typ
;
12821 if Is_Access_Type
(Desig
) then
12822 Desig
:= Directly_Designated_Type
(Desig
);
12825 if Is_Class_Wide_Type
(Desig
) then
12826 Desig
:= Root_Type
(Desig
);
12830 Ekind
(Desig
) = E_Incomplete_Type
12831 and then From_Limited_With
(Desig
);
12832 end Designates_From_Limited_With
;
12834 ---------------------------
12835 -- Is_Class_Wide_Default --
12836 ---------------------------
12838 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean is
12840 return Is_Class_Wide_Type
(Designated_Type
(Etype
(D
)))
12841 or else (Nkind
(D
) = N_Attribute_Reference
12842 and then Attribute_Name
(D
) = Name_Access
12843 and then Is_Class_Wide_Type
(Etype
(Prefix
(D
))));
12844 end Is_Class_Wide_Default
;
12848 Context
: constant Node_Id
:= Parent
(Parent
(T
));
12850 Formal
: Entity_Id
;
12851 Formal_Type
: Entity_Id
;
12852 Param_Spec
: Node_Id
;
12855 Num_Out_Params
: Nat
:= 0;
12856 First_Out_Param
: Entity_Id
:= Empty
;
12857 -- Used for setting Is_Only_Out_Parameter
12859 -- Start of processing for Process_Formals
12862 -- In order to prevent premature use of the formals in the same formal
12863 -- part, the Ekind is left undefined until all default expressions are
12864 -- analyzed. The Ekind is established in a separate loop at the end.
12866 Param_Spec
:= First
(T
);
12867 while Present
(Param_Spec
) loop
12868 Formal
:= Defining_Identifier
(Param_Spec
);
12869 Set_Never_Set_In_Source
(Formal
, True);
12870 Enter_Name
(Formal
);
12872 -- Case of ordinary parameters
12874 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
12875 Find_Type
(Parameter_Type
(Param_Spec
));
12876 Ptype
:= Parameter_Type
(Param_Spec
);
12878 if Ptype
= Error
then
12882 -- Protect against malformed parameter types
12884 if Nkind
(Ptype
) not in N_Has_Entity
then
12885 Formal_Type
:= Any_Type
;
12887 Formal_Type
:= Entity
(Ptype
);
12890 if Is_Incomplete_Type
(Formal_Type
)
12892 (Is_Class_Wide_Type
(Formal_Type
)
12893 and then Is_Incomplete_Type
(Root_Type
(Formal_Type
)))
12895 -- Ada 2005 (AI-326): Tagged incomplete types allowed in
12896 -- primitive operations, as long as their completion is
12897 -- in the same declarative part. If in the private part
12898 -- this means that the type cannot be a Taft-amendment type.
12899 -- Check is done on package exit. For access to subprograms,
12900 -- the use is legal for Taft-amendment types.
12902 -- Ada 2012: tagged incomplete types are allowed as generic
12903 -- formal types. They do not introduce dependencies and the
12904 -- corresponding generic subprogram does not have a delayed
12905 -- freeze, because it does not need a freeze node. However,
12906 -- it is still the case that untagged incomplete types cannot
12907 -- be Taft-amendment types and must be completed in private
12908 -- part, so the subprogram must appear in the list of private
12909 -- dependents of the type.
12911 if Is_Tagged_Type
(Formal_Type
)
12912 or else (Ada_Version
>= Ada_2012
12913 and then not From_Limited_With
(Formal_Type
)
12914 and then not Is_Generic_Type
(Formal_Type
))
12916 if Ekind
(Scope
(Current_Scope
)) = E_Package
12917 and then not Is_Generic_Type
(Formal_Type
)
12918 and then not Is_Class_Wide_Type
(Formal_Type
)
12920 if Nkind
(Parent
(T
)) not in
12921 N_Access_Function_Definition |
12922 N_Access_Procedure_Definition
12924 Append_Elmt
(Current_Scope
,
12925 Private_Dependents
(Base_Type
(Formal_Type
)));
12927 -- Freezing is delayed to ensure that Register_Prim
12928 -- will get called for this operation, which is needed
12929 -- in cases where static dispatch tables aren't built.
12930 -- (Note that the same is done for controlling access
12931 -- parameter cases in function Access_Definition.)
12933 if not Is_Thunk
(Current_Scope
) then
12934 Set_Has_Delayed_Freeze
(Current_Scope
);
12939 elsif Nkind
(Parent
(T
)) not in N_Access_Function_Definition
12940 | N_Access_Procedure_Definition
12942 -- AI05-0151: Tagged incomplete types are allowed in all
12943 -- formal parts. Untagged incomplete types are not allowed
12944 -- in bodies. Limited views of either kind are not allowed
12945 -- if there is no place at which the non-limited view can
12946 -- become available.
12948 -- Incomplete formal untagged types are not allowed in
12949 -- subprogram bodies (but are legal in their declarations).
12950 -- This excludes bodies created for null procedures, which
12951 -- are basic declarations.
12953 if Is_Generic_Type
(Formal_Type
)
12954 and then not Is_Tagged_Type
(Formal_Type
)
12955 and then Nkind
(Parent
(Related_Nod
)) = N_Subprogram_Body
12958 ("invalid use of formal incomplete type", Param_Spec
);
12960 elsif Ada_Version
>= Ada_2012
then
12961 if Is_Tagged_Type
(Formal_Type
)
12962 and then (not From_Limited_With
(Formal_Type
)
12963 or else not In_Package_Body
)
12967 elsif Nkind
(Context
) in N_Accept_Statement
12968 | N_Accept_Alternative
12970 or else (Nkind
(Context
) = N_Subprogram_Body
12971 and then Comes_From_Source
(Context
))
12974 ("invalid use of untagged incomplete type &",
12975 Ptype
, Formal_Type
);
12980 ("invalid use of incomplete type&",
12981 Param_Spec
, Formal_Type
);
12983 -- Further checks on the legality of incomplete types
12984 -- in formal parts are delayed until the freeze point
12985 -- of the enclosing subprogram or access to subprogram.
12989 elsif Ekind
(Formal_Type
) = E_Void
then
12991 ("premature use of&",
12992 Parameter_Type
(Param_Spec
), Formal_Type
);
12995 -- Ada 2012 (AI-142): Handle aliased parameters
12997 if Ada_Version
>= Ada_2012
12998 and then Aliased_Present
(Param_Spec
)
13000 Set_Is_Aliased
(Formal
);
13002 -- AI12-001: All aliased objects are considered to be specified
13003 -- as independently addressable (RM C.6(8.1/4)).
13005 Set_Is_Independent
(Formal
);
13008 -- Ada 2005 (AI-231): Create and decorate an internal subtype
13009 -- declaration corresponding to the null-excluding type of the
13010 -- formal in the enclosing scope. Finally, replace the parameter
13011 -- type of the formal with the internal subtype.
13013 if Ada_Version
>= Ada_2005
13014 and then Null_Exclusion_Present
(Param_Spec
)
13016 if not Is_Access_Type
(Formal_Type
) then
13018 ("`NOT NULL` allowed only for an access type", Param_Spec
);
13021 if Can_Never_Be_Null
(Formal_Type
)
13022 and then Comes_From_Source
(Related_Nod
)
13025 ("`NOT NULL` not allowed (& already excludes null)",
13026 Param_Spec
, Formal_Type
);
13030 Create_Null_Excluding_Itype
13032 Related_Nod
=> Related_Nod
,
13033 Scope_Id
=> Scope
(Current_Scope
));
13035 -- If the designated type of the itype is an itype that is
13036 -- not frozen yet, we set the Has_Delayed_Freeze attribute
13037 -- on the access subtype, to prevent order-of-elaboration
13038 -- issues in the backend.
13041 -- type T is access procedure;
13042 -- procedure Op (O : not null T);
13044 if Is_Itype
(Directly_Designated_Type
(Formal_Type
))
13046 not Is_Frozen
(Directly_Designated_Type
(Formal_Type
))
13048 Set_Has_Delayed_Freeze
(Formal_Type
);
13053 -- An access formal type
13057 Access_Definition
(Related_Nod
, Parameter_Type
(Param_Spec
));
13059 -- No need to continue if we already notified errors
13061 if No
(Formal_Type
) then
13065 -- Ada 2005 (AI-254)
13068 AD
: constant Node_Id
:=
13069 Access_To_Subprogram_Definition
13070 (Parameter_Type
(Param_Spec
));
13072 if Present
(AD
) and then Protected_Present
(AD
) then
13074 Replace_Anonymous_Access_To_Protected_Subprogram
13080 Set_Etype
(Formal
, Formal_Type
);
13082 -- Deal with default expression if present
13084 Default
:= Expression
(Param_Spec
);
13086 if Present
(Default
) then
13087 if Out_Present
(Param_Spec
) then
13089 ("default initialization only allowed for IN parameters",
13093 -- Do the special preanalysis of the expression (see section on
13094 -- "Handling of Default Expressions" in the spec of package Sem).
13096 Preanalyze_Formal_Expression
(Default
, Formal_Type
);
13098 -- An access to constant cannot be the default for
13099 -- an access parameter that is an access to variable.
13101 if Ekind
(Formal_Type
) = E_Anonymous_Access_Type
13102 and then not Is_Access_Constant
(Formal_Type
)
13103 and then Is_Access_Type
(Etype
(Default
))
13104 and then Is_Access_Constant
(Etype
(Default
))
13107 ("formal that is access to variable cannot be initialized "
13108 & "with an access-to-constant expression", Default
);
13111 -- Check that the designated type of an access parameter's default
13112 -- is not a class-wide type unless the parameter's designated type
13113 -- is also class-wide.
13115 if Ekind
(Formal_Type
) = E_Anonymous_Access_Type
13116 and then not Designates_From_Limited_With
(Formal_Type
)
13117 and then Is_Class_Wide_Default
(Default
)
13118 and then not Is_Class_Wide_Type
(Designated_Type
(Formal_Type
))
13121 ("access to class-wide expression not allowed here", Default
);
13124 -- Check incorrect use of dynamically tagged expressions
13126 if Is_Tagged_Type
(Formal_Type
) then
13127 Check_Dynamically_Tagged_Expression
13129 Typ
=> Formal_Type
,
13130 Related_Nod
=> Default
);
13134 -- Ada 2005 (AI-231): Static checks
13136 if Ada_Version
>= Ada_2005
13137 and then Is_Access_Type
(Etype
(Formal
))
13138 and then Can_Never_Be_Null
(Etype
(Formal
))
13140 Null_Exclusion_Static_Checks
(Param_Spec
);
13143 -- Deal with aspects on formal parameters. Only Unreferenced is
13144 -- supported for the time being.
13146 if Has_Aspects
(Param_Spec
) then
13148 Aspect
: Node_Id
:= First
(Aspect_Specifications
(Param_Spec
));
13150 while Present
(Aspect
) loop
13151 if Chars
(Identifier
(Aspect
)) = Name_Unreferenced
then
13152 Set_Has_Pragma_Unreferenced
(Formal
);
13155 ("unsupported aspect& on parameter",
13156 Aspect
, Identifier
(Aspect
));
13168 -- If this is the formal part of a function specification, analyze the
13169 -- subtype mark in the context where the formals are visible but not
13170 -- yet usable, and may hide outer homographs.
13172 if Nkind
(Related_Nod
) = N_Function_Specification
then
13173 Analyze_Return_Type
(Related_Nod
);
13176 -- Now set the kind (mode) of each formal
13178 Param_Spec
:= First
(T
);
13179 while Present
(Param_Spec
) loop
13180 Formal
:= Defining_Identifier
(Param_Spec
);
13181 Set_Formal_Mode
(Formal
);
13183 if Ekind
(Formal
) = E_In_Parameter
then
13184 Default
:= Expression
(Param_Spec
);
13186 if Present
(Default
) then
13187 Set_Default_Value
(Formal
, Default
);
13189 if Is_Scalar_Type
(Etype
(Default
)) then
13190 if Nkind
(Parameter_Type
(Param_Spec
)) /=
13191 N_Access_Definition
13193 Formal_Type
:= Entity
(Parameter_Type
(Param_Spec
));
13197 (Related_Nod
, Parameter_Type
(Param_Spec
));
13200 Apply_Scalar_Range_Check
(Default
, Formal_Type
);
13204 elsif Ekind
(Formal
) = E_Out_Parameter
then
13205 Num_Out_Params
:= Num_Out_Params
+ 1;
13207 if Num_Out_Params
= 1 then
13208 First_Out_Param
:= Formal
;
13211 elsif Ekind
(Formal
) = E_In_Out_Parameter
then
13212 Num_Out_Params
:= Num_Out_Params
+ 1;
13215 -- Skip remaining processing if formal type was in error
13217 if Etype
(Formal
) = Any_Type
or else Error_Posted
(Formal
) then
13218 goto Next_Parameter
;
13221 -- Force call by reference if aliased
13224 Conv
: constant Convention_Id
:= Convention
(Etype
(Formal
));
13226 if Is_Aliased
(Formal
) then
13227 Set_Mechanism
(Formal
, By_Reference
);
13229 -- Warn if user asked this to be passed by copy
13231 if Conv
= Convention_Ada_Pass_By_Copy
then
13233 ("cannot pass aliased parameter & by copy??", Formal
);
13236 -- Force mechanism if type has Convention Ada_Pass_By_Ref/Copy
13238 elsif Conv
= Convention_Ada_Pass_By_Copy
then
13239 Set_Mechanism
(Formal
, By_Copy
);
13241 elsif Conv
= Convention_Ada_Pass_By_Reference
then
13242 Set_Mechanism
(Formal
, By_Reference
);
13250 if Present
(First_Out_Param
) and then Num_Out_Params
= 1 then
13251 Set_Is_Only_Out_Parameter
(First_Out_Param
);
13253 end Process_Formals
;
13255 ----------------------------
13256 -- Reference_Body_Formals --
13257 ----------------------------
13259 procedure Reference_Body_Formals
(Spec
: Entity_Id
; Bod
: Entity_Id
) is
13264 if Error_Posted
(Spec
) then
13268 -- Iterate over both lists. They may be of different lengths if the two
13269 -- specs are not conformant.
13271 Fs
:= First_Formal
(Spec
);
13272 Fb
:= First_Formal
(Bod
);
13273 while Present
(Fs
) and then Present
(Fb
) loop
13274 Generate_Reference
(Fs
, Fb
, 'b');
13276 if Style_Check
then
13277 Style
.Check_Identifier
(Fb
, Fs
);
13280 Set_Spec_Entity
(Fb
, Fs
);
13281 Set_Referenced
(Fs
, False);
13285 end Reference_Body_Formals
;
13287 -------------------------
13288 -- Set_Actual_Subtypes --
13289 -------------------------
13291 procedure Set_Actual_Subtypes
(N
: Node_Id
; Subp
: Entity_Id
) is
13293 Formal
: Entity_Id
;
13295 First_Stmt
: Node_Id
:= Empty
;
13296 AS_Needed
: Boolean;
13299 -- If this is an empty initialization procedure, no need to create
13300 -- actual subtypes (small optimization).
13302 if Ekind
(Subp
) = E_Procedure
and then Is_Null_Init_Proc
(Subp
) then
13305 -- Within a predicate function we do not want to generate local
13306 -- subtypes that may generate nested predicate functions.
13308 elsif Is_Subprogram
(Subp
) and then Is_Predicate_Function
(Subp
) then
13312 -- The subtype declarations may freeze the formals. The body generated
13313 -- for an expression function is not a freeze point, so do not emit
13314 -- these declarations (small loss of efficiency in rare cases).
13316 if Nkind
(N
) = N_Subprogram_Body
13317 and then Was_Expression_Function
(N
)
13322 Formal
:= First_Formal
(Subp
);
13323 while Present
(Formal
) loop
13324 T
:= Etype
(Formal
);
13326 -- We never need an actual subtype for a constrained formal
13328 if Is_Constrained
(T
) then
13329 AS_Needed
:= False;
13331 -- If we have unknown discriminants, then we do not need an actual
13332 -- subtype, or more accurately we cannot figure it out. Note that
13333 -- all class-wide types have unknown discriminants.
13335 elsif Has_Unknown_Discriminants
(T
) then
13336 AS_Needed
:= False;
13338 -- At this stage we have an unconstrained type that may need an
13339 -- actual subtype. For sure the actual subtype is needed if we have
13340 -- an unconstrained array type. However, in an instance, the type
13341 -- may appear as a subtype of the full view, while the actual is
13342 -- in fact private (in which case no actual subtype is needed) so
13343 -- check the kind of the base type.
13345 elsif Is_Array_Type
(Base_Type
(T
)) then
13348 -- The only other case needing an actual subtype is an unconstrained
13349 -- record type which is an IN parameter (we cannot generate actual
13350 -- subtypes for the OUT or IN OUT case, since an assignment can
13351 -- change the discriminant values. However we exclude the case of
13352 -- initialization procedures, since discriminants are handled very
13353 -- specially in this context, see the section entitled "Handling of
13354 -- Discriminants" in Einfo.
13356 -- We also exclude the case of Discrim_SO_Functions (functions used
13357 -- in front-end layout mode for size/offset values), since in such
13358 -- functions only discriminants are referenced, and not only are such
13359 -- subtypes not needed, but they cannot always be generated, because
13360 -- of order of elaboration issues.
13362 elsif Is_Record_Type
(T
)
13363 and then Ekind
(Formal
) = E_In_Parameter
13364 and then Chars
(Formal
) /= Name_uInit
13365 and then not Is_Unchecked_Union
(T
)
13366 and then not Is_Discrim_SO_Function
(Subp
)
13370 -- All other cases do not need an actual subtype
13373 AS_Needed
:= False;
13376 -- Generate actual subtypes for unconstrained arrays and
13377 -- unconstrained discriminated records.
13380 if Nkind
(N
) = N_Accept_Statement
then
13382 -- If expansion is active, the formal is replaced by a local
13383 -- variable that renames the corresponding entry of the
13384 -- parameter block, and it is this local variable that may
13385 -- require an actual subtype.
13387 if Expander_Active
then
13388 Decl
:= Build_Actual_Subtype
(T
, Renamed_Object
(Formal
));
13390 Decl
:= Build_Actual_Subtype
(T
, Formal
);
13393 if Present
(Handled_Statement_Sequence
(N
)) then
13395 First
(Statements
(Handled_Statement_Sequence
(N
)));
13396 Prepend
(Decl
, Statements
(Handled_Statement_Sequence
(N
)));
13397 Mark_Rewrite_Insertion
(Decl
);
13399 -- If the accept statement has no body, there will be no
13400 -- reference to the actuals, so no need to compute actual
13407 Decl
:= Build_Actual_Subtype
(T
, Formal
);
13408 Prepend
(Decl
, Declarations
(N
));
13409 Mark_Rewrite_Insertion
(Decl
);
13412 -- The declaration uses the bounds of an existing object, and
13413 -- therefore needs no constraint checks.
13415 Analyze
(Decl
, Suppress
=> All_Checks
);
13416 Set_Is_Actual_Subtype
(Defining_Identifier
(Decl
));
13418 -- We need to freeze manually the generated type when it is
13419 -- inserted anywhere else than in a declarative part.
13421 if Present
(First_Stmt
) then
13422 Insert_List_Before_And_Analyze
(First_Stmt
,
13423 Freeze_Entity
(Defining_Identifier
(Decl
), N
));
13425 -- Ditto if the type has a dynamic predicate, because the
13426 -- generated function will mention the actual subtype. The
13427 -- predicate may come from an explicit aspect of be inherited.
13429 elsif Has_Predicates
(T
) then
13430 Insert_List_After_And_Analyze
(Decl
,
13431 Freeze_Entity
(Defining_Identifier
(Decl
), N
));
13434 if Nkind
(N
) = N_Accept_Statement
13435 and then Expander_Active
13437 Set_Actual_Subtype
(Renamed_Object
(Formal
),
13438 Defining_Identifier
(Decl
));
13440 Set_Actual_Subtype
(Formal
, Defining_Identifier
(Decl
));
13444 Next_Formal
(Formal
);
13446 end Set_Actual_Subtypes
;
13448 ---------------------
13449 -- Set_Formal_Mode --
13450 ---------------------
13452 procedure Set_Formal_Mode
(Formal_Id
: Entity_Id
) is
13453 Spec
: constant Node_Id
:= Parent
(Formal_Id
);
13454 Id
: constant Entity_Id
:= Scope
(Formal_Id
);
13457 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
13458 -- since we ensure that corresponding actuals are always valid at the
13459 -- point of the call.
13461 if Out_Present
(Spec
) then
13463 or else Is_Subprogram_Or_Generic_Subprogram
(Id
)
13465 Set_Has_Out_Or_In_Out_Parameter
(Id
, True);
13468 if Ekind
(Id
) in E_Function | E_Generic_Function
then
13470 -- [IN] OUT parameters allowed for functions in Ada 2012
13472 if Ada_Version
>= Ada_2012
then
13474 -- Even in Ada 2012 operators can only have IN parameters
13476 if Is_Operator_Symbol_Name
(Chars
(Scope
(Formal_Id
))) then
13477 Error_Msg_N
("operators can only have IN parameters", Spec
);
13480 if In_Present
(Spec
) then
13481 Mutate_Ekind
(Formal_Id
, E_In_Out_Parameter
);
13483 Mutate_Ekind
(Formal_Id
, E_Out_Parameter
);
13486 -- But not in earlier versions of Ada
13489 Error_Msg_N
("functions can only have IN parameters", Spec
);
13490 Mutate_Ekind
(Formal_Id
, E_In_Parameter
);
13493 elsif In_Present
(Spec
) then
13494 Mutate_Ekind
(Formal_Id
, E_In_Out_Parameter
);
13497 Mutate_Ekind
(Formal_Id
, E_Out_Parameter
);
13498 Set_Is_True_Constant
(Formal_Id
, False);
13499 Set_Current_Value
(Formal_Id
, Empty
);
13503 Mutate_Ekind
(Formal_Id
, E_In_Parameter
);
13506 Set_Is_Not_Self_Hidden
(Formal_Id
);
13508 -- Set Is_Known_Non_Null for access parameters since the language
13509 -- guarantees that access parameters are always non-null. We also set
13510 -- Can_Never_Be_Null, since there is no way to change the value.
13512 if Nkind
(Parameter_Type
(Spec
)) = N_Access_Definition
then
13514 -- Ada 2005 (AI-231): In Ada 95, access parameters are always non-
13515 -- null; In Ada 2005, only if then null_exclusion is explicit.
13517 if Ada_Version
< Ada_2005
13518 or else Can_Never_Be_Null
(Etype
(Formal_Id
))
13520 Set_Is_Known_Non_Null
(Formal_Id
);
13521 Set_Can_Never_Be_Null
(Formal_Id
);
13524 -- Ada 2005 (AI-231): Null-exclusion access subtype
13526 elsif Is_Access_Type
(Etype
(Formal_Id
))
13527 and then Can_Never_Be_Null
(Etype
(Formal_Id
))
13529 Set_Is_Known_Non_Null
(Formal_Id
);
13531 -- We can also set Can_Never_Be_Null (thus preventing some junk
13532 -- access checks) for the case of an IN parameter, which cannot
13533 -- be changed, or for an IN OUT parameter, which can be changed but
13534 -- not to a null value. But for an OUT parameter, the initial value
13535 -- passed in can be null, so we can't set this flag in that case.
13537 if Ekind
(Formal_Id
) /= E_Out_Parameter
then
13538 Set_Can_Never_Be_Null
(Formal_Id
);
13542 Set_Mechanism
(Formal_Id
, Default_Mechanism
);
13543 Set_Formal_Validity
(Formal_Id
);
13544 end Set_Formal_Mode
;
13546 -------------------------
13547 -- Set_Formal_Validity --
13548 -------------------------
13550 procedure Set_Formal_Validity
(Formal_Id
: Entity_Id
) is
13552 -- If no validity checking, then we cannot assume anything about the
13553 -- validity of parameters, since we do not know there is any checking
13554 -- of the validity on the call side.
13556 if not Validity_Checks_On
then
13559 -- If validity checking for parameters is enabled, this means we are
13560 -- not supposed to make any assumptions about argument values.
13562 elsif Validity_Check_Parameters
then
13565 -- If we are checking in parameters, we will assume that the caller is
13566 -- also checking parameters, so we can assume the parameter is valid.
13568 elsif Ekind
(Formal_Id
) = E_In_Parameter
13569 and then Validity_Check_In_Params
13571 Set_Is_Known_Valid
(Formal_Id
, True);
13573 -- Similar treatment for IN OUT parameters
13575 elsif Ekind
(Formal_Id
) = E_In_Out_Parameter
13576 and then Validity_Check_In_Out_Params
13578 Set_Is_Known_Valid
(Formal_Id
, True);
13580 end Set_Formal_Validity
;
13582 ------------------------
13583 -- Subtype_Conformant --
13584 ------------------------
13586 function Subtype_Conformant
13587 (New_Id
: Entity_Id
;
13588 Old_Id
: Entity_Id
;
13589 Skip_Controlling_Formals
: Boolean := False) return Boolean
13593 Check_Conformance
(New_Id
, Old_Id
, Subtype_Conformant
, False, Result
,
13594 Skip_Controlling_Formals
=> Skip_Controlling_Formals
);
13596 end Subtype_Conformant
;
13598 ---------------------
13599 -- Type_Conformant --
13600 ---------------------
13602 function Type_Conformant
13603 (New_Id
: Entity_Id
;
13604 Old_Id
: Entity_Id
;
13605 Skip_Controlling_Formals
: Boolean := False) return Boolean
13609 May_Hide_Profile
:= False;
13611 (New_Id
, Old_Id
, Type_Conformant
, False, Result
,
13612 Skip_Controlling_Formals
=> Skip_Controlling_Formals
);
13614 end Type_Conformant
;
13616 -------------------------------
13617 -- Valid_Operator_Definition --
13618 -------------------------------
13620 procedure Valid_Operator_Definition
(Designator
: Entity_Id
) is
13623 Id
: constant Name_Id
:= Chars
(Designator
);
13627 F
:= First_Formal
(Designator
);
13628 while Present
(F
) loop
13631 if Present
(Default_Value
(F
)) then
13633 ("default values not allowed for operator parameters",
13636 -- For function instantiations that are operators, we must check
13637 -- separately that the corresponding generic only has in-parameters.
13638 -- For subprogram declarations this is done in Set_Formal_Mode. Such
13639 -- an error could not arise in earlier versions of the language.
13641 elsif Ekind
(F
) /= E_In_Parameter
then
13642 Error_Msg_N
("operators can only have IN parameters", F
);
13648 -- Verify that user-defined operators have proper number of arguments
13649 -- First case of operators which can only be unary
13651 if Id
in Name_Op_Not | Name_Op_Abs
then
13654 -- Case of operators which can be unary or binary
13656 elsif Id
in Name_Op_Add | Name_Op_Subtract
then
13657 N_OK
:= (N
in 1 .. 2);
13659 -- All other operators can only be binary
13667 ("incorrect number of arguments for operator", Designator
);
13671 and then Base_Type
(Etype
(Designator
)) = Standard_Boolean
13672 and then not Is_Intrinsic_Subprogram
(Designator
)
13675 ("explicit definition of inequality not allowed", Designator
);
13677 end Valid_Operator_Definition
;