1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Contracts
; use Contracts
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Elists
; use Elists
;
33 with Errout
; use Errout
;
34 with Expander
; use Expander
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch7
; use Exp_Ch7
;
37 with Exp_Ch9
; use Exp_Ch9
;
38 with Exp_Dbug
; use Exp_Dbug
;
39 with Exp_Disp
; use Exp_Disp
;
40 with Exp_Tss
; use Exp_Tss
;
41 with Exp_Util
; use Exp_Util
;
42 with Fname
; use Fname
;
43 with Freeze
; use Freeze
;
44 with Ghost
; use Ghost
;
45 with Inline
; use Inline
;
46 with Itypes
; use Itypes
;
47 with Lib
.Xref
; use Lib
.Xref
;
48 with Layout
; use Layout
;
49 with Namet
; use Namet
;
51 with Nlists
; use Nlists
;
52 with Nmake
; use Nmake
;
54 with Output
; use Output
;
55 with Restrict
; use Restrict
;
56 with Rident
; use Rident
;
57 with Rtsfind
; use Rtsfind
;
59 with Sem_Aux
; use Sem_Aux
;
60 with Sem_Cat
; use Sem_Cat
;
61 with Sem_Ch3
; use Sem_Ch3
;
62 with Sem_Ch4
; use Sem_Ch4
;
63 with Sem_Ch5
; use Sem_Ch5
;
64 with Sem_Ch8
; use Sem_Ch8
;
65 with Sem_Ch10
; use Sem_Ch10
;
66 with Sem_Ch12
; use Sem_Ch12
;
67 with Sem_Ch13
; use Sem_Ch13
;
68 with Sem_Dim
; use Sem_Dim
;
69 with Sem_Disp
; use Sem_Disp
;
70 with Sem_Dist
; use Sem_Dist
;
71 with Sem_Elim
; use Sem_Elim
;
72 with Sem_Eval
; use Sem_Eval
;
73 with Sem_Mech
; use Sem_Mech
;
74 with Sem_Prag
; use Sem_Prag
;
75 with Sem_Res
; use Sem_Res
;
76 with Sem_Util
; use Sem_Util
;
77 with Sem_Type
; use Sem_Type
;
78 with Sem_Warn
; use Sem_Warn
;
79 with Sinput
; use Sinput
;
80 with Stand
; use Stand
;
81 with Sinfo
; use Sinfo
;
82 with Sinfo
.CN
; use Sinfo
.CN
;
83 with Snames
; use Snames
;
84 with Stringt
; use Stringt
;
86 with Stylesw
; use Stylesw
;
87 with Tbuild
; use Tbuild
;
88 with Uintp
; use Uintp
;
89 with Urealp
; use Urealp
;
90 with Validsw
; use Validsw
;
92 package body Sem_Ch6
is
94 May_Hide_Profile
: Boolean := False;
95 -- This flag is used to indicate that two formals in two subprograms being
96 -- checked for conformance differ only in that one is an access parameter
97 -- while the other is of a general access type with the same designated
98 -- type. In this case, if the rest of the signatures match, a call to
99 -- either subprogram may be ambiguous, which is worth a warning. The flag
100 -- is set in Compatible_Types, and the warning emitted in
101 -- New_Overloaded_Entity.
103 -----------------------
104 -- Local Subprograms --
105 -----------------------
107 procedure Analyze_Function_Return
(N
: Node_Id
);
108 -- Subsidiary to Analyze_Return_Statement. Called when the return statement
109 -- applies to a [generic] function.
111 procedure Analyze_Generic_Subprogram_Body
(N
: Node_Id
; Gen_Id
: Entity_Id
);
112 -- Analyze a generic subprogram body. N is the body to be analyzed, and
113 -- Gen_Id is the defining entity Id for the corresponding spec.
115 procedure Analyze_Null_Procedure
117 Is_Completion
: out Boolean);
118 -- A null procedure can be a declaration or (Ada 2012) a completion
120 procedure Analyze_Return_Statement
(N
: Node_Id
);
121 -- Common processing for simple and extended return statements
123 procedure Analyze_Return_Type
(N
: Node_Id
);
124 -- Subsidiary to Process_Formals: analyze subtype mark in function
125 -- specification in a context where the formals are visible and hide
128 procedure Analyze_Subprogram_Body_Helper
(N
: Node_Id
);
129 -- Does all the real work of Analyze_Subprogram_Body. This is split out so
130 -- that we can use RETURN but not skip the debug output at the end.
132 function Can_Override_Operator
(Subp
: Entity_Id
) return Boolean;
133 -- Returns true if Subp can override a predefined operator.
135 procedure Check_Conformance
138 Ctype
: Conformance_Type
;
140 Conforms
: out Boolean;
141 Err_Loc
: Node_Id
:= Empty
;
142 Get_Inst
: Boolean := False;
143 Skip_Controlling_Formals
: Boolean := False);
144 -- Given two entities, this procedure checks that the profiles associated
145 -- with these entities meet the conformance criterion given by the third
146 -- parameter. If they conform, Conforms is set True and control returns
147 -- to the caller. If they do not conform, Conforms is set to False, and
148 -- in addition, if Errmsg is True on the call, proper messages are output
149 -- to complain about the conformance failure. If Err_Loc is non_Empty
150 -- the error messages are placed on Err_Loc, if Err_Loc is empty, then
151 -- error messages are placed on the appropriate part of the construct
152 -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance
153 -- against a formal access-to-subprogram type so Get_Instance_Of must
156 procedure Check_Limited_Return
160 -- Check the appropriate (Ada 95 or Ada 2005) rules for returning limited
161 -- types. Used only for simple return statements. Expr is the expression
164 procedure Check_Subprogram_Order
(N
: Node_Id
);
165 -- N is the N_Subprogram_Body node for a subprogram. This routine applies
166 -- the alpha ordering rule for N if this ordering requirement applicable.
168 procedure Check_Returns
172 Proc
: Entity_Id
:= Empty
);
173 -- Called to check for missing return statements in a function body, or for
174 -- returns present in a procedure body which has No_Return set. HSS is the
175 -- handled statement sequence for the subprogram body. This procedure
176 -- checks all flow paths to make sure they either have return (Mode = 'F',
177 -- used for functions) or do not have a return (Mode = 'P', used for
178 -- No_Return procedures). The flag Err is set if there are any control
179 -- paths not explicitly terminated by a return in the function case, and is
180 -- True otherwise. Proc is the entity for the procedure case and is used
181 -- in posting the warning message.
183 procedure Check_Untagged_Equality
(Eq_Op
: Entity_Id
);
184 -- In Ada 2012, a primitive equality operator on an untagged record type
185 -- must appear before the type is frozen, and have the same visibility as
186 -- that of the type. This procedure checks that this rule is met, and
187 -- otherwise emits an error on the subprogram declaration and a warning
188 -- on the earlier freeze point if it is easy to locate. In Ada 2012 mode,
189 -- this routine outputs errors (or warnings if -gnatd.E is set). In earlier
190 -- versions of Ada, warnings are output if Warn_On_Ada_2012_Incompatibility
191 -- is set, otherwise the call has no effect.
193 procedure Enter_Overloaded_Entity
(S
: Entity_Id
);
194 -- This procedure makes S, a new overloaded entity, into the first visible
195 -- entity with that name.
197 function Is_Non_Overriding_Operation
199 New_E
: Entity_Id
) return Boolean;
200 -- Enforce the rule given in 12.3(18): a private operation in an instance
201 -- overrides an inherited operation only if the corresponding operation
202 -- was overriding in the generic. This needs to be checked for primitive
203 -- operations of types derived (in the generic unit) from formal private
204 -- or formal derived types.
206 procedure Make_Inequality_Operator
(S
: Entity_Id
);
207 -- Create the declaration for an inequality operator that is implicitly
208 -- created by a user-defined equality operator that yields a boolean.
210 procedure Set_Formal_Validity
(Formal_Id
: Entity_Id
);
211 -- Formal_Id is an formal parameter entity. This procedure deals with
212 -- setting the proper validity status for this entity, which depends on
213 -- the kind of parameter and the validity checking mode.
215 ---------------------------------------------
216 -- Analyze_Abstract_Subprogram_Declaration --
217 ---------------------------------------------
219 procedure Analyze_Abstract_Subprogram_Declaration
(N
: Node_Id
) is
220 Scop
: constant Entity_Id
:= Current_Scope
;
221 Subp_Id
: constant Entity_Id
:=
222 Analyze_Subprogram_Specification
(Specification
(N
));
225 Check_SPARK_05_Restriction
("abstract subprogram is not allowed", N
);
227 Generate_Definition
(Subp_Id
);
229 Set_Is_Abstract_Subprogram
(Subp_Id
);
230 New_Overloaded_Entity
(Subp_Id
);
231 Check_Delayed_Subprogram
(Subp_Id
);
233 Set_Categorization_From_Scope
(Subp_Id
, Scop
);
235 -- An abstract subprogram declared within a Ghost region is rendered
236 -- Ghost (SPARK RM 6.9(2)).
238 if Ghost_Mode
> None
then
239 Set_Is_Ghost_Entity
(Subp_Id
);
242 if Ekind
(Scope
(Subp_Id
)) = E_Protected_Type
then
243 Error_Msg_N
("abstract subprogram not allowed in protected type", N
);
245 -- Issue a warning if the abstract subprogram is neither a dispatching
246 -- operation nor an operation that overrides an inherited subprogram or
247 -- predefined operator, since this most likely indicates a mistake.
249 elsif Warn_On_Redundant_Constructs
250 and then not Is_Dispatching_Operation
(Subp_Id
)
251 and then not Present
(Overridden_Operation
(Subp_Id
))
252 and then (not Is_Operator_Symbol_Name
(Chars
(Subp_Id
))
253 or else Scop
/= Scope
(Etype
(First_Formal
(Subp_Id
))))
256 ("abstract subprogram is not dispatching or overriding?r?", N
);
259 Generate_Reference_To_Formals
(Subp_Id
);
260 Check_Eliminated
(Subp_Id
);
262 if Has_Aspects
(N
) then
263 Analyze_Aspect_Specifications
(N
, Subp_Id
);
265 end Analyze_Abstract_Subprogram_Declaration
;
267 ---------------------------------
268 -- Analyze_Expression_Function --
269 ---------------------------------
271 procedure Analyze_Expression_Function
(N
: Node_Id
) is
272 Expr
: constant Node_Id
:= Expression
(N
);
273 Loc
: constant Source_Ptr
:= Sloc
(N
);
274 LocX
: constant Source_Ptr
:= Sloc
(Expr
);
275 Spec
: constant Node_Id
:= Specification
(N
);
280 -- If the expression is a completion, Prev is the entity whose
281 -- declaration is completed. Def_Id is needed to analyze the spec.
289 -- This is one of the occasions on which we transform the tree during
290 -- semantic analysis. If this is a completion, transform the expression
291 -- function into an equivalent subprogram body, and analyze it.
293 -- Expression functions are inlined unconditionally. The back-end will
294 -- determine whether this is possible.
296 Inline_Processing_Required
:= True;
298 -- Create a specification for the generated body. This must be done
299 -- prior to the analysis of the initial declaration.
301 New_Spec
:= Copy_Subprogram_Spec
(Spec
);
302 Prev
:= Current_Entity_In_Scope
(Defining_Entity
(Spec
));
304 -- If there are previous overloadable entities with the same name,
305 -- check whether any of them is completed by the expression function.
306 -- In a generic context a formal subprogram has no completion.
309 and then Is_Overloadable
(Prev
)
310 and then not Is_Formal_Subprogram
(Prev
)
312 Def_Id
:= Analyze_Subprogram_Specification
(Spec
);
313 Prev
:= Find_Corresponding_Spec
(N
);
315 -- The previous entity may be an expression function as well, in
316 -- which case the redeclaration is illegal.
319 and then Nkind
(Original_Node
(Unit_Declaration_Node
(Prev
))) =
320 N_Expression_Function
322 Error_Msg_Sloc
:= Sloc
(Prev
);
323 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
328 Ret
:= Make_Simple_Return_Statement
(LocX
, Expression
(N
));
331 Make_Subprogram_Body
(Loc
,
332 Specification
=> New_Spec
,
333 Declarations
=> Empty_List
,
334 Handled_Statement_Sequence
=>
335 Make_Handled_Sequence_Of_Statements
(LocX
,
336 Statements
=> New_List
(Ret
)));
337 Set_Was_Expression_Function
(New_Body
);
339 -- If the expression completes a generic subprogram, we must create a
340 -- separate node for the body, because at instantiation the original
341 -- node of the generic copy must be a generic subprogram body, and
342 -- cannot be a expression function. Otherwise we just rewrite the
343 -- expression with the non-generic body.
345 if Present
(Prev
) and then Ekind
(Prev
) = E_Generic_Function
then
346 Insert_After
(N
, New_Body
);
348 -- Propagate any aspects or pragmas that apply to the expression
349 -- function to the proper body when the expression function acts
352 if Has_Aspects
(N
) then
353 Move_Aspects
(N
, To
=> New_Body
);
356 Relocate_Pragmas_To_Body
(New_Body
);
358 Rewrite
(N
, Make_Null_Statement
(Loc
));
359 Set_Has_Completion
(Prev
, False);
362 Set_Is_Inlined
(Prev
);
364 -- If the expression function is a completion, the previous declaration
365 -- must come from source. We know already that it appears in the current
366 -- scope. The entity itself may be internally created if within a body
370 and then Comes_From_Source
(Parent
(Prev
))
371 and then not Is_Formal_Subprogram
(Prev
)
373 Set_Has_Completion
(Prev
, False);
374 Set_Is_Inlined
(Prev
);
376 -- An expression function that is a completion freezes the
377 -- expression. This means freezing the return type, and if it is
378 -- an access type, freezing its designated type as well.
380 -- Note that we cannot defer this freezing to the analysis of the
381 -- expression itself, because a freeze node might appear in a nested
382 -- scope, leading to an elaboration order issue in gigi.
384 Freeze_Before
(N
, Etype
(Prev
));
386 if Is_Access_Type
(Etype
(Prev
)) then
387 Freeze_Before
(N
, Designated_Type
(Etype
(Prev
)));
390 -- For navigation purposes, indicate that the function is a body
392 Generate_Reference
(Prev
, Defining_Entity
(N
), 'b', Force
=> True);
393 Rewrite
(N
, New_Body
);
395 -- Correct the parent pointer of the aspect specification list to
396 -- reference the rewritten node.
398 if Has_Aspects
(N
) then
399 Set_Parent
(Aspect_Specifications
(N
), N
);
402 -- Propagate any pragmas that apply to the expression function to the
403 -- proper body when the expression function acts as a completion.
404 -- Aspects are automatically transfered because of node rewriting.
406 Relocate_Pragmas_To_Body
(N
);
409 -- Prev is the previous entity with the same name, but it is can
410 -- be an unrelated spec that is not completed by the expression
411 -- function. In that case the relevant entity is the one in the body.
412 -- Not clear that the backend can inline it in this case ???
414 if Has_Completion
(Prev
) then
416 -- The formals of the expression function are body formals,
417 -- and do not appear in the ali file, which will only contain
418 -- references to the formals of the original subprogram spec.
425 F1
:= First_Formal
(Def_Id
);
426 F2
:= First_Formal
(Prev
);
428 while Present
(F1
) loop
429 Set_Spec_Entity
(F1
, F2
);
436 Set_Is_Inlined
(Defining_Entity
(New_Body
));
439 -- If this is not a completion, create both a declaration and a body, so
440 -- that the expression can be inlined whenever possible.
443 -- An expression function that is not a completion is not a
444 -- subprogram declaration, and thus cannot appear in a protected
447 if Nkind
(Parent
(N
)) = N_Protected_Definition
then
449 ("an expression function is not a legal protected operation", N
);
452 Rewrite
(N
, Make_Subprogram_Declaration
(Loc
, Specification
=> Spec
));
454 -- Correct the parent pointer of the aspect specification list to
455 -- reference the rewritten node.
457 if Has_Aspects
(N
) then
458 Set_Parent
(Aspect_Specifications
(N
), N
);
462 Def_Id
:= Defining_Entity
(N
);
464 -- If aspect SPARK_Mode was specified on the body, it needs to be
465 -- repeated both on the generated spec and the body.
467 Asp
:= Find_Aspect
(Defining_Unit_Name
(Spec
), Aspect_SPARK_Mode
);
469 if Present
(Asp
) then
470 Asp
:= New_Copy_Tree
(Asp
);
471 Set_Analyzed
(Asp
, False);
472 Set_Aspect_Specifications
(New_Body
, New_List
(Asp
));
475 -- Within a generic pre-analyze the original expression for name
476 -- capture. The body is also generated but plays no role in
477 -- this because it is not part of the original source.
479 if Inside_A_Generic
then
480 Set_Has_Completion
(Def_Id
);
482 Install_Formals
(Def_Id
);
483 Preanalyze_Spec_Expression
(Expr
, Etype
(Def_Id
));
487 Set_Is_Inlined
(Defining_Entity
(N
));
489 -- Establish the linkages between the spec and the body. These are
490 -- used when the expression function acts as the prefix of attribute
491 -- 'Access in order to freeze the original expression which has been
492 -- moved to the generated body.
494 Set_Corresponding_Body
(N
, Defining_Entity
(New_Body
));
495 Set_Corresponding_Spec
(New_Body
, Defining_Entity
(N
));
497 -- To prevent premature freeze action, insert the new body at the end
498 -- of the current declarations, or at the end of the package spec.
499 -- However, resolve usage names now, to prevent spurious visibility
500 -- on later entities. Note that the function can now be called in
501 -- the current declarative part, which will appear to be prior to
502 -- the presence of the body in the code. There are nevertheless no
503 -- order of elaboration issues because all name resolution has taken
504 -- place at the point of declaration.
507 Decls
: List_Id
:= List_Containing
(N
);
508 Expr
: constant Node_Id
:= Expression
(Ret
);
509 Par
: constant Node_Id
:= Parent
(Decls
);
510 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
513 -- If this is a wrapper created for in an instance for a formal
514 -- subprogram, insert body after declaration, to be analyzed when
515 -- the enclosing instance is analyzed.
518 and then Is_Generic_Actual_Subprogram
(Defining_Entity
(N
))
520 Insert_After
(N
, New_Body
);
523 if Nkind
(Par
) = N_Package_Specification
524 and then Decls
= Visible_Declarations
(Par
)
525 and then Present
(Private_Declarations
(Par
))
526 and then not Is_Empty_List
(Private_Declarations
(Par
))
528 Decls
:= Private_Declarations
(Par
);
531 Insert_After
(Last
(Decls
), New_Body
);
533 -- Preanalyze the expression for name capture, except in an
534 -- instance, where this has been done during generic analysis,
535 -- and will be redone when analyzing the body.
537 Set_Parent
(Expr
, Ret
);
539 Install_Formals
(Def_Id
);
541 if not In_Instance
then
542 Preanalyze_Spec_Expression
(Expr
, Typ
);
543 Check_Limited_Return
(Original_Node
(N
), Expr
, Typ
);
551 -- If the return expression is a static constant, we suppress warning
552 -- messages on unused formals, which in most cases will be noise.
554 Set_Is_Trivial_Subprogram
555 (Defining_Entity
(New_Body
), Is_OK_Static_Expression
(Expr
));
556 end Analyze_Expression_Function
;
558 ----------------------------------------
559 -- Analyze_Extended_Return_Statement --
560 ----------------------------------------
562 procedure Analyze_Extended_Return_Statement
(N
: Node_Id
) is
564 Check_Compiler_Unit
("extended return statement", N
);
565 Analyze_Return_Statement
(N
);
566 end Analyze_Extended_Return_Statement
;
568 ----------------------------
569 -- Analyze_Function_Call --
570 ----------------------------
572 procedure Analyze_Function_Call
(N
: Node_Id
) is
573 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
574 Func_Nam
: constant Node_Id
:= Name
(N
);
580 -- A call of the form A.B (X) may be an Ada 2005 call, which is
581 -- rewritten as B (A, X). If the rewriting is successful, the call
582 -- has been analyzed and we just return.
584 if Nkind
(Func_Nam
) = N_Selected_Component
585 and then Name
(N
) /= Func_Nam
586 and then Is_Rewrite_Substitution
(N
)
587 and then Present
(Etype
(N
))
592 -- If error analyzing name, then set Any_Type as result type and return
594 if Etype
(Func_Nam
) = Any_Type
then
595 Set_Etype
(N
, Any_Type
);
599 -- Otherwise analyze the parameters
601 if Present
(Actuals
) then
602 Actual
:= First
(Actuals
);
603 while Present
(Actual
) loop
605 Check_Parameterless_Call
(Actual
);
611 end Analyze_Function_Call
;
613 -----------------------------
614 -- Analyze_Function_Return --
615 -----------------------------
617 procedure Analyze_Function_Return
(N
: Node_Id
) is
618 Loc
: constant Source_Ptr
:= Sloc
(N
);
619 Stm_Entity
: constant Entity_Id
:= Return_Statement_Entity
(N
);
620 Scope_Id
: constant Entity_Id
:= Return_Applies_To
(Stm_Entity
);
622 R_Type
: constant Entity_Id
:= Etype
(Scope_Id
);
623 -- Function result subtype
625 procedure Check_Aggregate_Accessibility
(Aggr
: Node_Id
);
626 -- Apply legality rule of 6.5 (8.2) to the access discriminants of an
627 -- aggregate in a return statement.
629 procedure Check_Return_Subtype_Indication
(Obj_Decl
: Node_Id
);
630 -- Check that the return_subtype_indication properly matches the result
631 -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
633 -----------------------------------
634 -- Check_Aggregate_Accessibility --
635 -----------------------------------
637 procedure Check_Aggregate_Accessibility
(Aggr
: Node_Id
) is
638 Typ
: constant Entity_Id
:= Etype
(Aggr
);
645 if Is_Record_Type
(Typ
) and then Has_Discriminants
(Typ
) then
646 Discr
:= First_Discriminant
(Typ
);
647 Assoc
:= First
(Component_Associations
(Aggr
));
648 while Present
(Discr
) loop
649 if Ekind
(Etype
(Discr
)) = E_Anonymous_Access_Type
then
650 Expr
:= Expression
(Assoc
);
651 if Nkind
(Expr
) = N_Attribute_Reference
652 and then Attribute_Name
(Expr
) /= Name_Unrestricted_Access
654 Obj
:= Prefix
(Expr
);
655 while Nkind_In
(Obj
, N_Indexed_Component
,
656 N_Selected_Component
)
661 -- No check needed for an aliased formal.
662 -- A run-time check may still be needed ???
664 if Is_Entity_Name
(Obj
)
665 and then Is_Formal
(Entity
(Obj
))
666 and then Is_Aliased
(Entity
(Obj
))
670 elsif Object_Access_Level
(Obj
) >
671 Scope_Depth
(Scope
(Scope_Id
))
674 ("access discriminant in return aggregate would be "
675 & "a dangling reference", Obj
);
680 Next_Discriminant
(Discr
);
683 end Check_Aggregate_Accessibility
;
685 -------------------------------------
686 -- Check_Return_Subtype_Indication --
687 -------------------------------------
689 procedure Check_Return_Subtype_Indication
(Obj_Decl
: Node_Id
) is
690 Return_Obj
: constant Node_Id
:= Defining_Identifier
(Obj_Decl
);
692 R_Stm_Type
: constant Entity_Id
:= Etype
(Return_Obj
);
693 -- Subtype given in the extended return statement (must match R_Type)
695 Subtype_Ind
: constant Node_Id
:=
696 Object_Definition
(Original_Node
(Obj_Decl
));
698 R_Type_Is_Anon_Access
: constant Boolean :=
700 E_Anonymous_Access_Subprogram_Type
,
701 E_Anonymous_Access_Protected_Subprogram_Type
,
702 E_Anonymous_Access_Type
);
703 -- True if return type of the function is an anonymous access type
704 -- Can't we make Is_Anonymous_Access_Type in einfo ???
706 R_Stm_Type_Is_Anon_Access
: constant Boolean :=
707 Ekind_In
(R_Stm_Type
,
708 E_Anonymous_Access_Subprogram_Type
,
709 E_Anonymous_Access_Protected_Subprogram_Type
,
710 E_Anonymous_Access_Type
);
711 -- True if type of the return object is an anonymous access type
713 procedure Error_No_Match
(N
: Node_Id
);
714 -- Output error messages for case where types do not statically
715 -- match. N is the location for the messages.
721 procedure Error_No_Match
(N
: Node_Id
) is
724 ("subtype must statically match function result subtype", N
);
726 if not Predicates_Match
(R_Stm_Type
, R_Type
) then
727 Error_Msg_Node_2
:= R_Type
;
729 ("\predicate of& does not match predicate of&",
734 -- Start of processing for Check_Return_Subtype_Indication
737 -- First, avoid cascaded errors
739 if Error_Posted
(Obj_Decl
) or else Error_Posted
(Subtype_Ind
) then
743 -- "return access T" case; check that the return statement also has
744 -- "access T", and that the subtypes statically match:
745 -- if this is an access to subprogram the signatures must match.
747 if R_Type_Is_Anon_Access
then
748 if R_Stm_Type_Is_Anon_Access
then
750 Ekind
(Designated_Type
(R_Stm_Type
)) /= E_Subprogram_Type
752 if Base_Type
(Designated_Type
(R_Stm_Type
)) /=
753 Base_Type
(Designated_Type
(R_Type
))
754 or else not Subtypes_Statically_Match
(R_Stm_Type
, R_Type
)
756 Error_No_Match
(Subtype_Mark
(Subtype_Ind
));
760 -- For two anonymous access to subprogram types, the
761 -- types themselves must be type conformant.
763 if not Conforming_Types
764 (R_Stm_Type
, R_Type
, Fully_Conformant
)
766 Error_No_Match
(Subtype_Ind
);
771 Error_Msg_N
("must use anonymous access type", Subtype_Ind
);
774 -- If the return object is of an anonymous access type, then report
775 -- an error if the function's result type is not also anonymous.
777 elsif R_Stm_Type_Is_Anon_Access
778 and then not R_Type_Is_Anon_Access
780 Error_Msg_N
("anonymous access not allowed for function with "
781 & "named access result", Subtype_Ind
);
783 -- Subtype indication case: check that the return object's type is
784 -- covered by the result type, and that the subtypes statically match
785 -- when the result subtype is constrained. Also handle record types
786 -- with unknown discriminants for which we have built the underlying
787 -- record view. Coverage is needed to allow specific-type return
788 -- objects when the result type is class-wide (see AI05-32).
790 elsif Covers
(Base_Type
(R_Type
), Base_Type
(R_Stm_Type
))
791 or else (Is_Underlying_Record_View
(Base_Type
(R_Stm_Type
))
795 Underlying_Record_View
(Base_Type
(R_Stm_Type
))))
797 -- A null exclusion may be present on the return type, on the
798 -- function specification, on the object declaration or on the
801 if Is_Access_Type
(R_Type
)
803 (Can_Never_Be_Null
(R_Type
)
804 or else Null_Exclusion_Present
(Parent
(Scope_Id
))) /=
805 Can_Never_Be_Null
(R_Stm_Type
)
807 Error_No_Match
(Subtype_Ind
);
810 -- AI05-103: for elementary types, subtypes must statically match
812 if Is_Constrained
(R_Type
)
813 or else Is_Access_Type
(R_Type
)
815 if not Subtypes_Statically_Match
(R_Stm_Type
, R_Type
) then
816 Error_No_Match
(Subtype_Ind
);
820 -- All remaining cases are illegal
822 -- Note: previous versions of this subprogram allowed the return
823 -- value to be the ancestor of the return type if the return type
824 -- was a null extension. This was plainly incorrect.
828 ("wrong type for return_subtype_indication", Subtype_Ind
);
830 end Check_Return_Subtype_Indication
;
832 ---------------------
833 -- Local Variables --
834 ---------------------
839 -- Start of processing for Analyze_Function_Return
842 Set_Return_Present
(Scope_Id
);
844 if Nkind
(N
) = N_Simple_Return_Statement
then
845 Expr
:= Expression
(N
);
847 -- Guard against a malformed expression. The parser may have tried to
848 -- recover but the node is not analyzable.
850 if Nkind
(Expr
) = N_Error
then
851 Set_Etype
(Expr
, Any_Type
);
852 Expander_Mode_Save_And_Set
(False);
856 -- The resolution of a controlled [extension] aggregate associated
857 -- with a return statement creates a temporary which needs to be
858 -- finalized on function exit. Wrap the return statement inside a
859 -- block so that the finalization machinery can detect this case.
860 -- This early expansion is done only when the return statement is
861 -- not part of a handled sequence of statements.
863 if Nkind_In
(Expr
, N_Aggregate
,
864 N_Extension_Aggregate
)
865 and then Needs_Finalization
(R_Type
)
866 and then Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
869 Make_Block_Statement
(Loc
,
870 Handled_Statement_Sequence
=>
871 Make_Handled_Sequence_Of_Statements
(Loc
,
872 Statements
=> New_List
(Relocate_Node
(N
)))));
880 -- Ada 2005 (AI-251): If the type of the returned object is
881 -- an access to an interface type then we add an implicit type
882 -- conversion to force the displacement of the "this" pointer to
883 -- reference the secondary dispatch table. We cannot delay the
884 -- generation of this implicit conversion until the expansion
885 -- because in this case the type resolution changes the decoration
886 -- of the expression node to match R_Type; by contrast, if the
887 -- returned object is a class-wide interface type then it is too
888 -- early to generate here the implicit conversion since the return
889 -- statement may be rewritten by the expander into an extended
890 -- return statement whose expansion takes care of adding the
891 -- implicit type conversion to displace the pointer to the object.
894 and then Serious_Errors_Detected
= 0
895 and then Is_Access_Type
(R_Type
)
896 and then Nkind
(Expr
) /= N_Null
897 and then Is_Interface
(Designated_Type
(R_Type
))
898 and then Is_Progenitor
(Designated_Type
(R_Type
),
899 Designated_Type
(Etype
(Expr
)))
901 Rewrite
(Expr
, Convert_To
(R_Type
, Relocate_Node
(Expr
)));
905 Resolve
(Expr
, R_Type
);
906 Check_Limited_Return
(N
, Expr
, R_Type
);
908 if Present
(Expr
) and then Nkind
(Expr
) = N_Aggregate
then
909 Check_Aggregate_Accessibility
(Expr
);
913 -- RETURN only allowed in SPARK as the last statement in function
915 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
917 (Nkind
(Parent
(Parent
(N
))) /= N_Subprogram_Body
918 or else Present
(Next
(N
)))
920 Check_SPARK_05_Restriction
921 ("RETURN should be the last statement in function", N
);
925 Check_SPARK_05_Restriction
("extended RETURN is not allowed", N
);
926 Obj_Decl
:= Last
(Return_Object_Declarations
(N
));
928 -- Analyze parts specific to extended_return_statement:
931 Has_Aliased
: constant Boolean := Aliased_Present
(Obj_Decl
);
932 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
935 Expr
:= Expression
(Obj_Decl
);
937 -- Note: The check for OK_For_Limited_Init will happen in
938 -- Analyze_Object_Declaration; we treat it as a normal
939 -- object declaration.
941 Set_Is_Return_Object
(Defining_Identifier
(Obj_Decl
));
944 Check_Return_Subtype_Indication
(Obj_Decl
);
946 if Present
(HSS
) then
949 if Present
(Exception_Handlers
(HSS
)) then
951 -- ???Has_Nested_Block_With_Handler needs to be set.
952 -- Probably by creating an actual N_Block_Statement.
953 -- Probably in Expand.
959 -- Mark the return object as referenced, since the return is an
960 -- implicit reference of the object.
962 Set_Referenced
(Defining_Identifier
(Obj_Decl
));
964 Check_References
(Stm_Entity
);
966 -- Check RM 6.5 (5.9/3)
969 if Ada_Version
< Ada_2012
then
971 -- Shouldn't this test Warn_On_Ada_2012_Compatibility ???
972 -- Can it really happen (extended return???)
975 ("aliased only allowed for limited return objects "
976 & "in Ada 2012??", N
);
978 elsif not Is_Limited_View
(R_Type
) then
980 ("aliased only allowed for limited return objects", N
);
986 -- Case of Expr present
990 -- Defend against previous errors
992 and then Nkind
(Expr
) /= N_Empty
993 and then Present
(Etype
(Expr
))
995 -- Apply constraint check. Note that this is done before the implicit
996 -- conversion of the expression done for anonymous access types to
997 -- ensure correct generation of the null-excluding check associated
998 -- with null-excluding expressions found in return statements.
1000 Apply_Constraint_Check
(Expr
, R_Type
);
1002 -- Ada 2005 (AI-318-02): When the result type is an anonymous access
1003 -- type, apply an implicit conversion of the expression to that type
1004 -- to force appropriate static and run-time accessibility checks.
1006 if Ada_Version
>= Ada_2005
1007 and then Ekind
(R_Type
) = E_Anonymous_Access_Type
1009 Rewrite
(Expr
, Convert_To
(R_Type
, Relocate_Node
(Expr
)));
1010 Analyze_And_Resolve
(Expr
, R_Type
);
1012 -- If this is a local anonymous access to subprogram, the
1013 -- accessibility check can be applied statically. The return is
1014 -- illegal if the access type of the return expression is declared
1015 -- inside of the subprogram (except if it is the subtype indication
1016 -- of an extended return statement).
1018 elsif Ekind
(R_Type
) = E_Anonymous_Access_Subprogram_Type
then
1019 if not Comes_From_Source
(Current_Scope
)
1020 or else Ekind
(Current_Scope
) = E_Return_Statement
1025 Scope_Depth
(Scope
(Etype
(Expr
))) >= Scope_Depth
(Scope_Id
)
1027 Error_Msg_N
("cannot return local access to subprogram", N
);
1030 -- The expression cannot be of a formal incomplete type
1032 elsif Ekind
(Etype
(Expr
)) = E_Incomplete_Type
1033 and then Is_Generic_Type
(Etype
(Expr
))
1036 ("cannot return expression of a formal incomplete type", N
);
1039 -- If the result type is class-wide, then check that the return
1040 -- expression's type is not declared at a deeper level than the
1041 -- function (RM05-6.5(5.6/2)).
1043 if Ada_Version
>= Ada_2005
1044 and then Is_Class_Wide_Type
(R_Type
)
1046 if Type_Access_Level
(Etype
(Expr
)) >
1047 Subprogram_Access_Level
(Scope_Id
)
1050 ("level of return expression type is deeper than "
1051 & "class-wide function!", Expr
);
1055 -- Check incorrect use of dynamically tagged expression
1057 if Is_Tagged_Type
(R_Type
) then
1058 Check_Dynamically_Tagged_Expression
1064 -- ??? A real run-time accessibility check is needed in cases
1065 -- involving dereferences of access parameters. For now we just
1066 -- check the static cases.
1068 if (Ada_Version
< Ada_2005
or else Debug_Flag_Dot_L
)
1069 and then Is_Limited_View
(Etype
(Scope_Id
))
1070 and then Object_Access_Level
(Expr
) >
1071 Subprogram_Access_Level
(Scope_Id
)
1073 -- Suppress the message in a generic, where the rewriting
1076 if Inside_A_Generic
then
1081 Make_Raise_Program_Error
(Loc
,
1082 Reason
=> PE_Accessibility_Check_Failed
));
1085 Error_Msg_Warn
:= SPARK_Mode
/= On
;
1086 Error_Msg_N
("cannot return a local value by reference<<", N
);
1087 Error_Msg_NE
("\& [<<", N
, Standard_Program_Error
);
1091 if Known_Null
(Expr
)
1092 and then Nkind
(Parent
(Scope_Id
)) = N_Function_Specification
1093 and then Null_Exclusion_Present
(Parent
(Scope_Id
))
1095 Apply_Compile_Time_Constraint_Error
1097 Msg
=> "(Ada 2005) null not allowed for "
1098 & "null-excluding return??",
1099 Reason
=> CE_Null_Not_Allowed
);
1102 -- RM 6.5 (5.4/3): accessibility checks also apply if the return object
1103 -- has no initializing expression.
1105 elsif Ada_Version
> Ada_2005
and then Is_Class_Wide_Type
(R_Type
) then
1106 if Type_Access_Level
(Etype
(Defining_Identifier
(Obj_Decl
))) >
1107 Subprogram_Access_Level
(Scope_Id
)
1110 ("level of return expression type is deeper than "
1111 & "class-wide function!", Obj_Decl
);
1114 end Analyze_Function_Return
;
1116 -------------------------------------
1117 -- Analyze_Generic_Subprogram_Body --
1118 -------------------------------------
1120 procedure Analyze_Generic_Subprogram_Body
1124 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Id
);
1125 Kind
: constant Entity_Kind
:= Ekind
(Gen_Id
);
1126 Body_Id
: Entity_Id
;
1131 -- Copy body and disable expansion while analyzing the generic For a
1132 -- stub, do not copy the stub (which would load the proper body), this
1133 -- will be done when the proper body is analyzed.
1135 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
1136 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
1139 -- Once the contents of the generic copy and the template are
1140 -- swapped, do the same for their respective aspect specifications.
1142 Exchange_Aspects
(N
, New_N
);
1144 -- Collect all contract-related source pragmas found within the
1145 -- template and attach them to the contract of the subprogram body.
1146 -- This contract is used in the capture of global references within
1149 Create_Generic_Contract
(N
);
1154 Spec
:= Specification
(N
);
1156 -- Within the body of the generic, the subprogram is callable, and
1157 -- behaves like the corresponding non-generic unit.
1159 Body_Id
:= Defining_Entity
(Spec
);
1161 if Kind
= E_Generic_Procedure
1162 and then Nkind
(Spec
) /= N_Procedure_Specification
1164 Error_Msg_N
("invalid body for generic procedure ", Body_Id
);
1167 elsif Kind
= E_Generic_Function
1168 and then Nkind
(Spec
) /= N_Function_Specification
1170 Error_Msg_N
("invalid body for generic function ", Body_Id
);
1174 Set_Corresponding_Body
(Gen_Decl
, Body_Id
);
1176 if Has_Completion
(Gen_Id
)
1177 and then Nkind
(Parent
(N
)) /= N_Subunit
1179 Error_Msg_N
("duplicate generic body", N
);
1182 Set_Has_Completion
(Gen_Id
);
1185 if Nkind
(N
) = N_Subprogram_Body_Stub
then
1186 Set_Ekind
(Defining_Entity
(Specification
(N
)), Kind
);
1188 Set_Corresponding_Spec
(N
, Gen_Id
);
1191 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
1192 Set_Cunit_Entity
(Current_Sem_Unit
, Defining_Entity
(N
));
1195 -- Make generic parameters immediately visible in the body. They are
1196 -- needed to process the formals declarations. Then make the formals
1197 -- visible in a separate step.
1199 Push_Scope
(Gen_Id
);
1203 First_Ent
: Entity_Id
;
1206 First_Ent
:= First_Entity
(Gen_Id
);
1209 while Present
(E
) and then not Is_Formal
(E
) loop
1214 Set_Use
(Generic_Formal_Declarations
(Gen_Decl
));
1216 -- Now generic formals are visible, and the specification can be
1217 -- analyzed, for subsequent conformance check.
1219 Body_Id
:= Analyze_Subprogram_Specification
(Spec
);
1221 -- Make formal parameters visible
1225 -- E is the first formal parameter, we loop through the formals
1226 -- installing them so that they will be visible.
1228 Set_First_Entity
(Gen_Id
, E
);
1229 while Present
(E
) loop
1235 -- Visible generic entity is callable within its own body
1237 Set_Ekind
(Gen_Id
, Ekind
(Body_Id
));
1238 Set_Ekind
(Body_Id
, E_Subprogram_Body
);
1239 Set_Convention
(Body_Id
, Convention
(Gen_Id
));
1240 Set_Is_Obsolescent
(Body_Id
, Is_Obsolescent
(Gen_Id
));
1241 Set_Scope
(Body_Id
, Scope
(Gen_Id
));
1243 -- Inherit the "ghostness" of the generic spec. Note that this
1244 -- property is not directly inherited as the body may be subject
1245 -- to a different Ghost assertion policy.
1247 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Gen_Id
) then
1248 Set_Is_Ghost_Entity
(Body_Id
);
1250 -- The Ghost policy in effect at the point of declaration and at
1251 -- the point of completion must match (SPARK RM 6.9(14)).
1253 Check_Ghost_Completion
(Gen_Id
, Body_Id
);
1256 Check_Fully_Conformant
(Body_Id
, Gen_Id
, Body_Id
);
1258 if Nkind
(N
) = N_Subprogram_Body_Stub
then
1260 -- No body to analyze, so restore state of generic unit
1262 Set_Ekind
(Gen_Id
, Kind
);
1263 Set_Ekind
(Body_Id
, Kind
);
1265 if Present
(First_Ent
) then
1266 Set_First_Entity
(Gen_Id
, First_Ent
);
1273 -- If this is a compilation unit, it must be made visible explicitly,
1274 -- because the compilation of the declaration, unlike other library
1275 -- unit declarations, does not. If it is not a unit, the following
1276 -- is redundant but harmless.
1278 Set_Is_Immediately_Visible
(Gen_Id
);
1279 Reference_Body_Formals
(Gen_Id
, Body_Id
);
1281 if Is_Child_Unit
(Gen_Id
) then
1282 Generate_Reference
(Gen_Id
, Scope
(Gen_Id
), 'k', False);
1285 Set_Actual_Subtypes
(N
, Current_Scope
);
1287 Set_SPARK_Pragma
(Body_Id
, SPARK_Mode_Pragma
);
1288 Set_SPARK_Pragma_Inherited
(Body_Id
);
1290 -- Analyze any aspect specifications that appear on the generic
1293 if Has_Aspects
(N
) then
1294 Analyze_Aspect_Specifications_On_Body_Or_Stub
(N
);
1297 Analyze_Declarations
(Declarations
(N
));
1300 -- Process the contract of the subprogram body after all declarations
1301 -- have been analyzed. This ensures that any contract-related pragmas
1302 -- are available through the N_Contract node of the body.
1304 Analyze_Entry_Or_Subprogram_Body_Contract
(Body_Id
);
1306 Analyze
(Handled_Statement_Sequence
(N
));
1307 Save_Global_References
(Original_Node
(N
));
1309 -- Prior to exiting the scope, include generic formals again (if any
1310 -- are present) in the set of local entities.
1312 if Present
(First_Ent
) then
1313 Set_First_Entity
(Gen_Id
, First_Ent
);
1316 Check_References
(Gen_Id
);
1319 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Current_Scope
);
1321 Check_Subprogram_Order
(N
);
1323 -- Outside of its body, unit is generic again
1325 Set_Ekind
(Gen_Id
, Kind
);
1326 Generate_Reference
(Gen_Id
, Body_Id
, 'b', Set_Ref
=> False);
1329 Style
.Check_Identifier
(Body_Id
, Gen_Id
);
1333 end Analyze_Generic_Subprogram_Body
;
1335 ----------------------------
1336 -- Analyze_Null_Procedure --
1337 ----------------------------
1339 procedure Analyze_Null_Procedure
1341 Is_Completion
: out Boolean)
1343 Loc
: constant Source_Ptr
:= Sloc
(N
);
1344 Spec
: constant Node_Id
:= Specification
(N
);
1345 Designator
: Entity_Id
;
1347 Null_Body
: Node_Id
:= Empty
;
1351 -- Capture the profile of the null procedure before analysis, for
1352 -- expansion at the freeze point and at each point of call. The body is
1353 -- used if the procedure has preconditions, or if it is a completion. In
1354 -- the first case the body is analyzed at the freeze point, in the other
1355 -- it replaces the null procedure declaration.
1358 Make_Subprogram_Body
(Loc
,
1359 Specification
=> New_Copy_Tree
(Spec
),
1360 Declarations
=> New_List
,
1361 Handled_Statement_Sequence
=>
1362 Make_Handled_Sequence_Of_Statements
(Loc
,
1363 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1365 -- Create new entities for body and formals
1367 Set_Defining_Unit_Name
(Specification
(Null_Body
),
1368 Make_Defining_Identifier
1369 (Sloc
(Defining_Entity
(N
)),
1370 Chars
(Defining_Entity
(N
))));
1372 Form
:= First
(Parameter_Specifications
(Specification
(Null_Body
)));
1373 while Present
(Form
) loop
1374 Set_Defining_Identifier
(Form
,
1375 Make_Defining_Identifier
1376 (Sloc
(Defining_Identifier
(Form
)),
1377 Chars
(Defining_Identifier
(Form
))));
1381 -- Determine whether the null procedure may be a completion of a generic
1382 -- suprogram, in which case we use the new null body as the completion
1383 -- and set minimal semantic information on the original declaration,
1384 -- which is rewritten as a null statement.
1386 Prev
:= Current_Entity_In_Scope
(Defining_Entity
(Spec
));
1388 if Present
(Prev
) and then Is_Generic_Subprogram
(Prev
) then
1389 Insert_Before
(N
, Null_Body
);
1390 Set_Ekind
(Defining_Entity
(N
), Ekind
(Prev
));
1392 Rewrite
(N
, Make_Null_Statement
(Loc
));
1393 Analyze_Generic_Subprogram_Body
(Null_Body
, Prev
);
1394 Is_Completion
:= True;
1398 -- Resolve the types of the formals now, because the freeze point
1399 -- may appear in a different context, e.g. an instantiation.
1401 Form
:= First
(Parameter_Specifications
(Specification
(Null_Body
)));
1402 while Present
(Form
) loop
1403 if Nkind
(Parameter_Type
(Form
)) /= N_Access_Definition
then
1404 Find_Type
(Parameter_Type
(Form
));
1407 No
(Access_To_Subprogram_Definition
(Parameter_Type
(Form
)))
1409 Find_Type
(Subtype_Mark
(Parameter_Type
(Form
)));
1412 -- The case of a null procedure with a formal that is an
1413 -- access_to_subprogram type, and that is used as an actual
1414 -- in an instantiation is left to the enthusiastic reader.
1423 -- If there are previous overloadable entities with the same name,
1424 -- check whether any of them is completed by the null procedure.
1426 if Present
(Prev
) and then Is_Overloadable
(Prev
) then
1427 Designator
:= Analyze_Subprogram_Specification
(Spec
);
1428 Prev
:= Find_Corresponding_Spec
(N
);
1431 if No
(Prev
) or else not Comes_From_Source
(Prev
) then
1432 Designator
:= Analyze_Subprogram_Specification
(Spec
);
1433 Set_Has_Completion
(Designator
);
1435 -- Signal to caller that this is a procedure declaration
1437 Is_Completion
:= False;
1439 -- Null procedures are always inlined, but generic formal subprograms
1440 -- which appear as such in the internal instance of formal packages,
1441 -- need no completion and are not marked Inline.
1444 and then Nkind
(N
) /= N_Formal_Concrete_Subprogram_Declaration
1446 Set_Corresponding_Body
(N
, Defining_Entity
(Null_Body
));
1447 Set_Body_To_Inline
(N
, Null_Body
);
1448 Set_Is_Inlined
(Designator
);
1452 -- The null procedure is a completion. We unconditionally rewrite
1453 -- this as a null body (even if expansion is not active), because
1454 -- there are various error checks that are applied on this body
1455 -- when it is analyzed (e.g. correct aspect placement).
1457 if Has_Completion
(Prev
) then
1458 Error_Msg_Sloc
:= Sloc
(Prev
);
1459 Error_Msg_NE
("duplicate body for & declared#", N
, Prev
);
1462 Is_Completion
:= True;
1463 Rewrite
(N
, Null_Body
);
1466 end Analyze_Null_Procedure
;
1468 -----------------------------
1469 -- Analyze_Operator_Symbol --
1470 -----------------------------
1472 -- An operator symbol such as "+" or "and" may appear in context where the
1473 -- literal denotes an entity name, such as "+"(x, y) or in context when it
1474 -- is just a string, as in (conjunction = "or"). In these cases the parser
1475 -- generates this node, and the semantics does the disambiguation. Other
1476 -- such case are actuals in an instantiation, the generic unit in an
1477 -- instantiation, and pragma arguments.
1479 procedure Analyze_Operator_Symbol
(N
: Node_Id
) is
1480 Par
: constant Node_Id
:= Parent
(N
);
1483 if (Nkind
(Par
) = N_Function_Call
and then N
= Name
(Par
))
1484 or else Nkind
(Par
) = N_Function_Instantiation
1485 or else (Nkind
(Par
) = N_Indexed_Component
and then N
= Prefix
(Par
))
1486 or else (Nkind
(Par
) = N_Pragma_Argument_Association
1487 and then not Is_Pragma_String_Literal
(Par
))
1488 or else Nkind
(Par
) = N_Subprogram_Renaming_Declaration
1489 or else (Nkind
(Par
) = N_Attribute_Reference
1490 and then Attribute_Name
(Par
) /= Name_Value
)
1492 Find_Direct_Name
(N
);
1495 Change_Operator_Symbol_To_String_Literal
(N
);
1498 end Analyze_Operator_Symbol
;
1500 -----------------------------------
1501 -- Analyze_Parameter_Association --
1502 -----------------------------------
1504 procedure Analyze_Parameter_Association
(N
: Node_Id
) is
1506 Analyze
(Explicit_Actual_Parameter
(N
));
1507 end Analyze_Parameter_Association
;
1509 ----------------------------
1510 -- Analyze_Procedure_Call --
1511 ----------------------------
1513 procedure Analyze_Procedure_Call
(N
: Node_Id
) is
1514 procedure Analyze_Call_And_Resolve
;
1515 -- Do Analyze and Resolve calls for procedure call
1516 -- At end, check illegal order dependence.
1518 ------------------------------
1519 -- Analyze_Call_And_Resolve --
1520 ------------------------------
1522 procedure Analyze_Call_And_Resolve
is
1524 if Nkind
(N
) = N_Procedure_Call_Statement
then
1526 Resolve
(N
, Standard_Void_Type
);
1530 end Analyze_Call_And_Resolve
;
1534 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
1535 Loc
: constant Source_Ptr
:= Sloc
(N
);
1536 P
: constant Node_Id
:= Name
(N
);
1540 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1542 -- Start of processing for Analyze_Procedure_Call
1545 -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
1546 -- a procedure call or an entry call. The prefix may denote an access
1547 -- to subprogram type, in which case an implicit dereference applies.
1548 -- If the prefix is an indexed component (without implicit dereference)
1549 -- then the construct denotes a call to a member of an entire family.
1550 -- If the prefix is a simple name, it may still denote a call to a
1551 -- parameterless member of an entry family. Resolution of these various
1552 -- interpretations is delicate.
1554 -- Do not analyze machine code statements to avoid rejecting them in
1557 if CodePeer_Mode
and then Nkind
(P
) = N_Qualified_Expression
then
1558 Set_Etype
(P
, Standard_Void_Type
);
1563 -- If this is a call of the form Obj.Op, the call may have been analyzed
1564 -- and possibly rewritten into a block, in which case we are done.
1566 if Analyzed
(N
) then
1570 -- If there is an error analyzing the name (which may have been
1571 -- rewritten if the original call was in prefix notation) then error
1572 -- has been emitted already, mark node and return.
1574 if Error_Posted
(N
) or else Etype
(Name
(N
)) = Any_Type
then
1575 Set_Etype
(N
, Any_Type
);
1579 -- A procedure call is Ghost when its name denotes a Ghost procedure.
1580 -- Set the mode now to ensure that any nodes generated during analysis
1581 -- and expansion are properly marked as Ghost.
1585 -- Otherwise analyze the parameters
1587 if Present
(Actuals
) then
1588 Actual
:= First
(Actuals
);
1590 while Present
(Actual
) loop
1592 Check_Parameterless_Call
(Actual
);
1597 -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
1599 if Nkind
(P
) = N_Attribute_Reference
1600 and then Nam_In
(Attribute_Name
(P
), Name_Elab_Spec
,
1602 Name_Elab_Subp_Body
)
1604 if Present
(Actuals
) then
1606 ("no parameters allowed for this call", First
(Actuals
));
1610 Set_Etype
(N
, Standard_Void_Type
);
1613 elsif Is_Entity_Name
(P
)
1614 and then Is_Record_Type
(Etype
(Entity
(P
)))
1615 and then Remote_AST_I_Dereference
(P
)
1617 Ghost_Mode
:= Save_Ghost_Mode
;
1620 elsif Is_Entity_Name
(P
)
1621 and then Ekind
(Entity
(P
)) /= E_Entry_Family
1623 if Is_Access_Type
(Etype
(P
))
1624 and then Ekind
(Designated_Type
(Etype
(P
))) = E_Subprogram_Type
1625 and then No
(Actuals
)
1626 and then Comes_From_Source
(N
)
1628 Error_Msg_N
("missing explicit dereference in call", N
);
1631 Analyze_Call_And_Resolve
;
1633 -- If the prefix is the simple name of an entry family, this is a
1634 -- parameterless call from within the task body itself.
1636 elsif Is_Entity_Name
(P
)
1637 and then Nkind
(P
) = N_Identifier
1638 and then Ekind
(Entity
(P
)) = E_Entry_Family
1639 and then Present
(Actuals
)
1640 and then No
(Next
(First
(Actuals
)))
1642 -- Can be call to parameterless entry family. What appears to be the
1643 -- sole argument is in fact the entry index. Rewrite prefix of node
1644 -- accordingly. Source representation is unchanged by this
1648 Make_Indexed_Component
(Loc
,
1650 Make_Selected_Component
(Loc
,
1651 Prefix
=> New_Occurrence_Of
(Scope
(Entity
(P
)), Loc
),
1652 Selector_Name
=> New_Occurrence_Of
(Entity
(P
), Loc
)),
1653 Expressions
=> Actuals
);
1654 Set_Name
(N
, New_N
);
1655 Set_Etype
(New_N
, Standard_Void_Type
);
1656 Set_Parameter_Associations
(N
, No_List
);
1657 Analyze_Call_And_Resolve
;
1659 elsif Nkind
(P
) = N_Explicit_Dereference
then
1660 if Ekind
(Etype
(P
)) = E_Subprogram_Type
then
1661 Analyze_Call_And_Resolve
;
1663 Error_Msg_N
("expect access to procedure in call", P
);
1666 -- The name can be a selected component or an indexed component that
1667 -- yields an access to subprogram. Such a prefix is legal if the call
1668 -- has parameter associations.
1670 elsif Is_Access_Type
(Etype
(P
))
1671 and then Ekind
(Designated_Type
(Etype
(P
))) = E_Subprogram_Type
1673 if Present
(Actuals
) then
1674 Analyze_Call_And_Resolve
;
1676 Error_Msg_N
("missing explicit dereference in call ", N
);
1679 -- If not an access to subprogram, then the prefix must resolve to the
1680 -- name of an entry, entry family, or protected operation.
1682 -- For the case of a simple entry call, P is a selected component where
1683 -- the prefix is the task and the selector name is the entry. A call to
1684 -- a protected procedure will have the same syntax. If the protected
1685 -- object contains overloaded operations, the entity may appear as a
1686 -- function, the context will select the operation whose type is Void.
1688 elsif Nkind
(P
) = N_Selected_Component
1689 and then Ekind_In
(Entity
(Selector_Name
(P
)), E_Entry
,
1693 Analyze_Call_And_Resolve
;
1695 elsif Nkind
(P
) = N_Selected_Component
1696 and then Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
1697 and then Present
(Actuals
)
1698 and then No
(Next
(First
(Actuals
)))
1700 -- Can be call to parameterless entry family. What appears to be the
1701 -- sole argument is in fact the entry index. Rewrite prefix of node
1702 -- accordingly. Source representation is unchanged by this
1706 Make_Indexed_Component
(Loc
,
1707 Prefix
=> New_Copy
(P
),
1708 Expressions
=> Actuals
);
1709 Set_Name
(N
, New_N
);
1710 Set_Etype
(New_N
, Standard_Void_Type
);
1711 Set_Parameter_Associations
(N
, No_List
);
1712 Analyze_Call_And_Resolve
;
1714 -- For the case of a reference to an element of an entry family, P is
1715 -- an indexed component whose prefix is a selected component (task and
1716 -- entry family), and whose index is the entry family index.
1718 elsif Nkind
(P
) = N_Indexed_Component
1719 and then Nkind
(Prefix
(P
)) = N_Selected_Component
1720 and then Ekind
(Entity
(Selector_Name
(Prefix
(P
)))) = E_Entry_Family
1722 Analyze_Call_And_Resolve
;
1724 -- If the prefix is the name of an entry family, it is a call from
1725 -- within the task body itself.
1727 elsif Nkind
(P
) = N_Indexed_Component
1728 and then Nkind
(Prefix
(P
)) = N_Identifier
1729 and then Ekind
(Entity
(Prefix
(P
))) = E_Entry_Family
1732 Make_Selected_Component
(Loc
,
1733 Prefix
=> New_Occurrence_Of
(Scope
(Entity
(Prefix
(P
))), Loc
),
1734 Selector_Name
=> New_Occurrence_Of
(Entity
(Prefix
(P
)), Loc
));
1735 Rewrite
(Prefix
(P
), New_N
);
1737 Analyze_Call_And_Resolve
;
1739 -- In Ada 2012. a qualified expression is a name, but it cannot be a
1740 -- procedure name, so the construct can only be a qualified expression.
1742 elsif Nkind
(P
) = N_Qualified_Expression
1743 and then Ada_Version
>= Ada_2012
1745 Rewrite
(N
, Make_Code_Statement
(Loc
, Expression
=> P
));
1748 -- Anything else is an error
1751 Error_Msg_N
("invalid procedure or entry call", N
);
1754 Ghost_Mode
:= Save_Ghost_Mode
;
1755 end Analyze_Procedure_Call
;
1757 ------------------------------
1758 -- Analyze_Return_Statement --
1759 ------------------------------
1761 procedure Analyze_Return_Statement
(N
: Node_Id
) is
1763 pragma Assert
(Nkind_In
(N
, N_Simple_Return_Statement
,
1764 N_Extended_Return_Statement
));
1766 Returns_Object
: constant Boolean :=
1767 Nkind
(N
) = N_Extended_Return_Statement
1769 (Nkind
(N
) = N_Simple_Return_Statement
1770 and then Present
(Expression
(N
)));
1771 -- True if we're returning something; that is, "return <expression>;"
1772 -- or "return Result : T [:= ...]". False for "return;". Used for error
1773 -- checking: If Returns_Object is True, N should apply to a function
1774 -- body; otherwise N should apply to a procedure body, entry body,
1775 -- accept statement, or extended return statement.
1777 function Find_What_It_Applies_To
return Entity_Id
;
1778 -- Find the entity representing the innermost enclosing body, accept
1779 -- statement, or extended return statement. If the result is a callable
1780 -- construct or extended return statement, then this will be the value
1781 -- of the Return_Applies_To attribute. Otherwise, the program is
1782 -- illegal. See RM-6.5(4/2).
1784 -----------------------------
1785 -- Find_What_It_Applies_To --
1786 -----------------------------
1788 function Find_What_It_Applies_To
return Entity_Id
is
1789 Result
: Entity_Id
:= Empty
;
1792 -- Loop outward through the Scope_Stack, skipping blocks, loops,
1793 -- and postconditions.
1795 for J
in reverse 0 .. Scope_Stack
.Last
loop
1796 Result
:= Scope_Stack
.Table
(J
).Entity
;
1797 exit when not Ekind_In
(Result
, E_Block
, E_Loop
)
1798 and then Chars
(Result
) /= Name_uPostconditions
;
1801 pragma Assert
(Present
(Result
));
1803 end Find_What_It_Applies_To
;
1805 -- Local declarations
1807 Scope_Id
: constant Entity_Id
:= Find_What_It_Applies_To
;
1808 Kind
: constant Entity_Kind
:= Ekind
(Scope_Id
);
1809 Loc
: constant Source_Ptr
:= Sloc
(N
);
1810 Stm_Entity
: constant Entity_Id
:=
1812 (E_Return_Statement
, Current_Scope
, Loc
, 'R');
1814 -- Start of processing for Analyze_Return_Statement
1817 Set_Return_Statement_Entity
(N
, Stm_Entity
);
1819 Set_Etype
(Stm_Entity
, Standard_Void_Type
);
1820 Set_Return_Applies_To
(Stm_Entity
, Scope_Id
);
1822 -- Place Return entity on scope stack, to simplify enforcement of 6.5
1823 -- (4/2): an inner return statement will apply to this extended return.
1825 if Nkind
(N
) = N_Extended_Return_Statement
then
1826 Push_Scope
(Stm_Entity
);
1829 -- Check that pragma No_Return is obeyed. Don't complain about the
1830 -- implicitly-generated return that is placed at the end.
1832 if No_Return
(Scope_Id
) and then Comes_From_Source
(N
) then
1833 Error_Msg_N
("RETURN statement not allowed (No_Return)", N
);
1836 -- Warn on any unassigned OUT parameters if in procedure
1838 if Ekind
(Scope_Id
) = E_Procedure
then
1839 Warn_On_Unassigned_Out_Parameter
(N
, Scope_Id
);
1842 -- Check that functions return objects, and other things do not
1844 if Kind
= E_Function
or else Kind
= E_Generic_Function
then
1845 if not Returns_Object
then
1846 Error_Msg_N
("missing expression in return from function", N
);
1849 elsif Kind
= E_Procedure
or else Kind
= E_Generic_Procedure
then
1850 if Returns_Object
then
1851 Error_Msg_N
("procedure cannot return value (use function)", N
);
1854 elsif Kind
= E_Entry
or else Kind
= E_Entry_Family
then
1855 if Returns_Object
then
1856 if Is_Protected_Type
(Scope
(Scope_Id
)) then
1857 Error_Msg_N
("entry body cannot return value", N
);
1859 Error_Msg_N
("accept statement cannot return value", N
);
1863 elsif Kind
= E_Return_Statement
then
1865 -- We are nested within another return statement, which must be an
1866 -- extended_return_statement.
1868 if Returns_Object
then
1869 if Nkind
(N
) = N_Extended_Return_Statement
then
1871 ("extended return statement cannot be nested (use `RETURN;`)",
1874 -- Case of a simple return statement with a value inside extended
1875 -- return statement.
1879 ("return nested in extended return statement cannot return "
1880 & "value (use `RETURN;`)", N
);
1885 Error_Msg_N
("illegal context for return statement", N
);
1888 if Ekind_In
(Kind
, E_Function
, E_Generic_Function
) then
1889 Analyze_Function_Return
(N
);
1891 elsif Ekind_In
(Kind
, E_Procedure
, E_Generic_Procedure
) then
1892 Set_Return_Present
(Scope_Id
);
1895 if Nkind
(N
) = N_Extended_Return_Statement
then
1899 Kill_Current_Values
(Last_Assignment_Only
=> True);
1900 Check_Unreachable_Code
(N
);
1902 Analyze_Dimension
(N
);
1903 end Analyze_Return_Statement
;
1905 -------------------------------------
1906 -- Analyze_Simple_Return_Statement --
1907 -------------------------------------
1909 procedure Analyze_Simple_Return_Statement
(N
: Node_Id
) is
1911 if Present
(Expression
(N
)) then
1912 Mark_Coextensions
(N
, Expression
(N
));
1915 Analyze_Return_Statement
(N
);
1916 end Analyze_Simple_Return_Statement
;
1918 -------------------------
1919 -- Analyze_Return_Type --
1920 -------------------------
1922 procedure Analyze_Return_Type
(N
: Node_Id
) is
1923 Designator
: constant Entity_Id
:= Defining_Entity
(N
);
1924 Typ
: Entity_Id
:= Empty
;
1927 -- Normal case where result definition does not indicate an error
1929 if Result_Definition
(N
) /= Error
then
1930 if Nkind
(Result_Definition
(N
)) = N_Access_Definition
then
1931 Check_SPARK_05_Restriction
1932 ("access result is not allowed", Result_Definition
(N
));
1934 -- Ada 2005 (AI-254): Handle anonymous access to subprograms
1937 AD
: constant Node_Id
:=
1938 Access_To_Subprogram_Definition
(Result_Definition
(N
));
1940 if Present
(AD
) and then Protected_Present
(AD
) then
1941 Typ
:= Replace_Anonymous_Access_To_Protected_Subprogram
(N
);
1943 Typ
:= Access_Definition
(N
, Result_Definition
(N
));
1947 Set_Parent
(Typ
, Result_Definition
(N
));
1948 Set_Is_Local_Anonymous_Access
(Typ
);
1949 Set_Etype
(Designator
, Typ
);
1951 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1953 Null_Exclusion_Static_Checks
(N
);
1955 -- Subtype_Mark case
1958 Find_Type
(Result_Definition
(N
));
1959 Typ
:= Entity
(Result_Definition
(N
));
1960 Set_Etype
(Designator
, Typ
);
1962 -- Unconstrained array as result is not allowed in SPARK
1964 if Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
1965 Check_SPARK_05_Restriction
1966 ("returning an unconstrained array is not allowed",
1967 Result_Definition
(N
));
1970 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1972 Null_Exclusion_Static_Checks
(N
);
1974 -- If a null exclusion is imposed on the result type, then create
1975 -- a null-excluding itype (an access subtype) and use it as the
1976 -- function's Etype. Note that the null exclusion checks are done
1977 -- right before this, because they don't get applied to types that
1978 -- do not come from source.
1980 if Is_Access_Type
(Typ
) and then Null_Exclusion_Present
(N
) then
1981 Set_Etype
(Designator
,
1982 Create_Null_Excluding_Itype
1985 Scope_Id
=> Scope
(Current_Scope
)));
1987 -- The new subtype must be elaborated before use because
1988 -- it is visible outside of the function. However its base
1989 -- type may not be frozen yet, so the reference that will
1990 -- force elaboration must be attached to the freezing of
1993 -- If the return specification appears on a proper body,
1994 -- the subtype will have been created already on the spec.
1996 if Is_Frozen
(Typ
) then
1997 if Nkind
(Parent
(N
)) = N_Subprogram_Body
1998 and then Nkind
(Parent
(Parent
(N
))) = N_Subunit
2002 Build_Itype_Reference
(Etype
(Designator
), Parent
(N
));
2006 Ensure_Freeze_Node
(Typ
);
2009 IR
: constant Node_Id
:= Make_Itype_Reference
(Sloc
(N
));
2011 Set_Itype
(IR
, Etype
(Designator
));
2012 Append_Freeze_Actions
(Typ
, New_List
(IR
));
2017 Set_Etype
(Designator
, Typ
);
2020 if Ekind
(Typ
) = E_Incomplete_Type
2021 or else (Is_Class_Wide_Type
(Typ
)
2022 and then Ekind
(Root_Type
(Typ
)) = E_Incomplete_Type
)
2024 -- AI05-0151: Tagged incomplete types are allowed in all formal
2025 -- parts. Untagged incomplete types are not allowed in bodies.
2026 -- As a consequence, limited views cannot appear in a basic
2027 -- declaration that is itself within a body, because there is
2028 -- no point at which the non-limited view will become visible.
2030 if Ada_Version
>= Ada_2012
then
2031 if From_Limited_With
(Typ
) and then In_Package_Body
then
2033 ("invalid use of incomplete type&",
2034 Result_Definition
(N
), Typ
);
2036 -- The return type of a subprogram body cannot be of a
2037 -- formal incomplete type.
2039 elsif Is_Generic_Type
(Typ
)
2040 and then Nkind
(Parent
(N
)) = N_Subprogram_Body
2043 ("return type cannot be a formal incomplete type",
2044 Result_Definition
(N
));
2046 elsif Is_Class_Wide_Type
(Typ
)
2047 and then Is_Generic_Type
(Root_Type
(Typ
))
2048 and then Nkind
(Parent
(N
)) = N_Subprogram_Body
2051 ("return type cannot be a formal incomplete type",
2052 Result_Definition
(N
));
2054 elsif Is_Tagged_Type
(Typ
) then
2057 -- Use is legal in a thunk generated for an operation
2058 -- inherited from a progenitor.
2060 elsif Is_Thunk
(Designator
)
2061 and then Present
(Non_Limited_View
(Typ
))
2065 elsif Nkind
(Parent
(N
)) = N_Subprogram_Body
2066 or else Nkind_In
(Parent
(Parent
(N
)), N_Accept_Statement
,
2070 ("invalid use of untagged incomplete type&",
2074 -- The type must be completed in the current package. This
2075 -- is checked at the end of the package declaration when
2076 -- Taft-amendment types are identified. If the return type
2077 -- is class-wide, there is no required check, the type can
2078 -- be a bona fide TAT.
2080 if Ekind
(Scope
(Current_Scope
)) = E_Package
2081 and then In_Private_Part
(Scope
(Current_Scope
))
2082 and then not Is_Class_Wide_Type
(Typ
)
2084 Append_Elmt
(Designator
, Private_Dependents
(Typ
));
2089 ("invalid use of incomplete type&", Designator
, Typ
);
2094 -- Case where result definition does indicate an error
2097 Set_Etype
(Designator
, Any_Type
);
2099 end Analyze_Return_Type
;
2101 -----------------------------
2102 -- Analyze_Subprogram_Body --
2103 -----------------------------
2105 procedure Analyze_Subprogram_Body
(N
: Node_Id
) is
2106 Loc
: constant Source_Ptr
:= Sloc
(N
);
2107 Body_Spec
: constant Node_Id
:= Specification
(N
);
2108 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Spec
);
2111 if Debug_Flag_C
then
2112 Write_Str
("==> subprogram body ");
2113 Write_Name
(Chars
(Body_Id
));
2114 Write_Str
(" from ");
2115 Write_Location
(Loc
);
2120 Trace_Scope
(N
, Body_Id
, " Analyze subprogram: ");
2122 -- The real work is split out into the helper, so it can do "return;"
2123 -- without skipping the debug output:
2125 Analyze_Subprogram_Body_Helper
(N
);
2127 if Debug_Flag_C
then
2129 Write_Str
("<== subprogram body ");
2130 Write_Name
(Chars
(Body_Id
));
2131 Write_Str
(" from ");
2132 Write_Location
(Loc
);
2135 end Analyze_Subprogram_Body
;
2137 ------------------------------------
2138 -- Analyze_Subprogram_Body_Helper --
2139 ------------------------------------
2141 -- This procedure is called for regular subprogram bodies, generic bodies,
2142 -- and for subprogram stubs of both kinds. In the case of stubs, only the
2143 -- specification matters, and is used to create a proper declaration for
2144 -- the subprogram, or to perform conformance checks.
2146 procedure Analyze_Subprogram_Body_Helper
(N
: Node_Id
) is
2147 Loc
: constant Source_Ptr
:= Sloc
(N
);
2148 Body_Spec
: Node_Id
:= Specification
(N
);
2149 Body_Id
: Entity_Id
:= Defining_Entity
(Body_Spec
);
2150 Prev_Id
: constant Entity_Id
:= Current_Entity_In_Scope
(Body_Id
);
2151 Conformant
: Boolean;
2153 Prot_Typ
: Entity_Id
:= Empty
;
2154 Spec_Id
: Entity_Id
;
2155 Spec_Decl
: Node_Id
:= Empty
;
2157 Last_Real_Spec_Entity
: Entity_Id
:= Empty
;
2158 -- When we analyze a separate spec, the entity chain ends up containing
2159 -- the formals, as well as any itypes generated during analysis of the
2160 -- default expressions for parameters, or the arguments of associated
2161 -- precondition/postcondition pragmas (which are analyzed in the context
2162 -- of the spec since they have visibility on formals).
2164 -- These entities belong with the spec and not the body. However we do
2165 -- the analysis of the body in the context of the spec (again to obtain
2166 -- visibility to the formals), and all the entities generated during
2167 -- this analysis end up also chained to the entity chain of the spec.
2168 -- But they really belong to the body, and there is circuitry to move
2169 -- them from the spec to the body.
2171 -- However, when we do this move, we don't want to move the real spec
2172 -- entities (first para above) to the body. The Last_Real_Spec_Entity
2173 -- variable points to the last real spec entity, so we only move those
2174 -- chained beyond that point. It is initialized to Empty to deal with
2175 -- the case where there is no separate spec.
2177 function Body_Has_Contract
return Boolean;
2178 -- Check whether unanalyzed body has an aspect or pragma that may
2179 -- generate a SPARK contract.
2181 function Body_Has_SPARK_Mode_On
return Boolean;
2182 -- Check whether SPARK_Mode On applies to the subprogram body, either
2183 -- because it is specified directly on the body, or because it is
2184 -- inherited from the enclosing subprogram or package.
2186 procedure Build_Subprogram_Declaration
;
2187 -- Create a matching subprogram declaration for subprogram body N
2189 procedure Check_Anonymous_Return
;
2190 -- Ada 2005: if a function returns an access type that denotes a task,
2191 -- or a type that contains tasks, we must create a master entity for
2192 -- the anonymous type, which typically will be used in an allocator
2193 -- in the body of the function.
2195 procedure Check_Inline_Pragma
(Spec
: in out Node_Id
);
2196 -- Look ahead to recognize a pragma that may appear after the body.
2197 -- If there is a previous spec, check that it appears in the same
2198 -- declarative part. If the pragma is Inline_Always, perform inlining
2199 -- unconditionally, otherwise only if Front_End_Inlining is requested.
2200 -- If the body acts as a spec, and inlining is required, we create a
2201 -- subprogram declaration for it, in order to attach the body to inline.
2202 -- If pragma does not appear after the body, check whether there is
2203 -- an inline pragma before any local declarations.
2205 procedure Check_Missing_Return
;
2206 -- Checks for a function with a no return statements, and also performs
2207 -- the warning checks implemented by Check_Returns. In formal mode, also
2208 -- verify that a function ends with a RETURN and that a procedure does
2209 -- not contain any RETURN.
2211 function Disambiguate_Spec
return Entity_Id
;
2212 -- When a primitive is declared between the private view and the full
2213 -- view of a concurrent type which implements an interface, a special
2214 -- mechanism is used to find the corresponding spec of the primitive
2217 procedure Exchange_Limited_Views
(Subp_Id
: Entity_Id
);
2218 -- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains
2219 -- incomplete types coming from a limited context and swap their limited
2220 -- views with the non-limited ones.
2222 function Is_Private_Concurrent_Primitive
2223 (Subp_Id
: Entity_Id
) return Boolean;
2224 -- Determine whether subprogram Subp_Id is a primitive of a concurrent
2225 -- type that implements an interface and has a private view.
2227 procedure Set_Trivial_Subprogram
(N
: Node_Id
);
2228 -- Sets the Is_Trivial_Subprogram flag in both spec and body of the
2229 -- subprogram whose body is being analyzed. N is the statement node
2230 -- causing the flag to be set, if the following statement is a return
2231 -- of an entity, we mark the entity as set in source to suppress any
2232 -- warning on the stylized use of function stubs with a dummy return.
2234 procedure Verify_Overriding_Indicator
;
2235 -- If there was a previous spec, the entity has been entered in the
2236 -- current scope previously. If the body itself carries an overriding
2237 -- indicator, check that it is consistent with the known status of the
2240 -----------------------
2241 -- Body_Has_Contract --
2242 -----------------------
2244 function Body_Has_Contract
return Boolean is
2245 Decls
: constant List_Id
:= Declarations
(N
);
2249 -- Check for aspects that may generate a contract
2251 if Present
(Aspect_Specifications
(N
)) then
2252 Item
:= First
(Aspect_Specifications
(N
));
2253 while Present
(Item
) loop
2254 if Is_Subprogram_Contract_Annotation
(Item
) then
2262 -- Check for pragmas that may generate a contract
2264 if Present
(Decls
) then
2265 Item
:= First
(Decls
);
2266 while Present
(Item
) loop
2267 if Nkind
(Item
) = N_Pragma
2268 and then Is_Subprogram_Contract_Annotation
(Item
)
2278 end Body_Has_Contract
;
2280 ----------------------------
2281 -- Body_Has_SPARK_Mode_On --
2282 ----------------------------
2284 function Body_Has_SPARK_Mode_On
return Boolean is
2285 Decls
: constant List_Id
:= Declarations
(N
);
2289 -- Check for SPARK_Mode aspect
2291 if Present
(Aspect_Specifications
(N
)) then
2292 Item
:= First
(Aspect_Specifications
(N
));
2293 while Present
(Item
) loop
2294 if Get_Aspect_Id
(Item
) = Aspect_SPARK_Mode
then
2295 return Get_SPARK_Mode_From_Annotation
(Item
) = On
;
2302 -- Check for SPARK_Mode pragma
2304 if Present
(Decls
) then
2305 Item
:= First
(Decls
);
2306 while Present
(Item
) loop
2308 -- Pragmas that apply to a subprogram body are usually grouped
2309 -- together. Look for a potential pragma SPARK_Mode among them.
2311 if Nkind
(Item
) = N_Pragma
then
2312 if Get_Pragma_Id
(Item
) = Pragma_SPARK_Mode
then
2313 return Get_SPARK_Mode_From_Annotation
(Item
) = On
;
2316 -- Otherwise the first non-pragma declarative item terminates
2317 -- the region where pragma SPARK_Mode may appear.
2327 -- Otherwise, the applicable SPARK_Mode is inherited from the
2328 -- enclosing subprogram or package.
2330 return SPARK_Mode
= On
;
2331 end Body_Has_SPARK_Mode_On
;
2333 ----------------------------------
2334 -- Build_Subprogram_Declaration --
2335 ----------------------------------
2337 procedure Build_Subprogram_Declaration
is
2338 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
);
2339 -- Relocate certain categorization pragmas from the declarative list
2340 -- of subprogram body From and insert them after node To. The pragmas
2344 -- Volatile_Function
2350 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
) is
2352 Next_Decl
: Node_Id
;
2355 pragma Assert
(Nkind
(From
) = N_Subprogram_Body
);
2357 -- The destination node must be part of a list, as the pragmas are
2358 -- inserted after it.
2360 pragma Assert
(Is_List_Member
(To
));
2362 -- Inspect the declarations of the subprogram body looking for
2363 -- specific pragmas.
2365 Decl
:= First
(Declarations
(N
));
2366 while Present
(Decl
) loop
2367 Next_Decl
:= Next
(Decl
);
2369 if Nkind
(Decl
) = N_Pragma
2370 and then Nam_In
(Pragma_Name
(Decl
), Name_Ghost
,
2372 Name_Volatile_Function
)
2375 Insert_After
(To
, Decl
);
2385 Subp_Decl
: Node_Id
;
2387 -- Start of processing for Build_Subprogram_Declaration
2390 -- Create a matching subprogram spec using the profile of the body.
2391 -- The structure of the tree is identical, but has new entities for
2392 -- the defining unit name and formal parameters.
2395 Make_Subprogram_Declaration
(Loc
,
2396 Specification
=> Copy_Subprogram_Spec
(Body_Spec
));
2397 Set_Comes_From_Source
(Subp_Decl
, True);
2399 -- Relocate the aspects and relevant pragmas from the subprogram body
2400 -- to the generated spec because it acts as the initial declaration.
2402 Insert_Before
(N
, Subp_Decl
);
2403 Move_Aspects
(N
, To
=> Subp_Decl
);
2404 Move_Pragmas
(N
, To
=> Subp_Decl
);
2406 Analyze
(Subp_Decl
);
2408 -- Propagate the attribute Rewritten_For_C to the body since the
2409 -- expander may generate calls using that entity. Required to ensure
2410 -- that Expand_Call rewrites calls to this function by calls to the
2413 if Nkind
(Body_Spec
) = N_Function_Specification
then
2414 Set_Rewritten_For_C
(Defining_Entity
(Body_Spec
),
2415 Rewritten_For_C
(Defining_Entity
(Specification
(Subp_Decl
))));
2418 -- Analyze any relocated source pragmas or pragmas created for aspect
2421 Decl
:= Next
(Subp_Decl
);
2422 while Present
(Decl
) loop
2424 -- Stop the search for pragmas once the body has been reached as
2425 -- this terminates the region where pragmas may appear.
2430 elsif Nkind
(Decl
) = N_Pragma
then
2437 Spec_Id
:= Defining_Entity
(Subp_Decl
);
2438 Set_Corresponding_Spec
(N
, Spec_Id
);
2440 -- Mark the generated spec as a source construct to ensure that all
2441 -- calls to it are properly registered in ALI files for GNATprove.
2443 Set_Comes_From_Source
(Spec_Id
, True);
2445 -- Ensure that the specs of the subprogram declaration and its body
2446 -- are identical, otherwise they will appear non-conformant due to
2447 -- rewritings in the default values of formal parameters.
2449 Body_Spec
:= Copy_Subprogram_Spec
(Body_Spec
);
2450 Set_Specification
(N
, Body_Spec
);
2451 Body_Id
:= Analyze_Subprogram_Specification
(Body_Spec
);
2453 -- Ensure that the generated corresponding spec and original body
2454 -- share the same Ghost and SPARK_Mode attributes.
2456 Set_Is_Checked_Ghost_Entity
2457 (Body_Id
, Is_Checked_Ghost_Entity
(Spec_Id
));
2458 Set_Is_Ignored_Ghost_Entity
2459 (Body_Id
, Is_Ignored_Ghost_Entity
(Spec_Id
));
2461 Set_SPARK_Pragma
(Body_Id
, SPARK_Pragma
(Spec_Id
));
2462 Set_SPARK_Pragma_Inherited
2463 (Body_Id
, SPARK_Pragma_Inherited
(Spec_Id
));
2464 end Build_Subprogram_Declaration
;
2466 ----------------------------
2467 -- Check_Anonymous_Return --
2468 ----------------------------
2470 procedure Check_Anonymous_Return
is
2476 if Present
(Spec_Id
) then
2482 if Ekind
(Scop
) = E_Function
2483 and then Ekind
(Etype
(Scop
)) = E_Anonymous_Access_Type
2484 and then not Is_Thunk
(Scop
)
2486 -- Skip internally built functions which handle the case of
2487 -- a null access (see Expand_Interface_Conversion)
2489 and then not (Is_Interface
(Designated_Type
(Etype
(Scop
)))
2490 and then not Comes_From_Source
(Parent
(Scop
)))
2492 and then (Has_Task
(Designated_Type
(Etype
(Scop
)))
2494 (Is_Class_Wide_Type
(Designated_Type
(Etype
(Scop
)))
2496 Is_Limited_Record
(Designated_Type
(Etype
(Scop
)))))
2497 and then Expander_Active
2499 -- Avoid cases with no tasking support
2501 and then RTE_Available
(RE_Current_Master
)
2502 and then not Restriction_Active
(No_Task_Hierarchy
)
2505 Make_Object_Declaration
(Loc
,
2506 Defining_Identifier
=>
2507 Make_Defining_Identifier
(Loc
, Name_uMaster
),
2508 Constant_Present
=> True,
2509 Object_Definition
=>
2510 New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
2512 Make_Explicit_Dereference
(Loc
,
2513 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
2515 if Present
(Declarations
(N
)) then
2516 Prepend
(Decl
, Declarations
(N
));
2518 Set_Declarations
(N
, New_List
(Decl
));
2521 Set_Master_Id
(Etype
(Scop
), Defining_Identifier
(Decl
));
2522 Set_Has_Master_Entity
(Scop
);
2524 -- Now mark the containing scope as a task master
2527 while Nkind
(Par
) /= N_Compilation_Unit
loop
2528 Par
:= Parent
(Par
);
2529 pragma Assert
(Present
(Par
));
2531 -- If we fall off the top, we are at the outer level, and
2532 -- the environment task is our effective master, so nothing
2536 (Par
, N_Task_Body
, N_Block_Statement
, N_Subprogram_Body
)
2538 Set_Is_Task_Master
(Par
, True);
2543 end Check_Anonymous_Return
;
2545 -------------------------
2546 -- Check_Inline_Pragma --
2547 -------------------------
2549 procedure Check_Inline_Pragma
(Spec
: in out Node_Id
) is
2553 function Is_Inline_Pragma
(N
: Node_Id
) return Boolean;
2554 -- True when N is a pragma Inline or Inline_Always that applies
2555 -- to this subprogram.
2557 -----------------------
2558 -- Is_Inline_Pragma --
2559 -----------------------
2561 function Is_Inline_Pragma
(N
: Node_Id
) return Boolean is
2563 if Nkind
(N
) = N_Pragma
2565 (Pragma_Name
(N
) = Name_Inline_Always
2566 or else (Pragma_Name
(N
) = Name_Inline
2568 (Front_End_Inlining
or else Optimization_Level
> 0)))
2569 and then Present
(Pragma_Argument_Associations
(N
))
2572 Pragma_Arg
: Node_Id
:=
2573 Expression
(First
(Pragma_Argument_Associations
(N
)));
2575 if Nkind
(Pragma_Arg
) = N_Selected_Component
then
2576 Pragma_Arg
:= Selector_Name
(Pragma_Arg
);
2579 return Chars
(Pragma_Arg
) = Chars
(Body_Id
);
2585 end Is_Inline_Pragma
;
2587 -- Start of processing for Check_Inline_Pragma
2590 if not Expander_Active
then
2594 if Is_List_Member
(N
)
2595 and then Present
(Next
(N
))
2596 and then Is_Inline_Pragma
(Next
(N
))
2600 elsif Nkind
(N
) /= N_Subprogram_Body_Stub
2601 and then Present
(Declarations
(N
))
2602 and then Is_Inline_Pragma
(First
(Declarations
(N
)))
2604 Prag
:= First
(Declarations
(N
));
2610 if Present
(Prag
) then
2611 if Present
(Spec_Id
) then
2612 if Is_List_Member
(N
)
2613 and then Is_List_Member
(Unit_Declaration_Node
(Spec_Id
))
2614 and then In_Same_List
(N
, Unit_Declaration_Node
(Spec_Id
))
2620 -- Create a subprogram declaration, to make treatment uniform.
2621 -- Make the sloc of the subprogram name that of the entity in
2622 -- the body, so that style checks find identical strings.
2625 Subp
: constant Entity_Id
:=
2626 Make_Defining_Identifier
2627 (Sloc
(Body_Id
), Chars
(Body_Id
));
2628 Decl
: constant Node_Id
:=
2629 Make_Subprogram_Declaration
(Loc
,
2631 New_Copy_Tree
(Specification
(N
)));
2634 Set_Defining_Unit_Name
(Specification
(Decl
), Subp
);
2636 -- To ensure proper coverage when body is inlined, indicate
2637 -- whether the subprogram comes from source.
2639 Set_Comes_From_Source
(Subp
, Comes_From_Source
(N
));
2641 if Present
(First_Formal
(Body_Id
)) then
2642 Plist
:= Copy_Parameter_List
(Body_Id
);
2643 Set_Parameter_Specifications
2644 (Specification
(Decl
), Plist
);
2647 Insert_Before
(N
, Decl
);
2650 Set_Has_Pragma_Inline
(Subp
);
2652 if Pragma_Name
(Prag
) = Name_Inline_Always
then
2653 Set_Is_Inlined
(Subp
);
2654 Set_Has_Pragma_Inline_Always
(Subp
);
2657 -- Prior to copying the subprogram body to create a template
2658 -- for it for subsequent inlining, remove the pragma from
2659 -- the current body so that the copy that will produce the
2660 -- new body will start from a completely unanalyzed tree.
2662 if Nkind
(Parent
(Prag
)) = N_Subprogram_Body
then
2663 Rewrite
(Prag
, Make_Null_Statement
(Sloc
(Prag
)));
2670 end Check_Inline_Pragma
;
2672 --------------------------
2673 -- Check_Missing_Return --
2674 --------------------------
2676 procedure Check_Missing_Return
is
2678 Missing_Ret
: Boolean;
2681 if Nkind
(Body_Spec
) = N_Function_Specification
then
2682 if Present
(Spec_Id
) then
2688 if Return_Present
(Id
) then
2689 Check_Returns
(HSS
, 'F', Missing_Ret
);
2692 Set_Has_Missing_Return
(Id
);
2695 -- Within a premature instantiation of a package with no body, we
2696 -- build completions of the functions therein, with a Raise
2697 -- statement. No point in complaining about a missing return in
2700 elsif Ekind
(Id
) = E_Function
2701 and then In_Instance
2702 and then Present
(Statements
(HSS
))
2703 and then Nkind
(First
(Statements
(HSS
))) = N_Raise_Program_Error
2707 elsif Is_Generic_Subprogram
(Id
)
2708 or else not Is_Machine_Code_Subprogram
(Id
)
2710 Error_Msg_N
("missing RETURN statement in function body", N
);
2713 -- If procedure with No_Return, check returns
2715 elsif Nkind
(Body_Spec
) = N_Procedure_Specification
2716 and then Present
(Spec_Id
)
2717 and then No_Return
(Spec_Id
)
2719 Check_Returns
(HSS
, 'P', Missing_Ret
, Spec_Id
);
2722 -- Special checks in SPARK mode
2724 if Nkind
(Body_Spec
) = N_Function_Specification
then
2726 -- In SPARK mode, last statement of a function should be a return
2729 Stat
: constant Node_Id
:= Last_Source_Statement
(HSS
);
2732 and then not Nkind_In
(Stat
, N_Simple_Return_Statement
,
2733 N_Extended_Return_Statement
)
2735 Check_SPARK_05_Restriction
2736 ("last statement in function should be RETURN", Stat
);
2740 -- In SPARK mode, verify that a procedure has no return
2742 elsif Nkind
(Body_Spec
) = N_Procedure_Specification
then
2743 if Present
(Spec_Id
) then
2749 -- Would be nice to point to return statement here, can we
2750 -- borrow the Check_Returns procedure here ???
2752 if Return_Present
(Id
) then
2753 Check_SPARK_05_Restriction
2754 ("procedure should not have RETURN", N
);
2757 end Check_Missing_Return
;
2759 -----------------------
2760 -- Disambiguate_Spec --
2761 -----------------------
2763 function Disambiguate_Spec
return Entity_Id
is
2764 Priv_Spec
: Entity_Id
;
2767 procedure Replace_Types
(To_Corresponding
: Boolean);
2768 -- Depending on the flag, replace the type of formal parameters of
2769 -- Body_Id if it is a concurrent type implementing interfaces with
2770 -- the corresponding record type or the other way around.
2772 procedure Replace_Types
(To_Corresponding
: Boolean) is
2774 Formal_Typ
: Entity_Id
;
2777 Formal
:= First_Formal
(Body_Id
);
2778 while Present
(Formal
) loop
2779 Formal_Typ
:= Etype
(Formal
);
2781 if Is_Class_Wide_Type
(Formal_Typ
) then
2782 Formal_Typ
:= Root_Type
(Formal_Typ
);
2785 -- From concurrent type to corresponding record
2787 if To_Corresponding
then
2788 if Is_Concurrent_Type
(Formal_Typ
)
2789 and then Present
(Corresponding_Record_Type
(Formal_Typ
))
2792 (Corresponding_Record_Type
(Formal_Typ
)))
2795 Corresponding_Record_Type
(Formal_Typ
));
2798 -- From corresponding record to concurrent type
2801 if Is_Concurrent_Record_Type
(Formal_Typ
)
2802 and then Present
(Interfaces
(Formal_Typ
))
2805 Corresponding_Concurrent_Type
(Formal_Typ
));
2809 Next_Formal
(Formal
);
2813 -- Start of processing for Disambiguate_Spec
2816 -- Try to retrieve the specification of the body as is. All error
2817 -- messages are suppressed because the body may not have a spec in
2818 -- its current state.
2820 Spec_N
:= Find_Corresponding_Spec
(N
, False);
2822 -- It is possible that this is the body of a primitive declared
2823 -- between a private and a full view of a concurrent type. The
2824 -- controlling parameter of the spec carries the concurrent type,
2825 -- not the corresponding record type as transformed by Analyze_
2826 -- Subprogram_Specification. In such cases, we undo the change
2827 -- made by the analysis of the specification and try to find the
2830 -- Note that wrappers already have their corresponding specs and
2831 -- bodies set during their creation, so if the candidate spec is
2832 -- a wrapper, then we definitely need to swap all types to their
2833 -- original concurrent status.
2836 or else Is_Primitive_Wrapper
(Spec_N
)
2838 -- Restore all references of corresponding record types to the
2839 -- original concurrent types.
2841 Replace_Types
(To_Corresponding
=> False);
2842 Priv_Spec
:= Find_Corresponding_Spec
(N
, False);
2844 -- The current body truly belongs to a primitive declared between
2845 -- a private and a full view. We leave the modified body as is,
2846 -- and return the true spec.
2848 if Present
(Priv_Spec
)
2849 and then Is_Private_Primitive
(Priv_Spec
)
2854 -- In case that this is some sort of error, restore the original
2855 -- state of the body.
2857 Replace_Types
(To_Corresponding
=> True);
2861 end Disambiguate_Spec
;
2863 ----------------------------
2864 -- Exchange_Limited_Views --
2865 ----------------------------
2867 procedure Exchange_Limited_Views
(Subp_Id
: Entity_Id
) is
2868 procedure Detect_And_Exchange
(Id
: Entity_Id
);
2869 -- Determine whether Id's type denotes an incomplete type associated
2870 -- with a limited with clause and exchange the limited view with the
2871 -- non-limited one when available. Note that the non-limited view
2872 -- may exist because of a with_clause in another unit in the context,
2873 -- but cannot be used because the current view of the enclosing unit
2874 -- is still a limited view.
2876 -------------------------
2877 -- Detect_And_Exchange --
2878 -------------------------
2880 procedure Detect_And_Exchange
(Id
: Entity_Id
) is
2881 Typ
: constant Entity_Id
:= Etype
(Id
);
2883 if From_Limited_With
(Typ
)
2884 and then Has_Non_Limited_View
(Typ
)
2885 and then not From_Limited_With
(Scope
(Typ
))
2887 Set_Etype
(Id
, Non_Limited_View
(Typ
));
2889 end Detect_And_Exchange
;
2895 -- Start of processing for Exchange_Limited_Views
2898 if No
(Subp_Id
) then
2901 -- Do not process subprogram bodies as they already use the non-
2902 -- limited view of types.
2904 elsif not Ekind_In
(Subp_Id
, E_Function
, E_Procedure
) then
2908 -- Examine all formals and swap views when applicable
2910 Formal
:= First_Formal
(Subp_Id
);
2911 while Present
(Formal
) loop
2912 Detect_And_Exchange
(Formal
);
2914 Next_Formal
(Formal
);
2917 -- Process the return type of a function
2919 if Ekind
(Subp_Id
) = E_Function
then
2920 Detect_And_Exchange
(Subp_Id
);
2922 end Exchange_Limited_Views
;
2924 -------------------------------------
2925 -- Is_Private_Concurrent_Primitive --
2926 -------------------------------------
2928 function Is_Private_Concurrent_Primitive
2929 (Subp_Id
: Entity_Id
) return Boolean
2931 Formal_Typ
: Entity_Id
;
2934 if Present
(First_Formal
(Subp_Id
)) then
2935 Formal_Typ
:= Etype
(First_Formal
(Subp_Id
));
2937 if Is_Concurrent_Record_Type
(Formal_Typ
) then
2938 if Is_Class_Wide_Type
(Formal_Typ
) then
2939 Formal_Typ
:= Root_Type
(Formal_Typ
);
2942 Formal_Typ
:= Corresponding_Concurrent_Type
(Formal_Typ
);
2945 -- The type of the first formal is a concurrent tagged type with
2949 Is_Concurrent_Type
(Formal_Typ
)
2950 and then Is_Tagged_Type
(Formal_Typ
)
2951 and then Has_Private_Declaration
(Formal_Typ
);
2955 end Is_Private_Concurrent_Primitive
;
2957 ----------------------------
2958 -- Set_Trivial_Subprogram --
2959 ----------------------------
2961 procedure Set_Trivial_Subprogram
(N
: Node_Id
) is
2962 Nxt
: constant Node_Id
:= Next
(N
);
2965 Set_Is_Trivial_Subprogram
(Body_Id
);
2967 if Present
(Spec_Id
) then
2968 Set_Is_Trivial_Subprogram
(Spec_Id
);
2972 and then Nkind
(Nxt
) = N_Simple_Return_Statement
2973 and then No
(Next
(Nxt
))
2974 and then Present
(Expression
(Nxt
))
2975 and then Is_Entity_Name
(Expression
(Nxt
))
2977 Set_Never_Set_In_Source
(Entity
(Expression
(Nxt
)), False);
2979 end Set_Trivial_Subprogram
;
2981 ---------------------------------
2982 -- Verify_Overriding_Indicator --
2983 ---------------------------------
2985 procedure Verify_Overriding_Indicator
is
2987 if Must_Override
(Body_Spec
) then
2988 if Nkind
(Spec_Id
) = N_Defining_Operator_Symbol
2989 and then Operator_Matches_Spec
(Spec_Id
, Spec_Id
)
2993 elsif not Present
(Overridden_Operation
(Spec_Id
)) then
2995 ("subprogram& is not overriding", Body_Spec
, Spec_Id
);
2997 -- Overriding indicators aren't allowed for protected subprogram
2998 -- bodies (see the Confirmation in Ada Comment AC95-00213). Change
2999 -- this to a warning if -gnatd.E is enabled.
3001 elsif Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
3002 Error_Msg_Warn
:= Error_To_Warning
;
3004 ("<<overriding indicator not allowed for protected "
3005 & "subprogram body", Body_Spec
);
3008 elsif Must_Not_Override
(Body_Spec
) then
3009 if Present
(Overridden_Operation
(Spec_Id
)) then
3011 ("subprogram& overrides inherited operation",
3012 Body_Spec
, Spec_Id
);
3014 elsif Nkind
(Spec_Id
) = N_Defining_Operator_Symbol
3015 and then Operator_Matches_Spec
(Spec_Id
, Spec_Id
)
3018 ("subprogram& overrides predefined operator ",
3019 Body_Spec
, Spec_Id
);
3021 -- Overriding indicators aren't allowed for protected subprogram
3022 -- bodies (see the Confirmation in Ada Comment AC95-00213). Change
3023 -- this to a warning if -gnatd.E is enabled.
3025 elsif Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
3026 Error_Msg_Warn
:= Error_To_Warning
;
3029 ("<<overriding indicator not allowed "
3030 & "for protected subprogram body", Body_Spec
);
3032 -- If this is not a primitive operation, then the overriding
3033 -- indicator is altogether illegal.
3035 elsif not Is_Primitive
(Spec_Id
) then
3037 ("overriding indicator only allowed "
3038 & "if subprogram is primitive", Body_Spec
);
3041 -- If checking the style rule and the operation overrides, then
3042 -- issue a warning about a missing overriding_indicator. Protected
3043 -- subprogram bodies are excluded from this style checking, since
3044 -- they aren't primitives (even though their declarations can
3045 -- override) and aren't allowed to have an overriding_indicator.
3048 and then Present
(Overridden_Operation
(Spec_Id
))
3049 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
3051 pragma Assert
(Unit_Declaration_Node
(Body_Id
) = N
);
3052 Style
.Missing_Overriding
(N
, Body_Id
);
3055 and then Can_Override_Operator
(Spec_Id
)
3056 and then not Is_Predefined_File_Name
3057 (Unit_File_Name
(Get_Source_Unit
(Spec_Id
)))
3059 pragma Assert
(Unit_Declaration_Node
(Body_Id
) = N
);
3060 Style
.Missing_Overriding
(N
, Body_Id
);
3062 end Verify_Overriding_Indicator
;
3066 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
3068 -- Start of processing for Analyze_Subprogram_Body_Helper
3071 -- A [generic] subprogram body "freezes" the contract of the nearest
3072 -- enclosing package body and all other contracts encountered in the
3073 -- same declarative part up to and excluding the subprogram body:
3075 -- package body Nearest_Enclosing_Package
3076 -- with Refined_State => (State => Constit)
3080 -- procedure Freezes_Enclosing_Package_Body
3081 -- with Refined_Depends => (Input => Constit) ...
3083 -- This ensures that any annotations referenced by the contract of the
3084 -- [generic] subprogram body are available. This form of "freezing" is
3085 -- decoupled from the usual Freeze_xxx mechanism because it must also
3086 -- work in the context of generics where normal freezing is disabled.
3088 -- Only bodies coming from source should cause this type of "freezing".
3089 -- Expression functions that act as bodies and complete an initial
3090 -- declaration must be included in this category, hence the use of
3093 if Comes_From_Source
(Original_Node
(N
)) then
3094 Analyze_Previous_Contracts
(N
);
3097 -- Generic subprograms are handled separately. They always have a
3098 -- generic specification. Determine whether current scope has a
3099 -- previous declaration.
3101 -- If the subprogram body is defined within an instance of the same
3102 -- name, the instance appears as a package renaming, and will be hidden
3103 -- within the subprogram.
3105 if Present
(Prev_Id
)
3106 and then not Is_Overloadable
(Prev_Id
)
3107 and then (Nkind
(Parent
(Prev_Id
)) /= N_Package_Renaming_Declaration
3108 or else Comes_From_Source
(Prev_Id
))
3110 if Is_Generic_Subprogram
(Prev_Id
) then
3113 -- A subprogram body is Ghost when it is stand alone and subject
3114 -- to pragma Ghost or when the corresponding spec is Ghost. Set
3115 -- the mode now to ensure that any nodes generated during analysis
3116 -- and expansion are properly marked as Ghost.
3118 Set_Ghost_Mode
(N
, Spec_Id
);
3119 Set_Is_Compilation_Unit
(Body_Id
, Is_Compilation_Unit
(Spec_Id
));
3120 Set_Is_Child_Unit
(Body_Id
, Is_Child_Unit
(Spec_Id
));
3122 Analyze_Generic_Subprogram_Body
(N
, Spec_Id
);
3124 if Nkind
(N
) = N_Subprogram_Body
then
3125 HSS
:= Handled_Statement_Sequence
(N
);
3126 Check_Missing_Return
;
3129 Ghost_Mode
:= Save_Ghost_Mode
;
3133 -- Previous entity conflicts with subprogram name. Attempting to
3134 -- enter name will post error.
3136 Enter_Name
(Body_Id
);
3137 Ghost_Mode
:= Save_Ghost_Mode
;
3141 -- Non-generic case, find the subprogram declaration, if one was seen,
3142 -- or enter new overloaded entity in the current scope. If the
3143 -- Current_Entity is the Body_Id itself, the unit is being analyzed as
3144 -- part of the context of one of its subunits. No need to redo the
3147 elsif Prev_Id
= Body_Id
and then Has_Completion
(Body_Id
) then
3148 Ghost_Mode
:= Save_Ghost_Mode
;
3152 Body_Id
:= Analyze_Subprogram_Specification
(Body_Spec
);
3154 if Nkind
(N
) = N_Subprogram_Body_Stub
3155 or else No
(Corresponding_Spec
(N
))
3157 if Is_Private_Concurrent_Primitive
(Body_Id
) then
3158 Spec_Id
:= Disambiguate_Spec
;
3160 -- A subprogram body is Ghost when it is stand alone and
3161 -- subject to pragma Ghost or when the corresponding spec is
3162 -- Ghost. Set the mode now to ensure that any nodes generated
3163 -- during analysis and expansion are properly marked as Ghost.
3165 Set_Ghost_Mode
(N
, Spec_Id
);
3168 Spec_Id
:= Find_Corresponding_Spec
(N
);
3170 -- A subprogram body is Ghost when it is stand alone and
3171 -- subject to pragma Ghost or when the corresponding spec is
3172 -- Ghost. Set the mode now to ensure that any nodes generated
3173 -- during analysis and expansion are properly marked as Ghost.
3175 Set_Ghost_Mode
(N
, Spec_Id
);
3177 -- In GNATprove mode, if the body has no previous spec, create
3178 -- one so that the inlining machinery can operate properly.
3179 -- Transfer aspects, if any, to the new spec, so that they
3180 -- are legal and can be processed ahead of the body.
3181 -- We make two copies of the given spec, one for the new
3182 -- declaration, and one for the body.
3184 if No
(Spec_Id
) and then GNATprove_Mode
3186 -- Inlining does not apply during pre-analysis of code
3188 and then Full_Analysis
3190 -- Inlining only applies to full bodies, not stubs
3192 and then Nkind
(N
) /= N_Subprogram_Body_Stub
3194 -- Inlining only applies to bodies in the source code, not to
3195 -- those generated by the compiler. In particular, expression
3196 -- functions, whose body is generated by the compiler, are
3197 -- treated specially by GNATprove.
3199 and then Comes_From_Source
(Body_Id
)
3201 -- This cannot be done for a compilation unit, which is not
3202 -- in a context where we can insert a new spec.
3204 and then Is_List_Member
(N
)
3206 -- Inlining only applies to subprograms without contracts,
3207 -- as a contract is a sign that GNATprove should perform a
3208 -- modular analysis of the subprogram instead of a contextual
3209 -- analysis at each call site. The same test is performed in
3210 -- Inline.Can_Be_Inlined_In_GNATprove_Mode. It is repeated
3211 -- here in another form (because the contract has not
3212 -- been attached to the body) to avoid frontend errors in
3213 -- case pragmas are used instead of aspects, because the
3214 -- corresponding pragmas in the body would not be transferred
3215 -- to the spec, leading to legality errors.
3217 and then not Body_Has_Contract
3218 and then not Inside_A_Generic
3220 Build_Subprogram_Declaration
;
3222 -- If this is a function that returns a constrained array, and
3223 -- we are generating SPARK_For_C, create subprogram declaration
3224 -- to simplify subsequent C generation.
3227 and then Modify_Tree_For_C
3228 and then Nkind
(Body_Spec
) = N_Function_Specification
3229 and then Is_Array_Type
(Etype
(Body_Id
))
3230 and then Is_Constrained
(Etype
(Body_Id
))
3232 Build_Subprogram_Declaration
;
3236 -- If this is a duplicate body, no point in analyzing it
3238 if Error_Posted
(N
) then
3239 Ghost_Mode
:= Save_Ghost_Mode
;
3243 -- A subprogram body should cause freezing of its own declaration,
3244 -- but if there was no previous explicit declaration, then the
3245 -- subprogram will get frozen too late (there may be code within
3246 -- the body that depends on the subprogram having been frozen,
3247 -- such as uses of extra formals), so we force it to be frozen
3248 -- here. Same holds if the body and spec are compilation units.
3249 -- Finally, if the return type is an anonymous access to protected
3250 -- subprogram, it must be frozen before the body because its
3251 -- expansion has generated an equivalent type that is used when
3252 -- elaborating the body.
3254 -- An exception in the case of Ada 2012, AI05-177: The bodies
3255 -- created for expression functions do not freeze.
3258 and then Nkind
(Original_Node
(N
)) /= N_Expression_Function
3260 Freeze_Before
(N
, Body_Id
);
3262 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3263 Freeze_Before
(N
, Spec_Id
);
3265 elsif Is_Access_Subprogram_Type
(Etype
(Body_Id
)) then
3266 Freeze_Before
(N
, Etype
(Body_Id
));
3270 Spec_Id
:= Corresponding_Spec
(N
);
3272 -- A subprogram body is Ghost when it is stand alone and subject
3273 -- to pragma Ghost or when the corresponding spec is Ghost. Set
3274 -- the mode now to ensure that any nodes generated during analysis
3275 -- and expansion are properly marked as Ghost.
3277 Set_Ghost_Mode
(N
, Spec_Id
);
3281 -- Previously we scanned the body to look for nested subprograms, and
3282 -- rejected an inline directive if nested subprograms were present,
3283 -- because the back-end would generate conflicting symbols for the
3284 -- nested bodies. This is now unnecessary.
3286 -- Look ahead to recognize a pragma Inline that appears after the body
3288 Check_Inline_Pragma
(Spec_Id
);
3290 -- Deal with special case of a fully private operation in the body of
3291 -- the protected type. We must create a declaration for the subprogram,
3292 -- in order to attach the protected subprogram that will be used in
3293 -- internal calls. We exclude compiler generated bodies from the
3294 -- expander since the issue does not arise for those cases.
3297 and then Comes_From_Source
(N
)
3298 and then Is_Protected_Type
(Current_Scope
)
3300 Spec_Id
:= Build_Private_Protected_Declaration
(N
);
3303 -- If we are generating C and this is a function returning a constrained
3304 -- array type for which we must create a procedure with an extra out
3305 -- parameter, build and analyze the body now. The procedure declaration
3306 -- has already been created. We reuse the source body of the function,
3307 -- because in an instance it may contain global references that cannot
3308 -- be reanalyzed. The source function itself is not used any further,
3309 -- so we mark it as having a completion.
3312 and then Modify_Tree_For_C
3313 and then Present
(Spec_Id
)
3314 and then Ekind
(Spec_Id
) = E_Function
3315 and then Rewritten_For_C
(Spec_Id
)
3317 Set_Has_Completion
(Spec_Id
);
3319 Rewrite
(N
, Build_Procedure_Body_Form
(Spec_Id
, N
));
3322 -- The entity for the created procedure must remain invisible, so it
3323 -- does not participate in resolution of subsequent references to the
3326 Set_Is_Immediately_Visible
(Corresponding_Spec
(N
), False);
3330 -- If a separate spec is present, then deal with freezing issues
3332 if Present
(Spec_Id
) then
3333 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
3334 Verify_Overriding_Indicator
;
3336 -- In general, the spec will be frozen when we start analyzing the
3337 -- body. However, for internally generated operations, such as
3338 -- wrapper functions for inherited operations with controlling
3339 -- results, the spec may not have been frozen by the time we expand
3340 -- the freeze actions that include the bodies. In particular, extra
3341 -- formals for accessibility or for return-in-place may need to be
3342 -- generated. Freeze nodes, if any, are inserted before the current
3343 -- body. These freeze actions are also needed in ASIS mode and in
3344 -- Compile_Only mode to enable the proper back-end type annotations.
3345 -- They are necessary in any case to insure order of elaboration
3348 if not Is_Frozen
(Spec_Id
)
3349 and then (Expander_Active
3351 or else (Operating_Mode
= Check_Semantics
3352 and then Serious_Errors_Detected
= 0))
3354 Set_Has_Delayed_Freeze
(Spec_Id
);
3355 Freeze_Before
(N
, Spec_Id
);
3359 -- Place subprogram on scope stack, and make formals visible. If there
3360 -- is a spec, the visible entity remains that of the spec.
3362 if Present
(Spec_Id
) then
3363 Generate_Reference
(Spec_Id
, Body_Id
, 'b', Set_Ref
=> False);
3365 if Is_Child_Unit
(Spec_Id
) then
3366 Generate_Reference
(Spec_Id
, Scope
(Spec_Id
), 'k', False);
3370 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
3373 Set_Is_Compilation_Unit
(Body_Id
, Is_Compilation_Unit
(Spec_Id
));
3374 Set_Is_Child_Unit
(Body_Id
, Is_Child_Unit
(Spec_Id
));
3376 if Is_Abstract_Subprogram
(Spec_Id
) then
3377 Error_Msg_N
("an abstract subprogram cannot have a body", N
);
3378 Ghost_Mode
:= Save_Ghost_Mode
;
3382 Set_Convention
(Body_Id
, Convention
(Spec_Id
));
3383 Set_Has_Completion
(Spec_Id
);
3385 -- Inherit the "ghostness" of the subprogram spec. Note that this
3386 -- property is not directly inherited as the body may be subject
3387 -- to a different Ghost assertion policy.
3389 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Spec_Id
) then
3390 Set_Is_Ghost_Entity
(Body_Id
);
3392 -- The Ghost policy in effect at the point of declaration and
3393 -- at the point of completion must match (SPARK RM 6.9(14)).
3395 Check_Ghost_Completion
(Spec_Id
, Body_Id
);
3398 if Is_Protected_Type
(Scope
(Spec_Id
)) then
3399 Prot_Typ
:= Scope
(Spec_Id
);
3402 -- If this is a body generated for a renaming, do not check for
3403 -- full conformance. The check is redundant, because the spec of
3404 -- the body is a copy of the spec in the renaming declaration,
3405 -- and the test can lead to spurious errors on nested defaults.
3407 if Present
(Spec_Decl
)
3408 and then not Comes_From_Source
(N
)
3410 (Nkind
(Original_Node
(Spec_Decl
)) =
3411 N_Subprogram_Renaming_Declaration
3412 or else (Present
(Corresponding_Body
(Spec_Decl
))
3414 Nkind
(Unit_Declaration_Node
3415 (Corresponding_Body
(Spec_Decl
))) =
3416 N_Subprogram_Renaming_Declaration
))
3420 -- Conversely, the spec may have been generated for specless body
3421 -- with an inline pragma. The entity comes from source, which is
3422 -- both semantically correct and necessary for proper inlining.
3423 -- The subprogram declaration itself is not in the source.
3425 elsif Comes_From_Source
(N
)
3426 and then Present
(Spec_Decl
)
3427 and then not Comes_From_Source
(Spec_Decl
)
3428 and then Has_Pragma_Inline
(Spec_Id
)
3435 Fully_Conformant
, True, Conformant
, Body_Id
);
3438 -- If the body is not fully conformant, we have to decide if we
3439 -- should analyze it or not. If it has a really messed up profile
3440 -- then we probably should not analyze it, since we will get too
3441 -- many bogus messages.
3443 -- Our decision is to go ahead in the non-fully conformant case
3444 -- only if it is at least mode conformant with the spec. Note
3445 -- that the call to Check_Fully_Conformant has issued the proper
3446 -- error messages to complain about the lack of conformance.
3449 and then not Mode_Conformant
(Body_Id
, Spec_Id
)
3451 Ghost_Mode
:= Save_Ghost_Mode
;
3456 if Spec_Id
/= Body_Id
then
3457 Reference_Body_Formals
(Spec_Id
, Body_Id
);
3460 Set_Ekind
(Body_Id
, E_Subprogram_Body
);
3462 if Nkind
(N
) = N_Subprogram_Body_Stub
then
3463 Set_Corresponding_Spec_Of_Stub
(N
, Spec_Id
);
3468 Set_Corresponding_Spec
(N
, Spec_Id
);
3470 -- Ada 2005 (AI-345): If the operation is a primitive operation
3471 -- of a concurrent type, the type of the first parameter has been
3472 -- replaced with the corresponding record, which is the proper
3473 -- run-time structure to use. However, within the body there may
3474 -- be uses of the formals that depend on primitive operations
3475 -- of the type (in particular calls in prefixed form) for which
3476 -- we need the original concurrent type. The operation may have
3477 -- several controlling formals, so the replacement must be done
3480 if Comes_From_Source
(Spec_Id
)
3481 and then Present
(First_Entity
(Spec_Id
))
3482 and then Ekind
(Etype
(First_Entity
(Spec_Id
))) = E_Record_Type
3483 and then Is_Tagged_Type
(Etype
(First_Entity
(Spec_Id
)))
3484 and then Present
(Interfaces
(Etype
(First_Entity
(Spec_Id
))))
3485 and then Present
(Corresponding_Concurrent_Type
3486 (Etype
(First_Entity
(Spec_Id
))))
3489 Typ
: constant Entity_Id
:= Etype
(First_Entity
(Spec_Id
));
3493 Form
:= First_Formal
(Spec_Id
);
3494 while Present
(Form
) loop
3495 if Etype
(Form
) = Typ
then
3496 Set_Etype
(Form
, Corresponding_Concurrent_Type
(Typ
));
3504 -- Make the formals visible, and place subprogram on scope stack.
3505 -- This is also the point at which we set Last_Real_Spec_Entity
3506 -- to mark the entities which will not be moved to the body.
3508 Install_Formals
(Spec_Id
);
3509 Last_Real_Spec_Entity
:= Last_Entity
(Spec_Id
);
3511 -- Within an instance, add local renaming declarations so that
3512 -- gdb can retrieve the values of actuals more easily. This is
3513 -- only relevant if generating code (and indeed we definitely
3514 -- do not want these definitions -gnatc mode, because that would
3517 if Is_Generic_Instance
(Spec_Id
)
3518 and then Is_Wrapper_Package
(Current_Scope
)
3519 and then Expander_Active
3521 Build_Subprogram_Instance_Renamings
(N
, Current_Scope
);
3524 Push_Scope
(Spec_Id
);
3526 -- Make sure that the subprogram is immediately visible. For
3527 -- child units that have no separate spec this is indispensable.
3528 -- Otherwise it is safe albeit redundant.
3530 Set_Is_Immediately_Visible
(Spec_Id
);
3533 Set_Corresponding_Body
(Unit_Declaration_Node
(Spec_Id
), Body_Id
);
3534 Set_Is_Obsolescent
(Body_Id
, Is_Obsolescent
(Spec_Id
));
3535 Set_Scope
(Body_Id
, Scope
(Spec_Id
));
3537 -- Case of subprogram body with no previous spec
3540 -- Check for style warning required
3544 -- Only apply check for source level subprograms for which checks
3545 -- have not been suppressed.
3547 and then Comes_From_Source
(Body_Id
)
3548 and then not Suppress_Style_Checks
(Body_Id
)
3550 -- No warnings within an instance
3552 and then not In_Instance
3554 -- No warnings for expression functions
3556 and then Nkind
(Original_Node
(N
)) /= N_Expression_Function
3558 Style
.Body_With_No_Spec
(N
);
3561 New_Overloaded_Entity
(Body_Id
);
3563 -- A subprogram body declared within a Ghost region is automatically
3564 -- Ghost (SPARK RM 6.9(2)).
3566 if Ghost_Mode
> None
then
3567 Set_Is_Ghost_Entity
(Body_Id
);
3570 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
3571 Set_Acts_As_Spec
(N
);
3572 Generate_Definition
(Body_Id
);
3574 (Body_Id
, Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
3575 Install_Formals
(Body_Id
);
3577 Push_Scope
(Body_Id
);
3580 -- For stubs and bodies with no previous spec, generate references to
3583 Generate_Reference_To_Formals
(Body_Id
);
3586 -- Entry barrier functions are generated outside the protected type and
3587 -- should not carry the SPARK_Mode of the enclosing context.
3589 if Nkind
(N
) = N_Subprogram_Body
3590 and then Is_Entry_Barrier_Function
(N
)
3594 -- The body is generated as part of expression function expansion. When
3595 -- the expression function appears in the visible declarations of a
3596 -- package, the body is added to the private declarations. Since both
3597 -- declarative lists may be subject to a different SPARK_Mode, inherit
3598 -- the mode of the spec.
3600 -- package P with SPARK_Mode is
3601 -- function Expr_Func ... is (...); -- original
3602 -- [function Expr_Func ...;] -- generated spec
3605 -- pragma SPARK_Mode (Off);
3606 -- [function Expr_Func ... is return ...;] -- generated body
3607 -- end P; -- mode is ON
3609 elsif not Comes_From_Source
(N
)
3610 and then Present
(Prev_Id
)
3611 and then Is_Expression_Function
(Prev_Id
)
3613 Set_SPARK_Pragma
(Body_Id
, SPARK_Pragma
(Prev_Id
));
3614 Set_SPARK_Pragma_Inherited
3615 (Body_Id
, SPARK_Pragma_Inherited
(Prev_Id
));
3617 -- Set the SPARK_Mode from the current context (may be overwritten later
3618 -- with explicit pragma). Exclude the case where the SPARK_Mode appears
3619 -- initially on a stand-alone subprogram body, but is then relocated to
3620 -- a generated corresponding spec. In this scenario the mode is shared
3621 -- between the spec and body.
3623 elsif No
(SPARK_Pragma
(Body_Id
)) then
3624 Set_SPARK_Pragma
(Body_Id
, SPARK_Mode_Pragma
);
3625 Set_SPARK_Pragma_Inherited
(Body_Id
);
3628 -- If the return type is an anonymous access type whose designated type
3629 -- is the limited view of a class-wide type and the non-limited view is
3630 -- available, update the return type accordingly.
3632 if Ada_Version
>= Ada_2005
and then Comes_From_Source
(N
) then
3638 Rtyp
:= Etype
(Current_Scope
);
3640 if Ekind
(Rtyp
) = E_Anonymous_Access_Type
then
3641 Etyp
:= Directly_Designated_Type
(Rtyp
);
3643 if Is_Class_Wide_Type
(Etyp
)
3644 and then From_Limited_With
(Etyp
)
3646 Set_Directly_Designated_Type
3647 (Etype
(Current_Scope
), Available_View
(Etyp
));
3653 -- If this is the proper body of a stub, we must verify that the stub
3654 -- conforms to the body, and to the previous spec if one was present.
3655 -- We know already that the body conforms to that spec. This test is
3656 -- only required for subprograms that come from source.
3658 if Nkind
(Parent
(N
)) = N_Subunit
3659 and then Comes_From_Source
(N
)
3660 and then not Error_Posted
(Body_Id
)
3661 and then Nkind
(Corresponding_Stub
(Parent
(N
))) =
3662 N_Subprogram_Body_Stub
3665 Old_Id
: constant Entity_Id
:=
3667 (Specification
(Corresponding_Stub
(Parent
(N
))));
3669 Conformant
: Boolean := False;
3672 if No
(Spec_Id
) then
3673 Check_Fully_Conformant
(Body_Id
, Old_Id
);
3677 (Body_Id
, Old_Id
, Fully_Conformant
, False, Conformant
);
3679 if not Conformant
then
3681 -- The stub was taken to be a new declaration. Indicate that
3684 Set_Has_Completion
(Old_Id
, False);
3690 Set_Has_Completion
(Body_Id
);
3691 Check_Eliminated
(Body_Id
);
3693 -- Analyze any aspect specifications that appear on the subprogram body
3694 -- stub. Stop the analysis now as the stub does not have a declarative
3695 -- or a statement part, and it cannot be inlined.
3697 if Nkind
(N
) = N_Subprogram_Body_Stub
then
3698 if Has_Aspects
(N
) then
3699 Analyze_Aspect_Specifications_On_Body_Or_Stub
(N
);
3702 Ghost_Mode
:= Save_Ghost_Mode
;
3706 -- Handle frontend inlining
3708 -- Note: Normally we don't do any inlining if expansion is off, since
3709 -- we won't generate code in any case. An exception arises in GNATprove
3710 -- mode where we want to expand some calls in place, even with expansion
3711 -- disabled, since the inlining eases formal verification.
3713 if not GNATprove_Mode
3714 and then Expander_Active
3715 and then Serious_Errors_Detected
= 0
3716 and then Present
(Spec_Id
)
3717 and then Has_Pragma_Inline
(Spec_Id
)
3719 -- Legacy implementation (relying on frontend inlining)
3721 if not Back_End_Inlining
then
3722 if (Has_Pragma_Inline_Always
(Spec_Id
)
3723 and then not Opt
.Disable_FE_Inline_Always
)
3725 (Has_Pragma_Inline
(Spec_Id
) and then Front_End_Inlining
3726 and then not Opt
.Disable_FE_Inline
)
3728 Build_Body_To_Inline
(N
, Spec_Id
);
3731 -- New implementation (relying on backend inlining)
3734 if Has_Pragma_Inline_Always
(Spec_Id
)
3735 or else Optimization_Level
> 0
3737 -- Handle function returning an unconstrained type
3739 if Comes_From_Source
(Body_Id
)
3740 and then Ekind
(Spec_Id
) = E_Function
3741 and then Returns_Unconstrained_Type
(Spec_Id
)
3743 -- If function builds in place, i.e. returns a limited type,
3744 -- inlining cannot be done.
3746 and then not Is_Limited_Type
(Etype
(Spec_Id
))
3748 Check_And_Split_Unconstrained_Function
(N
, Spec_Id
, Body_Id
);
3752 Subp_Body
: constant Node_Id
:=
3753 Unit_Declaration_Node
(Body_Id
);
3754 Subp_Decl
: constant List_Id
:= Declarations
(Subp_Body
);
3757 -- Do not pass inlining to the backend if the subprogram
3758 -- has declarations or statements which cannot be inlined
3759 -- by the backend. This check is done here to emit an
3760 -- error instead of the generic warning message reported
3761 -- by the GCC backend (ie. "function might not be
3764 if Present
(Subp_Decl
)
3765 and then Has_Excluded_Declaration
(Spec_Id
, Subp_Decl
)
3769 elsif Has_Excluded_Statement
3772 (Handled_Statement_Sequence
(Subp_Body
)))
3776 -- If the backend inlining is available then at this
3777 -- stage we only have to mark the subprogram as inlined.
3778 -- The expander will take care of registering it in the
3779 -- table of subprograms inlined by the backend a part of
3780 -- processing calls to it (cf. Expand_Call)
3783 Set_Is_Inlined
(Spec_Id
);
3790 -- In GNATprove mode, inline only when there is a separate subprogram
3791 -- declaration for now, as inlining of subprogram bodies acting as
3792 -- declarations, or subprogram stubs, are not supported by frontend
3793 -- inlining. This inlining should occur after analysis of the body, so
3794 -- that it is known whether the value of SPARK_Mode, which can be
3795 -- defined by a pragma inside the body, is applicable to the body.
3797 elsif GNATprove_Mode
3798 and then Full_Analysis
3799 and then not Inside_A_Generic
3800 and then Present
(Spec_Id
)
3802 Nkind
(Unit_Declaration_Node
(Spec_Id
)) = N_Subprogram_Declaration
3803 and then Body_Has_SPARK_Mode_On
3804 and then Can_Be_Inlined_In_GNATprove_Mode
(Spec_Id
, Body_Id
)
3805 and then not Body_Has_Contract
3807 Build_Body_To_Inline
(N
, Spec_Id
);
3810 -- When generating code, inherited pre/postconditions are handled when
3811 -- expanding the corresponding contract.
3813 -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
3814 -- of the specification we have to install the private withed units.
3815 -- This holds for child units as well.
3817 if Is_Compilation_Unit
(Body_Id
)
3818 or else Nkind
(Parent
(N
)) = N_Compilation_Unit
3820 Install_Private_With_Clauses
(Body_Id
);
3823 Check_Anonymous_Return
;
3825 -- Set the Protected_Formal field of each extra formal of the protected
3826 -- subprogram to reference the corresponding extra formal of the
3827 -- subprogram that implements it. For regular formals this occurs when
3828 -- the protected subprogram's declaration is expanded, but the extra
3829 -- formals don't get created until the subprogram is frozen. We need to
3830 -- do this before analyzing the protected subprogram's body so that any
3831 -- references to the original subprogram's extra formals will be changed
3832 -- refer to the implementing subprogram's formals (see Expand_Formal).
3834 if Present
(Spec_Id
)
3835 and then Is_Protected_Type
(Scope
(Spec_Id
))
3836 and then Present
(Protected_Body_Subprogram
(Spec_Id
))
3839 Impl_Subp
: constant Entity_Id
:=
3840 Protected_Body_Subprogram
(Spec_Id
);
3841 Prot_Ext_Formal
: Entity_Id
:= Extra_Formals
(Spec_Id
);
3842 Impl_Ext_Formal
: Entity_Id
:= Extra_Formals
(Impl_Subp
);
3844 while Present
(Prot_Ext_Formal
) loop
3845 pragma Assert
(Present
(Impl_Ext_Formal
));
3846 Set_Protected_Formal
(Prot_Ext_Formal
, Impl_Ext_Formal
);
3847 Next_Formal_With_Extras
(Prot_Ext_Formal
);
3848 Next_Formal_With_Extras
(Impl_Ext_Formal
);
3853 -- Now we can go on to analyze the body
3855 HSS
:= Handled_Statement_Sequence
(N
);
3856 Set_Actual_Subtypes
(N
, Current_Scope
);
3858 -- Add a declaration for the Protection object, renaming declarations
3859 -- for discriminals and privals and finally a declaration for the entry
3860 -- family index (if applicable). This form of early expansion is done
3861 -- when the Expander is active because Install_Private_Data_Declarations
3862 -- references entities which were created during regular expansion. The
3863 -- subprogram entity must come from source, and not be an internally
3864 -- generated subprogram.
3867 and then Present
(Prot_Typ
)
3868 and then Present
(Spec_Id
)
3869 and then Comes_From_Source
(Spec_Id
)
3870 and then not Is_Eliminated
(Spec_Id
)
3872 Install_Private_Data_Declarations
3873 (Sloc
(N
), Spec_Id
, Prot_Typ
, N
, Declarations
(N
));
3876 -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context
3877 -- may now appear in parameter and result profiles. Since the analysis
3878 -- of a subprogram body may use the parameter and result profile of the
3879 -- spec, swap any limited views with their non-limited counterpart.
3881 if Ada_Version
>= Ada_2012
then
3882 Exchange_Limited_Views
(Spec_Id
);
3885 -- Analyze any aspect specifications that appear on the subprogram body
3887 if Has_Aspects
(N
) then
3888 Analyze_Aspect_Specifications_On_Body_Or_Stub
(N
);
3891 Analyze_Declarations
(Declarations
(N
));
3893 -- Verify that the SPARK_Mode of the body agrees with that of its spec
3895 if Present
(Spec_Id
) and then Present
(SPARK_Pragma
(Body_Id
)) then
3896 if Present
(SPARK_Pragma
(Spec_Id
)) then
3897 if Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Spec_Id
)) = Off
3899 Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Body_Id
)) = On
3901 Error_Msg_Sloc
:= Sloc
(SPARK_Pragma
(Body_Id
));
3902 Error_Msg_N
("incorrect application of SPARK_Mode#", N
);
3903 Error_Msg_Sloc
:= Sloc
(SPARK_Pragma
(Spec_Id
));
3905 ("\value Off was set for SPARK_Mode on & #", N
, Spec_Id
);
3908 elsif Nkind
(Parent
(Parent
(Spec_Id
))) = N_Subprogram_Body_Stub
then
3912 Error_Msg_Sloc
:= Sloc
(SPARK_Pragma
(Body_Id
));
3913 Error_Msg_N
("incorrect application of SPARK_Mode #", N
);
3914 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
3916 ("\no value was set for SPARK_Mode on & #", N
, Spec_Id
);
3920 -- A subprogram body "freezes" its own contract. Analyze the contract
3921 -- after the declarations of the body have been processed as pragmas
3922 -- are now chained on the contract of the subprogram body.
3924 Analyze_Entry_Or_Subprogram_Body_Contract
(Body_Id
);
3926 -- Check completion, and analyze the statements
3929 Inspect_Deferred_Constant_Completion
(Declarations
(N
));
3932 -- Deal with end of scope processing for the body
3934 Process_End_Label
(HSS
, 't', Current_Scope
);
3936 Check_Subprogram_Order
(N
);
3937 Set_Analyzed
(Body_Id
);
3939 -- If we have a separate spec, then the analysis of the declarations
3940 -- caused the entities in the body to be chained to the spec id, but
3941 -- we want them chained to the body id. Only the formal parameters
3942 -- end up chained to the spec id in this case.
3944 if Present
(Spec_Id
) then
3946 -- We must conform to the categorization of our spec
3948 Validate_Categorization_Dependency
(N
, Spec_Id
);
3950 -- And if this is a child unit, the parent units must conform
3952 if Is_Child_Unit
(Spec_Id
) then
3953 Validate_Categorization_Dependency
3954 (Unit_Declaration_Node
(Spec_Id
), Spec_Id
);
3957 -- Here is where we move entities from the spec to the body
3959 -- Case where there are entities that stay with the spec
3961 if Present
(Last_Real_Spec_Entity
) then
3963 -- No body entities (happens when the only real spec entities come
3964 -- from precondition and postcondition pragmas).
3966 if No
(Last_Entity
(Body_Id
)) then
3967 Set_First_Entity
(Body_Id
, Next_Entity
(Last_Real_Spec_Entity
));
3969 -- Body entities present (formals), so chain stuff past them
3973 (Last_Entity
(Body_Id
), Next_Entity
(Last_Real_Spec_Entity
));
3976 Set_Next_Entity
(Last_Real_Spec_Entity
, Empty
);
3977 Set_Last_Entity
(Body_Id
, Last_Entity
(Spec_Id
));
3978 Set_Last_Entity
(Spec_Id
, Last_Real_Spec_Entity
);
3980 -- Case where there are no spec entities, in this case there can be
3981 -- no body entities either, so just move everything.
3983 -- If the body is generated for an expression function, it may have
3984 -- been preanalyzed already, if 'access was applied to it.
3987 if Nkind
(Original_Node
(Unit_Declaration_Node
(Spec_Id
))) /=
3988 N_Expression_Function
3990 pragma Assert
(No
(Last_Entity
(Body_Id
)));
3994 Set_First_Entity
(Body_Id
, First_Entity
(Spec_Id
));
3995 Set_Last_Entity
(Body_Id
, Last_Entity
(Spec_Id
));
3996 Set_First_Entity
(Spec_Id
, Empty
);
3997 Set_Last_Entity
(Spec_Id
, Empty
);
4001 Check_Missing_Return
;
4003 -- Now we are going to check for variables that are never modified in
4004 -- the body of the procedure. But first we deal with a special case
4005 -- where we want to modify this check. If the body of the subprogram
4006 -- starts with a raise statement or its equivalent, or if the body
4007 -- consists entirely of a null statement, then it is pretty obvious that
4008 -- it is OK to not reference the parameters. For example, this might be
4009 -- the following common idiom for a stubbed function: statement of the
4010 -- procedure raises an exception. In particular this deals with the
4011 -- common idiom of a stubbed function, which appears something like:
4013 -- function F (A : Integer) return Some_Type;
4016 -- raise Program_Error;
4020 -- Here the purpose of X is simply to satisfy the annoying requirement
4021 -- in Ada that there be at least one return, and we certainly do not
4022 -- want to go posting warnings on X that it is not initialized. On
4023 -- the other hand, if X is entirely unreferenced that should still
4026 -- What we do is to detect these cases, and if we find them, flag the
4027 -- subprogram as being Is_Trivial_Subprogram and then use that flag to
4028 -- suppress unwanted warnings. For the case of the function stub above
4029 -- we have a special test to set X as apparently assigned to suppress
4036 -- Skip initial labels (for one thing this occurs when we are in
4037 -- front end ZCX mode, but in any case it is irrelevant), and also
4038 -- initial Push_xxx_Error_Label nodes, which are also irrelevant.
4040 Stm
:= First
(Statements
(HSS
));
4041 while Nkind
(Stm
) = N_Label
4042 or else Nkind
(Stm
) in N_Push_xxx_Label
4047 -- Do the test on the original statement before expansion
4050 Ostm
: constant Node_Id
:= Original_Node
(Stm
);
4053 -- If explicit raise statement, turn on flag
4055 if Nkind
(Ostm
) = N_Raise_Statement
then
4056 Set_Trivial_Subprogram
(Stm
);
4058 -- If null statement, and no following statements, turn on flag
4060 elsif Nkind
(Stm
) = N_Null_Statement
4061 and then Comes_From_Source
(Stm
)
4062 and then No
(Next
(Stm
))
4064 Set_Trivial_Subprogram
(Stm
);
4066 -- Check for explicit call cases which likely raise an exception
4068 elsif Nkind
(Ostm
) = N_Procedure_Call_Statement
then
4069 if Is_Entity_Name
(Name
(Ostm
)) then
4071 Ent
: constant Entity_Id
:= Entity
(Name
(Ostm
));
4074 -- If the procedure is marked No_Return, then likely it
4075 -- raises an exception, but in any case it is not coming
4076 -- back here, so turn on the flag.
4079 and then Ekind
(Ent
) = E_Procedure
4080 and then No_Return
(Ent
)
4082 Set_Trivial_Subprogram
(Stm
);
4090 -- Check for variables that are never modified
4096 -- If there is a separate spec, then transfer Never_Set_In_Source
4097 -- flags from out parameters to the corresponding entities in the
4098 -- body. The reason we do that is we want to post error flags on
4099 -- the body entities, not the spec entities.
4101 if Present
(Spec_Id
) then
4102 E1
:= First_Entity
(Spec_Id
);
4103 while Present
(E1
) loop
4104 if Ekind
(E1
) = E_Out_Parameter
then
4105 E2
:= First_Entity
(Body_Id
);
4106 while Present
(E2
) loop
4107 exit when Chars
(E1
) = Chars
(E2
);
4111 if Present
(E2
) then
4112 Set_Never_Set_In_Source
(E2
, Never_Set_In_Source
(E1
));
4120 -- Check references in body
4122 Check_References
(Body_Id
);
4125 -- Check for nested subprogram, and mark outer level subprogram if so
4131 if Present
(Spec_Id
) then
4138 Ent
:= Enclosing_Subprogram
(Ent
);
4139 exit when No
(Ent
) or else Is_Subprogram
(Ent
);
4142 if Present
(Ent
) then
4143 Set_Has_Nested_Subprogram
(Ent
);
4147 Ghost_Mode
:= Save_Ghost_Mode
;
4148 end Analyze_Subprogram_Body_Helper
;
4150 ------------------------------------
4151 -- Analyze_Subprogram_Declaration --
4152 ------------------------------------
4154 procedure Analyze_Subprogram_Declaration
(N
: Node_Id
) is
4155 Scop
: constant Entity_Id
:= Current_Scope
;
4156 Designator
: Entity_Id
;
4158 Is_Completion
: Boolean;
4159 -- Indicates whether a null procedure declaration is a completion
4162 -- Null procedures are not allowed in SPARK
4164 if Nkind
(Specification
(N
)) = N_Procedure_Specification
4165 and then Null_Present
(Specification
(N
))
4167 Check_SPARK_05_Restriction
("null procedure is not allowed", N
);
4169 -- Null procedures are allowed in protected types, following the
4170 -- recent AI12-0147.
4172 if Is_Protected_Type
(Current_Scope
)
4173 and then Ada_Version
< Ada_2012
4175 Error_Msg_N
("protected operation cannot be a null procedure", N
);
4178 Analyze_Null_Procedure
(N
, Is_Completion
);
4180 -- The null procedure acts as a body, nothing further is needed
4182 if Is_Completion
then
4187 Designator
:= Analyze_Subprogram_Specification
(Specification
(N
));
4189 -- A reference may already have been generated for the unit name, in
4190 -- which case the following call is redundant. However it is needed for
4191 -- declarations that are the rewriting of an expression function.
4193 Generate_Definition
(Designator
);
4195 -- Set the SPARK mode from the current context (may be overwritten later
4196 -- with explicit pragma). This is not done for entry barrier functions
4197 -- because they are generated outside the protected type and should not
4198 -- carry the mode of the enclosing context.
4200 if Nkind
(N
) = N_Subprogram_Declaration
4201 and then Is_Entry_Barrier_Function
(N
)
4205 Set_SPARK_Pragma
(Designator
, SPARK_Mode_Pragma
);
4206 Set_SPARK_Pragma_Inherited
(Designator
);
4209 -- A subprogram declared within a Ghost region is automatically Ghost
4210 -- (SPARK RM 6.9(2)).
4212 if Ghost_Mode
> None
then
4213 Set_Is_Ghost_Entity
(Designator
);
4216 if Debug_Flag_C
then
4217 Write_Str
("==> subprogram spec ");
4218 Write_Name
(Chars
(Designator
));
4219 Write_Str
(" from ");
4220 Write_Location
(Sloc
(N
));
4225 Validate_RCI_Subprogram_Declaration
(N
);
4226 New_Overloaded_Entity
(Designator
);
4227 Check_Delayed_Subprogram
(Designator
);
4229 -- If the type of the first formal of the current subprogram is a non-
4230 -- generic tagged private type, mark the subprogram as being a private
4231 -- primitive. Ditto if this is a function with controlling result, and
4232 -- the return type is currently private. In both cases, the type of the
4233 -- controlling argument or result must be in the current scope for the
4234 -- operation to be primitive.
4236 if Has_Controlling_Result
(Designator
)
4237 and then Is_Private_Type
(Etype
(Designator
))
4238 and then Scope
(Etype
(Designator
)) = Current_Scope
4239 and then not Is_Generic_Actual_Type
(Etype
(Designator
))
4241 Set_Is_Private_Primitive
(Designator
);
4243 elsif Present
(First_Formal
(Designator
)) then
4245 Formal_Typ
: constant Entity_Id
:=
4246 Etype
(First_Formal
(Designator
));
4248 Set_Is_Private_Primitive
(Designator
,
4249 Is_Tagged_Type
(Formal_Typ
)
4250 and then Scope
(Formal_Typ
) = Current_Scope
4251 and then Is_Private_Type
(Formal_Typ
)
4252 and then not Is_Generic_Actual_Type
(Formal_Typ
));
4256 -- Ada 2005 (AI-251): Abstract interface primitives must be abstract
4259 if Ada_Version
>= Ada_2005
4260 and then Comes_From_Source
(N
)
4261 and then Is_Dispatching_Operation
(Designator
)
4268 if Has_Controlling_Result
(Designator
) then
4269 Etyp
:= Etype
(Designator
);
4272 E
:= First_Entity
(Designator
);
4274 and then Is_Formal
(E
)
4275 and then not Is_Controlling_Formal
(E
)
4283 if Is_Access_Type
(Etyp
) then
4284 Etyp
:= Directly_Designated_Type
(Etyp
);
4287 if Is_Interface
(Etyp
)
4288 and then not Is_Abstract_Subprogram
(Designator
)
4289 and then not (Ekind
(Designator
) = E_Procedure
4290 and then Null_Present
(Specification
(N
)))
4292 Error_Msg_Name_1
:= Chars
(Defining_Entity
(N
));
4294 -- Specialize error message based on procedures vs. functions,
4295 -- since functions can't be null subprograms.
4297 if Ekind
(Designator
) = E_Procedure
then
4299 ("interface procedure % must be abstract or null", N
);
4302 ("interface function % must be abstract", N
);
4308 -- What is the following code for, it used to be
4310 -- ??? Set_Suppress_Elaboration_Checks
4311 -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
4313 -- The following seems equivalent, but a bit dubious
4315 if Elaboration_Checks_Suppressed
(Designator
) then
4316 Set_Kill_Elaboration_Checks
(Designator
);
4319 if Scop
/= Standard_Standard
and then not Is_Child_Unit
(Designator
) then
4320 Set_Categorization_From_Scope
(Designator
, Scop
);
4323 -- For a compilation unit, check for library-unit pragmas
4325 Push_Scope
(Designator
);
4326 Set_Categorization_From_Pragmas
(N
);
4327 Validate_Categorization_Dependency
(N
, Designator
);
4331 -- For a compilation unit, set body required. This flag will only be
4332 -- reset if a valid Import or Interface pragma is processed later on.
4334 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4335 Set_Body_Required
(Parent
(N
), True);
4337 if Ada_Version
>= Ada_2005
4338 and then Nkind
(Specification
(N
)) = N_Procedure_Specification
4339 and then Null_Present
(Specification
(N
))
4342 ("null procedure cannot be declared at library level", N
);
4346 Generate_Reference_To_Formals
(Designator
);
4347 Check_Eliminated
(Designator
);
4349 if Debug_Flag_C
then
4351 Write_Str
("<== subprogram spec ");
4352 Write_Name
(Chars
(Designator
));
4353 Write_Str
(" from ");
4354 Write_Location
(Sloc
(N
));
4358 if Is_Protected_Type
(Current_Scope
) then
4360 -- Indicate that this is a protected operation, because it may be
4361 -- used in subsequent declarations within the protected type.
4363 Set_Convention
(Designator
, Convention_Protected
);
4366 List_Inherited_Pre_Post_Aspects
(Designator
);
4368 if Has_Aspects
(N
) then
4369 Analyze_Aspect_Specifications
(N
, Designator
);
4371 end Analyze_Subprogram_Declaration
;
4373 --------------------------------------
4374 -- Analyze_Subprogram_Specification --
4375 --------------------------------------
4377 -- Reminder: N here really is a subprogram specification (not a subprogram
4378 -- declaration). This procedure is called to analyze the specification in
4379 -- both subprogram bodies and subprogram declarations (specs).
4381 function Analyze_Subprogram_Specification
(N
: Node_Id
) return Entity_Id
is
4382 Designator
: constant Entity_Id
:= Defining_Entity
(N
);
4383 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
4385 -- Start of processing for Analyze_Subprogram_Specification
4388 -- User-defined operator is not allowed in SPARK, except as a renaming
4390 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Operator_Symbol
4391 and then Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
4393 Check_SPARK_05_Restriction
4394 ("user-defined operator is not allowed", N
);
4397 -- Proceed with analysis. Do not emit a cross-reference entry if the
4398 -- specification comes from an expression function, because it may be
4399 -- the completion of a previous declaration. It is not, the cross-
4400 -- reference entry will be emitted for the new subprogram declaration.
4402 if Nkind
(Parent
(N
)) /= N_Expression_Function
then
4403 Generate_Definition
(Designator
);
4406 if Nkind
(N
) = N_Function_Specification
then
4407 Set_Ekind
(Designator
, E_Function
);
4408 Set_Mechanism
(Designator
, Default_Mechanism
);
4410 Set_Ekind
(Designator
, E_Procedure
);
4411 Set_Etype
(Designator
, Standard_Void_Type
);
4414 -- Flag Is_Inlined_Always is True by default, and reversed to False for
4415 -- those subprograms which could be inlined in GNATprove mode (because
4416 -- Body_To_Inline is non-Empty) but should not be inlined.
4418 if GNATprove_Mode
then
4419 Set_Is_Inlined_Always
(Designator
);
4422 -- Introduce new scope for analysis of the formals and the return type
4424 Set_Scope
(Designator
, Current_Scope
);
4426 if Present
(Formals
) then
4427 Push_Scope
(Designator
);
4428 Process_Formals
(Formals
, N
);
4430 -- Check dimensions in N for formals with default expression
4432 Analyze_Dimension_Formals
(N
, Formals
);
4434 -- Ada 2005 (AI-345): If this is an overriding operation of an
4435 -- inherited interface operation, and the controlling type is
4436 -- a synchronized type, replace the type with its corresponding
4437 -- record, to match the proper signature of an overriding operation.
4438 -- Same processing for an access parameter whose designated type is
4439 -- derived from a synchronized interface.
4441 if Ada_Version
>= Ada_2005
then
4444 Formal_Typ
: Entity_Id
;
4445 Rec_Typ
: Entity_Id
;
4446 Desig_Typ
: Entity_Id
;
4449 Formal
:= First_Formal
(Designator
);
4450 while Present
(Formal
) loop
4451 Formal_Typ
:= Etype
(Formal
);
4453 if Is_Concurrent_Type
(Formal_Typ
)
4454 and then Present
(Corresponding_Record_Type
(Formal_Typ
))
4456 Rec_Typ
:= Corresponding_Record_Type
(Formal_Typ
);
4458 if Present
(Interfaces
(Rec_Typ
)) then
4459 Set_Etype
(Formal
, Rec_Typ
);
4462 elsif Ekind
(Formal_Typ
) = E_Anonymous_Access_Type
then
4463 Desig_Typ
:= Designated_Type
(Formal_Typ
);
4465 if Is_Concurrent_Type
(Desig_Typ
)
4466 and then Present
(Corresponding_Record_Type
(Desig_Typ
))
4468 Rec_Typ
:= Corresponding_Record_Type
(Desig_Typ
);
4470 if Present
(Interfaces
(Rec_Typ
)) then
4471 Set_Directly_Designated_Type
(Formal_Typ
, Rec_Typ
);
4476 Next_Formal
(Formal
);
4483 -- The subprogram scope is pushed and popped around the processing of
4484 -- the return type for consistency with call above to Process_Formals
4485 -- (which itself can call Analyze_Return_Type), and to ensure that any
4486 -- itype created for the return type will be associated with the proper
4489 elsif Nkind
(N
) = N_Function_Specification
then
4490 Push_Scope
(Designator
);
4491 Analyze_Return_Type
(N
);
4497 if Nkind
(N
) = N_Function_Specification
then
4499 -- Deal with operator symbol case
4501 if Nkind
(Designator
) = N_Defining_Operator_Symbol
then
4502 Valid_Operator_Definition
(Designator
);
4505 May_Need_Actuals
(Designator
);
4507 -- Ada 2005 (AI-251): If the return type is abstract, verify that
4508 -- the subprogram is abstract also. This does not apply to renaming
4509 -- declarations, where abstractness is inherited, and to subprogram
4510 -- bodies generated for stream operations, which become renamings as
4513 -- In case of primitives associated with abstract interface types
4514 -- the check is applied later (see Analyze_Subprogram_Declaration).
4516 if not Nkind_In
(Original_Node
(Parent
(N
)),
4517 N_Abstract_Subprogram_Declaration
,
4518 N_Formal_Abstract_Subprogram_Declaration
,
4519 N_Subprogram_Renaming_Declaration
)
4521 if Is_Abstract_Type
(Etype
(Designator
))
4522 and then not Is_Interface
(Etype
(Designator
))
4525 ("function that returns abstract type must be abstract", N
);
4527 -- Ada 2012 (AI-0073): Extend this test to subprograms with an
4528 -- access result whose designated type is abstract.
4530 elsif Ada_Version
>= Ada_2012
4531 and then Nkind
(Result_Definition
(N
)) = N_Access_Definition
4533 not Is_Class_Wide_Type
(Designated_Type
(Etype
(Designator
)))
4534 and then Is_Abstract_Type
(Designated_Type
(Etype
(Designator
)))
4537 ("function whose access result designates abstract type "
4538 & "must be abstract", N
);
4544 end Analyze_Subprogram_Specification
;
4546 -----------------------
4547 -- Check_Conformance --
4548 -----------------------
4550 procedure Check_Conformance
4551 (New_Id
: Entity_Id
;
4553 Ctype
: Conformance_Type
;
4555 Conforms
: out Boolean;
4556 Err_Loc
: Node_Id
:= Empty
;
4557 Get_Inst
: Boolean := False;
4558 Skip_Controlling_Formals
: Boolean := False)
4560 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
);
4561 -- Sets Conforms to False. If Errmsg is False, then that's all it does.
4562 -- If Errmsg is True, then processing continues to post an error message
4563 -- for conformance error on given node. Two messages are output. The
4564 -- first message points to the previous declaration with a general "no
4565 -- conformance" message. The second is the detailed reason, supplied as
4566 -- Msg. The parameter N provide information for a possible & insertion
4567 -- in the message, and also provides the location for posting the
4568 -- message in the absence of a specified Err_Loc location.
4570 -----------------------
4571 -- Conformance_Error --
4572 -----------------------
4574 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
) is
4581 if No
(Err_Loc
) then
4587 Error_Msg_Sloc
:= Sloc
(Old_Id
);
4590 when Type_Conformant
=>
4591 Error_Msg_N
-- CODEFIX
4592 ("not type conformant with declaration#!", Enode
);
4594 when Mode_Conformant
=>
4595 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
4597 ("not mode conformant with operation inherited#!",
4601 ("not mode conformant with declaration#!", Enode
);
4604 when Subtype_Conformant
=>
4605 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
4607 ("not subtype conformant with operation inherited#!",
4611 ("not subtype conformant with declaration#!", Enode
);
4614 when Fully_Conformant
=>
4615 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
4616 Error_Msg_N
-- CODEFIX
4617 ("not fully conformant with operation inherited#!",
4620 Error_Msg_N
-- CODEFIX
4621 ("not fully conformant with declaration#!", Enode
);
4625 Error_Msg_NE
(Msg
, Enode
, N
);
4627 end Conformance_Error
;
4631 Old_Type
: constant Entity_Id
:= Etype
(Old_Id
);
4632 New_Type
: constant Entity_Id
:= Etype
(New_Id
);
4633 Old_Formal
: Entity_Id
;
4634 New_Formal
: Entity_Id
;
4635 Access_Types_Match
: Boolean;
4636 Old_Formal_Base
: Entity_Id
;
4637 New_Formal_Base
: Entity_Id
;
4639 -- Start of processing for Check_Conformance
4644 -- We need a special case for operators, since they don't appear
4647 if Ctype
= Type_Conformant
then
4648 if Ekind
(New_Id
) = E_Operator
4649 and then Operator_Matches_Spec
(New_Id
, Old_Id
)
4655 -- If both are functions/operators, check return types conform
4657 if Old_Type
/= Standard_Void_Type
4659 New_Type
/= Standard_Void_Type
4661 -- If we are checking interface conformance we omit controlling
4662 -- arguments and result, because we are only checking the conformance
4663 -- of the remaining parameters.
4665 if Has_Controlling_Result
(Old_Id
)
4666 and then Has_Controlling_Result
(New_Id
)
4667 and then Skip_Controlling_Formals
4671 elsif not Conforming_Types
(Old_Type
, New_Type
, Ctype
, Get_Inst
) then
4672 if Ctype
>= Subtype_Conformant
4673 and then not Predicates_Match
(Old_Type
, New_Type
)
4676 ("\predicate of return type does not match!", New_Id
);
4679 ("\return type does not match!", New_Id
);
4685 -- Ada 2005 (AI-231): In case of anonymous access types check the
4686 -- null-exclusion and access-to-constant attributes match.
4688 if Ada_Version
>= Ada_2005
4689 and then Ekind
(Etype
(Old_Type
)) = E_Anonymous_Access_Type
4691 (Can_Never_Be_Null
(Old_Type
) /= Can_Never_Be_Null
(New_Type
)
4692 or else Is_Access_Constant
(Etype
(Old_Type
)) /=
4693 Is_Access_Constant
(Etype
(New_Type
)))
4695 Conformance_Error
("\return type does not match!", New_Id
);
4699 -- If either is a function/operator and the other isn't, error
4701 elsif Old_Type
/= Standard_Void_Type
4702 or else New_Type
/= Standard_Void_Type
4704 Conformance_Error
("\functions can only match functions!", New_Id
);
4708 -- In subtype conformant case, conventions must match (RM 6.3.1(16)).
4709 -- If this is a renaming as body, refine error message to indicate that
4710 -- the conflict is with the original declaration. If the entity is not
4711 -- frozen, the conventions don't have to match, the one of the renamed
4712 -- entity is inherited.
4714 if Ctype
>= Subtype_Conformant
then
4715 if Convention
(Old_Id
) /= Convention
(New_Id
) then
4716 if not Is_Frozen
(New_Id
) then
4719 elsif Present
(Err_Loc
)
4720 and then Nkind
(Err_Loc
) = N_Subprogram_Renaming_Declaration
4721 and then Present
(Corresponding_Spec
(Err_Loc
))
4723 Error_Msg_Name_1
:= Chars
(New_Id
);
4725 Name_Ada
+ Convention_Id
'Pos (Convention
(New_Id
));
4726 Conformance_Error
("\prior declaration for% has convention %!");
4729 Conformance_Error
("\calling conventions do not match!");
4734 elsif Is_Formal_Subprogram
(Old_Id
)
4735 or else Is_Formal_Subprogram
(New_Id
)
4737 Conformance_Error
("\formal subprograms not allowed!");
4742 -- Deal with parameters
4744 -- Note: we use the entity information, rather than going directly
4745 -- to the specification in the tree. This is not only simpler, but
4746 -- absolutely necessary for some cases of conformance tests between
4747 -- operators, where the declaration tree simply does not exist.
4749 Old_Formal
:= First_Formal
(Old_Id
);
4750 New_Formal
:= First_Formal
(New_Id
);
4751 while Present
(Old_Formal
) and then Present
(New_Formal
) loop
4752 if Is_Controlling_Formal
(Old_Formal
)
4753 and then Is_Controlling_Formal
(New_Formal
)
4754 and then Skip_Controlling_Formals
4756 -- The controlling formals will have different types when
4757 -- comparing an interface operation with its match, but both
4758 -- or neither must be access parameters.
4760 if Is_Access_Type
(Etype
(Old_Formal
))
4762 Is_Access_Type
(Etype
(New_Formal
))
4764 goto Skip_Controlling_Formal
;
4767 ("\access parameter does not match!", New_Formal
);
4771 -- Ada 2012: Mode conformance also requires that formal parameters
4772 -- be both aliased, or neither.
4774 if Ctype
>= Mode_Conformant
and then Ada_Version
>= Ada_2012
then
4775 if Is_Aliased
(Old_Formal
) /= Is_Aliased
(New_Formal
) then
4777 ("\aliased parameter mismatch!", New_Formal
);
4781 if Ctype
= Fully_Conformant
then
4783 -- Names must match. Error message is more accurate if we do
4784 -- this before checking that the types of the formals match.
4786 if Chars
(Old_Formal
) /= Chars
(New_Formal
) then
4787 Conformance_Error
("\name& does not match!", New_Formal
);
4789 -- Set error posted flag on new formal as well to stop
4790 -- junk cascaded messages in some cases.
4792 Set_Error_Posted
(New_Formal
);
4796 -- Null exclusion must match
4798 if Null_Exclusion_Present
(Parent
(Old_Formal
))
4800 Null_Exclusion_Present
(Parent
(New_Formal
))
4802 -- Only give error if both come from source. This should be
4803 -- investigated some time, since it should not be needed ???
4805 if Comes_From_Source
(Old_Formal
)
4807 Comes_From_Source
(New_Formal
)
4810 ("\null exclusion for& does not match", New_Formal
);
4812 -- Mark error posted on the new formal to avoid duplicated
4813 -- complaint about types not matching.
4815 Set_Error_Posted
(New_Formal
);
4820 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
4821 -- case occurs whenever a subprogram is being renamed and one of its
4822 -- parameters imposes a null exclusion. For example:
4824 -- type T is null record;
4825 -- type Acc_T is access T;
4826 -- subtype Acc_T_Sub is Acc_T;
4828 -- procedure P (Obj : not null Acc_T_Sub); -- itype
4829 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype
4832 Old_Formal_Base
:= Etype
(Old_Formal
);
4833 New_Formal_Base
:= Etype
(New_Formal
);
4836 Old_Formal_Base
:= Get_Instance_Of
(Old_Formal_Base
);
4837 New_Formal_Base
:= Get_Instance_Of
(New_Formal_Base
);
4840 Access_Types_Match
:= Ada_Version
>= Ada_2005
4842 -- Ensure that this rule is only applied when New_Id is a
4843 -- renaming of Old_Id.
4845 and then Nkind
(Parent
(Parent
(New_Id
))) =
4846 N_Subprogram_Renaming_Declaration
4847 and then Nkind
(Name
(Parent
(Parent
(New_Id
)))) in N_Has_Entity
4848 and then Present
(Entity
(Name
(Parent
(Parent
(New_Id
)))))
4849 and then Entity
(Name
(Parent
(Parent
(New_Id
)))) = Old_Id
4851 -- Now handle the allowed access-type case
4853 and then Is_Access_Type
(Old_Formal_Base
)
4854 and then Is_Access_Type
(New_Formal_Base
)
4856 -- The type kinds must match. The only exception occurs with
4857 -- multiple generics of the form:
4860 -- type F is private; type A is private;
4861 -- type F_Ptr is access F; type A_Ptr is access A;
4862 -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
4863 -- package F_Pack is ... package A_Pack is
4864 -- package F_Inst is
4865 -- new F_Pack (A, A_Ptr, A_P);
4867 -- When checking for conformance between the parameters of A_P
4868 -- and F_P, the type kinds of F_Ptr and A_Ptr will not match
4869 -- because the compiler has transformed A_Ptr into a subtype of
4870 -- F_Ptr. We catch this case in the code below.
4872 and then (Ekind
(Old_Formal_Base
) = Ekind
(New_Formal_Base
)
4874 (Is_Generic_Type
(Old_Formal_Base
)
4875 and then Is_Generic_Type
(New_Formal_Base
)
4876 and then Is_Internal
(New_Formal_Base
)
4877 and then Etype
(Etype
(New_Formal_Base
)) =
4879 and then Directly_Designated_Type
(Old_Formal_Base
) =
4880 Directly_Designated_Type
(New_Formal_Base
)
4881 and then ((Is_Itype
(Old_Formal_Base
)
4882 and then Can_Never_Be_Null
(Old_Formal_Base
))
4884 (Is_Itype
(New_Formal_Base
)
4885 and then Can_Never_Be_Null
(New_Formal_Base
)));
4887 -- Types must always match. In the visible part of an instance,
4888 -- usual overloading rules for dispatching operations apply, and
4889 -- we check base types (not the actual subtypes).
4891 if In_Instance_Visible_Part
4892 and then Is_Dispatching_Operation
(New_Id
)
4894 if not Conforming_Types
4895 (T1
=> Base_Type
(Etype
(Old_Formal
)),
4896 T2
=> Base_Type
(Etype
(New_Formal
)),
4898 Get_Inst
=> Get_Inst
)
4899 and then not Access_Types_Match
4901 Conformance_Error
("\type of & does not match!", New_Formal
);
4905 elsif not Conforming_Types
4906 (T1
=> Old_Formal_Base
,
4907 T2
=> New_Formal_Base
,
4909 Get_Inst
=> Get_Inst
)
4910 and then not Access_Types_Match
4912 -- Don't give error message if old type is Any_Type. This test
4913 -- avoids some cascaded errors, e.g. in case of a bad spec.
4915 if Errmsg
and then Old_Formal_Base
= Any_Type
then
4918 if Ctype
>= Subtype_Conformant
4920 not Predicates_Match
(Old_Formal_Base
, New_Formal_Base
)
4923 ("\predicate of & does not match!", New_Formal
);
4926 ("\type of & does not match!", New_Formal
);
4933 -- For mode conformance, mode must match
4935 if Ctype
>= Mode_Conformant
then
4936 if Parameter_Mode
(Old_Formal
) /= Parameter_Mode
(New_Formal
) then
4937 if not Ekind_In
(New_Id
, E_Function
, E_Procedure
)
4938 or else not Is_Primitive_Wrapper
(New_Id
)
4940 Conformance_Error
("\mode of & does not match!", New_Formal
);
4944 T
: constant Entity_Id
:= Find_Dispatching_Type
(New_Id
);
4946 if Is_Protected_Type
(Corresponding_Concurrent_Type
(T
))
4948 Error_Msg_PT
(New_Id
, Ultimate_Alias
(Old_Id
));
4951 ("\mode of & does not match!", New_Formal
);
4958 -- Part of mode conformance for access types is having the same
4959 -- constant modifier.
4961 elsif Access_Types_Match
4962 and then Is_Access_Constant
(Old_Formal_Base
) /=
4963 Is_Access_Constant
(New_Formal_Base
)
4966 ("\constant modifier does not match!", New_Formal
);
4971 if Ctype
>= Subtype_Conformant
then
4973 -- Ada 2005 (AI-231): In case of anonymous access types check
4974 -- the null-exclusion and access-to-constant attributes must
4975 -- match. For null exclusion, we test the types rather than the
4976 -- formals themselves, since the attribute is only set reliably
4977 -- on the formals in the Ada 95 case, and we exclude the case
4978 -- where Old_Formal is marked as controlling, to avoid errors
4979 -- when matching completing bodies with dispatching declarations
4980 -- (access formals in the bodies aren't marked Can_Never_Be_Null).
4982 if Ada_Version
>= Ada_2005
4983 and then Ekind
(Etype
(Old_Formal
)) = E_Anonymous_Access_Type
4984 and then Ekind
(Etype
(New_Formal
)) = E_Anonymous_Access_Type
4986 ((Can_Never_Be_Null
(Etype
(Old_Formal
)) /=
4987 Can_Never_Be_Null
(Etype
(New_Formal
))
4989 not Is_Controlling_Formal
(Old_Formal
))
4991 Is_Access_Constant
(Etype
(Old_Formal
)) /=
4992 Is_Access_Constant
(Etype
(New_Formal
)))
4994 -- Do not complain if error already posted on New_Formal. This
4995 -- avoids some redundant error messages.
4997 and then not Error_Posted
(New_Formal
)
4999 -- It is allowed to omit the null-exclusion in case of stream
5000 -- attribute subprograms. We recognize stream subprograms
5001 -- through their TSS-generated suffix.
5004 TSS_Name
: constant TSS_Name_Type
:= Get_TSS_Name
(New_Id
);
5007 if TSS_Name
/= TSS_Stream_Read
5008 and then TSS_Name
/= TSS_Stream_Write
5009 and then TSS_Name
/= TSS_Stream_Input
5010 and then TSS_Name
/= TSS_Stream_Output
5012 -- Here we have a definite conformance error. It is worth
5013 -- special casing the error message for the case of a
5014 -- controlling formal (which excludes null).
5016 if Is_Controlling_Formal
(New_Formal
) then
5017 Error_Msg_Node_2
:= Scope
(New_Formal
);
5019 ("\controlling formal & of & excludes null, "
5020 & "declaration must exclude null as well",
5023 -- Normal case (couldn't we give more detail here???)
5027 ("\type of & does not match!", New_Formal
);
5036 -- Full conformance checks
5038 if Ctype
= Fully_Conformant
then
5040 -- We have checked already that names match
5042 if Parameter_Mode
(Old_Formal
) = E_In_Parameter
then
5044 -- Check default expressions for in parameters
5047 NewD
: constant Boolean :=
5048 Present
(Default_Value
(New_Formal
));
5049 OldD
: constant Boolean :=
5050 Present
(Default_Value
(Old_Formal
));
5052 if NewD
or OldD
then
5054 -- The old default value has been analyzed because the
5055 -- current full declaration will have frozen everything
5056 -- before. The new default value has not been analyzed,
5057 -- so analyze it now before we check for conformance.
5060 Push_Scope
(New_Id
);
5061 Preanalyze_Spec_Expression
5062 (Default_Value
(New_Formal
), Etype
(New_Formal
));
5066 if not (NewD
and OldD
)
5067 or else not Fully_Conformant_Expressions
5068 (Default_Value
(Old_Formal
),
5069 Default_Value
(New_Formal
))
5072 ("\default expression for & does not match!",
5081 -- A couple of special checks for Ada 83 mode. These checks are
5082 -- skipped if either entity is an operator in package Standard,
5083 -- or if either old or new instance is not from the source program.
5085 if Ada_Version
= Ada_83
5086 and then Sloc
(Old_Id
) > Standard_Location
5087 and then Sloc
(New_Id
) > Standard_Location
5088 and then Comes_From_Source
(Old_Id
)
5089 and then Comes_From_Source
(New_Id
)
5092 Old_Param
: constant Node_Id
:= Declaration_Node
(Old_Formal
);
5093 New_Param
: constant Node_Id
:= Declaration_Node
(New_Formal
);
5096 -- Explicit IN must be present or absent in both cases. This
5097 -- test is required only in the full conformance case.
5099 if In_Present
(Old_Param
) /= In_Present
(New_Param
)
5100 and then Ctype
= Fully_Conformant
5103 ("\(Ada 83) IN must appear in both declarations",
5108 -- Grouping (use of comma in param lists) must be the same
5109 -- This is where we catch a misconformance like:
5112 -- A : Integer; B : Integer
5114 -- which are represented identically in the tree except
5115 -- for the setting of the flags More_Ids and Prev_Ids.
5117 if More_Ids
(Old_Param
) /= More_Ids
(New_Param
)
5118 or else Prev_Ids
(Old_Param
) /= Prev_Ids
(New_Param
)
5121 ("\grouping of & does not match!", New_Formal
);
5127 -- This label is required when skipping controlling formals
5129 <<Skip_Controlling_Formal
>>
5131 Next_Formal
(Old_Formal
);
5132 Next_Formal
(New_Formal
);
5135 if Present
(Old_Formal
) then
5136 Conformance_Error
("\too few parameters!");
5139 elsif Present
(New_Formal
) then
5140 Conformance_Error
("\too many parameters!", New_Formal
);
5143 end Check_Conformance
;
5145 -----------------------
5146 -- Check_Conventions --
5147 -----------------------
5149 procedure Check_Conventions
(Typ
: Entity_Id
) is
5150 Ifaces_List
: Elist_Id
;
5152 procedure Check_Convention
(Op
: Entity_Id
);
5153 -- Verify that the convention of inherited dispatching operation Op is
5154 -- consistent among all subprograms it overrides. In order to minimize
5155 -- the search, Search_From is utilized to designate a specific point in
5156 -- the list rather than iterating over the whole list once more.
5158 ----------------------
5159 -- Check_Convention --
5160 ----------------------
5162 procedure Check_Convention
(Op
: Entity_Id
) is
5163 Op_Conv
: constant Convention_Id
:= Convention
(Op
);
5164 Iface_Conv
: Convention_Id
;
5165 Iface_Elmt
: Elmt_Id
;
5166 Iface_Prim_Elmt
: Elmt_Id
;
5167 Iface_Prim
: Entity_Id
;
5170 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
5171 while Present
(Iface_Elmt
) loop
5173 First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
5174 while Present
(Iface_Prim_Elmt
) loop
5175 Iface_Prim
:= Node
(Iface_Prim_Elmt
);
5176 Iface_Conv
:= Convention
(Iface_Prim
);
5178 if Is_Interface_Conformant
(Typ
, Iface_Prim
, Op
)
5179 and then Iface_Conv
/= Op_Conv
5182 ("inconsistent conventions in primitive operations", Typ
);
5184 Error_Msg_Name_1
:= Chars
(Op
);
5185 Error_Msg_Name_2
:= Get_Convention_Name
(Op_Conv
);
5186 Error_Msg_Sloc
:= Sloc
(Op
);
5188 if Comes_From_Source
(Op
) or else No
(Alias
(Op
)) then
5189 if not Present
(Overridden_Operation
(Op
)) then
5190 Error_Msg_N
("\\primitive % defined #", Typ
);
5193 ("\\overriding operation % with "
5194 & "convention % defined #", Typ
);
5197 else pragma Assert
(Present
(Alias
(Op
)));
5198 Error_Msg_Sloc
:= Sloc
(Alias
(Op
));
5199 Error_Msg_N
("\\inherited operation % with "
5200 & "convention % defined #", Typ
);
5203 Error_Msg_Name_1
:= Chars
(Op
);
5204 Error_Msg_Name_2
:= Get_Convention_Name
(Iface_Conv
);
5205 Error_Msg_Sloc
:= Sloc
(Iface_Prim
);
5206 Error_Msg_N
("\\overridden operation % with "
5207 & "convention % defined #", Typ
);
5209 -- Avoid cascading errors
5214 Next_Elmt
(Iface_Prim_Elmt
);
5217 Next_Elmt
(Iface_Elmt
);
5219 end Check_Convention
;
5223 Prim_Op
: Entity_Id
;
5224 Prim_Op_Elmt
: Elmt_Id
;
5226 -- Start of processing for Check_Conventions
5229 if not Has_Interfaces
(Typ
) then
5233 Collect_Interfaces
(Typ
, Ifaces_List
);
5235 -- The algorithm checks every overriding dispatching operation against
5236 -- all the corresponding overridden dispatching operations, detecting
5237 -- differences in conventions.
5239 Prim_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5240 while Present
(Prim_Op_Elmt
) loop
5241 Prim_Op
:= Node
(Prim_Op_Elmt
);
5243 -- A small optimization: skip the predefined dispatching operations
5244 -- since they always have the same convention.
5246 if not Is_Predefined_Dispatching_Operation
(Prim_Op
) then
5247 Check_Convention
(Prim_Op
);
5250 Next_Elmt
(Prim_Op_Elmt
);
5252 end Check_Conventions
;
5254 ------------------------------
5255 -- Check_Delayed_Subprogram --
5256 ------------------------------
5258 procedure Check_Delayed_Subprogram
(Designator
: Entity_Id
) is
5261 procedure Possible_Freeze
(T
: Entity_Id
);
5262 -- T is the type of either a formal parameter or of the return type.
5263 -- If T is not yet frozen and needs a delayed freeze, then the
5264 -- subprogram itself must be delayed. If T is the limited view of an
5265 -- incomplete type (or of a CW type thereof) the subprogram must be
5266 -- frozen as well, because T may depend on local types that have not
5269 ---------------------
5270 -- Possible_Freeze --
5271 ---------------------
5273 procedure Possible_Freeze
(T
: Entity_Id
) is
5275 if Has_Delayed_Freeze
(T
) and then not Is_Frozen
(T
) then
5276 Set_Has_Delayed_Freeze
(Designator
);
5278 elsif Is_Access_Type
(T
)
5279 and then Has_Delayed_Freeze
(Designated_Type
(T
))
5280 and then not Is_Frozen
(Designated_Type
(T
))
5282 Set_Has_Delayed_Freeze
(Designator
);
5284 elsif (Ekind
(T
) = E_Incomplete_Type
5285 or else Ekind
(T
) = E_Class_Wide_Type
)
5286 and then From_Limited_With
(T
)
5288 Set_Has_Delayed_Freeze
(Designator
);
5290 -- AI05-0151: In Ada 2012, Incomplete types can appear in the profile
5291 -- of a subprogram or entry declaration.
5293 elsif Ekind
(T
) = E_Incomplete_Type
5294 and then Ada_Version
>= Ada_2012
5296 Set_Has_Delayed_Freeze
(Designator
);
5299 end Possible_Freeze
;
5301 -- Start of processing for Check_Delayed_Subprogram
5304 -- All subprograms, including abstract subprograms, may need a freeze
5305 -- node if some formal type or the return type needs one.
5307 Possible_Freeze
(Etype
(Designator
));
5308 Possible_Freeze
(Base_Type
(Etype
(Designator
))); -- needed ???
5310 -- Need delayed freeze if any of the formal types themselves need
5311 -- a delayed freeze and are not yet frozen.
5313 F
:= First_Formal
(Designator
);
5314 while Present
(F
) loop
5315 Possible_Freeze
(Etype
(F
));
5316 Possible_Freeze
(Base_Type
(Etype
(F
))); -- needed ???
5320 -- Mark functions that return by reference. Note that it cannot be
5321 -- done for delayed_freeze subprograms because the underlying
5322 -- returned type may not be known yet (for private types)
5324 if not Has_Delayed_Freeze
(Designator
) and then Expander_Active
then
5326 Typ
: constant Entity_Id
:= Etype
(Designator
);
5327 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
5329 if Is_Limited_View
(Typ
) then
5330 Set_Returns_By_Ref
(Designator
);
5331 elsif Present
(Utyp
) and then CW_Or_Has_Controlled_Part
(Utyp
) then
5332 Set_Returns_By_Ref
(Designator
);
5336 end Check_Delayed_Subprogram
;
5338 ------------------------------------
5339 -- Check_Discriminant_Conformance --
5340 ------------------------------------
5342 procedure Check_Discriminant_Conformance
5347 Old_Discr
: Entity_Id
:= First_Discriminant
(Prev
);
5348 New_Discr
: Node_Id
:= First
(Discriminant_Specifications
(N
));
5349 New_Discr_Id
: Entity_Id
;
5350 New_Discr_Type
: Entity_Id
;
5352 procedure Conformance_Error
(Msg
: String; N
: Node_Id
);
5353 -- Post error message for conformance error on given node. Two messages
5354 -- are output. The first points to the previous declaration with a
5355 -- general "no conformance" message. The second is the detailed reason,
5356 -- supplied as Msg. The parameter N provide information for a possible
5357 -- & insertion in the message.
5359 -----------------------
5360 -- Conformance_Error --
5361 -----------------------
5363 procedure Conformance_Error
(Msg
: String; N
: Node_Id
) is
5365 Error_Msg_Sloc
:= Sloc
(Prev_Loc
);
5366 Error_Msg_N
-- CODEFIX
5367 ("not fully conformant with declaration#!", N
);
5368 Error_Msg_NE
(Msg
, N
, N
);
5369 end Conformance_Error
;
5371 -- Start of processing for Check_Discriminant_Conformance
5374 while Present
(Old_Discr
) and then Present
(New_Discr
) loop
5375 New_Discr_Id
:= Defining_Identifier
(New_Discr
);
5377 -- The subtype mark of the discriminant on the full type has not
5378 -- been analyzed so we do it here. For an access discriminant a new
5381 if Nkind
(Discriminant_Type
(New_Discr
)) = N_Access_Definition
then
5383 Access_Definition
(N
, Discriminant_Type
(New_Discr
));
5386 Analyze
(Discriminant_Type
(New_Discr
));
5387 New_Discr_Type
:= Etype
(Discriminant_Type
(New_Discr
));
5389 -- Ada 2005: if the discriminant definition carries a null
5390 -- exclusion, create an itype to check properly for consistency
5391 -- with partial declaration.
5393 if Is_Access_Type
(New_Discr_Type
)
5394 and then Null_Exclusion_Present
(New_Discr
)
5397 Create_Null_Excluding_Itype
5398 (T
=> New_Discr_Type
,
5399 Related_Nod
=> New_Discr
,
5400 Scope_Id
=> Current_Scope
);
5404 if not Conforming_Types
5405 (Etype
(Old_Discr
), New_Discr_Type
, Fully_Conformant
)
5407 Conformance_Error
("type of & does not match!", New_Discr_Id
);
5410 -- Treat the new discriminant as an occurrence of the old one,
5411 -- for navigation purposes, and fill in some semantic
5412 -- information, for completeness.
5414 Generate_Reference
(Old_Discr
, New_Discr_Id
, 'r');
5415 Set_Etype
(New_Discr_Id
, Etype
(Old_Discr
));
5416 Set_Scope
(New_Discr_Id
, Scope
(Old_Discr
));
5421 if Chars
(Old_Discr
) /= Chars
(Defining_Identifier
(New_Discr
)) then
5422 Conformance_Error
("name & does not match!", New_Discr_Id
);
5426 -- Default expressions must match
5429 NewD
: constant Boolean :=
5430 Present
(Expression
(New_Discr
));
5431 OldD
: constant Boolean :=
5432 Present
(Expression
(Parent
(Old_Discr
)));
5435 if NewD
or OldD
then
5437 -- The old default value has been analyzed and expanded,
5438 -- because the current full declaration will have frozen
5439 -- everything before. The new default values have not been
5440 -- expanded, so expand now to check conformance.
5443 Preanalyze_Spec_Expression
5444 (Expression
(New_Discr
), New_Discr_Type
);
5447 if not (NewD
and OldD
)
5448 or else not Fully_Conformant_Expressions
5449 (Expression
(Parent
(Old_Discr
)),
5450 Expression
(New_Discr
))
5454 ("default expression for & does not match!",
5461 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
5463 if Ada_Version
= Ada_83
then
5465 Old_Disc
: constant Node_Id
:= Declaration_Node
(Old_Discr
);
5468 -- Grouping (use of comma in param lists) must be the same
5469 -- This is where we catch a misconformance like:
5472 -- A : Integer; B : Integer
5474 -- which are represented identically in the tree except
5475 -- for the setting of the flags More_Ids and Prev_Ids.
5477 if More_Ids
(Old_Disc
) /= More_Ids
(New_Discr
)
5478 or else Prev_Ids
(Old_Disc
) /= Prev_Ids
(New_Discr
)
5481 ("grouping of & does not match!", New_Discr_Id
);
5487 Next_Discriminant
(Old_Discr
);
5491 if Present
(Old_Discr
) then
5492 Conformance_Error
("too few discriminants!", Defining_Identifier
(N
));
5495 elsif Present
(New_Discr
) then
5497 ("too many discriminants!", Defining_Identifier
(New_Discr
));
5500 end Check_Discriminant_Conformance
;
5502 ----------------------------
5503 -- Check_Fully_Conformant --
5504 ----------------------------
5506 procedure Check_Fully_Conformant
5507 (New_Id
: Entity_Id
;
5509 Err_Loc
: Node_Id
:= Empty
)
5512 pragma Warnings
(Off
, Result
);
5515 (New_Id
, Old_Id
, Fully_Conformant
, True, Result
, Err_Loc
);
5516 end Check_Fully_Conformant
;
5518 --------------------------
5519 -- Check_Limited_Return --
5520 --------------------------
5522 procedure Check_Limited_Return
5528 -- Ada 2005 (AI-318-02): Return-by-reference types have been removed and
5529 -- replaced by anonymous access results. This is an incompatibility with
5530 -- Ada 95. Not clear whether this should be enforced yet or perhaps
5531 -- controllable with special switch. ???
5533 -- A limited interface that is not immutably limited is OK
5535 if Is_Limited_Interface
(R_Type
)
5537 not (Is_Task_Interface
(R_Type
)
5538 or else Is_Protected_Interface
(R_Type
)
5539 or else Is_Synchronized_Interface
(R_Type
))
5543 elsif Is_Limited_Type
(R_Type
)
5544 and then not Is_Interface
(R_Type
)
5545 and then Comes_From_Source
(N
)
5546 and then not In_Instance_Body
5547 and then not OK_For_Limited_Init_In_05
(R_Type
, Expr
)
5549 -- Error in Ada 2005
5551 if Ada_Version
>= Ada_2005
5552 and then not Debug_Flag_Dot_L
5553 and then not GNAT_Mode
5556 ("(Ada 2005) cannot copy object of a limited type "
5557 & "(RM-2005 6.5(5.5/2))", Expr
);
5559 if Is_Limited_View
(R_Type
) then
5561 ("\return by reference not permitted in Ada 2005", Expr
);
5564 -- Warn in Ada 95 mode, to give folks a heads up about this
5567 -- In GNAT mode, this is just a warning, to allow it to be evilly
5568 -- turned off. Otherwise it is a real error.
5570 -- In a generic context, simplify the warning because it makes no
5571 -- sense to discuss pass-by-reference or copy.
5573 elsif Warn_On_Ada_2005_Compatibility
or GNAT_Mode
then
5574 if Inside_A_Generic
then
5576 ("return of limited object not permitted in Ada 2005 "
5577 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
5579 elsif Is_Limited_View
(R_Type
) then
5581 ("return by reference not permitted in Ada 2005 "
5582 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
5585 ("cannot copy object of a limited type in Ada 2005 "
5586 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
5589 -- Ada 95 mode, compatibility warnings disabled
5592 return; -- skip continuation messages below
5595 if not Inside_A_Generic
then
5597 ("\consider switching to return of access type", Expr
);
5598 Explain_Limited_Type
(R_Type
, Expr
);
5601 end Check_Limited_Return
;
5603 ---------------------------
5604 -- Check_Mode_Conformant --
5605 ---------------------------
5607 procedure Check_Mode_Conformant
5608 (New_Id
: Entity_Id
;
5610 Err_Loc
: Node_Id
:= Empty
;
5611 Get_Inst
: Boolean := False)
5614 pragma Warnings
(Off
, Result
);
5617 (New_Id
, Old_Id
, Mode_Conformant
, True, Result
, Err_Loc
, Get_Inst
);
5618 end Check_Mode_Conformant
;
5620 --------------------------------
5621 -- Check_Overriding_Indicator --
5622 --------------------------------
5624 procedure Check_Overriding_Indicator
5626 Overridden_Subp
: Entity_Id
;
5627 Is_Primitive
: Boolean)
5633 -- No overriding indicator for literals
5635 if Ekind
(Subp
) = E_Enumeration_Literal
then
5638 elsif Ekind
(Subp
) = E_Entry
then
5639 Decl
:= Parent
(Subp
);
5641 -- No point in analyzing a malformed operator
5643 elsif Nkind
(Subp
) = N_Defining_Operator_Symbol
5644 and then Error_Posted
(Subp
)
5649 Decl
:= Unit_Declaration_Node
(Subp
);
5652 if Nkind_In
(Decl
, N_Subprogram_Body
,
5653 N_Subprogram_Body_Stub
,
5654 N_Subprogram_Declaration
,
5655 N_Abstract_Subprogram_Declaration
,
5656 N_Subprogram_Renaming_Declaration
)
5658 Spec
:= Specification
(Decl
);
5660 elsif Nkind
(Decl
) = N_Entry_Declaration
then
5667 -- The overriding operation is type conformant with the overridden one,
5668 -- but the names of the formals are not required to match. If the names
5669 -- appear permuted in the overriding operation, this is a possible
5670 -- source of confusion that is worth diagnosing. Controlling formals
5671 -- often carry names that reflect the type, and it is not worthwhile
5672 -- requiring that their names match.
5674 if Present
(Overridden_Subp
)
5675 and then Nkind
(Subp
) /= N_Defining_Operator_Symbol
5682 Form1
:= First_Formal
(Subp
);
5683 Form2
:= First_Formal
(Overridden_Subp
);
5685 -- If the overriding operation is a synchronized operation, skip
5686 -- the first parameter of the overridden operation, which is
5687 -- implicit in the new one. If the operation is declared in the
5688 -- body it is not primitive and all formals must match.
5690 if Is_Concurrent_Type
(Scope
(Subp
))
5691 and then Is_Tagged_Type
(Scope
(Subp
))
5692 and then not Has_Completion
(Scope
(Subp
))
5694 Form2
:= Next_Formal
(Form2
);
5697 if Present
(Form1
) then
5698 Form1
:= Next_Formal
(Form1
);
5699 Form2
:= Next_Formal
(Form2
);
5702 while Present
(Form1
) loop
5703 if not Is_Controlling_Formal
(Form1
)
5704 and then Present
(Next_Formal
(Form2
))
5705 and then Chars
(Form1
) = Chars
(Next_Formal
(Form2
))
5707 Error_Msg_Node_2
:= Alias
(Overridden_Subp
);
5708 Error_Msg_Sloc
:= Sloc
(Error_Msg_Node_2
);
5710 ("& does not match corresponding formal of&#",
5715 Next_Formal
(Form1
);
5716 Next_Formal
(Form2
);
5721 -- If there is an overridden subprogram, then check that there is no
5722 -- "not overriding" indicator, and mark the subprogram as overriding.
5723 -- This is not done if the overridden subprogram is marked as hidden,
5724 -- which can occur for the case of inherited controlled operations
5725 -- (see Derive_Subprogram), unless the inherited subprogram's parent
5726 -- subprogram is not itself hidden. (Note: This condition could probably
5727 -- be simplified, leaving out the testing for the specific controlled
5728 -- cases, but it seems safer and clearer this way, and echoes similar
5729 -- special-case tests of this kind in other places.)
5731 if Present
(Overridden_Subp
)
5732 and then (not Is_Hidden
(Overridden_Subp
)
5734 (Nam_In
(Chars
(Overridden_Subp
), Name_Initialize
,
5737 and then Present
(Alias
(Overridden_Subp
))
5738 and then not Is_Hidden
(Alias
(Overridden_Subp
))))
5740 if Must_Not_Override
(Spec
) then
5741 Error_Msg_Sloc
:= Sloc
(Overridden_Subp
);
5743 if Ekind
(Subp
) = E_Entry
then
5745 ("entry & overrides inherited operation #", Spec
, Subp
);
5748 ("subprogram & overrides inherited operation #", Spec
, Subp
);
5751 -- Special-case to fix a GNAT oddity: Limited_Controlled is declared
5752 -- as an extension of Root_Controlled, and thus has a useless Adjust
5753 -- operation. This operation should not be inherited by other limited
5754 -- controlled types. An explicit Adjust for them is not overriding.
5756 elsif Must_Override
(Spec
)
5757 and then Chars
(Overridden_Subp
) = Name_Adjust
5758 and then Is_Limited_Type
(Etype
(First_Formal
(Subp
)))
5759 and then Present
(Alias
(Overridden_Subp
))
5761 Is_Predefined_File_Name
5762 (Unit_File_Name
(Get_Source_Unit
(Alias
(Overridden_Subp
))))
5764 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
5766 elsif Is_Subprogram
(Subp
) then
5767 if Is_Init_Proc
(Subp
) then
5770 elsif No
(Overridden_Operation
(Subp
)) then
5772 -- For entities generated by Derive_Subprograms the overridden
5773 -- operation is the inherited primitive (which is available
5774 -- through the attribute alias)
5776 if (Is_Dispatching_Operation
(Subp
)
5777 or else Is_Dispatching_Operation
(Overridden_Subp
))
5778 and then not Comes_From_Source
(Overridden_Subp
)
5779 and then Find_Dispatching_Type
(Overridden_Subp
) =
5780 Find_Dispatching_Type
(Subp
)
5781 and then Present
(Alias
(Overridden_Subp
))
5782 and then Comes_From_Source
(Alias
(Overridden_Subp
))
5784 Set_Overridden_Operation
(Subp
, Alias
(Overridden_Subp
));
5785 Inherit_Subprogram_Contract
(Subp
, Alias
(Overridden_Subp
));
5788 Set_Overridden_Operation
(Subp
, Overridden_Subp
);
5789 Inherit_Subprogram_Contract
(Subp
, Overridden_Subp
);
5794 -- If primitive flag is set or this is a protected operation, then
5795 -- the operation is overriding at the point of its declaration, so
5796 -- warn if necessary. Otherwise it may have been declared before the
5797 -- operation it overrides and no check is required.
5800 and then not Must_Override
(Spec
)
5801 and then (Is_Primitive
5802 or else Ekind
(Scope
(Subp
)) = E_Protected_Type
)
5804 Style
.Missing_Overriding
(Decl
, Subp
);
5807 -- If Subp is an operator, it may override a predefined operation, if
5808 -- it is defined in the same scope as the type to which it applies.
5809 -- In that case Overridden_Subp is empty because of our implicit
5810 -- representation for predefined operators. We have to check whether the
5811 -- signature of Subp matches that of a predefined operator. Note that
5812 -- first argument provides the name of the operator, and the second
5813 -- argument the signature that may match that of a standard operation.
5814 -- If the indicator is overriding, then the operator must match a
5815 -- predefined signature, because we know already that there is no
5816 -- explicit overridden operation.
5818 elsif Nkind
(Subp
) = N_Defining_Operator_Symbol
then
5819 if Must_Not_Override
(Spec
) then
5821 -- If this is not a primitive or a protected subprogram, then
5822 -- "not overriding" is illegal.
5825 and then Ekind
(Scope
(Subp
)) /= E_Protected_Type
5827 Error_Msg_N
("overriding indicator only allowed "
5828 & "if subprogram is primitive", Subp
);
5830 elsif Can_Override_Operator
(Subp
) then
5832 ("subprogram& overrides predefined operator ", Spec
, Subp
);
5835 elsif Must_Override
(Spec
) then
5836 if No
(Overridden_Operation
(Subp
))
5837 and then not Can_Override_Operator
(Subp
)
5839 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
5842 elsif not Error_Posted
(Subp
)
5843 and then Style_Check
5844 and then Can_Override_Operator
(Subp
)
5846 not Is_Predefined_File_Name
5847 (Unit_File_Name
(Get_Source_Unit
(Subp
)))
5849 -- If style checks are enabled, indicate that the indicator is
5850 -- missing. However, at the point of declaration, the type of
5851 -- which this is a primitive operation may be private, in which
5852 -- case the indicator would be premature.
5854 if Has_Private_Declaration
(Etype
(Subp
))
5855 or else Has_Private_Declaration
(Etype
(First_Formal
(Subp
)))
5859 Style
.Missing_Overriding
(Decl
, Subp
);
5863 elsif Must_Override
(Spec
) then
5864 if Ekind
(Subp
) = E_Entry
then
5865 Error_Msg_NE
("entry & is not overriding", Spec
, Subp
);
5867 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
5870 -- If the operation is marked "not overriding" and it's not primitive
5871 -- then an error is issued, unless this is an operation of a task or
5872 -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
5873 -- has been specified have already been checked above.
5875 elsif Must_Not_Override
(Spec
)
5876 and then not Is_Primitive
5877 and then Ekind
(Subp
) /= E_Entry
5878 and then Ekind
(Scope
(Subp
)) /= E_Protected_Type
5881 ("overriding indicator only allowed if subprogram is primitive",
5885 end Check_Overriding_Indicator
;
5891 -- Note: this procedure needs to know far too much about how the expander
5892 -- messes with exceptions. The use of the flag Exception_Junk and the
5893 -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
5894 -- works, but is not very clean. It would be better if the expansion
5895 -- routines would leave Original_Node working nicely, and we could use
5896 -- Original_Node here to ignore all the peculiar expander messing ???
5898 procedure Check_Returns
5902 Proc
: Entity_Id
:= Empty
)
5906 procedure Check_Statement_Sequence
(L
: List_Id
);
5907 -- Internal recursive procedure to check a list of statements for proper
5908 -- termination by a return statement (or a transfer of control or a
5909 -- compound statement that is itself internally properly terminated).
5911 ------------------------------
5912 -- Check_Statement_Sequence --
5913 ------------------------------
5915 procedure Check_Statement_Sequence
(L
: List_Id
) is
5920 function Assert_False
return Boolean;
5921 -- Returns True if Last_Stm is a pragma Assert (False) that has been
5922 -- rewritten as a null statement when assertions are off. The assert
5923 -- is not active, but it is still enough to kill the warning.
5929 function Assert_False
return Boolean is
5930 Orig
: constant Node_Id
:= Original_Node
(Last_Stm
);
5933 if Nkind
(Orig
) = N_Pragma
5934 and then Pragma_Name
(Orig
) = Name_Assert
5935 and then not Error_Posted
(Orig
)
5938 Arg
: constant Node_Id
:=
5939 First
(Pragma_Argument_Associations
(Orig
));
5940 Exp
: constant Node_Id
:= Expression
(Arg
);
5942 return Nkind
(Exp
) = N_Identifier
5943 and then Chars
(Exp
) = Name_False
;
5953 Raise_Exception_Call
: Boolean;
5954 -- Set True if statement sequence terminated by Raise_Exception call
5955 -- or a Reraise_Occurrence call.
5957 -- Start of processing for Check_Statement_Sequence
5960 Raise_Exception_Call
:= False;
5962 -- Get last real statement
5964 Last_Stm
:= Last
(L
);
5966 -- Deal with digging out exception handler statement sequences that
5967 -- have been transformed by the local raise to goto optimization.
5968 -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
5969 -- optimization has occurred, we are looking at something like:
5972 -- original stmts in block
5976 -- goto L1; | omitted if No_Exception_Propagation
5981 -- goto L3; -- skip handler when exception not raised
5983 -- <<L1>> -- target label for local exception
5997 -- and what we have to do is to dig out the estmts1 and estmts2
5998 -- sequences (which were the original sequences of statements in
5999 -- the exception handlers) and check them.
6001 if Nkind
(Last_Stm
) = N_Label
and then Exception_Junk
(Last_Stm
) then
6006 exit when Nkind
(Stm
) /= N_Block_Statement
;
6007 exit when not Exception_Junk
(Stm
);
6010 exit when Nkind
(Stm
) /= N_Label
;
6011 exit when not Exception_Junk
(Stm
);
6012 Check_Statement_Sequence
6013 (Statements
(Handled_Statement_Sequence
(Next
(Stm
))));
6018 exit when Nkind
(Stm
) /= N_Goto_Statement
;
6019 exit when not Exception_Junk
(Stm
);
6023 -- Don't count pragmas
6025 while Nkind
(Last_Stm
) = N_Pragma
6027 -- Don't count call to SS_Release (can happen after Raise_Exception)
6030 (Nkind
(Last_Stm
) = N_Procedure_Call_Statement
6032 Nkind
(Name
(Last_Stm
)) = N_Identifier
6034 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_SS_Release
))
6036 -- Don't count exception junk
6039 (Nkind_In
(Last_Stm
, N_Goto_Statement
,
6041 N_Object_Declaration
)
6042 and then Exception_Junk
(Last_Stm
))
6043 or else Nkind
(Last_Stm
) in N_Push_xxx_Label
6044 or else Nkind
(Last_Stm
) in N_Pop_xxx_Label
6046 -- Inserted code, such as finalization calls, is irrelevant: we only
6047 -- need to check original source.
6049 or else Is_Rewrite_Insertion
(Last_Stm
)
6054 -- Here we have the "real" last statement
6056 Kind
:= Nkind
(Last_Stm
);
6058 -- Transfer of control, OK. Note that in the No_Return procedure
6059 -- case, we already diagnosed any explicit return statements, so
6060 -- we can treat them as OK in this context.
6062 if Is_Transfer
(Last_Stm
) then
6065 -- Check cases of explicit non-indirect procedure calls
6067 elsif Kind
= N_Procedure_Call_Statement
6068 and then Is_Entity_Name
(Name
(Last_Stm
))
6070 -- Check call to Raise_Exception procedure which is treated
6071 -- specially, as is a call to Reraise_Occurrence.
6073 -- We suppress the warning in these cases since it is likely that
6074 -- the programmer really does not expect to deal with the case
6075 -- of Null_Occurrence, and thus would find a warning about a
6076 -- missing return curious, and raising Program_Error does not
6077 -- seem such a bad behavior if this does occur.
6079 -- Note that in the Ada 2005 case for Raise_Exception, the actual
6080 -- behavior will be to raise Constraint_Error (see AI-329).
6082 if Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Raise_Exception
)
6084 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Reraise_Occurrence
)
6086 Raise_Exception_Call
:= True;
6088 -- For Raise_Exception call, test first argument, if it is
6089 -- an attribute reference for a 'Identity call, then we know
6090 -- that the call cannot possibly return.
6093 Arg
: constant Node_Id
:=
6094 Original_Node
(First_Actual
(Last_Stm
));
6096 if Nkind
(Arg
) = N_Attribute_Reference
6097 and then Attribute_Name
(Arg
) = Name_Identity
6104 -- If statement, need to look inside if there is an else and check
6105 -- each constituent statement sequence for proper termination.
6107 elsif Kind
= N_If_Statement
6108 and then Present
(Else_Statements
(Last_Stm
))
6110 Check_Statement_Sequence
(Then_Statements
(Last_Stm
));
6111 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
6113 if Present
(Elsif_Parts
(Last_Stm
)) then
6115 Elsif_Part
: Node_Id
:= First
(Elsif_Parts
(Last_Stm
));
6118 while Present
(Elsif_Part
) loop
6119 Check_Statement_Sequence
(Then_Statements
(Elsif_Part
));
6127 -- Case statement, check each case for proper termination
6129 elsif Kind
= N_Case_Statement
then
6133 Case_Alt
:= First_Non_Pragma
(Alternatives
(Last_Stm
));
6134 while Present
(Case_Alt
) loop
6135 Check_Statement_Sequence
(Statements
(Case_Alt
));
6136 Next_Non_Pragma
(Case_Alt
);
6142 -- Block statement, check its handled sequence of statements
6144 elsif Kind
= N_Block_Statement
then
6150 (Handled_Statement_Sequence
(Last_Stm
), Mode
, Err1
);
6159 -- Loop statement. If there is an iteration scheme, we can definitely
6160 -- fall out of the loop. Similarly if there is an exit statement, we
6161 -- can fall out. In either case we need a following return.
6163 elsif Kind
= N_Loop_Statement
then
6164 if Present
(Iteration_Scheme
(Last_Stm
))
6165 or else Has_Exit
(Entity
(Identifier
(Last_Stm
)))
6169 -- A loop with no exit statement or iteration scheme is either
6170 -- an infinite loop, or it has some other exit (raise/return).
6171 -- In either case, no warning is required.
6177 -- Timed entry call, check entry call and delay alternatives
6179 -- Note: in expanded code, the timed entry call has been converted
6180 -- to a set of expanded statements on which the check will work
6181 -- correctly in any case.
6183 elsif Kind
= N_Timed_Entry_Call
then
6185 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
6186 DCA
: constant Node_Id
:= Delay_Alternative
(Last_Stm
);
6189 -- If statement sequence of entry call alternative is missing,
6190 -- then we can definitely fall through, and we post the error
6191 -- message on the entry call alternative itself.
6193 if No
(Statements
(ECA
)) then
6196 -- If statement sequence of delay alternative is missing, then
6197 -- we can definitely fall through, and we post the error
6198 -- message on the delay alternative itself.
6200 -- Note: if both ECA and DCA are missing the return, then we
6201 -- post only one message, should be enough to fix the bugs.
6202 -- If not we will get a message next time on the DCA when the
6205 elsif No
(Statements
(DCA
)) then
6208 -- Else check both statement sequences
6211 Check_Statement_Sequence
(Statements
(ECA
));
6212 Check_Statement_Sequence
(Statements
(DCA
));
6217 -- Conditional entry call, check entry call and else part
6219 -- Note: in expanded code, the conditional entry call has been
6220 -- converted to a set of expanded statements on which the check
6221 -- will work correctly in any case.
6223 elsif Kind
= N_Conditional_Entry_Call
then
6225 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
6228 -- If statement sequence of entry call alternative is missing,
6229 -- then we can definitely fall through, and we post the error
6230 -- message on the entry call alternative itself.
6232 if No
(Statements
(ECA
)) then
6235 -- Else check statement sequence and else part
6238 Check_Statement_Sequence
(Statements
(ECA
));
6239 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
6245 -- If we fall through, issue appropriate message
6249 -- Kill warning if last statement is a raise exception call,
6250 -- or a pragma Assert (False). Note that with assertions enabled,
6251 -- such a pragma has been converted into a raise exception call
6252 -- already, so the Assert_False is for the assertions off case.
6254 if not Raise_Exception_Call
and then not Assert_False
then
6256 -- In GNATprove mode, it is an error to have a missing return
6258 Error_Msg_Warn
:= SPARK_Mode
/= On
;
6260 -- Issue error message or warning
6263 ("RETURN statement missing following this statement<<!",
6266 ("\Program_Error ]<<!", Last_Stm
);
6269 -- Note: we set Err even though we have not issued a warning
6270 -- because we still have a case of a missing return. This is
6271 -- an extremely marginal case, probably will never be noticed
6272 -- but we might as well get it right.
6276 -- Otherwise we have the case of a procedure marked No_Return
6279 if not Raise_Exception_Call
then
6280 if GNATprove_Mode
then
6282 ("implied return after this statement "
6283 & "would have raised Program_Error", Last_Stm
);
6286 ("implied return after this statement "
6287 & "will raise Program_Error??", Last_Stm
);
6290 Error_Msg_Warn
:= SPARK_Mode
/= On
;
6292 ("\procedure & is marked as No_Return<<!", Last_Stm
, Proc
);
6296 RE
: constant Node_Id
:=
6297 Make_Raise_Program_Error
(Sloc
(Last_Stm
),
6298 Reason
=> PE_Implicit_Return
);
6300 Insert_After
(Last_Stm
, RE
);
6304 end Check_Statement_Sequence
;
6306 -- Start of processing for Check_Returns
6310 Check_Statement_Sequence
(Statements
(HSS
));
6312 if Present
(Exception_Handlers
(HSS
)) then
6313 Handler
:= First_Non_Pragma
(Exception_Handlers
(HSS
));
6314 while Present
(Handler
) loop
6315 Check_Statement_Sequence
(Statements
(Handler
));
6316 Next_Non_Pragma
(Handler
);
6321 ----------------------------
6322 -- Check_Subprogram_Order --
6323 ----------------------------
6325 procedure Check_Subprogram_Order
(N
: Node_Id
) is
6327 function Subprogram_Name_Greater
(S1
, S2
: String) return Boolean;
6328 -- This is used to check if S1 > S2 in the sense required by this test,
6329 -- for example nameab < namec, but name2 < name10.
6331 -----------------------------
6332 -- Subprogram_Name_Greater --
6333 -----------------------------
6335 function Subprogram_Name_Greater
(S1
, S2
: String) return Boolean is
6340 -- Deal with special case where names are identical except for a
6341 -- numerical suffix. These are handled specially, taking the numeric
6342 -- ordering from the suffix into account.
6345 while S1
(L1
) in '0' .. '9' loop
6350 while S2
(L2
) in '0' .. '9' loop
6354 -- If non-numeric parts non-equal, do straight compare
6356 if S1
(S1
'First .. L1
) /= S2
(S2
'First .. L2
) then
6359 -- If non-numeric parts equal, compare suffixed numeric parts. Note
6360 -- that a missing suffix is treated as numeric zero in this test.
6364 while L1
< S1
'Last loop
6366 N1
:= N1
* 10 + Character'Pos (S1
(L1
)) - Character'Pos ('0');
6370 while L2
< S2
'Last loop
6372 N2
:= N2
* 10 + Character'Pos (S2
(L2
)) - Character'Pos ('0');
6377 end Subprogram_Name_Greater
;
6379 -- Start of processing for Check_Subprogram_Order
6382 -- Check body in alpha order if this is option
6385 and then Style_Check_Order_Subprograms
6386 and then Nkind
(N
) = N_Subprogram_Body
6387 and then Comes_From_Source
(N
)
6388 and then In_Extended_Main_Source_Unit
(N
)
6392 renames Scope_Stack
.Table
6393 (Scope_Stack
.Last
).Last_Subprogram_Name
;
6395 Body_Id
: constant Entity_Id
:=
6396 Defining_Entity
(Specification
(N
));
6399 Get_Decoded_Name_String
(Chars
(Body_Id
));
6402 if Subprogram_Name_Greater
6403 (LSN
.all, Name_Buffer
(1 .. Name_Len
))
6405 Style
.Subprogram_Not_In_Alpha_Order
(Body_Id
);
6411 LSN
:= new String'(Name_Buffer (1 .. Name_Len));
6414 end Check_Subprogram_Order;
6416 ------------------------------
6417 -- Check_Subtype_Conformant --
6418 ------------------------------
6420 procedure Check_Subtype_Conformant
6421 (New_Id : Entity_Id;
6423 Err_Loc : Node_Id := Empty;
6424 Skip_Controlling_Formals : Boolean := False;
6425 Get_Inst : Boolean := False)
6428 pragma Warnings (Off, Result);
6431 (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
6432 Skip_Controlling_Formals => Skip_Controlling_Formals,
6433 Get_Inst => Get_Inst);
6434 end Check_Subtype_Conformant;
6436 ---------------------------
6437 -- Check_Type_Conformant --
6438 ---------------------------
6440 procedure Check_Type_Conformant
6441 (New_Id : Entity_Id;
6443 Err_Loc : Node_Id := Empty)
6446 pragma Warnings (Off, Result);
6449 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
6450 end Check_Type_Conformant;
6452 ---------------------------
6453 -- Can_Override_Operator --
6454 ---------------------------
6456 function Can_Override_Operator (Subp : Entity_Id) return Boolean is
6460 if Nkind (Subp) /= N_Defining_Operator_Symbol then
6464 Typ := Base_Type (Etype (First_Formal (Subp)));
6466 -- Check explicitly that the operation is a primitive of the type
6468 return Operator_Matches_Spec (Subp, Subp)
6469 and then not Is_Generic_Type (Typ)
6470 and then Scope (Subp) = Scope (Typ)
6471 and then not Is_Class_Wide_Type (Typ);
6473 end Can_Override_Operator;
6475 ----------------------
6476 -- Conforming_Types --
6477 ----------------------
6479 function Conforming_Types
6482 Ctype : Conformance_Type;
6483 Get_Inst : Boolean := False) return Boolean
6485 function Base_Types_Match
6487 Typ_2 : Entity_Id) return Boolean;
6488 -- If neither Typ_1 nor Typ_2 are generic actual types, or if they are
6489 -- in different scopes (e.g. parent and child instances), then verify
6490 -- that the base types are equal. Otherwise Typ_1 and Typ_2 must be on
6491 -- the same subtype chain. The whole purpose of this procedure is to
6492 -- prevent spurious ambiguities in an instantiation that may arise if
6493 -- two distinct generic types are instantiated with the same actual.
6495 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id;
6496 -- An access parameter can designate an incomplete type. If the
6497 -- incomplete type is the limited view of a type from a limited_
6498 -- with_clause, check whether the non-limited view is available.
6499 -- If it is a (non-limited) incomplete type, get the full view.
6501 function Matches_Limited_With_View
6503 Typ_2 : Entity_Id) return Boolean;
6504 -- Returns True if and only if either Typ_1 denotes a limited view of
6505 -- Typ_2 or Typ_2 denotes a limited view of Typ_1. This can arise when
6506 -- the limited with view of a type is used in a subprogram declaration
6507 -- and the subprogram body is in the scope of a regular with clause for
6508 -- the same unit. In such a case, the two type entities are considered
6509 -- identical for purposes of conformance checking.
6511 ----------------------
6512 -- Base_Types_Match --
6513 ----------------------
6515 function Base_Types_Match
6517 Typ_2 : Entity_Id) return Boolean
6519 Base_1 : constant Entity_Id := Base_Type (Typ_1);
6520 Base_2 : constant Entity_Id := Base_Type (Typ_2);
6523 if Typ_1 = Typ_2 then
6526 elsif Base_1 = Base_2 then
6528 -- The following is too permissive. A more precise test should
6529 -- check that the generic actual is an ancestor subtype of the
6532 -- See code in Find_Corresponding_Spec that applies an additional
6533 -- filter to handle accidental amiguities in instances.
6536 not Is_Generic_Actual_Type (Typ_1)
6537 or else not Is_Generic_Actual_Type (Typ_2)
6538 or else Scope (Typ_1) /= Scope (Typ_2);
6540 -- If Typ_2 is a generic actual type it is declared as the subtype of
6541 -- the actual. If that actual is itself a subtype we need to use its
6542 -- own base type to check for compatibility.
6544 elsif Ekind (Base_2) = Ekind (Typ_2)
6545 and then Base_1 = Base_Type (Base_2)
6549 elsif Ekind (Base_1) = Ekind (Typ_1)
6550 and then Base_2 = Base_Type (Base_1)
6557 end Base_Types_Match;
6559 --------------------------
6560 -- Find_Designated_Type --
6561 --------------------------
6563 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id is
6567 Desig := Directly_Designated_Type (Typ);
6569 if Ekind (Desig) = E_Incomplete_Type then
6571 -- If regular incomplete type, get full view if available
6573 if Present (Full_View (Desig)) then
6574 Desig := Full_View (Desig);
6576 -- If limited view of a type, get non-limited view if available,
6577 -- and check again for a regular incomplete type.
6579 elsif Present (Non_Limited_View (Desig)) then
6580 Desig := Get_Full_View (Non_Limited_View (Desig));
6585 end Find_Designated_Type;
6587 -------------------------------
6588 -- Matches_Limited_With_View --
6589 -------------------------------
6591 function Matches_Limited_With_View
6593 Typ_2 : Entity_Id) return Boolean
6595 function Is_Matching_Limited_View
6597 View : Entity_Id) return Boolean;
6598 -- Determine whether non-limited view View denotes type Typ in some
6599 -- conformant fashion.
6601 ------------------------------
6602 -- Is_Matching_Limited_View --
6603 ------------------------------
6605 function Is_Matching_Limited_View
6607 View : Entity_Id) return Boolean
6609 Root_Typ : Entity_Id;
6610 Root_View : Entity_Id;
6613 -- The non-limited view directly denotes the type
6618 -- The type is a subtype of the non-limited view
6620 elsif Is_Subtype_Of (Typ, View) then
6623 -- Both the non-limited view and the type denote class-wide types
6625 elsif Is_Class_Wide_Type (Typ)
6626 and then Is_Class_Wide_Type (View)
6628 Root_Typ := Root_Type (Typ);
6629 Root_View := Root_Type (View);
6631 if Root_Typ = Root_View then
6634 -- An incomplete tagged type and its full view may receive two
6635 -- distinct class-wide types when the related package has not
6636 -- been analyzed yet.
6639 -- type T is tagged; -- CW_1
6640 -- type T is tagged null record; -- CW_2
6643 -- This is because the package lacks any semantic information
6644 -- that may eventually link both views of T. As a consequence,
6645 -- a client of the limited view of Pack will see CW_2 while a
6646 -- client of the non-limited view of Pack will see CW_1.
6648 elsif Is_Incomplete_Type (Root_Typ)
6649 and then Present (Full_View (Root_Typ))
6650 and then Full_View (Root_Typ) = Root_View
6654 elsif Is_Incomplete_Type (Root_View)
6655 and then Present (Full_View (Root_View))
6656 and then Full_View (Root_View) = Root_Typ
6663 end Is_Matching_Limited_View;
6665 -- Start of processing for Matches_Limited_With_View
6668 -- In some cases a type imported through a limited_with clause, and
6669 -- its non-limited view are both visible, for example in an anonymous
6670 -- access-to-class-wide type in a formal, or when building the body
6671 -- for a subprogram renaming after the subprogram has been frozen.
6672 -- In these cases both entities designate the same type. In addition,
6673 -- if one of them is an actual in an instance, it may be a subtype of
6674 -- the non-limited view of the other.
6676 if From_Limited_With (Typ_1)
6677 and then From_Limited_With (Typ_2)
6678 and then Available_View (Typ_1) = Available_View (Typ_2)
6682 elsif From_Limited_With (Typ_1) then
6683 return Is_Matching_Limited_View (Typ_2, Available_View (Typ_1));
6685 elsif From_Limited_With (Typ_2) then
6686 return Is_Matching_Limited_View (Typ_1, Available_View (Typ_2));
6691 end Matches_Limited_With_View;
6695 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
6697 Type_1 : Entity_Id := T1;
6698 Type_2 : Entity_Id := T2;
6700 -- Start of processing for Conforming_Types
6703 -- The context is an instance association for a formal access-to-
6704 -- subprogram type; the formal parameter types require mapping because
6705 -- they may denote other formal parameters of the generic unit.
6708 Type_1 := Get_Instance_Of (T1);
6709 Type_2 := Get_Instance_Of (T2);
6712 -- If one of the types is a view of the other introduced by a limited
6713 -- with clause, treat these as conforming for all purposes.
6715 if Matches_Limited_With_View (T1, T2) then
6718 elsif Base_Types_Match (Type_1, Type_2) then
6719 return Ctype <= Mode_Conformant
6720 or else Subtypes_Statically_Match (Type_1, Type_2);
6722 elsif Is_Incomplete_Or_Private_Type (Type_1)
6723 and then Present (Full_View (Type_1))
6724 and then Base_Types_Match (Full_View (Type_1), Type_2)
6726 return Ctype <= Mode_Conformant
6727 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
6729 elsif Ekind (Type_2) = E_Incomplete_Type
6730 and then Present (Full_View (Type_2))
6731 and then Base_Types_Match (Type_1, Full_View (Type_2))
6733 return Ctype <= Mode_Conformant
6734 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
6736 elsif Is_Private_Type (Type_2)
6737 and then In_Instance
6738 and then Present (Full_View (Type_2))
6739 and then Base_Types_Match (Type_1, Full_View (Type_2))
6741 return Ctype <= Mode_Conformant
6742 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
6744 -- In Ada 2012, incomplete types (including limited views) can appear
6745 -- as actuals in instantiations.
6747 elsif Is_Incomplete_Type (Type_1)
6748 and then Is_Incomplete_Type (Type_2)
6749 and then (Used_As_Generic_Actual (Type_1)
6750 or else Used_As_Generic_Actual (Type_2))
6755 -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
6756 -- treated recursively because they carry a signature. As far as
6757 -- conformance is concerned, convention plays no role, and either
6758 -- or both could be access to protected subprograms.
6760 Are_Anonymous_Access_To_Subprogram_Types :=
6761 Ekind_In (Type_1, E_Anonymous_Access_Subprogram_Type,
6762 E_Anonymous_Access_Protected_Subprogram_Type)
6764 Ekind_In (Type_2, E_Anonymous_Access_Subprogram_Type,
6765 E_Anonymous_Access_Protected_Subprogram_Type);
6767 -- Test anonymous access type case. For this case, static subtype
6768 -- matching is required for mode conformance (RM 6.3.1(15)). We check
6769 -- the base types because we may have built internal subtype entities
6770 -- to handle null-excluding types (see Process_Formals).
6772 if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
6774 Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
6776 -- Ada 2005 (AI-254)
6778 or else Are_Anonymous_Access_To_Subprogram_Types
6781 Desig_1 : Entity_Id;
6782 Desig_2 : Entity_Id;
6785 -- In Ada 2005, access constant indicators must match for
6786 -- subtype conformance.
6788 if Ada_Version >= Ada_2005
6789 and then Ctype >= Subtype_Conformant
6791 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
6796 Desig_1 := Find_Designated_Type (Type_1);
6797 Desig_2 := Find_Designated_Type (Type_2);
6799 -- If the context is an instance association for a formal
6800 -- access-to-subprogram type; formal access parameter designated
6801 -- types require mapping because they may denote other formal
6802 -- parameters of the generic unit.
6805 Desig_1 := Get_Instance_Of (Desig_1);
6806 Desig_2 := Get_Instance_Of (Desig_2);
6809 -- It is possible for a Class_Wide_Type to be introduced for an
6810 -- incomplete type, in which case there is a separate class_ wide
6811 -- type for the full view. The types conform if their Etypes
6812 -- conform, i.e. one may be the full view of the other. This can
6813 -- only happen in the context of an access parameter, other uses
6814 -- of an incomplete Class_Wide_Type are illegal.
6816 if Is_Class_Wide_Type (Desig_1)
6818 Is_Class_Wide_Type (Desig_2)
6822 (Etype (Base_Type (Desig_1)),
6823 Etype (Base_Type (Desig_2)), Ctype);
6825 elsif Are_Anonymous_Access_To_Subprogram_Types then
6826 if Ada_Version < Ada_2005 then
6827 return Ctype = Type_Conformant
6829 Subtypes_Statically_Match (Desig_1, Desig_2);
6831 -- We must check the conformance of the signatures themselves
6835 Conformant : Boolean;
6838 (Desig_1, Desig_2, Ctype, False, Conformant);
6843 -- A limited view of an actual matches the corresponding
6844 -- incomplete formal.
6846 elsif Ekind (Desig_2) = E_Incomplete_Subtype
6847 and then From_Limited_With (Desig_2)
6848 and then Used_As_Generic_Actual (Etype (Desig_2))
6853 return Base_Type (Desig_1) = Base_Type (Desig_2)
6854 and then (Ctype = Type_Conformant
6856 Subtypes_Statically_Match (Desig_1, Desig_2));
6860 -- Otherwise definitely no match
6863 if ((Ekind (Type_1) = E_Anonymous_Access_Type
6864 and then Is_Access_Type (Type_2))
6865 or else (Ekind (Type_2) = E_Anonymous_Access_Type
6866 and then Is_Access_Type (Type_1)))
6869 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
6871 May_Hide_Profile := True;
6876 end Conforming_Types;
6878 --------------------------
6879 -- Create_Extra_Formals --
6880 --------------------------
6882 procedure Create_Extra_Formals (E : Entity_Id) is
6884 First_Extra : Entity_Id := Empty;
6885 Last_Extra : Entity_Id;
6886 Formal_Type : Entity_Id;
6887 P_Formal : Entity_Id := Empty;
6889 function Add_Extra_Formal
6890 (Assoc_Entity : Entity_Id;
6893 Suffix : String) return Entity_Id;
6894 -- Add an extra formal to the current list of formals and extra formals.
6895 -- The extra formal is added to the end of the list of extra formals,
6896 -- and also returned as the result. These formals are always of mode IN.
6897 -- The new formal has the type Typ, is declared in Scope, and its name
6898 -- is given by a concatenation of the name of Assoc_Entity and Suffix.
6899 -- The following suffixes are currently used. They should not be changed
6900 -- without coordinating with CodePeer, which makes use of these to
6901 -- provide better messages.
6903 -- O denotes the Constrained bit.
6904 -- L denotes the accessibility level.
6905 -- BIP_xxx denotes an extra formal for a build-in-place function. See
6906 -- the full list in exp_ch6.BIP_Formal_Kind.
6908 ----------------------
6909 -- Add_Extra_Formal --
6910 ----------------------
6912 function Add_Extra_Formal
6913 (Assoc_Entity : Entity_Id;
6916 Suffix : String) return Entity_Id
6918 EF : constant Entity_Id :=
6919 Make_Defining_Identifier (Sloc (Assoc_Entity),
6920 Chars => New_External_Name (Chars (Assoc_Entity),
6924 -- A little optimization. Never generate an extra formal for the
6925 -- _init operand of an initialization procedure, since it could
6928 if Chars (Formal) = Name_uInit then
6932 Set_Ekind (EF, E_In_Parameter);
6933 Set_Actual_Subtype (EF, Typ);
6934 Set_Etype (EF, Typ);
6935 Set_Scope (EF, Scope);
6936 Set_Mechanism (EF, Default_Mechanism);
6937 Set_Formal_Validity (EF);
6939 if No (First_Extra) then
6941 Set_Extra_Formals (Scope, First_Extra);
6944 if Present (Last_Extra) then
6945 Set_Extra_Formal (Last_Extra, EF);
6951 end Add_Extra_Formal;
6953 -- Start of processing for Create_Extra_Formals
6956 -- We never generate extra formals if expansion is not active because we
6957 -- don't need them unless we are generating code.
6959 if not Expander_Active then
6963 -- No need to generate extra formals in interface thunks whose target
6964 -- primitive has no extra formals.
6966 if Is_Thunk (E) and then No (Extra_Formals (Thunk_Entity (E))) then
6970 -- If this is a derived subprogram then the subtypes of the parent
6971 -- subprogram's formal parameters will be used to determine the need
6972 -- for extra formals.
6974 if Is_Overloadable (E) and then Present (Alias (E)) then
6975 P_Formal := First_Formal (Alias (E));
6978 Last_Extra := Empty;
6979 Formal := First_Formal (E);
6980 while Present (Formal) loop
6981 Last_Extra := Formal;
6982 Next_Formal (Formal);
6985 -- If Extra_Formals were already created, don't do it again. This
6986 -- situation may arise for subprogram types created as part of
6987 -- dispatching calls (see Expand_Dispatching_Call)
6989 if Present (Last_Extra) and then Present (Extra_Formal (Last_Extra)) then
6993 -- If the subprogram is a predefined dispatching subprogram then don't
6994 -- generate any extra constrained or accessibility level formals. In
6995 -- general we suppress these for internal subprograms (by not calling
6996 -- Freeze_Subprogram and Create_Extra_Formals at all), but internally
6997 -- generated stream attributes do get passed through because extra
6998 -- build-in-place formals are needed in some cases (limited 'Input
).
7000 if Is_Predefined_Internal_Operation
(E
) then
7001 goto Test_For_Func_Result_Extras
;
7004 Formal
:= First_Formal
(E
);
7005 while Present
(Formal
) loop
7007 -- Create extra formal for supporting the attribute 'Constrained.
7008 -- The case of a private type view without discriminants also
7009 -- requires the extra formal if the underlying type has defaulted
7012 if Ekind
(Formal
) /= E_In_Parameter
then
7013 if Present
(P_Formal
) then
7014 Formal_Type
:= Etype
(P_Formal
);
7016 Formal_Type
:= Etype
(Formal
);
7019 -- Do not produce extra formals for Unchecked_Union parameters.
7020 -- Jump directly to the end of the loop.
7022 if Is_Unchecked_Union
(Base_Type
(Formal_Type
)) then
7023 goto Skip_Extra_Formal_Generation
;
7026 if not Has_Discriminants
(Formal_Type
)
7027 and then Ekind
(Formal_Type
) in Private_Kind
7028 and then Present
(Underlying_Type
(Formal_Type
))
7030 Formal_Type
:= Underlying_Type
(Formal_Type
);
7033 -- Suppress the extra formal if formal's subtype is constrained or
7034 -- indefinite, or we're compiling for Ada 2012 and the underlying
7035 -- type is tagged and limited. In Ada 2012, a limited tagged type
7036 -- can have defaulted discriminants, but 'Constrained is required
7037 -- to return True, so the formal is never needed (see AI05-0214).
7038 -- Note that this ensures consistency of calling sequences for
7039 -- dispatching operations when some types in a class have defaults
7040 -- on discriminants and others do not (and requiring the extra
7041 -- formal would introduce distributed overhead).
7043 -- If the type does not have a completion yet, treat as prior to
7044 -- Ada 2012 for consistency.
7046 if Has_Discriminants
(Formal_Type
)
7047 and then not Is_Constrained
(Formal_Type
)
7048 and then Is_Definite_Subtype
(Formal_Type
)
7049 and then (Ada_Version
< Ada_2012
7050 or else No
(Underlying_Type
(Formal_Type
))
7052 (Is_Limited_Type
(Formal_Type
)
7055 (Underlying_Type
(Formal_Type
)))))
7057 Set_Extra_Constrained
7058 (Formal
, Add_Extra_Formal
(Formal
, Standard_Boolean
, E
, "O"));
7062 -- Create extra formal for supporting accessibility checking. This
7063 -- is done for both anonymous access formals and formals of named
7064 -- access types that are marked as controlling formals. The latter
7065 -- case can occur when Expand_Dispatching_Call creates a subprogram
7066 -- type and substitutes the types of access-to-class-wide actuals
7067 -- for the anonymous access-to-specific-type of controlling formals.
7068 -- Base_Type is applied because in cases where there is a null
7069 -- exclusion the formal may have an access subtype.
7071 -- This is suppressed if we specifically suppress accessibility
7072 -- checks at the package level for either the subprogram, or the
7073 -- package in which it resides. However, we do not suppress it
7074 -- simply if the scope has accessibility checks suppressed, since
7075 -- this could cause trouble when clients are compiled with a
7076 -- different suppression setting. The explicit checks at the
7077 -- package level are safe from this point of view.
7079 if (Ekind
(Base_Type
(Etype
(Formal
))) = E_Anonymous_Access_Type
7080 or else (Is_Controlling_Formal
(Formal
)
7081 and then Is_Access_Type
(Base_Type
(Etype
(Formal
)))))
7083 (Explicit_Suppress
(E
, Accessibility_Check
)
7085 Explicit_Suppress
(Scope
(E
), Accessibility_Check
))
7088 or else Present
(Extra_Accessibility
(P_Formal
)))
7090 Set_Extra_Accessibility
7091 (Formal
, Add_Extra_Formal
(Formal
, Standard_Natural
, E
, "L"));
7094 -- This label is required when skipping extra formal generation for
7095 -- Unchecked_Union parameters.
7097 <<Skip_Extra_Formal_Generation
>>
7099 if Present
(P_Formal
) then
7100 Next_Formal
(P_Formal
);
7103 Next_Formal
(Formal
);
7106 <<Test_For_Func_Result_Extras
>>
7108 -- Ada 2012 (AI05-234): "the accessibility level of the result of a
7109 -- function call is ... determined by the point of call ...".
7111 if Needs_Result_Accessibility_Level
(E
) then
7112 Set_Extra_Accessibility_Of_Result
7113 (E
, Add_Extra_Formal
(E
, Standard_Natural
, E
, "L"));
7116 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
7117 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
7119 if Ada_Version
>= Ada_2005
and then Is_Build_In_Place_Function
(E
) then
7121 Result_Subt
: constant Entity_Id
:= Etype
(E
);
7122 Full_Subt
: constant Entity_Id
:= Available_View
(Result_Subt
);
7123 Formal_Typ
: Entity_Id
;
7125 Discard
: Entity_Id
;
7126 pragma Warnings
(Off
, Discard
);
7129 -- In the case of functions with unconstrained result subtypes,
7130 -- add a 4-state formal indicating whether the return object is
7131 -- allocated by the caller (1), or should be allocated by the
7132 -- callee on the secondary stack (2), in the global heap (3), or
7133 -- in a user-defined storage pool (4). For the moment we just use
7134 -- Natural for the type of this formal. Note that this formal
7135 -- isn't usually needed in the case where the result subtype is
7136 -- constrained, but it is needed when the function has a tagged
7137 -- result, because generally such functions can be called in a
7138 -- dispatching context and such calls must be handled like calls
7139 -- to a class-wide function.
7141 if Needs_BIP_Alloc_Form
(E
) then
7144 (E
, Standard_Natural
,
7145 E
, BIP_Formal_Suffix
(BIP_Alloc_Form
));
7147 -- Add BIP_Storage_Pool, in case BIP_Alloc_Form indicates to
7148 -- use a user-defined pool. This formal is not added on
7149 -- ZFP as those targets do not support pools.
7151 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
7154 (E
, RTE
(RE_Root_Storage_Pool_Ptr
),
7155 E
, BIP_Formal_Suffix
(BIP_Storage_Pool
));
7159 -- In the case of functions whose result type needs finalization,
7160 -- add an extra formal which represents the finalization master.
7162 if Needs_BIP_Finalization_Master
(E
) then
7165 (E
, RTE
(RE_Finalization_Master_Ptr
),
7166 E
, BIP_Formal_Suffix
(BIP_Finalization_Master
));
7169 -- When the result type contains tasks, add two extra formals: the
7170 -- master of the tasks to be created, and the caller's activation
7173 if Has_Task
(Full_Subt
) then
7176 (E
, RTE
(RE_Master_Id
),
7177 E
, BIP_Formal_Suffix
(BIP_Task_Master
));
7180 (E
, RTE
(RE_Activation_Chain_Access
),
7181 E
, BIP_Formal_Suffix
(BIP_Activation_Chain
));
7184 -- All build-in-place functions get an extra formal that will be
7185 -- passed the address of the return object within the caller.
7188 Create_Itype
(E_Anonymous_Access_Type
, E
, Scope_Id
=> Scope
(E
));
7190 Set_Directly_Designated_Type
(Formal_Typ
, Result_Subt
);
7191 Set_Etype
(Formal_Typ
, Formal_Typ
);
7192 Set_Depends_On_Private
7193 (Formal_Typ
, Has_Private_Component
(Formal_Typ
));
7194 Set_Is_Public
(Formal_Typ
, Is_Public
(Scope
(Formal_Typ
)));
7195 Set_Is_Access_Constant
(Formal_Typ
, False);
7197 -- Ada 2005 (AI-50217): Propagate the attribute that indicates
7198 -- the designated type comes from the limited view (for back-end
7201 Set_From_Limited_With
7202 (Formal_Typ
, From_Limited_With
(Result_Subt
));
7204 Layout_Type
(Formal_Typ
);
7208 (E
, Formal_Typ
, E
, BIP_Formal_Suffix
(BIP_Object_Access
));
7211 end Create_Extra_Formals
;
7213 -----------------------------
7214 -- Enter_Overloaded_Entity --
7215 -----------------------------
7217 procedure Enter_Overloaded_Entity
(S
: Entity_Id
) is
7218 function Matches_Predefined_Op
return Boolean;
7219 -- This returns an approximation of whether S matches a predefined
7220 -- operator, based on the operator symbol, and the parameter and result
7221 -- types. The rules are scattered throughout chapter 4 of the Ada RM.
7223 ---------------------------
7224 -- Matches_Predefined_Op --
7225 ---------------------------
7227 function Matches_Predefined_Op
return Boolean is
7228 Formal_1
: constant Entity_Id
:= First_Formal
(S
);
7229 Formal_2
: constant Entity_Id
:= Next_Formal
(Formal_1
);
7230 Op
: constant Name_Id
:= Chars
(S
);
7231 Result_Type
: constant Entity_Id
:= Base_Type
(Etype
(S
));
7232 Type_1
: constant Entity_Id
:= Base_Type
(Etype
(Formal_1
));
7237 if Present
(Formal_2
) then
7239 Type_2
: constant Entity_Id
:= Base_Type
(Etype
(Formal_2
));
7242 -- All but "&" and "**" have same-types parameters
7245 when Name_Op_Concat |
7250 if Type_1
/= Type_2
then
7255 -- Check parameter and result types
7262 Is_Boolean_Type
(Result_Type
)
7263 and then Result_Type
= Type_1
;
7268 Is_Integer_Type
(Result_Type
)
7269 and then Result_Type
= Type_1
;
7276 Is_Numeric_Type
(Result_Type
)
7277 and then Result_Type
= Type_1
;
7282 Is_Boolean_Type
(Result_Type
)
7283 and then not Is_Limited_Type
(Type_1
);
7290 Is_Boolean_Type
(Result_Type
)
7291 and then (Is_Array_Type
(Type_1
)
7292 or else Is_Scalar_Type
(Type_1
));
7294 when Name_Op_Concat
=>
7295 return Is_Array_Type
(Result_Type
);
7297 when Name_Op_Expon
=>
7299 (Is_Integer_Type
(Result_Type
)
7300 or else Is_Floating_Point_Type
(Result_Type
))
7301 and then Result_Type
= Type_1
7302 and then Type_2
= Standard_Integer
;
7305 raise Program_Error
;
7317 Is_Numeric_Type
(Result_Type
)
7318 and then Result_Type
= Type_1
;
7322 Is_Boolean_Type
(Result_Type
)
7323 and then Result_Type
= Type_1
;
7326 raise Program_Error
;
7329 end Matches_Predefined_Op
;
7333 E
: Entity_Id
:= Current_Entity_In_Scope
(S
);
7334 C_E
: Entity_Id
:= Current_Entity
(S
);
7336 -- Start of processing for Enter_Overloaded_Entity
7340 Set_Has_Homonym
(E
);
7341 Set_Has_Homonym
(S
);
7344 Set_Is_Immediately_Visible
(S
);
7345 Set_Scope
(S
, Current_Scope
);
7347 -- Chain new entity if front of homonym in current scope, so that
7348 -- homonyms are contiguous.
7350 if Present
(E
) and then E
/= C_E
then
7351 while Homonym
(C_E
) /= E
loop
7352 C_E
:= Homonym
(C_E
);
7355 Set_Homonym
(C_E
, S
);
7359 Set_Current_Entity
(S
);
7364 if Is_Inherited_Operation
(S
) then
7365 Append_Inherited_Subprogram
(S
);
7367 Append_Entity
(S
, Current_Scope
);
7370 Set_Public_Status
(S
);
7372 if Debug_Flag_E
then
7373 Write_Str
("New overloaded entity chain: ");
7374 Write_Name
(Chars
(S
));
7377 while Present
(E
) loop
7378 Write_Str
(" "); Write_Int
(Int
(E
));
7385 -- Generate warning for hiding
7388 and then Comes_From_Source
(S
)
7389 and then In_Extended_Main_Source_Unit
(S
)
7396 -- Warn unless genuine overloading. Do not emit warning on
7397 -- hiding predefined operators in Standard (these are either an
7398 -- (artifact of our implicit declarations, or simple noise) but
7399 -- keep warning on a operator defined on a local subtype, because
7400 -- of the real danger that different operators may be applied in
7401 -- various parts of the program.
7403 -- Note that if E and S have the same scope, there is never any
7404 -- hiding. Either the two conflict, and the program is illegal,
7405 -- or S is overriding an implicit inherited subprogram.
7407 if Scope
(E
) /= Scope
(S
)
7408 and then (not Is_Overloadable
(E
)
7409 or else Subtype_Conformant
(E
, S
))
7410 and then (Is_Immediately_Visible
(E
)
7411 or else Is_Potentially_Use_Visible
(S
))
7413 if Scope
(E
) = Standard_Standard
then
7414 if Nkind
(S
) = N_Defining_Operator_Symbol
7415 and then Scope
(Base_Type
(Etype
(First_Formal
(S
)))) /=
7417 and then Matches_Predefined_Op
7420 ("declaration of & hides predefined operator?h?", S
);
7423 -- E not immediately within Standard
7426 Error_Msg_Sloc
:= Sloc
(E
);
7427 Error_Msg_N
("declaration of & hides one #?h?", S
);
7432 end Enter_Overloaded_Entity
;
7434 -----------------------------
7435 -- Check_Untagged_Equality --
7436 -----------------------------
7438 procedure Check_Untagged_Equality
(Eq_Op
: Entity_Id
) is
7439 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
7440 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Eq_Op
);
7444 -- This check applies only if we have a subprogram declaration with an
7445 -- untagged record type.
7447 if Nkind
(Decl
) /= N_Subprogram_Declaration
7448 or else not Is_Record_Type
(Typ
)
7449 or else Is_Tagged_Type
(Typ
)
7454 -- In Ada 2012 case, we will output errors or warnings depending on
7455 -- the setting of debug flag -gnatd.E.
7457 if Ada_Version
>= Ada_2012
then
7458 Error_Msg_Warn
:= Debug_Flag_Dot_EE
;
7460 -- In earlier versions of Ada, nothing to do unless we are warning on
7461 -- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set).
7464 if not Warn_On_Ada_2012_Compatibility
then
7469 -- Cases where the type has already been frozen
7471 if Is_Frozen
(Typ
) then
7473 -- If the type is not declared in a package, or if we are in the body
7474 -- of the package or in some other scope, the new operation is not
7475 -- primitive, and therefore legal, though suspicious. Should we
7476 -- generate a warning in this case ???
7478 if Ekind
(Scope
(Typ
)) /= E_Package
7479 or else Scope
(Typ
) /= Current_Scope
7483 -- If the type is a generic actual (sub)type, the operation is not
7484 -- primitive either because the base type is declared elsewhere.
7486 elsif Is_Generic_Actual_Type
(Typ
) then
7489 -- Here we have a definite error of declaration after freezing
7492 if Ada_Version
>= Ada_2012
then
7494 ("equality operator must be declared before type & is "
7495 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op
, Typ
);
7497 -- In Ada 2012 mode with error turned to warning, output one
7498 -- more warning to warn that the equality operation may not
7499 -- compose. This is the consequence of ignoring the error.
7501 if Error_Msg_Warn
then
7502 Error_Msg_N
("\equality operation may not compose??", Eq_Op
);
7507 ("equality operator must be declared before type& is "
7508 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op
, Typ
);
7511 -- If we are in the package body, we could just move the
7512 -- declaration to the package spec, so add a message saying that.
7514 if In_Package_Body
(Scope
(Typ
)) then
7515 if Ada_Version
>= Ada_2012
then
7517 ("\move declaration to package spec<<", Eq_Op
);
7520 ("\move declaration to package spec (Ada 2012)?y?", Eq_Op
);
7523 -- Otherwise try to find the freezing point
7526 Obj_Decl
:= Next
(Parent
(Typ
));
7527 while Present
(Obj_Decl
) and then Obj_Decl
/= Decl
loop
7528 if Nkind
(Obj_Decl
) = N_Object_Declaration
7529 and then Etype
(Defining_Identifier
(Obj_Decl
)) = Typ
7531 -- Freezing point, output warnings
7533 if Ada_Version
>= Ada_2012
then
7535 ("type& is frozen by declaration??", Obj_Decl
, Typ
);
7537 ("\an equality operator cannot be declared after "
7542 ("type& is frozen by declaration (Ada 2012)?y?",
7545 ("\an equality operator cannot be declared after "
7546 & "this point (Ada 2012)?y?",
7558 -- Here if type is not frozen yet. It is illegal to have a primitive
7559 -- equality declared in the private part if the type is visible.
7561 elsif not In_Same_List
(Parent
(Typ
), Decl
)
7562 and then not Is_Limited_Type
(Typ
)
7564 -- Shouldn't we give an RM reference here???
7566 if Ada_Version
>= Ada_2012
then
7568 ("equality operator appears too late<<", Eq_Op
);
7571 ("equality operator appears too late (Ada 2012)?y?", Eq_Op
);
7574 -- No error detected
7579 end Check_Untagged_Equality
;
7581 -----------------------------
7582 -- Find_Corresponding_Spec --
7583 -----------------------------
7585 function Find_Corresponding_Spec
7587 Post_Error
: Boolean := True) return Entity_Id
7589 Spec
: constant Node_Id
:= Specification
(N
);
7590 Designator
: constant Entity_Id
:= Defining_Entity
(Spec
);
7594 function Different_Generic_Profile
(E
: Entity_Id
) return Boolean;
7595 -- Even if fully conformant, a body may depend on a generic actual when
7596 -- the spec does not, or vice versa, in which case they were distinct
7597 -- entities in the generic.
7599 -------------------------------
7600 -- Different_Generic_Profile --
7601 -------------------------------
7603 function Different_Generic_Profile
(E
: Entity_Id
) return Boolean is
7606 function Same_Generic_Actual
(T1
, T2
: Entity_Id
) return Boolean;
7607 -- Check that the types of corresponding formals have the same
7608 -- generic actual if any. We have to account for subtypes of a
7609 -- generic formal, declared between a spec and a body, which may
7610 -- appear distinct in an instance but matched in the generic, and
7611 -- the subtype may be used either in the spec or the body of the
7612 -- subprogram being checked.
7614 -------------------------
7615 -- Same_Generic_Actual --
7616 -------------------------
7618 function Same_Generic_Actual
(T1
, T2
: Entity_Id
) return Boolean is
7620 function Is_Declared_Subtype
(S1
, S2
: Entity_Id
) return Boolean;
7621 -- Predicate to check whether S1 is a subtype of S2 in the source
7624 -------------------------
7625 -- Is_Declared_Subtype --
7626 -------------------------
7628 function Is_Declared_Subtype
(S1
, S2
: Entity_Id
) return Boolean is
7630 return Comes_From_Source
(Parent
(S1
))
7631 and then Nkind
(Parent
(S1
)) = N_Subtype_Declaration
7632 and then Is_Entity_Name
(Subtype_Indication
(Parent
(S1
)))
7633 and then Entity
(Subtype_Indication
(Parent
(S1
))) = S2
;
7634 end Is_Declared_Subtype
;
7636 -- Start of processing for Same_Generic_Actual
7639 return Is_Generic_Actual_Type
(T1
) = Is_Generic_Actual_Type
(T2
)
7640 or else Is_Declared_Subtype
(T1
, T2
)
7641 or else Is_Declared_Subtype
(T2
, T1
);
7642 end Same_Generic_Actual
;
7644 -- Start of processing for Different_Generic_Profile
7647 if not In_Instance
then
7650 elsif Ekind
(E
) = E_Function
7651 and then not Same_Generic_Actual
(Etype
(E
), Etype
(Designator
))
7656 F1
:= First_Formal
(Designator
);
7657 F2
:= First_Formal
(E
);
7658 while Present
(F1
) loop
7659 if not Same_Generic_Actual
(Etype
(F1
), Etype
(F2
)) then
7668 end Different_Generic_Profile
;
7670 -- Start of processing for Find_Corresponding_Spec
7673 E
:= Current_Entity
(Designator
);
7674 while Present
(E
) loop
7676 -- We are looking for a matching spec. It must have the same scope,
7677 -- and the same name, and either be type conformant, or be the case
7678 -- of a library procedure spec and its body (which belong to one
7679 -- another regardless of whether they are type conformant or not).
7681 if Scope
(E
) = Current_Scope
then
7682 if Current_Scope
= Standard_Standard
7683 or else (Ekind
(E
) = Ekind
(Designator
)
7684 and then Type_Conformant
(E
, Designator
))
7686 -- Within an instantiation, we know that spec and body are
7687 -- subtype conformant, because they were subtype conformant in
7688 -- the generic. We choose the subtype-conformant entity here as
7689 -- well, to resolve spurious ambiguities in the instance that
7690 -- were not present in the generic (i.e. when two different
7691 -- types are given the same actual). If we are looking for a
7692 -- spec to match a body, full conformance is expected.
7696 -- Inherit the convention and "ghostness" of the matching
7697 -- spec to ensure proper full and subtype conformance.
7699 Set_Convention
(Designator
, Convention
(E
));
7701 if Is_Ghost_Entity
(E
) then
7702 Set_Is_Ghost_Entity
(Designator
);
7705 -- Skip past subprogram bodies and subprogram renamings that
7706 -- may appear to have a matching spec, but that aren't fully
7707 -- conformant with it. That can occur in cases where an
7708 -- actual type causes unrelated homographs in the instance.
7710 if Nkind_In
(N
, N_Subprogram_Body
,
7711 N_Subprogram_Renaming_Declaration
)
7712 and then Present
(Homonym
(E
))
7713 and then not Fully_Conformant
(Designator
, E
)
7717 elsif not Subtype_Conformant
(Designator
, E
) then
7720 elsif Different_Generic_Profile
(E
) then
7725 -- Ada 2012 (AI05-0165): For internally generated bodies of
7726 -- null procedures locate the internally generated spec. We
7727 -- enforce mode conformance since a tagged type may inherit
7728 -- from interfaces several null primitives which differ only
7729 -- in the mode of the formals.
7731 if not (Comes_From_Source
(E
))
7732 and then Is_Null_Procedure
(E
)
7733 and then not Mode_Conformant
(Designator
, E
)
7737 -- For null procedures coming from source that are completions,
7738 -- analysis of the generated body will establish the link.
7740 elsif Comes_From_Source
(E
)
7741 and then Nkind
(Spec
) = N_Procedure_Specification
7742 and then Null_Present
(Spec
)
7746 -- Expression functions can be completions, but cannot be
7747 -- completed by an explicit body.
7749 elsif Comes_From_Source
(E
)
7750 and then Comes_From_Source
(N
)
7751 and then Nkind
(N
) = N_Subprogram_Body
7752 and then Nkind
(Original_Node
(Unit_Declaration_Node
(E
))) =
7753 N_Expression_Function
7755 Error_Msg_Sloc
:= Sloc
(E
);
7756 Error_Msg_N
("body conflicts with expression function#", N
);
7759 elsif not Has_Completion
(E
) then
7760 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
7761 Set_Corresponding_Spec
(N
, E
);
7764 Set_Has_Completion
(E
);
7767 elsif Nkind
(Parent
(N
)) = N_Subunit
then
7769 -- If this is the proper body of a subunit, the completion
7770 -- flag is set when analyzing the stub.
7774 -- If E is an internal function with a controlling result that
7775 -- was created for an operation inherited by a null extension,
7776 -- it may be overridden by a body without a previous spec (one
7777 -- more reason why these should be shunned). In that case we
7778 -- remove the generated body if present, because the current
7779 -- one is the explicit overriding.
7781 elsif Ekind
(E
) = E_Function
7782 and then Ada_Version
>= Ada_2005
7783 and then not Comes_From_Source
(E
)
7784 and then Has_Controlling_Result
(E
)
7785 and then Is_Null_Extension
(Etype
(E
))
7786 and then Comes_From_Source
(Spec
)
7788 Set_Has_Completion
(E
, False);
7791 and then Nkind
(Parent
(E
)) = N_Function_Specification
7794 (Unit_Declaration_Node
7795 (Corresponding_Body
(Unit_Declaration_Node
(E
))));
7799 -- If expansion is disabled, or if the wrapper function has
7800 -- not been generated yet, this a late body overriding an
7801 -- inherited operation, or it is an overriding by some other
7802 -- declaration before the controlling result is frozen. In
7803 -- either case this is a declaration of a new entity.
7809 -- If the body already exists, then this is an error unless
7810 -- the previous declaration is the implicit declaration of a
7811 -- derived subprogram. It is also legal for an instance to
7812 -- contain type conformant overloadable declarations (but the
7813 -- generic declaration may not), per 8.3(26/2).
7815 elsif No
(Alias
(E
))
7816 and then not Is_Intrinsic_Subprogram
(E
)
7817 and then not In_Instance
7820 Error_Msg_Sloc
:= Sloc
(E
);
7822 if Is_Imported
(E
) then
7824 ("body not allowed for imported subprogram & declared#",
7827 Error_Msg_NE
("duplicate body for & declared#", N
, E
);
7831 -- Child units cannot be overloaded, so a conformance mismatch
7832 -- between body and a previous spec is an error.
7834 elsif Is_Child_Unit
(E
)
7836 Nkind
(Unit_Declaration_Node
(Designator
)) = N_Subprogram_Body
7838 Nkind
(Parent
(Unit_Declaration_Node
(Designator
))) =
7843 ("body of child unit does not match previous declaration", N
);
7851 -- On exit, we know that no previous declaration of subprogram exists
7854 end Find_Corresponding_Spec
;
7856 ----------------------
7857 -- Fully_Conformant --
7858 ----------------------
7860 function Fully_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
7863 Check_Conformance
(New_Id
, Old_Id
, Fully_Conformant
, False, Result
);
7865 end Fully_Conformant
;
7867 ----------------------------------
7868 -- Fully_Conformant_Expressions --
7869 ----------------------------------
7871 function Fully_Conformant_Expressions
7872 (Given_E1
: Node_Id
;
7873 Given_E2
: Node_Id
) return Boolean
7875 E1
: constant Node_Id
:= Original_Node
(Given_E1
);
7876 E2
: constant Node_Id
:= Original_Node
(Given_E2
);
7877 -- We always test conformance on original nodes, since it is possible
7878 -- for analysis and/or expansion to make things look as though they
7879 -- conform when they do not, e.g. by converting 1+2 into 3.
7881 function FCE
(Given_E1
, Given_E2
: Node_Id
) return Boolean
7882 renames Fully_Conformant_Expressions
;
7884 function FCL
(L1
, L2
: List_Id
) return Boolean;
7885 -- Compare elements of two lists for conformance. Elements have to be
7886 -- conformant, and actuals inserted as default parameters do not match
7887 -- explicit actuals with the same value.
7889 function FCO
(Op_Node
, Call_Node
: Node_Id
) return Boolean;
7890 -- Compare an operator node with a function call
7896 function FCL
(L1
, L2
: List_Id
) return Boolean is
7900 if L1
= No_List
then
7906 if L2
= No_List
then
7912 -- Compare two lists, skipping rewrite insertions (we want to compare
7913 -- the original trees, not the expanded versions).
7916 if Is_Rewrite_Insertion
(N1
) then
7918 elsif Is_Rewrite_Insertion
(N2
) then
7924 elsif not FCE
(N1
, N2
) then
7937 function FCO
(Op_Node
, Call_Node
: Node_Id
) return Boolean is
7938 Actuals
: constant List_Id
:= Parameter_Associations
(Call_Node
);
7943 or else Entity
(Op_Node
) /= Entity
(Name
(Call_Node
))
7948 Act
:= First
(Actuals
);
7950 if Nkind
(Op_Node
) in N_Binary_Op
then
7951 if not FCE
(Left_Opnd
(Op_Node
), Act
) then
7958 return Present
(Act
)
7959 and then FCE
(Right_Opnd
(Op_Node
), Act
)
7960 and then No
(Next
(Act
));
7964 -- Start of processing for Fully_Conformant_Expressions
7967 -- Non-conformant if paren count does not match. Note: if some idiot
7968 -- complains that we don't do this right for more than 3 levels of
7969 -- parentheses, they will be treated with the respect they deserve.
7971 if Paren_Count
(E1
) /= Paren_Count
(E2
) then
7974 -- If same entities are referenced, then they are conformant even if
7975 -- they have different forms (RM 8.3.1(19-20)).
7977 elsif Is_Entity_Name
(E1
) and then Is_Entity_Name
(E2
) then
7978 if Present
(Entity
(E1
)) then
7979 return Entity
(E1
) = Entity
(E2
)
7980 or else (Chars
(Entity
(E1
)) = Chars
(Entity
(E2
))
7981 and then Ekind
(Entity
(E1
)) = E_Discriminant
7982 and then Ekind
(Entity
(E2
)) = E_In_Parameter
);
7984 elsif Nkind
(E1
) = N_Expanded_Name
7985 and then Nkind
(E2
) = N_Expanded_Name
7986 and then Nkind
(Selector_Name
(E1
)) = N_Character_Literal
7987 and then Nkind
(Selector_Name
(E2
)) = N_Character_Literal
7989 return Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
));
7992 -- Identifiers in component associations don't always have
7993 -- entities, but their names must conform.
7995 return Nkind
(E1
) = N_Identifier
7996 and then Nkind
(E2
) = N_Identifier
7997 and then Chars
(E1
) = Chars
(E2
);
8000 elsif Nkind
(E1
) = N_Character_Literal
8001 and then Nkind
(E2
) = N_Expanded_Name
8003 return Nkind
(Selector_Name
(E2
)) = N_Character_Literal
8004 and then Chars
(E1
) = Chars
(Selector_Name
(E2
));
8006 elsif Nkind
(E2
) = N_Character_Literal
8007 and then Nkind
(E1
) = N_Expanded_Name
8009 return Nkind
(Selector_Name
(E1
)) = N_Character_Literal
8010 and then Chars
(E2
) = Chars
(Selector_Name
(E1
));
8012 elsif Nkind
(E1
) in N_Op
and then Nkind
(E2
) = N_Function_Call
then
8013 return FCO
(E1
, E2
);
8015 elsif Nkind
(E2
) in N_Op
and then Nkind
(E1
) = N_Function_Call
then
8016 return FCO
(E2
, E1
);
8018 -- Otherwise we must have the same syntactic entity
8020 elsif Nkind
(E1
) /= Nkind
(E2
) then
8023 -- At this point, we specialize by node type
8030 FCL
(Expressions
(E1
), Expressions
(E2
))
8032 FCL
(Component_Associations
(E1
),
8033 Component_Associations
(E2
));
8036 if Nkind
(Expression
(E1
)) = N_Qualified_Expression
8038 Nkind
(Expression
(E2
)) = N_Qualified_Expression
8040 return FCE
(Expression
(E1
), Expression
(E2
));
8042 -- Check that the subtype marks and any constraints
8047 Indic1
: constant Node_Id
:= Expression
(E1
);
8048 Indic2
: constant Node_Id
:= Expression
(E2
);
8053 if Nkind
(Indic1
) /= N_Subtype_Indication
then
8055 Nkind
(Indic2
) /= N_Subtype_Indication
8056 and then Entity
(Indic1
) = Entity
(Indic2
);
8058 elsif Nkind
(Indic2
) /= N_Subtype_Indication
then
8060 Nkind
(Indic1
) /= N_Subtype_Indication
8061 and then Entity
(Indic1
) = Entity
(Indic2
);
8064 if Entity
(Subtype_Mark
(Indic1
)) /=
8065 Entity
(Subtype_Mark
(Indic2
))
8070 Elt1
:= First
(Constraints
(Constraint
(Indic1
)));
8071 Elt2
:= First
(Constraints
(Constraint
(Indic2
)));
8072 while Present
(Elt1
) and then Present
(Elt2
) loop
8073 if not FCE
(Elt1
, Elt2
) then
8086 when N_Attribute_Reference
=>
8088 Attribute_Name
(E1
) = Attribute_Name
(E2
)
8089 and then FCL
(Expressions
(E1
), Expressions
(E2
));
8093 Entity
(E1
) = Entity
(E2
)
8094 and then FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
8095 and then FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
8097 when N_Short_Circuit | N_Membership_Test
=>
8099 FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
8101 FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
8103 when N_Case_Expression
=>
8109 if not FCE
(Expression
(E1
), Expression
(E2
)) then
8113 Alt1
:= First
(Alternatives
(E1
));
8114 Alt2
:= First
(Alternatives
(E2
));
8116 if Present
(Alt1
) /= Present
(Alt2
) then
8118 elsif No
(Alt1
) then
8122 if not FCE
(Expression
(Alt1
), Expression
(Alt2
))
8123 or else not FCL
(Discrete_Choices
(Alt1
),
8124 Discrete_Choices
(Alt2
))
8135 when N_Character_Literal
=>
8137 Char_Literal_Value
(E1
) = Char_Literal_Value
(E2
);
8139 when N_Component_Association
=>
8141 FCL
(Choices
(E1
), Choices
(E2
))
8143 FCE
(Expression
(E1
), Expression
(E2
));
8145 when N_Explicit_Dereference
=>
8147 FCE
(Prefix
(E1
), Prefix
(E2
));
8149 when N_Extension_Aggregate
=>
8151 FCL
(Expressions
(E1
), Expressions
(E2
))
8152 and then Null_Record_Present
(E1
) =
8153 Null_Record_Present
(E2
)
8154 and then FCL
(Component_Associations
(E1
),
8155 Component_Associations
(E2
));
8157 when N_Function_Call
=>
8159 FCE
(Name
(E1
), Name
(E2
))
8161 FCL
(Parameter_Associations
(E1
),
8162 Parameter_Associations
(E2
));
8164 when N_If_Expression
=>
8166 FCL
(Expressions
(E1
), Expressions
(E2
));
8168 when N_Indexed_Component
=>
8170 FCE
(Prefix
(E1
), Prefix
(E2
))
8172 FCL
(Expressions
(E1
), Expressions
(E2
));
8174 when N_Integer_Literal
=>
8175 return (Intval
(E1
) = Intval
(E2
));
8180 when N_Operator_Symbol
=>
8182 Chars
(E1
) = Chars
(E2
);
8184 when N_Others_Choice
=>
8187 when N_Parameter_Association
=>
8189 Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
))
8190 and then FCE
(Explicit_Actual_Parameter
(E1
),
8191 Explicit_Actual_Parameter
(E2
));
8193 when N_Qualified_Expression
=>
8195 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
8197 FCE
(Expression
(E1
), Expression
(E2
));
8199 when N_Quantified_Expression
=>
8200 if not FCE
(Condition
(E1
), Condition
(E2
)) then
8204 if Present
(Loop_Parameter_Specification
(E1
))
8205 and then Present
(Loop_Parameter_Specification
(E2
))
8208 L1
: constant Node_Id
:=
8209 Loop_Parameter_Specification
(E1
);
8210 L2
: constant Node_Id
:=
8211 Loop_Parameter_Specification
(E2
);
8215 Reverse_Present
(L1
) = Reverse_Present
(L2
)
8217 FCE
(Defining_Identifier
(L1
),
8218 Defining_Identifier
(L2
))
8220 FCE
(Discrete_Subtype_Definition
(L1
),
8221 Discrete_Subtype_Definition
(L2
));
8224 elsif Present
(Iterator_Specification
(E1
))
8225 and then Present
(Iterator_Specification
(E2
))
8228 I1
: constant Node_Id
:= Iterator_Specification
(E1
);
8229 I2
: constant Node_Id
:= Iterator_Specification
(E2
);
8233 FCE
(Defining_Identifier
(I1
),
8234 Defining_Identifier
(I2
))
8236 Of_Present
(I1
) = Of_Present
(I2
)
8238 Reverse_Present
(I1
) = Reverse_Present
(I2
)
8239 and then FCE
(Name
(I1
), Name
(I2
))
8240 and then FCE
(Subtype_Indication
(I1
),
8241 Subtype_Indication
(I2
));
8244 -- The quantified expressions used different specifications to
8245 -- walk their respective ranges.
8253 FCE
(Low_Bound
(E1
), Low_Bound
(E2
))
8255 FCE
(High_Bound
(E1
), High_Bound
(E2
));
8257 when N_Real_Literal
=>
8258 return (Realval
(E1
) = Realval
(E2
));
8260 when N_Selected_Component
=>
8262 FCE
(Prefix
(E1
), Prefix
(E2
))
8264 FCE
(Selector_Name
(E1
), Selector_Name
(E2
));
8268 FCE
(Prefix
(E1
), Prefix
(E2
))
8270 FCE
(Discrete_Range
(E1
), Discrete_Range
(E2
));
8272 when N_String_Literal
=>
8274 S1
: constant String_Id
:= Strval
(E1
);
8275 S2
: constant String_Id
:= Strval
(E2
);
8276 L1
: constant Nat
:= String_Length
(S1
);
8277 L2
: constant Nat
:= String_Length
(S2
);
8284 for J
in 1 .. L1
loop
8285 if Get_String_Char
(S1
, J
) /=
8286 Get_String_Char
(S2
, J
)
8296 when N_Type_Conversion
=>
8298 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
8300 FCE
(Expression
(E1
), Expression
(E2
));
8304 Entity
(E1
) = Entity
(E2
)
8306 FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
8308 when N_Unchecked_Type_Conversion
=>
8310 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
8312 FCE
(Expression
(E1
), Expression
(E2
));
8314 -- All other node types cannot appear in this context. Strictly
8315 -- we should raise a fatal internal error. Instead we just ignore
8316 -- the nodes. This means that if anyone makes a mistake in the
8317 -- expander and mucks an expression tree irretrievably, the result
8318 -- will be a failure to detect a (probably very obscure) case
8319 -- of non-conformance, which is better than bombing on some
8320 -- case where two expressions do in fact conform.
8327 end Fully_Conformant_Expressions
;
8329 ----------------------------------------
8330 -- Fully_Conformant_Discrete_Subtypes --
8331 ----------------------------------------
8333 function Fully_Conformant_Discrete_Subtypes
8334 (Given_S1
: Node_Id
;
8335 Given_S2
: Node_Id
) return Boolean
8337 S1
: constant Node_Id
:= Original_Node
(Given_S1
);
8338 S2
: constant Node_Id
:= Original_Node
(Given_S2
);
8340 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean;
8341 -- Special-case for a bound given by a discriminant, which in the body
8342 -- is replaced with the discriminal of the enclosing type.
8344 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean;
8345 -- Check both bounds
8347 -----------------------
8348 -- Conforming_Bounds --
8349 -----------------------
8351 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean is
8353 if Is_Entity_Name
(B1
)
8354 and then Is_Entity_Name
(B2
)
8355 and then Ekind
(Entity
(B1
)) = E_Discriminant
8357 return Chars
(B1
) = Chars
(B2
);
8360 return Fully_Conformant_Expressions
(B1
, B2
);
8362 end Conforming_Bounds
;
8364 -----------------------
8365 -- Conforming_Ranges --
8366 -----------------------
8368 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean is
8371 Conforming_Bounds
(Low_Bound
(R1
), Low_Bound
(R2
))
8373 Conforming_Bounds
(High_Bound
(R1
), High_Bound
(R2
));
8374 end Conforming_Ranges
;
8376 -- Start of processing for Fully_Conformant_Discrete_Subtypes
8379 if Nkind
(S1
) /= Nkind
(S2
) then
8382 elsif Is_Entity_Name
(S1
) then
8383 return Entity
(S1
) = Entity
(S2
);
8385 elsif Nkind
(S1
) = N_Range
then
8386 return Conforming_Ranges
(S1
, S2
);
8388 elsif Nkind
(S1
) = N_Subtype_Indication
then
8390 Entity
(Subtype_Mark
(S1
)) = Entity
(Subtype_Mark
(S2
))
8393 (Range_Expression
(Constraint
(S1
)),
8394 Range_Expression
(Constraint
(S2
)));
8398 end Fully_Conformant_Discrete_Subtypes
;
8400 --------------------
8401 -- Install_Entity --
8402 --------------------
8404 procedure Install_Entity
(E
: Entity_Id
) is
8405 Prev
: constant Entity_Id
:= Current_Entity
(E
);
8407 Set_Is_Immediately_Visible
(E
);
8408 Set_Current_Entity
(E
);
8409 Set_Homonym
(E
, Prev
);
8412 ---------------------
8413 -- Install_Formals --
8414 ---------------------
8416 procedure Install_Formals
(Id
: Entity_Id
) is
8419 F
:= First_Formal
(Id
);
8420 while Present
(F
) loop
8424 end Install_Formals
;
8426 -----------------------------
8427 -- Is_Interface_Conformant --
8428 -----------------------------
8430 function Is_Interface_Conformant
8431 (Tagged_Type
: Entity_Id
;
8432 Iface_Prim
: Entity_Id
;
8433 Prim
: Entity_Id
) return Boolean
8435 -- The operation may in fact be an inherited (implicit) operation
8436 -- rather than the original interface primitive, so retrieve the
8437 -- ultimate ancestor.
8439 Iface
: constant Entity_Id
:=
8440 Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
));
8441 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
8443 function Controlling_Formal
(Prim
: Entity_Id
) return Entity_Id
;
8444 -- Return the controlling formal of Prim
8446 ------------------------
8447 -- Controlling_Formal --
8448 ------------------------
8450 function Controlling_Formal
(Prim
: Entity_Id
) return Entity_Id
is
8454 E
:= First_Entity
(Prim
);
8455 while Present
(E
) loop
8456 if Is_Formal
(E
) and then Is_Controlling_Formal
(E
) then
8464 end Controlling_Formal
;
8468 Iface_Ctrl_F
: constant Entity_Id
:= Controlling_Formal
(Iface_Prim
);
8469 Prim_Ctrl_F
: constant Entity_Id
:= Controlling_Formal
(Prim
);
8471 -- Start of processing for Is_Interface_Conformant
8474 pragma Assert
(Is_Subprogram
(Iface_Prim
)
8475 and then Is_Subprogram
(Prim
)
8476 and then Is_Dispatching_Operation
(Iface_Prim
)
8477 and then Is_Dispatching_Operation
(Prim
));
8479 pragma Assert
(Is_Interface
(Iface
)
8480 or else (Present
(Alias
(Iface_Prim
))
8483 (Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
)))));
8485 if Prim
= Iface_Prim
8486 or else not Is_Subprogram
(Prim
)
8487 or else Ekind
(Prim
) /= Ekind
(Iface_Prim
)
8488 or else not Is_Dispatching_Operation
(Prim
)
8489 or else Scope
(Prim
) /= Scope
(Tagged_Type
)
8491 or else Base_Type
(Typ
) /= Base_Type
(Tagged_Type
)
8492 or else not Primitive_Names_Match
(Iface_Prim
, Prim
)
8496 -- The mode of the controlling formals must match
8498 elsif Present
(Iface_Ctrl_F
)
8499 and then Present
(Prim_Ctrl_F
)
8500 and then Ekind
(Iface_Ctrl_F
) /= Ekind
(Prim_Ctrl_F
)
8504 -- Case of a procedure, or a function whose result type matches the
8505 -- result type of the interface primitive, or a function that has no
8506 -- controlling result (I or access I).
8508 elsif Ekind
(Iface_Prim
) = E_Procedure
8509 or else Etype
(Prim
) = Etype
(Iface_Prim
)
8510 or else not Has_Controlling_Result
(Prim
)
8512 return Type_Conformant
8513 (Iface_Prim
, Prim
, Skip_Controlling_Formals
=> True);
8515 -- Case of a function returning an interface, or an access to one. Check
8516 -- that the return types correspond.
8518 elsif Implements_Interface
(Typ
, Iface
) then
8519 if (Ekind
(Etype
(Prim
)) = E_Anonymous_Access_Type
)
8521 (Ekind
(Etype
(Iface_Prim
)) = E_Anonymous_Access_Type
)
8526 Type_Conformant
(Prim
, Ultimate_Alias
(Iface_Prim
),
8527 Skip_Controlling_Formals
=> True);
8533 end Is_Interface_Conformant
;
8535 ---------------------------------
8536 -- Is_Non_Overriding_Operation --
8537 ---------------------------------
8539 function Is_Non_Overriding_Operation
8540 (Prev_E
: Entity_Id
;
8541 New_E
: Entity_Id
) return Boolean
8545 G_Typ
: Entity_Id
:= Empty
;
8547 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
;
8548 -- If F_Type is a derived type associated with a generic actual subtype,
8549 -- then return its Generic_Parent_Type attribute, else return Empty.
8551 function Types_Correspond
8552 (P_Type
: Entity_Id
;
8553 N_Type
: Entity_Id
) return Boolean;
8554 -- Returns true if and only if the types (or designated types in the
8555 -- case of anonymous access types) are the same or N_Type is derived
8556 -- directly or indirectly from P_Type.
8558 -----------------------------
8559 -- Get_Generic_Parent_Type --
8560 -----------------------------
8562 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
is
8568 if Is_Derived_Type
(F_Typ
)
8569 and then Nkind
(Parent
(F_Typ
)) = N_Full_Type_Declaration
8571 -- The tree must be traversed to determine the parent subtype in
8572 -- the generic unit, which unfortunately isn't always available
8573 -- via semantic attributes. ??? (Note: The use of Original_Node
8574 -- is needed for cases where a full derived type has been
8577 -- If the parent type is a scalar type, the derivation creates
8578 -- an anonymous base type for it, and the source type is its
8581 if Is_Scalar_Type
(F_Typ
)
8582 and then not Comes_From_Source
(F_Typ
)
8586 (Original_Node
(Parent
(First_Subtype
(F_Typ
))));
8588 Defn
:= Type_Definition
(Original_Node
(Parent
(F_Typ
)));
8590 if Nkind
(Defn
) = N_Derived_Type_Definition
then
8591 Indic
:= Subtype_Indication
(Defn
);
8593 if Nkind
(Indic
) = N_Subtype_Indication
then
8594 G_Typ
:= Entity
(Subtype_Mark
(Indic
));
8596 G_Typ
:= Entity
(Indic
);
8599 if Nkind
(Parent
(G_Typ
)) = N_Subtype_Declaration
8600 and then Present
(Generic_Parent_Type
(Parent
(G_Typ
)))
8602 return Generic_Parent_Type
(Parent
(G_Typ
));
8608 end Get_Generic_Parent_Type
;
8610 ----------------------
8611 -- Types_Correspond --
8612 ----------------------
8614 function Types_Correspond
8615 (P_Type
: Entity_Id
;
8616 N_Type
: Entity_Id
) return Boolean
8618 Prev_Type
: Entity_Id
:= Base_Type
(P_Type
);
8619 New_Type
: Entity_Id
:= Base_Type
(N_Type
);
8622 if Ekind
(Prev_Type
) = E_Anonymous_Access_Type
then
8623 Prev_Type
:= Designated_Type
(Prev_Type
);
8626 if Ekind
(New_Type
) = E_Anonymous_Access_Type
then
8627 New_Type
:= Designated_Type
(New_Type
);
8630 if Prev_Type
= New_Type
then
8633 elsif not Is_Class_Wide_Type
(New_Type
) then
8634 while Etype
(New_Type
) /= New_Type
loop
8635 New_Type
:= Etype
(New_Type
);
8637 if New_Type
= Prev_Type
then
8643 end Types_Correspond
;
8645 -- Start of processing for Is_Non_Overriding_Operation
8648 -- In the case where both operations are implicit derived subprograms
8649 -- then neither overrides the other. This can only occur in certain
8650 -- obscure cases (e.g., derivation from homographs created in a generic
8653 if Present
(Alias
(Prev_E
)) and then Present
(Alias
(New_E
)) then
8656 elsif Ekind
(Current_Scope
) = E_Package
8657 and then Is_Generic_Instance
(Current_Scope
)
8658 and then In_Private_Part
(Current_Scope
)
8659 and then Comes_From_Source
(New_E
)
8661 -- We examine the formals and result type of the inherited operation,
8662 -- to determine whether their type is derived from (the instance of)
8663 -- a generic type. The first such formal or result type is the one
8666 Formal
:= First_Formal
(Prev_E
);
8667 while Present
(Formal
) loop
8668 F_Typ
:= Base_Type
(Etype
(Formal
));
8670 if Ekind
(F_Typ
) = E_Anonymous_Access_Type
then
8671 F_Typ
:= Designated_Type
(F_Typ
);
8674 G_Typ
:= Get_Generic_Parent_Type
(F_Typ
);
8675 exit when Present
(G_Typ
);
8677 Next_Formal
(Formal
);
8680 if No
(G_Typ
) and then Ekind
(Prev_E
) = E_Function
then
8681 G_Typ
:= Get_Generic_Parent_Type
(Base_Type
(Etype
(Prev_E
)));
8688 -- If the generic type is a private type, then the original operation
8689 -- was not overriding in the generic, because there was no primitive
8690 -- operation to override.
8692 if Nkind
(Parent
(G_Typ
)) = N_Formal_Type_Declaration
8693 and then Nkind
(Formal_Type_Definition
(Parent
(G_Typ
))) =
8694 N_Formal_Private_Type_Definition
8698 -- The generic parent type is the ancestor of a formal derived
8699 -- type declaration. We need to check whether it has a primitive
8700 -- operation that should be overridden by New_E in the generic.
8704 P_Formal
: Entity_Id
;
8705 N_Formal
: Entity_Id
;
8709 Prim_Elt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(G_Typ
));
8712 while Present
(Prim_Elt
) loop
8713 P_Prim
:= Node
(Prim_Elt
);
8715 if Chars
(P_Prim
) = Chars
(New_E
)
8716 and then Ekind
(P_Prim
) = Ekind
(New_E
)
8718 P_Formal
:= First_Formal
(P_Prim
);
8719 N_Formal
:= First_Formal
(New_E
);
8720 while Present
(P_Formal
) and then Present
(N_Formal
) loop
8721 P_Typ
:= Etype
(P_Formal
);
8722 N_Typ
:= Etype
(N_Formal
);
8724 if not Types_Correspond
(P_Typ
, N_Typ
) then
8728 Next_Entity
(P_Formal
);
8729 Next_Entity
(N_Formal
);
8732 -- Found a matching primitive operation belonging to the
8733 -- formal ancestor type, so the new subprogram is
8737 and then No
(N_Formal
)
8738 and then (Ekind
(New_E
) /= E_Function
8741 (Etype
(P_Prim
), Etype
(New_E
)))
8747 Next_Elmt
(Prim_Elt
);
8750 -- If no match found, then the new subprogram does not override
8751 -- in the generic (nor in the instance).
8753 -- If the type in question is not abstract, and the subprogram
8754 -- is, this will be an error if the new operation is in the
8755 -- private part of the instance. Emit a warning now, which will
8756 -- make the subsequent error message easier to understand.
8758 if not Is_Abstract_Type
(F_Typ
)
8759 and then Is_Abstract_Subprogram
(Prev_E
)
8760 and then In_Private_Part
(Current_Scope
)
8762 Error_Msg_Node_2
:= F_Typ
;
8764 ("private operation& in generic unit does not override "
8765 & "any primitive operation of& (RM 12.3 (18))??",
8775 end Is_Non_Overriding_Operation
;
8777 -------------------------------------
8778 -- List_Inherited_Pre_Post_Aspects --
8779 -------------------------------------
8781 procedure List_Inherited_Pre_Post_Aspects
(E
: Entity_Id
) is
8783 if Opt
.List_Inherited_Aspects
8784 and then Is_Subprogram_Or_Generic_Subprogram
(E
)
8787 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(E
);
8792 for Index
in Subps
'Range loop
8793 Items
:= Contract
(Subps
(Index
));
8795 if Present
(Items
) then
8796 Prag
:= Pre_Post_Conditions
(Items
);
8797 while Present
(Prag
) loop
8798 Error_Msg_Sloc
:= Sloc
(Prag
);
8800 if Class_Present
(Prag
)
8801 and then not Split_PPC
(Prag
)
8803 if Pragma_Name
(Prag
) = Name_Precondition
then
8805 ("info: & inherits `Pre''Class` aspect from "
8809 ("info: & inherits `Post''Class` aspect from "
8814 Prag
:= Next_Pragma
(Prag
);
8820 end List_Inherited_Pre_Post_Aspects
;
8822 ------------------------------
8823 -- Make_Inequality_Operator --
8824 ------------------------------
8826 -- S is the defining identifier of an equality operator. We build a
8827 -- subprogram declaration with the right signature. This operation is
8828 -- intrinsic, because it is always expanded as the negation of the
8829 -- call to the equality function.
8831 procedure Make_Inequality_Operator
(S
: Entity_Id
) is
8832 Loc
: constant Source_Ptr
:= Sloc
(S
);
8835 Op_Name
: Entity_Id
;
8837 FF
: constant Entity_Id
:= First_Formal
(S
);
8838 NF
: constant Entity_Id
:= Next_Formal
(FF
);
8841 -- Check that equality was properly defined, ignore call if not
8848 A
: constant Entity_Id
:=
8849 Make_Defining_Identifier
(Sloc
(FF
),
8850 Chars
=> Chars
(FF
));
8852 B
: constant Entity_Id
:=
8853 Make_Defining_Identifier
(Sloc
(NF
),
8854 Chars
=> Chars
(NF
));
8857 Op_Name
:= Make_Defining_Operator_Symbol
(Loc
, Name_Op_Ne
);
8859 Formals
:= New_List
(
8860 Make_Parameter_Specification
(Loc
,
8861 Defining_Identifier
=> A
,
8863 New_Occurrence_Of
(Etype
(First_Formal
(S
)),
8864 Sloc
(Etype
(First_Formal
(S
))))),
8866 Make_Parameter_Specification
(Loc
,
8867 Defining_Identifier
=> B
,
8869 New_Occurrence_Of
(Etype
(Next_Formal
(First_Formal
(S
))),
8870 Sloc
(Etype
(Next_Formal
(First_Formal
(S
)))))));
8873 Make_Subprogram_Declaration
(Loc
,
8875 Make_Function_Specification
(Loc
,
8876 Defining_Unit_Name
=> Op_Name
,
8877 Parameter_Specifications
=> Formals
,
8878 Result_Definition
=>
8879 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8881 -- Insert inequality right after equality if it is explicit or after
8882 -- the derived type when implicit. These entities are created only
8883 -- for visibility purposes, and eventually replaced in the course
8884 -- of expansion, so they do not need to be attached to the tree and
8885 -- seen by the back-end. Keeping them internal also avoids spurious
8886 -- freezing problems. The declaration is inserted in the tree for
8887 -- analysis, and removed afterwards. If the equality operator comes
8888 -- from an explicit declaration, attach the inequality immediately
8889 -- after. Else the equality is inherited from a derived type
8890 -- declaration, so insert inequality after that declaration.
8892 if No
(Alias
(S
)) then
8893 Insert_After
(Unit_Declaration_Node
(S
), Decl
);
8894 elsif Is_List_Member
(Parent
(S
)) then
8895 Insert_After
(Parent
(S
), Decl
);
8897 Insert_After
(Parent
(Etype
(First_Formal
(S
))), Decl
);
8900 Mark_Rewrite_Insertion
(Decl
);
8901 Set_Is_Intrinsic_Subprogram
(Op_Name
);
8904 Set_Has_Completion
(Op_Name
);
8905 Set_Corresponding_Equality
(Op_Name
, S
);
8906 Set_Is_Abstract_Subprogram
(Op_Name
, Is_Abstract_Subprogram
(S
));
8908 end Make_Inequality_Operator
;
8910 ----------------------
8911 -- May_Need_Actuals --
8912 ----------------------
8914 procedure May_Need_Actuals
(Fun
: Entity_Id
) is
8919 F
:= First_Formal
(Fun
);
8921 while Present
(F
) loop
8922 if No
(Default_Value
(F
)) then
8930 Set_Needs_No_Actuals
(Fun
, B
);
8931 end May_Need_Actuals
;
8933 ---------------------
8934 -- Mode_Conformant --
8935 ---------------------
8937 function Mode_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
8940 Check_Conformance
(New_Id
, Old_Id
, Mode_Conformant
, False, Result
);
8942 end Mode_Conformant
;
8944 ---------------------------
8945 -- New_Overloaded_Entity --
8946 ---------------------------
8948 procedure New_Overloaded_Entity
8950 Derived_Type
: Entity_Id
:= Empty
)
8952 Overridden_Subp
: Entity_Id
:= Empty
;
8953 -- Set if the current scope has an operation that is type-conformant
8954 -- with S, and becomes hidden by S.
8956 Is_Primitive_Subp
: Boolean;
8957 -- Set to True if the new subprogram is primitive
8960 -- Entity that S overrides
8962 Prev_Vis
: Entity_Id
:= Empty
;
8963 -- Predecessor of E in Homonym chain
8965 procedure Check_For_Primitive_Subprogram
8966 (Is_Primitive
: out Boolean;
8967 Is_Overriding
: Boolean := False);
8968 -- If the subprogram being analyzed is a primitive operation of the type
8969 -- of a formal or result, set the Has_Primitive_Operations flag on the
8970 -- type, and set Is_Primitive to True (otherwise set to False). Set the
8971 -- corresponding flag on the entity itself for later use.
8973 procedure Check_Synchronized_Overriding
8974 (Def_Id
: Entity_Id
;
8975 Overridden_Subp
: out Entity_Id
);
8976 -- First determine if Def_Id is an entry or a subprogram either defined
8977 -- in the scope of a task or protected type, or is a primitive of such
8978 -- a type. Check whether Def_Id overrides a subprogram of an interface
8979 -- implemented by the synchronized type, return the overridden entity
8982 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean;
8983 -- Check that E is declared in the private part of the current package,
8984 -- or in the package body, where it may hide a previous declaration.
8985 -- We can't use In_Private_Part by itself because this flag is also
8986 -- set when freezing entities, so we must examine the place of the
8987 -- declaration in the tree, and recognize wrapper packages as well.
8989 function Is_Overriding_Alias
8991 New_E
: Entity_Id
) return Boolean;
8992 -- Check whether new subprogram and old subprogram are both inherited
8993 -- from subprograms that have distinct dispatch table entries. This can
8994 -- occur with derivations from instances with accidental homonyms. The
8995 -- function is conservative given that the converse is only true within
8996 -- instances that contain accidental overloadings.
8998 ------------------------------------
8999 -- Check_For_Primitive_Subprogram --
9000 ------------------------------------
9002 procedure Check_For_Primitive_Subprogram
9003 (Is_Primitive
: out Boolean;
9004 Is_Overriding
: Boolean := False)
9010 function Visible_Part_Type
(T
: Entity_Id
) return Boolean;
9011 -- Returns true if T is declared in the visible part of the current
9012 -- package scope; otherwise returns false. Assumes that T is declared
9015 procedure Check_Private_Overriding
(T
: Entity_Id
);
9016 -- Checks that if a primitive abstract subprogram of a visible
9017 -- abstract type is declared in a private part, then it must override
9018 -- an abstract subprogram declared in the visible part. Also checks
9019 -- that if a primitive function with a controlling result is declared
9020 -- in a private part, then it must override a function declared in
9021 -- the visible part.
9023 ------------------------------
9024 -- Check_Private_Overriding --
9025 ------------------------------
9027 procedure Check_Private_Overriding
(T
: Entity_Id
) is
9028 function Overrides_Private_Part_Op
return Boolean;
9029 -- This detects the special case where the overriding subprogram
9030 -- is overriding a subprogram that was declared in the same
9031 -- private part. That case is illegal by 3.9.3(10).
9033 function Overrides_Visible_Function
9034 (Partial_View
: Entity_Id
) return Boolean;
9035 -- True if S overrides a function in the visible part. The
9036 -- overridden function could be explicitly or implicitly declared.
9038 -------------------------------
9039 -- Overrides_Private_Part_Op --
9040 -------------------------------
9042 function Overrides_Private_Part_Op
return Boolean is
9043 Over_Decl
: constant Node_Id
:=
9044 Unit_Declaration_Node
(Overridden_Operation
(S
));
9045 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(S
);
9048 pragma Assert
(Is_Overriding
);
9050 (Nkind
(Over_Decl
) = N_Abstract_Subprogram_Declaration
);
9052 (Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
);
9054 return In_Same_List
(Over_Decl
, Subp_Decl
);
9055 end Overrides_Private_Part_Op
;
9057 --------------------------------
9058 -- Overrides_Visible_Function --
9059 --------------------------------
9061 function Overrides_Visible_Function
9062 (Partial_View
: Entity_Id
) return Boolean
9065 if not Is_Overriding
or else not Has_Homonym
(S
) then
9069 if not Present
(Partial_View
) then
9073 -- Search through all the homonyms H of S in the current
9074 -- package spec, and return True if we find one that matches.
9075 -- Note that Parent (H) will be the declaration of the
9076 -- partial view of T for a match.
9083 exit when not Present
(H
) or else Scope
(H
) /= Scope
(S
);
9087 N_Private_Extension_Declaration
,
9088 N_Private_Type_Declaration
)
9089 and then Defining_Identifier
(Parent
(H
)) = Partial_View
9097 end Overrides_Visible_Function
;
9099 -- Start of processing for Check_Private_Overriding
9102 if Is_Package_Or_Generic_Package
(Current_Scope
)
9103 and then In_Private_Part
(Current_Scope
)
9104 and then Visible_Part_Type
(T
)
9105 and then not In_Instance
9107 if Is_Abstract_Type
(T
)
9108 and then Is_Abstract_Subprogram
(S
)
9109 and then (not Is_Overriding
9110 or else not Is_Abstract_Subprogram
(E
)
9111 or else Overrides_Private_Part_Op
)
9114 ("abstract subprograms must be visible (RM 3.9.3(10))!",
9117 elsif Ekind
(S
) = E_Function
then
9119 Partial_View
: constant Entity_Id
:=
9120 Incomplete_Or_Partial_View
(T
);
9123 if not Overrides_Visible_Function
(Partial_View
) then
9125 -- Here, S is "function ... return T;" declared in
9126 -- the private part, not overriding some visible
9127 -- operation. That's illegal in the tagged case
9128 -- (but not if the private type is untagged).
9130 if ((Present
(Partial_View
)
9131 and then Is_Tagged_Type
(Partial_View
))
9132 or else (not Present
(Partial_View
)
9133 and then Is_Tagged_Type
(T
)))
9134 and then T
= Base_Type
(Etype
(S
))
9137 ("private function with tagged result must"
9138 & " override visible-part function", S
);
9140 ("\move subprogram to the visible part"
9141 & " (RM 3.9.3(10))", S
);
9143 -- AI05-0073: extend this test to the case of a
9144 -- function with a controlling access result.
9146 elsif Ekind
(Etype
(S
)) = E_Anonymous_Access_Type
9147 and then Is_Tagged_Type
(Designated_Type
(Etype
(S
)))
9149 not Is_Class_Wide_Type
9150 (Designated_Type
(Etype
(S
)))
9151 and then Ada_Version
>= Ada_2012
9154 ("private function with controlling access "
9155 & "result must override visible-part function",
9158 ("\move subprogram to the visible part"
9159 & " (RM 3.9.3(10))", S
);
9165 end Check_Private_Overriding
;
9167 -----------------------
9168 -- Visible_Part_Type --
9169 -----------------------
9171 function Visible_Part_Type
(T
: Entity_Id
) return Boolean is
9172 P
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(T
));
9176 -- If the entity is a private type, then it must be declared in a
9179 if Ekind
(T
) in Private_Kind
then
9183 -- Otherwise, we traverse the visible part looking for its
9184 -- corresponding declaration. We cannot use the declaration
9185 -- node directly because in the private part the entity of a
9186 -- private type is the one in the full view, which does not
9187 -- indicate that it is the completion of something visible.
9189 N
:= First
(Visible_Declarations
(Specification
(P
)));
9190 while Present
(N
) loop
9191 if Nkind
(N
) = N_Full_Type_Declaration
9192 and then Present
(Defining_Identifier
(N
))
9193 and then T
= Defining_Identifier
(N
)
9197 elsif Nkind_In
(N
, N_Private_Type_Declaration
,
9198 N_Private_Extension_Declaration
)
9199 and then Present
(Defining_Identifier
(N
))
9200 and then T
= Full_View
(Defining_Identifier
(N
))
9209 end Visible_Part_Type
;
9211 -- Start of processing for Check_For_Primitive_Subprogram
9214 Is_Primitive
:= False;
9216 if not Comes_From_Source
(S
) then
9219 -- If subprogram is at library level, it is not primitive operation
9221 elsif Current_Scope
= Standard_Standard
then
9224 elsif (Is_Package_Or_Generic_Package
(Current_Scope
)
9225 and then not In_Package_Body
(Current_Scope
))
9226 or else Is_Overriding
9228 -- For function, check return type
9230 if Ekind
(S
) = E_Function
then
9231 if Ekind
(Etype
(S
)) = E_Anonymous_Access_Type
then
9232 F_Typ
:= Designated_Type
(Etype
(S
));
9237 B_Typ
:= Base_Type
(F_Typ
);
9239 if Scope
(B_Typ
) = Current_Scope
9240 and then not Is_Class_Wide_Type
(B_Typ
)
9241 and then not Is_Generic_Type
(B_Typ
)
9243 Is_Primitive
:= True;
9244 Set_Has_Primitive_Operations
(B_Typ
);
9245 Set_Is_Primitive
(S
);
9246 Check_Private_Overriding
(B_Typ
);
9248 -- The Ghost policy in effect at the point of declaration of
9249 -- a tagged type and a primitive operation must match
9250 -- (SPARK RM 6.9(16)).
9252 Check_Ghost_Primitive
(S
, B_Typ
);
9256 -- For all subprograms, check formals
9258 Formal
:= First_Formal
(S
);
9259 while Present
(Formal
) loop
9260 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
9261 F_Typ
:= Designated_Type
(Etype
(Formal
));
9263 F_Typ
:= Etype
(Formal
);
9266 B_Typ
:= Base_Type
(F_Typ
);
9268 if Ekind
(B_Typ
) = E_Access_Subtype
then
9269 B_Typ
:= Base_Type
(B_Typ
);
9272 if Scope
(B_Typ
) = Current_Scope
9273 and then not Is_Class_Wide_Type
(B_Typ
)
9274 and then not Is_Generic_Type
(B_Typ
)
9276 Is_Primitive
:= True;
9277 Set_Is_Primitive
(S
);
9278 Set_Has_Primitive_Operations
(B_Typ
);
9279 Check_Private_Overriding
(B_Typ
);
9281 -- The Ghost policy in effect at the point of declaration of
9282 -- a tagged type and a primitive operation must match
9283 -- (SPARK RM 6.9(16)).
9285 Check_Ghost_Primitive
(S
, B_Typ
);
9288 Next_Formal
(Formal
);
9291 -- Special case: An equality function can be redefined for a type
9292 -- occurring in a declarative part, and won't otherwise be treated as
9293 -- a primitive because it doesn't occur in a package spec and doesn't
9294 -- override an inherited subprogram. It's important that we mark it
9295 -- primitive so it can be returned by Collect_Primitive_Operations
9296 -- and be used in composing the equality operation of later types
9297 -- that have a component of the type.
9299 elsif Chars
(S
) = Name_Op_Eq
9300 and then Etype
(S
) = Standard_Boolean
9302 B_Typ
:= Base_Type
(Etype
(First_Formal
(S
)));
9304 if Scope
(B_Typ
) = Current_Scope
9306 Base_Type
(Etype
(Next_Formal
(First_Formal
(S
)))) = B_Typ
9307 and then not Is_Limited_Type
(B_Typ
)
9309 Is_Primitive
:= True;
9310 Set_Is_Primitive
(S
);
9311 Set_Has_Primitive_Operations
(B_Typ
);
9312 Check_Private_Overriding
(B_Typ
);
9314 -- The Ghost policy in effect at the point of declaration of a
9315 -- tagged type and a primitive operation must match
9316 -- (SPARK RM 6.9(16)).
9318 Check_Ghost_Primitive
(S
, B_Typ
);
9321 end Check_For_Primitive_Subprogram
;
9323 -----------------------------------
9324 -- Check_Synchronized_Overriding --
9325 -----------------------------------
9327 procedure Check_Synchronized_Overriding
9328 (Def_Id
: Entity_Id
;
9329 Overridden_Subp
: out Entity_Id
)
9331 Ifaces_List
: Elist_Id
;
9335 function Matches_Prefixed_View_Profile
9336 (Prim_Params
: List_Id
;
9337 Iface_Params
: List_Id
) return Boolean;
9338 -- Determine whether a subprogram's parameter profile Prim_Params
9339 -- matches that of a potentially overridden interface subprogram
9340 -- Iface_Params. Also determine if the type of first parameter of
9341 -- Iface_Params is an implemented interface.
9343 -----------------------------------
9344 -- Matches_Prefixed_View_Profile --
9345 -----------------------------------
9347 function Matches_Prefixed_View_Profile
9348 (Prim_Params
: List_Id
;
9349 Iface_Params
: List_Id
) return Boolean
9351 Iface_Id
: Entity_Id
;
9352 Iface_Param
: Node_Id
;
9353 Iface_Typ
: Entity_Id
;
9354 Prim_Id
: Entity_Id
;
9355 Prim_Param
: Node_Id
;
9356 Prim_Typ
: Entity_Id
;
9358 function Is_Implemented
9359 (Ifaces_List
: Elist_Id
;
9360 Iface
: Entity_Id
) return Boolean;
9361 -- Determine if Iface is implemented by the current task or
9364 --------------------
9365 -- Is_Implemented --
9366 --------------------
9368 function Is_Implemented
9369 (Ifaces_List
: Elist_Id
;
9370 Iface
: Entity_Id
) return Boolean
9372 Iface_Elmt
: Elmt_Id
;
9375 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
9376 while Present
(Iface_Elmt
) loop
9377 if Node
(Iface_Elmt
) = Iface
then
9381 Next_Elmt
(Iface_Elmt
);
9387 -- Start of processing for Matches_Prefixed_View_Profile
9390 Iface_Param
:= First
(Iface_Params
);
9391 Iface_Typ
:= Etype
(Defining_Identifier
(Iface_Param
));
9393 if Is_Access_Type
(Iface_Typ
) then
9394 Iface_Typ
:= Designated_Type
(Iface_Typ
);
9397 Prim_Param
:= First
(Prim_Params
);
9399 -- The first parameter of the potentially overridden subprogram
9400 -- must be an interface implemented by Prim.
9402 if not Is_Interface
(Iface_Typ
)
9403 or else not Is_Implemented
(Ifaces_List
, Iface_Typ
)
9408 -- The checks on the object parameters are done, move onto the
9409 -- rest of the parameters.
9411 if not In_Scope
then
9412 Prim_Param
:= Next
(Prim_Param
);
9415 Iface_Param
:= Next
(Iface_Param
);
9416 while Present
(Iface_Param
) and then Present
(Prim_Param
) loop
9417 Iface_Id
:= Defining_Identifier
(Iface_Param
);
9418 Iface_Typ
:= Find_Parameter_Type
(Iface_Param
);
9420 Prim_Id
:= Defining_Identifier
(Prim_Param
);
9421 Prim_Typ
:= Find_Parameter_Type
(Prim_Param
);
9423 if Ekind
(Iface_Typ
) = E_Anonymous_Access_Type
9424 and then Ekind
(Prim_Typ
) = E_Anonymous_Access_Type
9425 and then Is_Concurrent_Type
(Designated_Type
(Prim_Typ
))
9427 Iface_Typ
:= Designated_Type
(Iface_Typ
);
9428 Prim_Typ
:= Designated_Type
(Prim_Typ
);
9431 -- Case of multiple interface types inside a parameter profile
9433 -- (Obj_Param : in out Iface; ...; Param : Iface)
9435 -- If the interface type is implemented, then the matching type
9436 -- in the primitive should be the implementing record type.
9438 if Ekind
(Iface_Typ
) = E_Record_Type
9439 and then Is_Interface
(Iface_Typ
)
9440 and then Is_Implemented
(Ifaces_List
, Iface_Typ
)
9442 if Prim_Typ
/= Typ
then
9446 -- The two parameters must be both mode and subtype conformant
9448 elsif Ekind
(Iface_Id
) /= Ekind
(Prim_Id
)
9450 Conforming_Types
(Iface_Typ
, Prim_Typ
, Subtype_Conformant
)
9459 -- One of the two lists contains more parameters than the other
9461 if Present
(Iface_Param
) or else Present
(Prim_Param
) then
9466 end Matches_Prefixed_View_Profile
;
9468 -- Start of processing for Check_Synchronized_Overriding
9471 Overridden_Subp
:= Empty
;
9473 -- Def_Id must be an entry or a subprogram. We should skip predefined
9474 -- primitives internally generated by the frontend; however at this
9475 -- stage predefined primitives are still not fully decorated. As a
9476 -- minor optimization we skip here internally generated subprograms.
9478 if (Ekind
(Def_Id
) /= E_Entry
9479 and then Ekind
(Def_Id
) /= E_Function
9480 and then Ekind
(Def_Id
) /= E_Procedure
)
9481 or else not Comes_From_Source
(Def_Id
)
9486 -- Search for the concurrent declaration since it contains the list
9487 -- of all implemented interfaces. In this case, the subprogram is
9488 -- declared within the scope of a protected or a task type.
9490 if Present
(Scope
(Def_Id
))
9491 and then Is_Concurrent_Type
(Scope
(Def_Id
))
9492 and then not Is_Generic_Actual_Type
(Scope
(Def_Id
))
9494 Typ
:= Scope
(Def_Id
);
9497 -- The enclosing scope is not a synchronized type and the subprogram
9500 elsif No
(First_Formal
(Def_Id
)) then
9503 -- The subprogram has formals and hence it may be a primitive of a
9507 Typ
:= Etype
(First_Formal
(Def_Id
));
9509 if Is_Access_Type
(Typ
) then
9510 Typ
:= Directly_Designated_Type
(Typ
);
9513 if Is_Concurrent_Type
(Typ
)
9514 and then not Is_Generic_Actual_Type
(Typ
)
9518 -- This case occurs when the concurrent type is declared within
9519 -- a generic unit. As a result the corresponding record has been
9520 -- built and used as the type of the first formal, we just have
9521 -- to retrieve the corresponding concurrent type.
9523 elsif Is_Concurrent_Record_Type
(Typ
)
9524 and then not Is_Class_Wide_Type
(Typ
)
9525 and then Present
(Corresponding_Concurrent_Type
(Typ
))
9527 Typ
:= Corresponding_Concurrent_Type
(Typ
);
9535 -- There is no overriding to check if is an inherited operation in a
9536 -- type derivation on for a generic actual.
9538 Collect_Interfaces
(Typ
, Ifaces_List
);
9540 if Is_Empty_Elmt_List
(Ifaces_List
) then
9544 -- Determine whether entry or subprogram Def_Id overrides a primitive
9545 -- operation that belongs to one of the interfaces in Ifaces_List.
9548 Candidate
: Entity_Id
:= Empty
;
9549 Hom
: Entity_Id
:= Empty
;
9550 Subp
: Entity_Id
:= Empty
;
9553 -- Traverse the homonym chain, looking for a potentially
9554 -- overridden subprogram that belongs to an implemented
9557 Hom
:= Current_Entity_In_Scope
(Def_Id
);
9558 while Present
(Hom
) loop
9562 or else not Is_Overloadable
(Subp
)
9563 or else not Is_Primitive
(Subp
)
9564 or else not Is_Dispatching_Operation
(Subp
)
9565 or else not Present
(Find_Dispatching_Type
(Subp
))
9566 or else not Is_Interface
(Find_Dispatching_Type
(Subp
))
9570 -- Entries and procedures can override abstract or null
9571 -- interface procedures.
9573 elsif (Ekind
(Def_Id
) = E_Procedure
9574 or else Ekind
(Def_Id
) = E_Entry
)
9575 and then Ekind
(Subp
) = E_Procedure
9576 and then Matches_Prefixed_View_Profile
9577 (Parameter_Specifications
(Parent
(Def_Id
)),
9578 Parameter_Specifications
(Parent
(Subp
)))
9582 -- For an overridden subprogram Subp, check whether the mode
9583 -- of its first parameter is correct depending on the kind
9584 -- of synchronized type.
9587 Formal
: constant Node_Id
:= First_Formal
(Candidate
);
9590 -- In order for an entry or a protected procedure to
9591 -- override, the first parameter of the overridden
9592 -- routine must be of mode "out", "in out" or
9593 -- access-to-variable.
9595 if Ekind_In
(Candidate
, E_Entry
, E_Procedure
)
9596 and then Is_Protected_Type
(Typ
)
9597 and then Ekind
(Formal
) /= E_In_Out_Parameter
9598 and then Ekind
(Formal
) /= E_Out_Parameter
9599 and then Nkind
(Parameter_Type
(Parent
(Formal
))) /=
9604 -- All other cases are OK since a task entry or routine
9605 -- does not have a restriction on the mode of the first
9606 -- parameter of the overridden interface routine.
9609 Overridden_Subp
:= Candidate
;
9614 -- Functions can override abstract interface functions
9616 elsif Ekind
(Def_Id
) = E_Function
9617 and then Ekind
(Subp
) = E_Function
9618 and then Matches_Prefixed_View_Profile
9619 (Parameter_Specifications
(Parent
(Def_Id
)),
9620 Parameter_Specifications
(Parent
(Subp
)))
9621 and then Etype
(Result_Definition
(Parent
(Def_Id
))) =
9622 Etype
(Result_Definition
(Parent
(Subp
)))
9626 -- If an inherited subprogram is implemented by a protected
9627 -- function, then the first parameter of the inherited
9628 -- subprogram shall be of mode in, but not an
9629 -- access-to-variable parameter (RM 9.4(11/9)
9631 if Present
(First_Formal
(Subp
))
9632 and then Ekind
(First_Formal
(Subp
)) = E_In_Parameter
9634 (not Is_Access_Type
(Etype
(First_Formal
(Subp
)))
9636 Is_Access_Constant
(Etype
(First_Formal
(Subp
))))
9638 Overridden_Subp
:= Subp
;
9643 Hom
:= Homonym
(Hom
);
9646 -- After examining all candidates for overriding, we are left with
9647 -- the best match which is a mode incompatible interface routine.
9649 if In_Scope
and then Present
(Candidate
) then
9650 Error_Msg_PT
(Def_Id
, Candidate
);
9653 Overridden_Subp
:= Candidate
;
9656 end Check_Synchronized_Overriding
;
9658 ----------------------------
9659 -- Is_Private_Declaration --
9660 ----------------------------
9662 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean is
9663 Priv_Decls
: List_Id
;
9664 Decl
: constant Node_Id
:= Unit_Declaration_Node
(E
);
9667 if Is_Package_Or_Generic_Package
(Current_Scope
)
9668 and then In_Private_Part
(Current_Scope
)
9671 Private_Declarations
(Package_Specification
(Current_Scope
));
9673 return In_Package_Body
(Current_Scope
)
9675 (Is_List_Member
(Decl
)
9676 and then List_Containing
(Decl
) = Priv_Decls
)
9677 or else (Nkind
(Parent
(Decl
)) = N_Package_Specification
9680 (Defining_Entity
(Parent
(Decl
)))
9681 and then List_Containing
(Parent
(Parent
(Decl
))) =
9686 end Is_Private_Declaration
;
9688 --------------------------
9689 -- Is_Overriding_Alias --
9690 --------------------------
9692 function Is_Overriding_Alias
9694 New_E
: Entity_Id
) return Boolean
9696 AO
: constant Entity_Id
:= Alias
(Old_E
);
9697 AN
: constant Entity_Id
:= Alias
(New_E
);
9699 return Scope
(AO
) /= Scope
(AN
)
9700 or else No
(DTC_Entity
(AO
))
9701 or else No
(DTC_Entity
(AN
))
9702 or else DT_Position
(AO
) = DT_Position
(AN
);
9703 end Is_Overriding_Alias
;
9705 -- Start of processing for New_Overloaded_Entity
9708 -- We need to look for an entity that S may override. This must be a
9709 -- homonym in the current scope, so we look for the first homonym of
9710 -- S in the current scope as the starting point for the search.
9712 E
:= Current_Entity_In_Scope
(S
);
9714 -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
9715 -- They are directly added to the list of primitive operations of
9716 -- Derived_Type, unless this is a rederivation in the private part
9717 -- of an operation that was already derived in the visible part of
9718 -- the current package.
9720 if Ada_Version
>= Ada_2005
9721 and then Present
(Derived_Type
)
9722 and then Present
(Alias
(S
))
9723 and then Is_Dispatching_Operation
(Alias
(S
))
9724 and then Present
(Find_Dispatching_Type
(Alias
(S
)))
9725 and then Is_Interface
(Find_Dispatching_Type
(Alias
(S
)))
9727 -- For private types, when the full-view is processed we propagate to
9728 -- the full view the non-overridden entities whose attribute "alias"
9729 -- references an interface primitive. These entities were added by
9730 -- Derive_Subprograms to ensure that interface primitives are
9733 -- Inside_Freeze_Actions is non zero when S corresponds with an
9734 -- internal entity that links an interface primitive with its
9735 -- covering primitive through attribute Interface_Alias (see
9736 -- Add_Internal_Interface_Entities).
9738 if Inside_Freezing_Actions
= 0
9739 and then Is_Package_Or_Generic_Package
(Current_Scope
)
9740 and then In_Private_Part
(Current_Scope
)
9741 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
9742 and then Nkind
(Parent
(S
)) = N_Full_Type_Declaration
9743 and then Full_View
(Defining_Identifier
(Parent
(E
)))
9744 = Defining_Identifier
(Parent
(S
))
9745 and then Alias
(E
) = Alias
(S
)
9747 Check_Operation_From_Private_View
(S
, E
);
9748 Set_Is_Dispatching_Operation
(S
);
9753 Enter_Overloaded_Entity
(S
);
9754 Check_Dispatching_Operation
(S
, Empty
);
9755 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
9761 -- If there is no homonym then this is definitely not overriding
9764 Enter_Overloaded_Entity
(S
);
9765 Check_Dispatching_Operation
(S
, Empty
);
9766 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
9768 -- If subprogram has an explicit declaration, check whether it has an
9769 -- overriding indicator.
9771 if Comes_From_Source
(S
) then
9772 Check_Synchronized_Overriding
(S
, Overridden_Subp
);
9774 -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then
9775 -- it may have overridden some hidden inherited primitive. Update
9776 -- Overridden_Subp to avoid spurious errors when checking the
9777 -- overriding indicator.
9779 if Ada_Version
>= Ada_2012
9780 and then No
(Overridden_Subp
)
9781 and then Is_Dispatching_Operation
(S
)
9782 and then Present
(Overridden_Operation
(S
))
9784 Overridden_Subp
:= Overridden_Operation
(S
);
9787 Check_Overriding_Indicator
9788 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
9790 -- The Ghost policy in effect at the point of declaration of a
9791 -- parent subprogram and an overriding subprogram must match
9792 -- (SPARK RM 6.9(17)).
9794 Check_Ghost_Overriding
(S
, Overridden_Subp
);
9797 -- If there is a homonym that is not overloadable, then we have an
9798 -- error, except for the special cases checked explicitly below.
9800 elsif not Is_Overloadable
(E
) then
9802 -- Check for spurious conflict produced by a subprogram that has the
9803 -- same name as that of the enclosing generic package. The conflict
9804 -- occurs within an instance, between the subprogram and the renaming
9805 -- declaration for the package. After the subprogram, the package
9806 -- renaming declaration becomes hidden.
9808 if Ekind
(E
) = E_Package
9809 and then Present
(Renamed_Object
(E
))
9810 and then Renamed_Object
(E
) = Current_Scope
9811 and then Nkind
(Parent
(Renamed_Object
(E
))) =
9812 N_Package_Specification
9813 and then Present
(Generic_Parent
(Parent
(Renamed_Object
(E
))))
9816 Set_Is_Immediately_Visible
(E
, False);
9817 Enter_Overloaded_Entity
(S
);
9818 Set_Homonym
(S
, Homonym
(E
));
9819 Check_Dispatching_Operation
(S
, Empty
);
9820 Check_Overriding_Indicator
(S
, Empty
, Is_Primitive
=> False);
9822 -- If the subprogram is implicit it is hidden by the previous
9823 -- declaration. However if it is dispatching, it must appear in the
9824 -- dispatch table anyway, because it can be dispatched to even if it
9825 -- cannot be called directly.
9827 elsif Present
(Alias
(S
)) and then not Comes_From_Source
(S
) then
9828 Set_Scope
(S
, Current_Scope
);
9830 if Is_Dispatching_Operation
(Alias
(S
)) then
9831 Check_Dispatching_Operation
(S
, Empty
);
9837 Error_Msg_Sloc
:= Sloc
(E
);
9839 -- Generate message, with useful additional warning if in generic
9841 if Is_Generic_Unit
(E
) then
9842 Error_Msg_N
("previous generic unit cannot be overloaded", S
);
9843 Error_Msg_N
("\& conflicts with declaration#", S
);
9845 Error_Msg_N
("& conflicts with declaration#", S
);
9851 -- E exists and is overloadable
9854 Check_Synchronized_Overriding
(S
, Overridden_Subp
);
9856 -- Loop through E and its homonyms to determine if any of them is
9857 -- the candidate for overriding by S.
9859 while Present
(E
) loop
9861 -- Definitely not interesting if not in the current scope
9863 if Scope
(E
) /= Current_Scope
then
9866 -- A function can overload the name of an abstract state. The
9867 -- state can be viewed as a function with a profile that cannot
9868 -- be matched by anything.
9870 elsif Ekind
(S
) = E_Function
9871 and then Ekind
(E
) = E_Abstract_State
9873 Enter_Overloaded_Entity
(S
);
9876 -- Ada 2012 (AI05-0165): For internally generated bodies of null
9877 -- procedures locate the internally generated spec. We enforce
9878 -- mode conformance since a tagged type may inherit from
9879 -- interfaces several null primitives which differ only in
9880 -- the mode of the formals.
9882 elsif not Comes_From_Source
(S
)
9883 and then Is_Null_Procedure
(S
)
9884 and then not Mode_Conformant
(E
, S
)
9888 -- Check if we have type conformance
9890 elsif Type_Conformant
(E
, S
) then
9892 -- If the old and new entities have the same profile and one
9893 -- is not the body of the other, then this is an error, unless
9894 -- one of them is implicitly declared.
9896 -- There are some cases when both can be implicit, for example
9897 -- when both a literal and a function that overrides it are
9898 -- inherited in a derivation, or when an inherited operation
9899 -- of a tagged full type overrides the inherited operation of
9900 -- a private extension. Ada 83 had a special rule for the
9901 -- literal case. In Ada 95, the later implicit operation hides
9902 -- the former, and the literal is always the former. In the
9903 -- odd case where both are derived operations declared at the
9904 -- same point, both operations should be declared, and in that
9905 -- case we bypass the following test and proceed to the next
9906 -- part. This can only occur for certain obscure cases in
9907 -- instances, when an operation on a type derived from a formal
9908 -- private type does not override a homograph inherited from
9909 -- the actual. In subsequent derivations of such a type, the
9910 -- DT positions of these operations remain distinct, if they
9913 if Present
(Alias
(S
))
9914 and then (No
(Alias
(E
))
9915 or else Comes_From_Source
(E
)
9916 or else Is_Abstract_Subprogram
(S
)
9918 (Is_Dispatching_Operation
(E
)
9919 and then Is_Overriding_Alias
(E
, S
)))
9920 and then Ekind
(E
) /= E_Enumeration_Literal
9922 -- When an derived operation is overloaded it may be due to
9923 -- the fact that the full view of a private extension
9924 -- re-inherits. It has to be dealt with.
9926 if Is_Package_Or_Generic_Package
(Current_Scope
)
9927 and then In_Private_Part
(Current_Scope
)
9929 Check_Operation_From_Private_View
(S
, E
);
9932 -- In any case the implicit operation remains hidden by the
9933 -- existing declaration, which is overriding. Indicate that
9934 -- E overrides the operation from which S is inherited.
9936 if Present
(Alias
(S
)) then
9937 Set_Overridden_Operation
(E
, Alias
(S
));
9938 Inherit_Subprogram_Contract
(E
, Alias
(S
));
9941 Set_Overridden_Operation
(E
, S
);
9942 Inherit_Subprogram_Contract
(E
, S
);
9945 if Comes_From_Source
(E
) then
9946 Check_Overriding_Indicator
(E
, S
, Is_Primitive
=> False);
9948 -- The Ghost policy in effect at the point of declaration
9949 -- of a parent subprogram and an overriding subprogram
9950 -- must match (SPARK RM 6.9(17)).
9952 Check_Ghost_Overriding
(E
, S
);
9957 -- Within an instance, the renaming declarations for actual
9958 -- subprograms may become ambiguous, but they do not hide each
9961 elsif Ekind
(E
) /= E_Entry
9962 and then not Comes_From_Source
(E
)
9963 and then not Is_Generic_Instance
(E
)
9964 and then (Present
(Alias
(E
))
9965 or else Is_Intrinsic_Subprogram
(E
))
9966 and then (not In_Instance
9967 or else No
(Parent
(E
))
9968 or else Nkind
(Unit_Declaration_Node
(E
)) /=
9969 N_Subprogram_Renaming_Declaration
)
9971 -- A subprogram child unit is not allowed to override an
9972 -- inherited subprogram (10.1.1(20)).
9974 if Is_Child_Unit
(S
) then
9976 ("child unit overrides inherited subprogram in parent",
9981 if Is_Non_Overriding_Operation
(E
, S
) then
9982 Enter_Overloaded_Entity
(S
);
9984 if No
(Derived_Type
)
9985 or else Is_Tagged_Type
(Derived_Type
)
9987 Check_Dispatching_Operation
(S
, Empty
);
9993 -- E is a derived operation or an internal operator which
9994 -- is being overridden. Remove E from further visibility.
9995 -- Furthermore, if E is a dispatching operation, it must be
9996 -- replaced in the list of primitive operations of its type
9997 -- (see Override_Dispatching_Operation).
9999 Overridden_Subp
:= E
;
10005 Prev
:= First_Entity
(Current_Scope
);
10006 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
10007 Next_Entity
(Prev
);
10010 -- It is possible for E to be in the current scope and
10011 -- yet not in the entity chain. This can only occur in a
10012 -- generic context where E is an implicit concatenation
10013 -- in the formal part, because in a generic body the
10014 -- entity chain starts with the formals.
10016 -- In GNATprove mode, a wrapper for an operation with
10017 -- axiomatization may be a homonym of another declaration
10018 -- for an actual subprogram (needs refinement ???).
10022 and then GNATprove_Mode
10024 Nkind
(Original_Node
(Unit_Declaration_Node
(S
))) =
10025 N_Subprogram_Renaming_Declaration
10029 pragma Assert
(Chars
(E
) = Name_Op_Concat
);
10034 -- E must be removed both from the entity_list of the
10035 -- current scope, and from the visibility chain.
10037 if Debug_Flag_E
then
10038 Write_Str
("Override implicit operation ");
10039 Write_Int
(Int
(E
));
10043 -- If E is a predefined concatenation, it stands for four
10044 -- different operations. As a result, a single explicit
10045 -- declaration does not hide it. In a possible ambiguous
10046 -- situation, Disambiguate chooses the user-defined op,
10047 -- so it is correct to retain the previous internal one.
10049 if Chars
(E
) /= Name_Op_Concat
10050 or else Ekind
(E
) /= E_Operator
10052 -- For nondispatching derived operations that are
10053 -- overridden by a subprogram declared in the private
10054 -- part of a package, we retain the derived subprogram
10055 -- but mark it as not immediately visible. If the
10056 -- derived operation was declared in the visible part
10057 -- then this ensures that it will still be visible
10058 -- outside the package with the proper signature
10059 -- (calls from outside must also be directed to this
10060 -- version rather than the overriding one, unlike the
10061 -- dispatching case). Calls from inside the package
10062 -- will still resolve to the overriding subprogram
10063 -- since the derived one is marked as not visible
10064 -- within the package.
10066 -- If the private operation is dispatching, we achieve
10067 -- the overriding by keeping the implicit operation
10068 -- but setting its alias to be the overriding one. In
10069 -- this fashion the proper body is executed in all
10070 -- cases, but the original signature is used outside
10073 -- If the overriding is not in the private part, we
10074 -- remove the implicit operation altogether.
10076 if Is_Private_Declaration
(S
) then
10077 if not Is_Dispatching_Operation
(E
) then
10078 Set_Is_Immediately_Visible
(E
, False);
10080 -- Work done in Override_Dispatching_Operation,
10081 -- so nothing else needs to be done here.
10087 -- Find predecessor of E in Homonym chain
10089 if E
= Current_Entity
(E
) then
10092 Prev_Vis
:= Current_Entity
(E
);
10093 while Homonym
(Prev_Vis
) /= E
loop
10094 Prev_Vis
:= Homonym
(Prev_Vis
);
10098 if Prev_Vis
/= Empty
then
10100 -- Skip E in the visibility chain
10102 Set_Homonym
(Prev_Vis
, Homonym
(E
));
10105 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
10108 Set_Next_Entity
(Prev
, Next_Entity
(E
));
10110 if No
(Next_Entity
(Prev
)) then
10111 Set_Last_Entity
(Current_Scope
, Prev
);
10116 Enter_Overloaded_Entity
(S
);
10118 -- For entities generated by Derive_Subprograms the
10119 -- overridden operation is the inherited primitive
10120 -- (which is available through the attribute alias).
10122 if not (Comes_From_Source
(E
))
10123 and then Is_Dispatching_Operation
(E
)
10124 and then Find_Dispatching_Type
(E
) =
10125 Find_Dispatching_Type
(S
)
10126 and then Present
(Alias
(E
))
10127 and then Comes_From_Source
(Alias
(E
))
10129 Set_Overridden_Operation
(S
, Alias
(E
));
10130 Inherit_Subprogram_Contract
(S
, Alias
(E
));
10132 -- Normal case of setting entity as overridden
10134 -- Note: Static_Initialization and Overridden_Operation
10135 -- attributes use the same field in subprogram entities.
10136 -- Static_Initialization is only defined for internal
10137 -- initialization procedures, where Overridden_Operation
10138 -- is irrelevant. Therefore the setting of this attribute
10139 -- must check whether the target is an init_proc.
10141 elsif not Is_Init_Proc
(S
) then
10142 Set_Overridden_Operation
(S
, E
);
10143 Inherit_Subprogram_Contract
(S
, E
);
10146 Check_Overriding_Indicator
(S
, E
, Is_Primitive
=> True);
10148 -- The Ghost policy in effect at the point of declaration
10149 -- of a parent subprogram and an overriding subprogram
10150 -- must match (SPARK RM 6.9(17)).
10152 Check_Ghost_Overriding
(S
, E
);
10154 -- If S is a user-defined subprogram or a null procedure
10155 -- expanded to override an inherited null procedure, or a
10156 -- predefined dispatching primitive then indicate that E
10157 -- overrides the operation from which S is inherited.
10159 if Comes_From_Source
(S
)
10161 (Present
(Parent
(S
))
10163 Nkind
(Parent
(S
)) = N_Procedure_Specification
10165 Null_Present
(Parent
(S
)))
10167 (Present
(Alias
(E
))
10169 Is_Predefined_Dispatching_Operation
(Alias
(E
)))
10171 if Present
(Alias
(E
)) then
10172 Set_Overridden_Operation
(S
, Alias
(E
));
10173 Inherit_Subprogram_Contract
(S
, Alias
(E
));
10177 if Is_Dispatching_Operation
(E
) then
10179 -- An overriding dispatching subprogram inherits the
10180 -- convention of the overridden subprogram (AI-117).
10182 Set_Convention
(S
, Convention
(E
));
10183 Check_Dispatching_Operation
(S
, E
);
10185 -- In GNATprove_Mode, create the pragmas corresponding
10186 -- to inherited class-wide conditions.
10188 if GNATprove_Mode
then
10189 Collect_Inherited_Class_Wide_Conditions
(S
);
10193 Check_Dispatching_Operation
(S
, Empty
);
10196 Check_For_Primitive_Subprogram
10197 (Is_Primitive_Subp
, Is_Overriding
=> True);
10198 goto Check_Inequality
;
10201 -- Apparent redeclarations in instances can occur when two
10202 -- formal types get the same actual type. The subprograms in
10203 -- in the instance are legal, even if not callable from the
10204 -- outside. Calls from within are disambiguated elsewhere.
10205 -- For dispatching operations in the visible part, the usual
10206 -- rules apply, and operations with the same profile are not
10207 -- legal (B830001).
10209 elsif (In_Instance_Visible_Part
10210 and then not Is_Dispatching_Operation
(E
))
10211 or else In_Instance_Not_Visible
10215 -- Here we have a real error (identical profile)
10218 Error_Msg_Sloc
:= Sloc
(E
);
10220 -- Avoid cascaded errors if the entity appears in
10221 -- subsequent calls.
10223 Set_Scope
(S
, Current_Scope
);
10225 -- Generate error, with extra useful warning for the case
10226 -- of a generic instance with no completion.
10228 if Is_Generic_Instance
(S
)
10229 and then not Has_Completion
(E
)
10232 ("instantiation cannot provide body for&", S
);
10233 Error_Msg_N
("\& conflicts with declaration#", S
);
10235 Error_Msg_N
("& conflicts with declaration#", S
);
10242 -- If one subprogram has an access parameter and the other
10243 -- a parameter of an access type, calls to either might be
10244 -- ambiguous. Verify that parameters match except for the
10245 -- access parameter.
10247 if May_Hide_Profile
then
10253 F1
:= First_Formal
(S
);
10254 F2
:= First_Formal
(E
);
10255 while Present
(F1
) and then Present
(F2
) loop
10256 if Is_Access_Type
(Etype
(F1
)) then
10257 if not Is_Access_Type
(Etype
(F2
))
10258 or else not Conforming_Types
10259 (Designated_Type
(Etype
(F1
)),
10260 Designated_Type
(Etype
(F2
)),
10263 May_Hide_Profile
:= False;
10267 not Conforming_Types
10268 (Etype
(F1
), Etype
(F2
), Type_Conformant
)
10270 May_Hide_Profile
:= False;
10277 if May_Hide_Profile
10281 Error_Msg_NE
("calls to& may be ambiguous??", S
, S
);
10290 -- On exit, we know that S is a new entity
10292 Enter_Overloaded_Entity
(S
);
10293 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
10294 Check_Overriding_Indicator
10295 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
10297 -- The Ghost policy in effect at the point of declaration of a parent
10298 -- subprogram and an overriding subprogram must match
10299 -- (SPARK RM 6.9(17)).
10301 Check_Ghost_Overriding
(S
, Overridden_Subp
);
10303 -- Overloading is not allowed in SPARK, except for operators
10305 if Nkind
(S
) /= N_Defining_Operator_Symbol
then
10306 Error_Msg_Sloc
:= Sloc
(Homonym
(S
));
10307 Check_SPARK_05_Restriction
10308 ("overloading not allowed with entity#", S
);
10311 -- If S is a derived operation for an untagged type then by
10312 -- definition it's not a dispatching operation (even if the parent
10313 -- operation was dispatching), so Check_Dispatching_Operation is not
10314 -- called in that case.
10316 if No
(Derived_Type
)
10317 or else Is_Tagged_Type
(Derived_Type
)
10319 Check_Dispatching_Operation
(S
, Empty
);
10323 -- If this is a user-defined equality operator that is not a derived
10324 -- subprogram, create the corresponding inequality. If the operation is
10325 -- dispatching, the expansion is done elsewhere, and we do not create
10326 -- an explicit inequality operation.
10328 <<Check_Inequality
>>
10329 if Chars
(S
) = Name_Op_Eq
10330 and then Etype
(S
) = Standard_Boolean
10331 and then Present
(Parent
(S
))
10332 and then not Is_Dispatching_Operation
(S
)
10334 Make_Inequality_Operator
(S
);
10335 Check_Untagged_Equality
(S
);
10337 end New_Overloaded_Entity
;
10339 ---------------------
10340 -- Process_Formals --
10341 ---------------------
10343 procedure Process_Formals
10345 Related_Nod
: Node_Id
)
10347 function Designates_From_Limited_With
(Typ
: Entity_Id
) return Boolean;
10348 -- Determine whether an access type designates a type coming from a
10351 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean;
10352 -- Check whether the default has a class-wide type. After analysis the
10353 -- default has the type of the formal, so we must also check explicitly
10354 -- for an access attribute.
10356 ----------------------------------
10357 -- Designates_From_Limited_With --
10358 ----------------------------------
10360 function Designates_From_Limited_With
(Typ
: Entity_Id
) return Boolean is
10361 Desig
: Entity_Id
:= Typ
;
10364 if Is_Access_Type
(Desig
) then
10365 Desig
:= Directly_Designated_Type
(Desig
);
10368 if Is_Class_Wide_Type
(Desig
) then
10369 Desig
:= Root_Type
(Desig
);
10373 Ekind
(Desig
) = E_Incomplete_Type
10374 and then From_Limited_With
(Desig
);
10375 end Designates_From_Limited_With
;
10377 ---------------------------
10378 -- Is_Class_Wide_Default --
10379 ---------------------------
10381 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean is
10383 return Is_Class_Wide_Type
(Designated_Type
(Etype
(D
)))
10384 or else (Nkind
(D
) = N_Attribute_Reference
10385 and then Attribute_Name
(D
) = Name_Access
10386 and then Is_Class_Wide_Type
(Etype
(Prefix
(D
))));
10387 end Is_Class_Wide_Default
;
10391 Context
: constant Node_Id
:= Parent
(Parent
(T
));
10393 Formal
: Entity_Id
;
10394 Formal_Type
: Entity_Id
;
10395 Param_Spec
: Node_Id
;
10398 Num_Out_Params
: Nat
:= 0;
10399 First_Out_Param
: Entity_Id
:= Empty
;
10400 -- Used for setting Is_Only_Out_Parameter
10402 -- Start of processing for Process_Formals
10405 -- In order to prevent premature use of the formals in the same formal
10406 -- part, the Ekind is left undefined until all default expressions are
10407 -- analyzed. The Ekind is established in a separate loop at the end.
10409 Param_Spec
:= First
(T
);
10410 while Present
(Param_Spec
) loop
10411 Formal
:= Defining_Identifier
(Param_Spec
);
10412 Set_Never_Set_In_Source
(Formal
, True);
10413 Enter_Name
(Formal
);
10415 -- Case of ordinary parameters
10417 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
10418 Find_Type
(Parameter_Type
(Param_Spec
));
10419 Ptype
:= Parameter_Type
(Param_Spec
);
10421 if Ptype
= Error
then
10425 Formal_Type
:= Entity
(Ptype
);
10427 if Is_Incomplete_Type
(Formal_Type
)
10429 (Is_Class_Wide_Type
(Formal_Type
)
10430 and then Is_Incomplete_Type
(Root_Type
(Formal_Type
)))
10432 -- Ada 2005 (AI-326): Tagged incomplete types allowed in
10433 -- primitive operations, as long as their completion is
10434 -- in the same declarative part. If in the private part
10435 -- this means that the type cannot be a Taft-amendment type.
10436 -- Check is done on package exit. For access to subprograms,
10437 -- the use is legal for Taft-amendment types.
10439 -- Ada 2012: tagged incomplete types are allowed as generic
10440 -- formal types. They do not introduce dependencies and the
10441 -- corresponding generic subprogram does not have a delayed
10442 -- freeze, because it does not need a freeze node. However,
10443 -- it is still the case that untagged incomplete types cannot
10444 -- be Taft-amendment types and must be completed in private
10445 -- part, so the subprogram must appear in the list of private
10446 -- dependents of the type. If the type is class-wide, it is
10447 -- not a primitive, but the freezing of the subprogram must
10448 -- also be delayed to force the creation of a freeze node.
10450 if Is_Tagged_Type
(Formal_Type
)
10451 or else (Ada_Version
>= Ada_2012
10452 and then not From_Limited_With
(Formal_Type
)
10453 and then not Is_Generic_Type
(Formal_Type
))
10455 if Ekind
(Scope
(Current_Scope
)) = E_Package
10456 and then not Is_Generic_Type
(Formal_Type
)
10459 (Parent
(T
), N_Access_Function_Definition
,
10460 N_Access_Procedure_Definition
)
10462 -- A limited view has no private dependents
10464 if not Is_Class_Wide_Type
(Formal_Type
)
10465 and then not From_Limited_With
(Formal_Type
)
10467 Append_Elmt
(Current_Scope
,
10468 Private_Dependents
(Base_Type
(Formal_Type
)));
10471 -- Freezing is delayed to ensure that Register_Prim
10472 -- will get called for this operation, which is needed
10473 -- in cases where static dispatch tables aren't built.
10474 -- (Note that the same is done for controlling access
10475 -- parameter cases in function Access_Definition.)
10477 if not Is_Thunk
(Current_Scope
) then
10478 Set_Has_Delayed_Freeze
(Current_Scope
);
10483 elsif not Nkind_In
(Parent
(T
), N_Access_Function_Definition
,
10484 N_Access_Procedure_Definition
)
10486 -- AI05-0151: Tagged incomplete types are allowed in all
10487 -- formal parts. Untagged incomplete types are not allowed
10488 -- in bodies. Limited views of either kind are not allowed
10489 -- if there is no place at which the non-limited view can
10490 -- become available.
10492 -- Incomplete formal untagged types are not allowed in
10493 -- subprogram bodies (but are legal in their declarations).
10494 -- This excludes bodies created for null procedures, which
10495 -- are basic declarations.
10497 if Is_Generic_Type
(Formal_Type
)
10498 and then not Is_Tagged_Type
(Formal_Type
)
10499 and then Nkind
(Parent
(Related_Nod
)) = N_Subprogram_Body
10502 ("invalid use of formal incomplete type", Param_Spec
);
10504 elsif Ada_Version
>= Ada_2012
then
10505 if Is_Tagged_Type
(Formal_Type
)
10506 and then (not From_Limited_With
(Formal_Type
)
10507 or else not In_Package_Body
)
10511 elsif Nkind_In
(Context
, N_Accept_Statement
,
10512 N_Accept_Alternative
,
10514 or else (Nkind
(Context
) = N_Subprogram_Body
10515 and then Comes_From_Source
(Context
))
10518 ("invalid use of untagged incomplete type &",
10519 Ptype
, Formal_Type
);
10524 ("invalid use of incomplete type&",
10525 Param_Spec
, Formal_Type
);
10527 -- Further checks on the legality of incomplete types
10528 -- in formal parts are delayed until the freeze point
10529 -- of the enclosing subprogram or access to subprogram.
10533 elsif Ekind
(Formal_Type
) = E_Void
then
10535 ("premature use of&",
10536 Parameter_Type
(Param_Spec
), Formal_Type
);
10539 -- Ada 2012 (AI-142): Handle aliased parameters
10541 if Ada_Version
>= Ada_2012
10542 and then Aliased_Present
(Param_Spec
)
10544 Set_Is_Aliased
(Formal
);
10547 -- Ada 2005 (AI-231): Create and decorate an internal subtype
10548 -- declaration corresponding to the null-excluding type of the
10549 -- formal in the enclosing scope. Finally, replace the parameter
10550 -- type of the formal with the internal subtype.
10552 if Ada_Version
>= Ada_2005
10553 and then Null_Exclusion_Present
(Param_Spec
)
10555 if not Is_Access_Type
(Formal_Type
) then
10557 ("`NOT NULL` allowed only for an access type", Param_Spec
);
10560 if Can_Never_Be_Null
(Formal_Type
)
10561 and then Comes_From_Source
(Related_Nod
)
10564 ("`NOT NULL` not allowed (& already excludes null)",
10565 Param_Spec
, Formal_Type
);
10569 Create_Null_Excluding_Itype
10571 Related_Nod
=> Related_Nod
,
10572 Scope_Id
=> Scope
(Current_Scope
));
10574 -- If the designated type of the itype is an itype that is
10575 -- not frozen yet, we set the Has_Delayed_Freeze attribute
10576 -- on the access subtype, to prevent order-of-elaboration
10577 -- issues in the backend.
10580 -- type T is access procedure;
10581 -- procedure Op (O : not null T);
10583 if Is_Itype
(Directly_Designated_Type
(Formal_Type
))
10585 not Is_Frozen
(Directly_Designated_Type
(Formal_Type
))
10587 Set_Has_Delayed_Freeze
(Formal_Type
);
10592 -- An access formal type
10596 Access_Definition
(Related_Nod
, Parameter_Type
(Param_Spec
));
10598 -- No need to continue if we already notified errors
10600 if not Present
(Formal_Type
) then
10604 -- Ada 2005 (AI-254)
10607 AD
: constant Node_Id
:=
10608 Access_To_Subprogram_Definition
10609 (Parameter_Type
(Param_Spec
));
10611 if Present
(AD
) and then Protected_Present
(AD
) then
10613 Replace_Anonymous_Access_To_Protected_Subprogram
10619 Set_Etype
(Formal
, Formal_Type
);
10621 -- Deal with default expression if present
10623 Default
:= Expression
(Param_Spec
);
10625 if Present
(Default
) then
10626 Check_SPARK_05_Restriction
10627 ("default expression is not allowed", Default
);
10629 if Out_Present
(Param_Spec
) then
10631 ("default initialization only allowed for IN parameters",
10635 -- Do the special preanalysis of the expression (see section on
10636 -- "Handling of Default Expressions" in the spec of package Sem).
10638 Preanalyze_Spec_Expression
(Default
, Formal_Type
);
10640 -- An access to constant cannot be the default for
10641 -- an access parameter that is an access to variable.
10643 if Ekind
(Formal_Type
) = E_Anonymous_Access_Type
10644 and then not Is_Access_Constant
(Formal_Type
)
10645 and then Is_Access_Type
(Etype
(Default
))
10646 and then Is_Access_Constant
(Etype
(Default
))
10649 ("formal that is access to variable cannot be initialized "
10650 & "with an access-to-constant expression", Default
);
10653 -- Check that the designated type of an access parameter's default
10654 -- is not a class-wide type unless the parameter's designated type
10655 -- is also class-wide.
10657 if Ekind
(Formal_Type
) = E_Anonymous_Access_Type
10658 and then not Designates_From_Limited_With
(Formal_Type
)
10659 and then Is_Class_Wide_Default
(Default
)
10660 and then not Is_Class_Wide_Type
(Designated_Type
(Formal_Type
))
10663 ("access to class-wide expression not allowed here", Default
);
10666 -- Check incorrect use of dynamically tagged expressions
10668 if Is_Tagged_Type
(Formal_Type
) then
10669 Check_Dynamically_Tagged_Expression
10671 Typ
=> Formal_Type
,
10672 Related_Nod
=> Default
);
10676 -- Ada 2005 (AI-231): Static checks
10678 if Ada_Version
>= Ada_2005
10679 and then Is_Access_Type
(Etype
(Formal
))
10680 and then Can_Never_Be_Null
(Etype
(Formal
))
10682 Null_Exclusion_Static_Checks
(Param_Spec
);
10685 -- The following checks are relevant only when SPARK_Mode is on as
10686 -- these are not standard Ada legality rules.
10688 if SPARK_Mode
= On
then
10689 if Ekind_In
(Scope
(Formal
), E_Function
, E_Generic_Function
) then
10691 -- A function cannot have a parameter of mode IN OUT or OUT
10694 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
10696 ("function cannot have parameter of mode `OUT` or "
10697 & "`IN OUT`", Formal
);
10700 -- A procedure cannot have an effectively volatile formal
10701 -- parameter of mode IN because it behaves as a constant
10702 -- (SPARK RM 7.1.3(6)). -- ??? maybe 7.1.3(4)
10704 elsif Ekind
(Scope
(Formal
)) = E_Procedure
10705 and then Ekind
(Formal
) = E_In_Parameter
10706 and then Is_Effectively_Volatile
(Formal
)
10709 ("formal parameter of mode `IN` cannot be volatile", Formal
);
10717 -- If this is the formal part of a function specification, analyze the
10718 -- subtype mark in the context where the formals are visible but not
10719 -- yet usable, and may hide outer homographs.
10721 if Nkind
(Related_Nod
) = N_Function_Specification
then
10722 Analyze_Return_Type
(Related_Nod
);
10724 -- If return type is class-wide, subprogram freezing may be
10725 -- delayed as well, unless the declaration is a compilation unit
10726 -- in which case the freeze node would appear too late.
10728 if Is_Class_Wide_Type
(Etype
(Current_Scope
))
10729 and then not Is_Thunk
(Current_Scope
)
10730 and then not Is_Compilation_Unit
(Current_Scope
)
10731 and then Nkind
(Unit_Declaration_Node
(Current_Scope
)) =
10732 N_Subprogram_Declaration
10734 Set_Has_Delayed_Freeze
(Current_Scope
);
10738 -- Now set the kind (mode) of each formal
10740 Param_Spec
:= First
(T
);
10741 while Present
(Param_Spec
) loop
10742 Formal
:= Defining_Identifier
(Param_Spec
);
10743 Set_Formal_Mode
(Formal
);
10745 if Ekind
(Formal
) = E_In_Parameter
then
10746 Set_Default_Value
(Formal
, Expression
(Param_Spec
));
10748 if Present
(Expression
(Param_Spec
)) then
10749 Default
:= Expression
(Param_Spec
);
10751 if Is_Scalar_Type
(Etype
(Default
)) then
10752 if Nkind
(Parameter_Type
(Param_Spec
)) /=
10753 N_Access_Definition
10755 Formal_Type
:= Entity
(Parameter_Type
(Param_Spec
));
10759 (Related_Nod
, Parameter_Type
(Param_Spec
));
10762 Apply_Scalar_Range_Check
(Default
, Formal_Type
);
10766 elsif Ekind
(Formal
) = E_Out_Parameter
then
10767 Num_Out_Params
:= Num_Out_Params
+ 1;
10769 if Num_Out_Params
= 1 then
10770 First_Out_Param
:= Formal
;
10773 elsif Ekind
(Formal
) = E_In_Out_Parameter
then
10774 Num_Out_Params
:= Num_Out_Params
+ 1;
10777 -- Skip remaining processing if formal type was in error
10779 if Etype
(Formal
) = Any_Type
or else Error_Posted
(Formal
) then
10780 goto Next_Parameter
;
10783 -- Force call by reference if aliased
10785 if Is_Aliased
(Formal
) then
10786 Set_Mechanism
(Formal
, By_Reference
);
10788 -- Warn if user asked this to be passed by copy
10790 if Convention
(Formal_Type
) = Convention_Ada_Pass_By_Copy
then
10792 ("cannot pass aliased parameter & by copy??", Formal
);
10795 -- Force mechanism if type has Convention Ada_Pass_By_Ref/Copy
10797 elsif Convention
(Formal_Type
) = Convention_Ada_Pass_By_Copy
then
10798 Set_Mechanism
(Formal
, By_Copy
);
10800 elsif Convention
(Formal_Type
) = Convention_Ada_Pass_By_Reference
then
10801 Set_Mechanism
(Formal
, By_Reference
);
10808 if Present
(First_Out_Param
) and then Num_Out_Params
= 1 then
10809 Set_Is_Only_Out_Parameter
(First_Out_Param
);
10811 end Process_Formals
;
10813 ----------------------------
10814 -- Reference_Body_Formals --
10815 ----------------------------
10817 procedure Reference_Body_Formals
(Spec
: Entity_Id
; Bod
: Entity_Id
) is
10822 if Error_Posted
(Spec
) then
10826 -- Iterate over both lists. They may be of different lengths if the two
10827 -- specs are not conformant.
10829 Fs
:= First_Formal
(Spec
);
10830 Fb
:= First_Formal
(Bod
);
10831 while Present
(Fs
) and then Present
(Fb
) loop
10832 Generate_Reference
(Fs
, Fb
, 'b');
10834 if Style_Check
then
10835 Style
.Check_Identifier
(Fb
, Fs
);
10838 Set_Spec_Entity
(Fb
, Fs
);
10839 Set_Referenced
(Fs
, False);
10843 end Reference_Body_Formals
;
10845 -------------------------
10846 -- Set_Actual_Subtypes --
10847 -------------------------
10849 procedure Set_Actual_Subtypes
(N
: Node_Id
; Subp
: Entity_Id
) is
10851 Formal
: Entity_Id
;
10853 First_Stmt
: Node_Id
:= Empty
;
10854 AS_Needed
: Boolean;
10857 -- If this is an empty initialization procedure, no need to create
10858 -- actual subtypes (small optimization).
10860 if Ekind
(Subp
) = E_Procedure
and then Is_Null_Init_Proc
(Subp
) then
10864 Formal
:= First_Formal
(Subp
);
10865 while Present
(Formal
) loop
10866 T
:= Etype
(Formal
);
10868 -- We never need an actual subtype for a constrained formal
10870 if Is_Constrained
(T
) then
10871 AS_Needed
:= False;
10873 -- If we have unknown discriminants, then we do not need an actual
10874 -- subtype, or more accurately we cannot figure it out. Note that
10875 -- all class-wide types have unknown discriminants.
10877 elsif Has_Unknown_Discriminants
(T
) then
10878 AS_Needed
:= False;
10880 -- At this stage we have an unconstrained type that may need an
10881 -- actual subtype. For sure the actual subtype is needed if we have
10882 -- an unconstrained array type.
10884 elsif Is_Array_Type
(T
) then
10887 -- The only other case needing an actual subtype is an unconstrained
10888 -- record type which is an IN parameter (we cannot generate actual
10889 -- subtypes for the OUT or IN OUT case, since an assignment can
10890 -- change the discriminant values. However we exclude the case of
10891 -- initialization procedures, since discriminants are handled very
10892 -- specially in this context, see the section entitled "Handling of
10893 -- Discriminants" in Einfo.
10895 -- We also exclude the case of Discrim_SO_Functions (functions used
10896 -- in front end layout mode for size/offset values), since in such
10897 -- functions only discriminants are referenced, and not only are such
10898 -- subtypes not needed, but they cannot always be generated, because
10899 -- of order of elaboration issues.
10901 elsif Is_Record_Type
(T
)
10902 and then Ekind
(Formal
) = E_In_Parameter
10903 and then Chars
(Formal
) /= Name_uInit
10904 and then not Is_Unchecked_Union
(T
)
10905 and then not Is_Discrim_SO_Function
(Subp
)
10909 -- All other cases do not need an actual subtype
10912 AS_Needed
:= False;
10915 -- Generate actual subtypes for unconstrained arrays and
10916 -- unconstrained discriminated records.
10919 if Nkind
(N
) = N_Accept_Statement
then
10921 -- If expansion is active, the formal is replaced by a local
10922 -- variable that renames the corresponding entry of the
10923 -- parameter block, and it is this local variable that may
10924 -- require an actual subtype.
10926 if Expander_Active
then
10927 Decl
:= Build_Actual_Subtype
(T
, Renamed_Object
(Formal
));
10929 Decl
:= Build_Actual_Subtype
(T
, Formal
);
10932 if Present
(Handled_Statement_Sequence
(N
)) then
10934 First
(Statements
(Handled_Statement_Sequence
(N
)));
10935 Prepend
(Decl
, Statements
(Handled_Statement_Sequence
(N
)));
10936 Mark_Rewrite_Insertion
(Decl
);
10938 -- If the accept statement has no body, there will be no
10939 -- reference to the actuals, so no need to compute actual
10946 Decl
:= Build_Actual_Subtype
(T
, Formal
);
10947 Prepend
(Decl
, Declarations
(N
));
10948 Mark_Rewrite_Insertion
(Decl
);
10951 -- The declaration uses the bounds of an existing object, and
10952 -- therefore needs no constraint checks.
10954 Analyze
(Decl
, Suppress
=> All_Checks
);
10956 -- We need to freeze manually the generated type when it is
10957 -- inserted anywhere else than in a declarative part.
10959 if Present
(First_Stmt
) then
10960 Insert_List_Before_And_Analyze
(First_Stmt
,
10961 Freeze_Entity
(Defining_Identifier
(Decl
), N
));
10963 -- Ditto if the type has a dynamic predicate, because the
10964 -- generated function will mention the actual subtype.
10966 elsif Has_Dynamic_Predicate_Aspect
(T
) then
10967 Insert_List_Before_And_Analyze
(Decl
,
10968 Freeze_Entity
(Defining_Identifier
(Decl
), N
));
10971 if Nkind
(N
) = N_Accept_Statement
10972 and then Expander_Active
10974 Set_Actual_Subtype
(Renamed_Object
(Formal
),
10975 Defining_Identifier
(Decl
));
10977 Set_Actual_Subtype
(Formal
, Defining_Identifier
(Decl
));
10981 Next_Formal
(Formal
);
10983 end Set_Actual_Subtypes
;
10985 ---------------------
10986 -- Set_Formal_Mode --
10987 ---------------------
10989 procedure Set_Formal_Mode
(Formal_Id
: Entity_Id
) is
10990 Spec
: constant Node_Id
:= Parent
(Formal_Id
);
10991 Id
: constant Entity_Id
:= Scope
(Formal_Id
);
10994 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
10995 -- since we ensure that corresponding actuals are always valid at the
10996 -- point of the call.
10998 if Out_Present
(Spec
) then
10999 if Ekind_In
(Id
, E_Entry
, E_Entry_Family
)
11000 or else Is_Subprogram_Or_Generic_Subprogram
(Id
)
11002 Set_Has_Out_Or_In_Out_Parameter
(Id
, True);
11005 if Ekind_In
(Id
, E_Function
, E_Generic_Function
) then
11007 -- [IN] OUT parameters allowed for functions in Ada 2012
11009 if Ada_Version
>= Ada_2012
then
11011 -- Even in Ada 2012 operators can only have IN parameters
11013 if Is_Operator_Symbol_Name
(Chars
(Scope
(Formal_Id
))) then
11014 Error_Msg_N
("operators can only have IN parameters", Spec
);
11017 if In_Present
(Spec
) then
11018 Set_Ekind
(Formal_Id
, E_In_Out_Parameter
);
11020 Set_Ekind
(Formal_Id
, E_Out_Parameter
);
11023 -- But not in earlier versions of Ada
11026 Error_Msg_N
("functions can only have IN parameters", Spec
);
11027 Set_Ekind
(Formal_Id
, E_In_Parameter
);
11030 elsif In_Present
(Spec
) then
11031 Set_Ekind
(Formal_Id
, E_In_Out_Parameter
);
11034 Set_Ekind
(Formal_Id
, E_Out_Parameter
);
11035 Set_Never_Set_In_Source
(Formal_Id
, True);
11036 Set_Is_True_Constant
(Formal_Id
, False);
11037 Set_Current_Value
(Formal_Id
, Empty
);
11041 Set_Ekind
(Formal_Id
, E_In_Parameter
);
11044 -- Set Is_Known_Non_Null for access parameters since the language
11045 -- guarantees that access parameters are always non-null. We also set
11046 -- Can_Never_Be_Null, since there is no way to change the value.
11048 if Nkind
(Parameter_Type
(Spec
)) = N_Access_Definition
then
11050 -- Ada 2005 (AI-231): In Ada 95, access parameters are always non-
11051 -- null; In Ada 2005, only if then null_exclusion is explicit.
11053 if Ada_Version
< Ada_2005
11054 or else Can_Never_Be_Null
(Etype
(Formal_Id
))
11056 Set_Is_Known_Non_Null
(Formal_Id
);
11057 Set_Can_Never_Be_Null
(Formal_Id
);
11060 -- Ada 2005 (AI-231): Null-exclusion access subtype
11062 elsif Is_Access_Type
(Etype
(Formal_Id
))
11063 and then Can_Never_Be_Null
(Etype
(Formal_Id
))
11065 Set_Is_Known_Non_Null
(Formal_Id
);
11067 -- We can also set Can_Never_Be_Null (thus preventing some junk
11068 -- access checks) for the case of an IN parameter, which cannot
11069 -- be changed, or for an IN OUT parameter, which can be changed but
11070 -- not to a null value. But for an OUT parameter, the initial value
11071 -- passed in can be null, so we can't set this flag in that case.
11073 if Ekind
(Formal_Id
) /= E_Out_Parameter
then
11074 Set_Can_Never_Be_Null
(Formal_Id
);
11078 Set_Mechanism
(Formal_Id
, Default_Mechanism
);
11079 Set_Formal_Validity
(Formal_Id
);
11080 end Set_Formal_Mode
;
11082 -------------------------
11083 -- Set_Formal_Validity --
11084 -------------------------
11086 procedure Set_Formal_Validity
(Formal_Id
: Entity_Id
) is
11088 -- If no validity checking, then we cannot assume anything about the
11089 -- validity of parameters, since we do not know there is any checking
11090 -- of the validity on the call side.
11092 if not Validity_Checks_On
then
11095 -- If validity checking for parameters is enabled, this means we are
11096 -- not supposed to make any assumptions about argument values.
11098 elsif Validity_Check_Parameters
then
11101 -- If we are checking in parameters, we will assume that the caller is
11102 -- also checking parameters, so we can assume the parameter is valid.
11104 elsif Ekind
(Formal_Id
) = E_In_Parameter
11105 and then Validity_Check_In_Params
11107 Set_Is_Known_Valid
(Formal_Id
, True);
11109 -- Similar treatment for IN OUT parameters
11111 elsif Ekind
(Formal_Id
) = E_In_Out_Parameter
11112 and then Validity_Check_In_Out_Params
11114 Set_Is_Known_Valid
(Formal_Id
, True);
11116 end Set_Formal_Validity
;
11118 ------------------------
11119 -- Subtype_Conformant --
11120 ------------------------
11122 function Subtype_Conformant
11123 (New_Id
: Entity_Id
;
11124 Old_Id
: Entity_Id
;
11125 Skip_Controlling_Formals
: Boolean := False) return Boolean
11129 Check_Conformance
(New_Id
, Old_Id
, Subtype_Conformant
, False, Result
,
11130 Skip_Controlling_Formals
=> Skip_Controlling_Formals
);
11132 end Subtype_Conformant
;
11134 ---------------------
11135 -- Type_Conformant --
11136 ---------------------
11138 function Type_Conformant
11139 (New_Id
: Entity_Id
;
11140 Old_Id
: Entity_Id
;
11141 Skip_Controlling_Formals
: Boolean := False) return Boolean
11145 May_Hide_Profile
:= False;
11147 (New_Id
, Old_Id
, Type_Conformant
, False, Result
,
11148 Skip_Controlling_Formals
=> Skip_Controlling_Formals
);
11150 end Type_Conformant
;
11152 -------------------------------
11153 -- Valid_Operator_Definition --
11154 -------------------------------
11156 procedure Valid_Operator_Definition
(Designator
: Entity_Id
) is
11159 Id
: constant Name_Id
:= Chars
(Designator
);
11163 F
:= First_Formal
(Designator
);
11164 while Present
(F
) loop
11167 if Present
(Default_Value
(F
)) then
11169 ("default values not allowed for operator parameters",
11172 -- For function instantiations that are operators, we must check
11173 -- separately that the corresponding generic only has in-parameters.
11174 -- For subprogram declarations this is done in Set_Formal_Mode. Such
11175 -- an error could not arise in earlier versions of the language.
11177 elsif Ekind
(F
) /= E_In_Parameter
then
11178 Error_Msg_N
("operators can only have IN parameters", F
);
11184 -- Verify that user-defined operators have proper number of arguments
11185 -- First case of operators which can only be unary
11187 if Nam_In
(Id
, Name_Op_Not
, Name_Op_Abs
) then
11190 -- Case of operators which can be unary or binary
11192 elsif Nam_In
(Id
, Name_Op_Add
, Name_Op_Subtract
) then
11193 N_OK
:= (N
in 1 .. 2);
11195 -- All other operators can only be binary
11203 ("incorrect number of arguments for operator", Designator
);
11207 and then Base_Type
(Etype
(Designator
)) = Standard_Boolean
11208 and then not Is_Intrinsic_Subprogram
(Designator
)
11211 ("explicit definition of inequality not allowed", Designator
);
11213 end Valid_Operator_Definition
;