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
);
285 -- If the expression is a completion, Prev is the entity whose
286 -- 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 -- Remove any existing aspects from the original node because the act
396 -- of rewriting cases the list to be shared between the two nodes.
398 Orig_N
:= Original_Node
(N
);
399 Remove_Aspects
(Orig_N
);
401 -- Propagate any pragmas that apply to the expression function to the
402 -- proper body when the expression function acts as a completion.
403 -- Aspects are automatically transfered because of node rewriting.
405 Relocate_Pragmas_To_Body
(N
);
408 -- Once the aspects of the generated body has been analyzed, create a
409 -- copy for ASIS purposes and assciate it with the original node.
411 if Has_Aspects
(N
) then
412 Set_Aspect_Specifications
(Orig_N
,
413 New_Copy_List_Tree
(Aspect_Specifications
(N
)));
416 -- Prev is the previous entity with the same name, but it is can
417 -- be an unrelated spec that is not completed by the expression
418 -- function. In that case the relevant entity is the one in the body.
419 -- Not clear that the backend can inline it in this case ???
421 if Has_Completion
(Prev
) then
423 -- The formals of the expression function are body formals,
424 -- and do not appear in the ali file, which will only contain
425 -- references to the formals of the original subprogram spec.
432 F1
:= First_Formal
(Def_Id
);
433 F2
:= First_Formal
(Prev
);
435 while Present
(F1
) loop
436 Set_Spec_Entity
(F1
, F2
);
443 Set_Is_Inlined
(Defining_Entity
(New_Body
));
446 -- If this is not a completion, create both a declaration and a body, so
447 -- that the expression can be inlined whenever possible.
450 -- An expression function that is not a completion is not a
451 -- subprogram declaration, and thus cannot appear in a protected
454 if Nkind
(Parent
(N
)) = N_Protected_Definition
then
456 ("an expression function is not a legal protected operation", N
);
459 Rewrite
(N
, Make_Subprogram_Declaration
(Loc
, Specification
=> Spec
));
461 -- Remove any existing aspects from the original node because the act
462 -- of rewriting cases the list to be shared between the two nodes.
464 Orig_N
:= Original_Node
(N
);
465 Remove_Aspects
(Orig_N
);
469 -- Once the aspects of the generated spec has been analyzed, create a
470 -- copy for ASIS purposes and assciate it with the original node.
472 if Has_Aspects
(N
) then
473 Set_Aspect_Specifications
(Orig_N
,
474 New_Copy_List_Tree
(Aspect_Specifications
(N
)));
477 -- If aspect SPARK_Mode was specified on the body, it needs to be
478 -- repeated both on the generated spec and the body.
480 Asp
:= Find_Aspect
(Defining_Unit_Name
(Spec
), Aspect_SPARK_Mode
);
482 if Present
(Asp
) then
483 Asp
:= New_Copy_Tree
(Asp
);
484 Set_Analyzed
(Asp
, False);
485 Set_Aspect_Specifications
(New_Body
, New_List
(Asp
));
488 Def_Id
:= Defining_Entity
(N
);
490 -- Within a generic pre-analyze the original expression for name
491 -- capture. The body is also generated but plays no role in
492 -- this because it is not part of the original source.
494 if Inside_A_Generic
then
495 Set_Has_Completion
(Def_Id
);
497 Install_Formals
(Def_Id
);
498 Preanalyze_Spec_Expression
(Expr
, Etype
(Def_Id
));
502 Set_Is_Inlined
(Defining_Entity
(N
));
504 -- If the expression function is Ghost, mark its body entity as
505 -- Ghost too. This avoids spurious errors on unanalyzed body entities
506 -- of expression functions, which are not yet marked as ghost, yet
507 -- identified as the Corresponding_Body of the ghost declaration.
509 if Is_Ghost_Entity
(Def_Id
) then
510 Set_Is_Ghost_Entity
(Defining_Entity
(New_Body
));
513 -- Establish the linkages between the spec and the body. These are
514 -- used when the expression function acts as the prefix of attribute
515 -- 'Access in order to freeze the original expression which has been
516 -- moved to the generated body.
518 Set_Corresponding_Body
(N
, Defining_Entity
(New_Body
));
519 Set_Corresponding_Spec
(New_Body
, Defining_Entity
(N
));
521 -- To prevent premature freeze action, insert the new body at the end
522 -- of the current declarations, or at the end of the package spec.
523 -- However, resolve usage names now, to prevent spurious visibility
524 -- on later entities. Note that the function can now be called in
525 -- the current declarative part, which will appear to be prior to
526 -- the presence of the body in the code. There are nevertheless no
527 -- order of elaboration issues because all name resolution has taken
528 -- place at the point of declaration.
531 Decls
: List_Id
:= List_Containing
(N
);
532 Expr
: constant Node_Id
:= Expression
(Ret
);
533 Par
: constant Node_Id
:= Parent
(Decls
);
534 Typ
: constant Entity_Id
:= Etype
(Def_Id
);
537 -- If this is a wrapper created for in an instance for a formal
538 -- subprogram, insert body after declaration, to be analyzed when
539 -- the enclosing instance is analyzed.
542 and then Is_Generic_Actual_Subprogram
(Defining_Entity
(N
))
544 Insert_After
(N
, New_Body
);
547 if Nkind
(Par
) = N_Package_Specification
548 and then Decls
= Visible_Declarations
(Par
)
549 and then Present
(Private_Declarations
(Par
))
550 and then not Is_Empty_List
(Private_Declarations
(Par
))
552 Decls
:= Private_Declarations
(Par
);
555 Insert_After
(Last
(Decls
), New_Body
);
557 -- Preanalyze the expression for name capture, except in an
558 -- instance, where this has been done during generic analysis,
559 -- and will be redone when analyzing the body.
561 Set_Parent
(Expr
, Ret
);
563 Install_Formals
(Def_Id
);
565 if not In_Instance
then
566 Preanalyze_Spec_Expression
(Expr
, Typ
);
567 Check_Limited_Return
(Original_Node
(N
), Expr
, Typ
);
575 -- If the return expression is a static constant, we suppress warning
576 -- messages on unused formals, which in most cases will be noise.
578 Set_Is_Trivial_Subprogram
579 (Defining_Entity
(New_Body
), Is_OK_Static_Expression
(Expr
));
580 end Analyze_Expression_Function
;
582 ----------------------------------------
583 -- Analyze_Extended_Return_Statement --
584 ----------------------------------------
586 procedure Analyze_Extended_Return_Statement
(N
: Node_Id
) is
588 Check_Compiler_Unit
("extended return statement", N
);
589 Analyze_Return_Statement
(N
);
590 end Analyze_Extended_Return_Statement
;
592 ----------------------------
593 -- Analyze_Function_Call --
594 ----------------------------
596 procedure Analyze_Function_Call
(N
: Node_Id
) is
597 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
598 Func_Nam
: constant Node_Id
:= Name
(N
);
604 -- A call of the form A.B (X) may be an Ada 2005 call, which is
605 -- rewritten as B (A, X). If the rewriting is successful, the call
606 -- has been analyzed and we just return.
608 if Nkind
(Func_Nam
) = N_Selected_Component
609 and then Name
(N
) /= Func_Nam
610 and then Is_Rewrite_Substitution
(N
)
611 and then Present
(Etype
(N
))
616 -- If error analyzing name, then set Any_Type as result type and return
618 if Etype
(Func_Nam
) = Any_Type
then
619 Set_Etype
(N
, Any_Type
);
623 -- Otherwise analyze the parameters
625 if Present
(Actuals
) then
626 Actual
:= First
(Actuals
);
627 while Present
(Actual
) loop
629 Check_Parameterless_Call
(Actual
);
635 end Analyze_Function_Call
;
637 -----------------------------
638 -- Analyze_Function_Return --
639 -----------------------------
641 procedure Analyze_Function_Return
(N
: Node_Id
) is
642 Loc
: constant Source_Ptr
:= Sloc
(N
);
643 Stm_Entity
: constant Entity_Id
:= Return_Statement_Entity
(N
);
644 Scope_Id
: constant Entity_Id
:= Return_Applies_To
(Stm_Entity
);
646 R_Type
: constant Entity_Id
:= Etype
(Scope_Id
);
647 -- Function result subtype
649 procedure Check_Aggregate_Accessibility
(Aggr
: Node_Id
);
650 -- Apply legality rule of 6.5 (8.2) to the access discriminants of an
651 -- aggregate in a return statement.
653 procedure Check_Return_Subtype_Indication
(Obj_Decl
: Node_Id
);
654 -- Check that the return_subtype_indication properly matches the result
655 -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
657 -----------------------------------
658 -- Check_Aggregate_Accessibility --
659 -----------------------------------
661 procedure Check_Aggregate_Accessibility
(Aggr
: Node_Id
) is
662 Typ
: constant Entity_Id
:= Etype
(Aggr
);
669 if Is_Record_Type
(Typ
) and then Has_Discriminants
(Typ
) then
670 Discr
:= First_Discriminant
(Typ
);
671 Assoc
:= First
(Component_Associations
(Aggr
));
672 while Present
(Discr
) loop
673 if Ekind
(Etype
(Discr
)) = E_Anonymous_Access_Type
then
674 Expr
:= Expression
(Assoc
);
675 if Nkind
(Expr
) = N_Attribute_Reference
676 and then Attribute_Name
(Expr
) /= Name_Unrestricted_Access
678 Obj
:= Prefix
(Expr
);
679 while Nkind_In
(Obj
, N_Indexed_Component
,
680 N_Selected_Component
)
685 -- No check needed for an aliased formal.
686 -- A run-time check may still be needed ???
688 if Is_Entity_Name
(Obj
)
689 and then Is_Formal
(Entity
(Obj
))
690 and then Is_Aliased
(Entity
(Obj
))
694 elsif Object_Access_Level
(Obj
) >
695 Scope_Depth
(Scope
(Scope_Id
))
698 ("access discriminant in return aggregate would be "
699 & "a dangling reference", Obj
);
704 Next_Discriminant
(Discr
);
707 end Check_Aggregate_Accessibility
;
709 -------------------------------------
710 -- Check_Return_Subtype_Indication --
711 -------------------------------------
713 procedure Check_Return_Subtype_Indication
(Obj_Decl
: Node_Id
) is
714 Return_Obj
: constant Node_Id
:= Defining_Identifier
(Obj_Decl
);
716 R_Stm_Type
: constant Entity_Id
:= Etype
(Return_Obj
);
717 -- Subtype given in the extended return statement (must match R_Type)
719 Subtype_Ind
: constant Node_Id
:=
720 Object_Definition
(Original_Node
(Obj_Decl
));
722 R_Type_Is_Anon_Access
: constant Boolean :=
724 E_Anonymous_Access_Subprogram_Type
,
725 E_Anonymous_Access_Protected_Subprogram_Type
,
726 E_Anonymous_Access_Type
);
727 -- True if return type of the function is an anonymous access type
728 -- Can't we make Is_Anonymous_Access_Type in einfo ???
730 R_Stm_Type_Is_Anon_Access
: constant Boolean :=
731 Ekind_In
(R_Stm_Type
,
732 E_Anonymous_Access_Subprogram_Type
,
733 E_Anonymous_Access_Protected_Subprogram_Type
,
734 E_Anonymous_Access_Type
);
735 -- True if type of the return object is an anonymous access type
737 procedure Error_No_Match
(N
: Node_Id
);
738 -- Output error messages for case where types do not statically
739 -- match. N is the location for the messages.
745 procedure Error_No_Match
(N
: Node_Id
) is
748 ("subtype must statically match function result subtype", N
);
750 if not Predicates_Match
(R_Stm_Type
, R_Type
) then
751 Error_Msg_Node_2
:= R_Type
;
753 ("\predicate of& does not match predicate of&",
758 -- Start of processing for Check_Return_Subtype_Indication
761 -- First, avoid cascaded errors
763 if Error_Posted
(Obj_Decl
) or else Error_Posted
(Subtype_Ind
) then
767 -- "return access T" case; check that the return statement also has
768 -- "access T", and that the subtypes statically match:
769 -- if this is an access to subprogram the signatures must match.
771 if R_Type_Is_Anon_Access
then
772 if R_Stm_Type_Is_Anon_Access
then
774 Ekind
(Designated_Type
(R_Stm_Type
)) /= E_Subprogram_Type
776 if Base_Type
(Designated_Type
(R_Stm_Type
)) /=
777 Base_Type
(Designated_Type
(R_Type
))
778 or else not Subtypes_Statically_Match
(R_Stm_Type
, R_Type
)
780 Error_No_Match
(Subtype_Mark
(Subtype_Ind
));
784 -- For two anonymous access to subprogram types, the
785 -- types themselves must be type conformant.
787 if not Conforming_Types
788 (R_Stm_Type
, R_Type
, Fully_Conformant
)
790 Error_No_Match
(Subtype_Ind
);
795 Error_Msg_N
("must use anonymous access type", Subtype_Ind
);
798 -- If the return object is of an anonymous access type, then report
799 -- an error if the function's result type is not also anonymous.
801 elsif R_Stm_Type_Is_Anon_Access
then
802 pragma Assert
(not R_Type_Is_Anon_Access
);
803 Error_Msg_N
("anonymous access not allowed for function with "
804 & "named access result", Subtype_Ind
);
806 -- Subtype indication case: check that the return object's type is
807 -- covered by the result type, and that the subtypes statically match
808 -- when the result subtype is constrained. Also handle record types
809 -- with unknown discriminants for which we have built the underlying
810 -- record view. Coverage is needed to allow specific-type return
811 -- objects when the result type is class-wide (see AI05-32).
813 elsif Covers
(Base_Type
(R_Type
), Base_Type
(R_Stm_Type
))
814 or else (Is_Underlying_Record_View
(Base_Type
(R_Stm_Type
))
818 Underlying_Record_View
(Base_Type
(R_Stm_Type
))))
820 -- A null exclusion may be present on the return type, on the
821 -- function specification, on the object declaration or on the
824 if Is_Access_Type
(R_Type
)
826 (Can_Never_Be_Null
(R_Type
)
827 or else Null_Exclusion_Present
(Parent
(Scope_Id
))) /=
828 Can_Never_Be_Null
(R_Stm_Type
)
830 Error_No_Match
(Subtype_Ind
);
833 -- AI05-103: for elementary types, subtypes must statically match
835 if Is_Constrained
(R_Type
)
836 or else Is_Access_Type
(R_Type
)
838 if not Subtypes_Statically_Match
(R_Stm_Type
, R_Type
) then
839 Error_No_Match
(Subtype_Ind
);
843 -- All remaining cases are illegal
845 -- Note: previous versions of this subprogram allowed the return
846 -- value to be the ancestor of the return type if the return type
847 -- was a null extension. This was plainly incorrect.
851 ("wrong type for return_subtype_indication", Subtype_Ind
);
853 end Check_Return_Subtype_Indication
;
855 ---------------------
856 -- Local Variables --
857 ---------------------
862 -- Start of processing for Analyze_Function_Return
865 Set_Return_Present
(Scope_Id
);
867 if Nkind
(N
) = N_Simple_Return_Statement
then
868 Expr
:= Expression
(N
);
870 -- Guard against a malformed expression. The parser may have tried to
871 -- recover but the node is not analyzable.
873 if Nkind
(Expr
) = N_Error
then
874 Set_Etype
(Expr
, Any_Type
);
875 Expander_Mode_Save_And_Set
(False);
879 -- The resolution of a controlled [extension] aggregate associated
880 -- with a return statement creates a temporary which needs to be
881 -- finalized on function exit. Wrap the return statement inside a
882 -- block so that the finalization machinery can detect this case.
883 -- This early expansion is done only when the return statement is
884 -- not part of a handled sequence of statements.
886 if Nkind_In
(Expr
, N_Aggregate
,
887 N_Extension_Aggregate
)
888 and then Needs_Finalization
(R_Type
)
889 and then Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
892 Make_Block_Statement
(Loc
,
893 Handled_Statement_Sequence
=>
894 Make_Handled_Sequence_Of_Statements
(Loc
,
895 Statements
=> New_List
(Relocate_Node
(N
)))));
903 -- Ada 2005 (AI-251): If the type of the returned object is
904 -- an access to an interface type then we add an implicit type
905 -- conversion to force the displacement of the "this" pointer to
906 -- reference the secondary dispatch table. We cannot delay the
907 -- generation of this implicit conversion until the expansion
908 -- because in this case the type resolution changes the decoration
909 -- of the expression node to match R_Type; by contrast, if the
910 -- returned object is a class-wide interface type then it is too
911 -- early to generate here the implicit conversion since the return
912 -- statement may be rewritten by the expander into an extended
913 -- return statement whose expansion takes care of adding the
914 -- implicit type conversion to displace the pointer to the object.
917 and then Serious_Errors_Detected
= 0
918 and then Is_Access_Type
(R_Type
)
919 and then Nkind
(Expr
) /= N_Null
920 and then Is_Interface
(Designated_Type
(R_Type
))
921 and then Is_Progenitor
(Designated_Type
(R_Type
),
922 Designated_Type
(Etype
(Expr
)))
924 Rewrite
(Expr
, Convert_To
(R_Type
, Relocate_Node
(Expr
)));
928 Resolve
(Expr
, R_Type
);
929 Check_Limited_Return
(N
, Expr
, R_Type
);
931 if Present
(Expr
) and then Nkind
(Expr
) = N_Aggregate
then
932 Check_Aggregate_Accessibility
(Expr
);
936 -- RETURN only allowed in SPARK as the last statement in function
938 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
940 (Nkind
(Parent
(Parent
(N
))) /= N_Subprogram_Body
941 or else Present
(Next
(N
)))
943 Check_SPARK_05_Restriction
944 ("RETURN should be the last statement in function", N
);
948 Check_SPARK_05_Restriction
("extended RETURN is not allowed", N
);
949 Obj_Decl
:= Last
(Return_Object_Declarations
(N
));
951 -- Analyze parts specific to extended_return_statement:
954 Has_Aliased
: constant Boolean := Aliased_Present
(Obj_Decl
);
955 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
958 Expr
:= Expression
(Obj_Decl
);
960 -- Note: The check for OK_For_Limited_Init will happen in
961 -- Analyze_Object_Declaration; we treat it as a normal
962 -- object declaration.
964 Set_Is_Return_Object
(Defining_Identifier
(Obj_Decl
));
967 Check_Return_Subtype_Indication
(Obj_Decl
);
969 if Present
(HSS
) then
972 if Present
(Exception_Handlers
(HSS
)) then
974 -- ???Has_Nested_Block_With_Handler needs to be set.
975 -- Probably by creating an actual N_Block_Statement.
976 -- Probably in Expand.
982 -- Mark the return object as referenced, since the return is an
983 -- implicit reference of the object.
985 Set_Referenced
(Defining_Identifier
(Obj_Decl
));
987 Check_References
(Stm_Entity
);
989 -- Check RM 6.5 (5.9/3)
992 if Ada_Version
< Ada_2012
then
994 -- Shouldn't this test Warn_On_Ada_2012_Compatibility ???
995 -- Can it really happen (extended return???)
998 ("aliased only allowed for limited return objects "
999 & "in Ada 2012??", N
);
1001 elsif not Is_Limited_View
(R_Type
) then
1003 ("aliased only allowed for limited return objects", N
);
1009 -- Case of Expr present
1013 -- Defend against previous errors
1015 and then Nkind
(Expr
) /= N_Empty
1016 and then Present
(Etype
(Expr
))
1018 -- Apply constraint check. Note that this is done before the implicit
1019 -- conversion of the expression done for anonymous access types to
1020 -- ensure correct generation of the null-excluding check associated
1021 -- with null-excluding expressions found in return statements.
1023 Apply_Constraint_Check
(Expr
, R_Type
);
1025 -- Ada 2005 (AI-318-02): When the result type is an anonymous access
1026 -- type, apply an implicit conversion of the expression to that type
1027 -- to force appropriate static and run-time accessibility checks.
1029 if Ada_Version
>= Ada_2005
1030 and then Ekind
(R_Type
) = E_Anonymous_Access_Type
1032 Rewrite
(Expr
, Convert_To
(R_Type
, Relocate_Node
(Expr
)));
1033 Analyze_And_Resolve
(Expr
, R_Type
);
1035 -- If this is a local anonymous access to subprogram, the
1036 -- accessibility check can be applied statically. The return is
1037 -- illegal if the access type of the return expression is declared
1038 -- inside of the subprogram (except if it is the subtype indication
1039 -- of an extended return statement).
1041 elsif Ekind
(R_Type
) = E_Anonymous_Access_Subprogram_Type
then
1042 if not Comes_From_Source
(Current_Scope
)
1043 or else Ekind
(Current_Scope
) = E_Return_Statement
1048 Scope_Depth
(Scope
(Etype
(Expr
))) >= Scope_Depth
(Scope_Id
)
1050 Error_Msg_N
("cannot return local access to subprogram", N
);
1053 -- The expression cannot be of a formal incomplete type
1055 elsif Ekind
(Etype
(Expr
)) = E_Incomplete_Type
1056 and then Is_Generic_Type
(Etype
(Expr
))
1059 ("cannot return expression of a formal incomplete type", N
);
1062 -- If the result type is class-wide, then check that the return
1063 -- expression's type is not declared at a deeper level than the
1064 -- function (RM05-6.5(5.6/2)).
1066 if Ada_Version
>= Ada_2005
1067 and then Is_Class_Wide_Type
(R_Type
)
1069 if Type_Access_Level
(Etype
(Expr
)) >
1070 Subprogram_Access_Level
(Scope_Id
)
1073 ("level of return expression type is deeper than "
1074 & "class-wide function!", Expr
);
1078 -- Check incorrect use of dynamically tagged expression
1080 if Is_Tagged_Type
(R_Type
) then
1081 Check_Dynamically_Tagged_Expression
1087 -- ??? A real run-time accessibility check is needed in cases
1088 -- involving dereferences of access parameters. For now we just
1089 -- check the static cases.
1091 if (Ada_Version
< Ada_2005
or else Debug_Flag_Dot_L
)
1092 and then Is_Limited_View
(Etype
(Scope_Id
))
1093 and then Object_Access_Level
(Expr
) >
1094 Subprogram_Access_Level
(Scope_Id
)
1096 -- Suppress the message in a generic, where the rewriting
1099 if Inside_A_Generic
then
1104 Make_Raise_Program_Error
(Loc
,
1105 Reason
=> PE_Accessibility_Check_Failed
));
1108 Error_Msg_Warn
:= SPARK_Mode
/= On
;
1109 Error_Msg_N
("cannot return a local value by reference<<", N
);
1110 Error_Msg_NE
("\& [<<", N
, Standard_Program_Error
);
1114 if Known_Null
(Expr
)
1115 and then Nkind
(Parent
(Scope_Id
)) = N_Function_Specification
1116 and then Null_Exclusion_Present
(Parent
(Scope_Id
))
1118 Apply_Compile_Time_Constraint_Error
1120 Msg
=> "(Ada 2005) null not allowed for "
1121 & "null-excluding return??",
1122 Reason
=> CE_Null_Not_Allowed
);
1125 -- RM 6.5 (5.4/3): accessibility checks also apply if the return object
1126 -- has no initializing expression.
1128 elsif Ada_Version
> Ada_2005
and then Is_Class_Wide_Type
(R_Type
) then
1129 if Type_Access_Level
(Etype
(Defining_Identifier
(Obj_Decl
))) >
1130 Subprogram_Access_Level
(Scope_Id
)
1133 ("level of return expression type is deeper than "
1134 & "class-wide function!", Obj_Decl
);
1137 end Analyze_Function_Return
;
1139 -------------------------------------
1140 -- Analyze_Generic_Subprogram_Body --
1141 -------------------------------------
1143 procedure Analyze_Generic_Subprogram_Body
1147 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Id
);
1148 Kind
: constant Entity_Kind
:= Ekind
(Gen_Id
);
1149 Body_Id
: Entity_Id
;
1154 -- Copy body and disable expansion while analyzing the generic For a
1155 -- stub, do not copy the stub (which would load the proper body), this
1156 -- will be done when the proper body is analyzed.
1158 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
1159 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
1162 -- Once the contents of the generic copy and the template are
1163 -- swapped, do the same for their respective aspect specifications.
1165 Exchange_Aspects
(N
, New_N
);
1167 -- Collect all contract-related source pragmas found within the
1168 -- template and attach them to the contract of the subprogram body.
1169 -- This contract is used in the capture of global references within
1172 Create_Generic_Contract
(N
);
1177 Spec
:= Specification
(N
);
1179 -- Within the body of the generic, the subprogram is callable, and
1180 -- behaves like the corresponding non-generic unit.
1182 Body_Id
:= Defining_Entity
(Spec
);
1184 if Kind
= E_Generic_Procedure
1185 and then Nkind
(Spec
) /= N_Procedure_Specification
1187 Error_Msg_N
("invalid body for generic procedure ", Body_Id
);
1190 elsif Kind
= E_Generic_Function
1191 and then Nkind
(Spec
) /= N_Function_Specification
1193 Error_Msg_N
("invalid body for generic function ", Body_Id
);
1197 Set_Corresponding_Body
(Gen_Decl
, Body_Id
);
1199 if Has_Completion
(Gen_Id
)
1200 and then Nkind
(Parent
(N
)) /= N_Subunit
1202 Error_Msg_N
("duplicate generic body", N
);
1205 Set_Has_Completion
(Gen_Id
);
1208 if Nkind
(N
) = N_Subprogram_Body_Stub
then
1209 Set_Ekind
(Defining_Entity
(Specification
(N
)), Kind
);
1211 Set_Corresponding_Spec
(N
, Gen_Id
);
1214 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
1215 Set_Cunit_Entity
(Current_Sem_Unit
, Defining_Entity
(N
));
1218 -- Make generic parameters immediately visible in the body. They are
1219 -- needed to process the formals declarations. Then make the formals
1220 -- visible in a separate step.
1222 Push_Scope
(Gen_Id
);
1226 First_Ent
: Entity_Id
;
1229 First_Ent
:= First_Entity
(Gen_Id
);
1232 while Present
(E
) and then not Is_Formal
(E
) loop
1237 Set_Use
(Generic_Formal_Declarations
(Gen_Decl
));
1239 -- Now generic formals are visible, and the specification can be
1240 -- analyzed, for subsequent conformance check.
1242 Body_Id
:= Analyze_Subprogram_Specification
(Spec
);
1244 -- Make formal parameters visible
1248 -- E is the first formal parameter, we loop through the formals
1249 -- installing them so that they will be visible.
1251 Set_First_Entity
(Gen_Id
, E
);
1252 while Present
(E
) loop
1258 -- Visible generic entity is callable within its own body
1260 Set_Ekind
(Gen_Id
, Ekind
(Body_Id
));
1261 Set_Ekind
(Body_Id
, E_Subprogram_Body
);
1262 Set_Convention
(Body_Id
, Convention
(Gen_Id
));
1263 Set_Is_Obsolescent
(Body_Id
, Is_Obsolescent
(Gen_Id
));
1264 Set_Scope
(Body_Id
, Scope
(Gen_Id
));
1266 -- Inherit the "ghostness" of the generic spec. Note that this
1267 -- property is not directly inherited as the body may be subject
1268 -- to a different Ghost assertion policy.
1270 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Gen_Id
) then
1271 Set_Is_Ghost_Entity
(Body_Id
);
1273 -- The Ghost policy in effect at the point of declaration and at
1274 -- the point of completion must match (SPARK RM 6.9(14)).
1276 Check_Ghost_Completion
(Gen_Id
, Body_Id
);
1279 Check_Fully_Conformant
(Body_Id
, Gen_Id
, Body_Id
);
1281 if Nkind
(N
) = N_Subprogram_Body_Stub
then
1283 -- No body to analyze, so restore state of generic unit
1285 Set_Ekind
(Gen_Id
, Kind
);
1286 Set_Ekind
(Body_Id
, Kind
);
1288 if Present
(First_Ent
) then
1289 Set_First_Entity
(Gen_Id
, First_Ent
);
1296 -- If this is a compilation unit, it must be made visible explicitly,
1297 -- because the compilation of the declaration, unlike other library
1298 -- unit declarations, does not. If it is not a unit, the following
1299 -- is redundant but harmless.
1301 Set_Is_Immediately_Visible
(Gen_Id
);
1302 Reference_Body_Formals
(Gen_Id
, Body_Id
);
1304 if Is_Child_Unit
(Gen_Id
) then
1305 Generate_Reference
(Gen_Id
, Scope
(Gen_Id
), 'k', False);
1308 Set_Actual_Subtypes
(N
, Current_Scope
);
1310 Set_SPARK_Pragma
(Body_Id
, SPARK_Mode_Pragma
);
1311 Set_SPARK_Pragma_Inherited
(Body_Id
);
1313 -- Analyze any aspect specifications that appear on the generic
1316 if Has_Aspects
(N
) then
1317 Analyze_Aspect_Specifications_On_Body_Or_Stub
(N
);
1320 Analyze_Declarations
(Declarations
(N
));
1323 -- Process the contract of the subprogram body after all declarations
1324 -- have been analyzed. This ensures that any contract-related pragmas
1325 -- are available through the N_Contract node of the body.
1327 Analyze_Entry_Or_Subprogram_Body_Contract
(Body_Id
);
1329 Analyze
(Handled_Statement_Sequence
(N
));
1330 Save_Global_References
(Original_Node
(N
));
1332 -- Prior to exiting the scope, include generic formals again (if any
1333 -- are present) in the set of local entities.
1335 if Present
(First_Ent
) then
1336 Set_First_Entity
(Gen_Id
, First_Ent
);
1339 Check_References
(Gen_Id
);
1342 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Current_Scope
);
1344 Check_Subprogram_Order
(N
);
1346 -- Outside of its body, unit is generic again
1348 Set_Ekind
(Gen_Id
, Kind
);
1349 Generate_Reference
(Gen_Id
, Body_Id
, 'b', Set_Ref
=> False);
1352 Style
.Check_Identifier
(Body_Id
, Gen_Id
);
1356 end Analyze_Generic_Subprogram_Body
;
1358 ----------------------------
1359 -- Analyze_Null_Procedure --
1360 ----------------------------
1362 procedure Analyze_Null_Procedure
1364 Is_Completion
: out Boolean)
1366 Loc
: constant Source_Ptr
:= Sloc
(N
);
1367 Spec
: constant Node_Id
:= Specification
(N
);
1368 Designator
: Entity_Id
;
1370 Null_Body
: Node_Id
:= Empty
;
1374 -- Capture the profile of the null procedure before analysis, for
1375 -- expansion at the freeze point and at each point of call. The body is
1376 -- used if the procedure has preconditions, or if it is a completion. In
1377 -- the first case the body is analyzed at the freeze point, in the other
1378 -- it replaces the null procedure declaration.
1381 Make_Subprogram_Body
(Loc
,
1382 Specification
=> New_Copy_Tree
(Spec
),
1383 Declarations
=> New_List
,
1384 Handled_Statement_Sequence
=>
1385 Make_Handled_Sequence_Of_Statements
(Loc
,
1386 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1388 -- Create new entities for body and formals
1390 Set_Defining_Unit_Name
(Specification
(Null_Body
),
1391 Make_Defining_Identifier
1392 (Sloc
(Defining_Entity
(N
)),
1393 Chars
(Defining_Entity
(N
))));
1395 Form
:= First
(Parameter_Specifications
(Specification
(Null_Body
)));
1396 while Present
(Form
) loop
1397 Set_Defining_Identifier
(Form
,
1398 Make_Defining_Identifier
1399 (Sloc
(Defining_Identifier
(Form
)),
1400 Chars
(Defining_Identifier
(Form
))));
1404 -- Determine whether the null procedure may be a completion of a generic
1405 -- suprogram, in which case we use the new null body as the completion
1406 -- and set minimal semantic information on the original declaration,
1407 -- which is rewritten as a null statement.
1409 Prev
:= Current_Entity_In_Scope
(Defining_Entity
(Spec
));
1411 if Present
(Prev
) and then Is_Generic_Subprogram
(Prev
) then
1412 Insert_Before
(N
, Null_Body
);
1413 Set_Ekind
(Defining_Entity
(N
), Ekind
(Prev
));
1415 Rewrite
(N
, Make_Null_Statement
(Loc
));
1416 Analyze_Generic_Subprogram_Body
(Null_Body
, Prev
);
1417 Is_Completion
:= True;
1421 -- Resolve the types of the formals now, because the freeze point
1422 -- may appear in a different context, e.g. an instantiation.
1424 Form
:= First
(Parameter_Specifications
(Specification
(Null_Body
)));
1425 while Present
(Form
) loop
1426 if Nkind
(Parameter_Type
(Form
)) /= N_Access_Definition
then
1427 Find_Type
(Parameter_Type
(Form
));
1430 No
(Access_To_Subprogram_Definition
(Parameter_Type
(Form
)))
1432 Find_Type
(Subtype_Mark
(Parameter_Type
(Form
)));
1435 -- The case of a null procedure with a formal that is an
1436 -- access_to_subprogram type, and that is used as an actual
1437 -- in an instantiation is left to the enthusiastic reader.
1446 -- If there are previous overloadable entities with the same name,
1447 -- check whether any of them is completed by the null procedure.
1449 if Present
(Prev
) and then Is_Overloadable
(Prev
) then
1450 Designator
:= Analyze_Subprogram_Specification
(Spec
);
1451 Prev
:= Find_Corresponding_Spec
(N
);
1454 if No
(Prev
) or else not Comes_From_Source
(Prev
) then
1455 Designator
:= Analyze_Subprogram_Specification
(Spec
);
1456 Set_Has_Completion
(Designator
);
1458 -- Signal to caller that this is a procedure declaration
1460 Is_Completion
:= False;
1462 -- Null procedures are always inlined, but generic formal subprograms
1463 -- which appear as such in the internal instance of formal packages,
1464 -- need no completion and are not marked Inline.
1467 and then Nkind
(N
) /= N_Formal_Concrete_Subprogram_Declaration
1469 Set_Corresponding_Body
(N
, Defining_Entity
(Null_Body
));
1470 Set_Body_To_Inline
(N
, Null_Body
);
1471 Set_Is_Inlined
(Designator
);
1475 -- The null procedure is a completion. We unconditionally rewrite
1476 -- this as a null body (even if expansion is not active), because
1477 -- there are various error checks that are applied on this body
1478 -- when it is analyzed (e.g. correct aspect placement).
1480 if Has_Completion
(Prev
) then
1481 Error_Msg_Sloc
:= Sloc
(Prev
);
1482 Error_Msg_NE
("duplicate body for & declared#", N
, Prev
);
1485 Is_Completion
:= True;
1486 Rewrite
(N
, Null_Body
);
1489 end Analyze_Null_Procedure
;
1491 -----------------------------
1492 -- Analyze_Operator_Symbol --
1493 -----------------------------
1495 -- An operator symbol such as "+" or "and" may appear in context where the
1496 -- literal denotes an entity name, such as "+"(x, y) or in context when it
1497 -- is just a string, as in (conjunction = "or"). In these cases the parser
1498 -- generates this node, and the semantics does the disambiguation. Other
1499 -- such case are actuals in an instantiation, the generic unit in an
1500 -- instantiation, and pragma arguments.
1502 procedure Analyze_Operator_Symbol
(N
: Node_Id
) is
1503 Par
: constant Node_Id
:= Parent
(N
);
1506 if (Nkind
(Par
) = N_Function_Call
and then N
= Name
(Par
))
1507 or else Nkind
(Par
) = N_Function_Instantiation
1508 or else (Nkind
(Par
) = N_Indexed_Component
and then N
= Prefix
(Par
))
1509 or else (Nkind
(Par
) = N_Pragma_Argument_Association
1510 and then not Is_Pragma_String_Literal
(Par
))
1511 or else Nkind
(Par
) = N_Subprogram_Renaming_Declaration
1512 or else (Nkind
(Par
) = N_Attribute_Reference
1513 and then Attribute_Name
(Par
) /= Name_Value
)
1515 Find_Direct_Name
(N
);
1518 Change_Operator_Symbol_To_String_Literal
(N
);
1521 end Analyze_Operator_Symbol
;
1523 -----------------------------------
1524 -- Analyze_Parameter_Association --
1525 -----------------------------------
1527 procedure Analyze_Parameter_Association
(N
: Node_Id
) is
1529 Analyze
(Explicit_Actual_Parameter
(N
));
1530 end Analyze_Parameter_Association
;
1532 ----------------------------
1533 -- Analyze_Procedure_Call --
1534 ----------------------------
1536 procedure Analyze_Procedure_Call
(N
: Node_Id
) is
1537 procedure Analyze_Call_And_Resolve
;
1538 -- Do Analyze and Resolve calls for procedure call
1539 -- At end, check illegal order dependence.
1541 ------------------------------
1542 -- Analyze_Call_And_Resolve --
1543 ------------------------------
1545 procedure Analyze_Call_And_Resolve
is
1547 if Nkind
(N
) = N_Procedure_Call_Statement
then
1549 Resolve
(N
, Standard_Void_Type
);
1553 end Analyze_Call_And_Resolve
;
1557 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
1558 Loc
: constant Source_Ptr
:= Sloc
(N
);
1559 P
: constant Node_Id
:= Name
(N
);
1563 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1565 -- Start of processing for Analyze_Procedure_Call
1568 -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
1569 -- a procedure call or an entry call. The prefix may denote an access
1570 -- to subprogram type, in which case an implicit dereference applies.
1571 -- If the prefix is an indexed component (without implicit dereference)
1572 -- then the construct denotes a call to a member of an entire family.
1573 -- If the prefix is a simple name, it may still denote a call to a
1574 -- parameterless member of an entry family. Resolution of these various
1575 -- interpretations is delicate.
1577 -- Do not analyze machine code statements to avoid rejecting them in
1580 if CodePeer_Mode
and then Nkind
(P
) = N_Qualified_Expression
then
1581 Set_Etype
(P
, Standard_Void_Type
);
1586 -- If this is a call of the form Obj.Op, the call may have been analyzed
1587 -- and possibly rewritten into a block, in which case we are done.
1589 if Analyzed
(N
) then
1593 -- If there is an error analyzing the name (which may have been
1594 -- rewritten if the original call was in prefix notation) then error
1595 -- has been emitted already, mark node and return.
1597 if Error_Posted
(N
) or else Etype
(Name
(N
)) = Any_Type
then
1598 Set_Etype
(N
, Any_Type
);
1602 -- A procedure call is Ghost when its name denotes a Ghost procedure.
1603 -- Set the mode now to ensure that any nodes generated during analysis
1604 -- and expansion are properly marked as Ghost.
1608 -- Otherwise analyze the parameters
1610 if Present
(Actuals
) then
1611 Actual
:= First
(Actuals
);
1613 while Present
(Actual
) loop
1615 Check_Parameterless_Call
(Actual
);
1620 -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
1622 if Nkind
(P
) = N_Attribute_Reference
1623 and then Nam_In
(Attribute_Name
(P
), Name_Elab_Spec
,
1625 Name_Elab_Subp_Body
)
1627 if Present
(Actuals
) then
1629 ("no parameters allowed for this call", First
(Actuals
));
1633 Set_Etype
(N
, Standard_Void_Type
);
1636 elsif Is_Entity_Name
(P
)
1637 and then Is_Record_Type
(Etype
(Entity
(P
)))
1638 and then Remote_AST_I_Dereference
(P
)
1640 Ghost_Mode
:= Save_Ghost_Mode
;
1643 elsif Is_Entity_Name
(P
)
1644 and then Ekind
(Entity
(P
)) /= E_Entry_Family
1646 if Is_Access_Type
(Etype
(P
))
1647 and then Ekind
(Designated_Type
(Etype
(P
))) = E_Subprogram_Type
1648 and then No
(Actuals
)
1649 and then Comes_From_Source
(N
)
1651 Error_Msg_N
("missing explicit dereference in call", N
);
1654 Analyze_Call_And_Resolve
;
1656 -- If the prefix is the simple name of an entry family, this is a
1657 -- parameterless call from within the task body itself.
1659 elsif Is_Entity_Name
(P
)
1660 and then Nkind
(P
) = N_Identifier
1661 and then Ekind
(Entity
(P
)) = E_Entry_Family
1662 and then Present
(Actuals
)
1663 and then No
(Next
(First
(Actuals
)))
1665 -- Can be call to parameterless entry family. What appears to be the
1666 -- sole argument is in fact the entry index. Rewrite prefix of node
1667 -- accordingly. Source representation is unchanged by this
1671 Make_Indexed_Component
(Loc
,
1673 Make_Selected_Component
(Loc
,
1674 Prefix
=> New_Occurrence_Of
(Scope
(Entity
(P
)), Loc
),
1675 Selector_Name
=> New_Occurrence_Of
(Entity
(P
), Loc
)),
1676 Expressions
=> Actuals
);
1677 Set_Name
(N
, New_N
);
1678 Set_Etype
(New_N
, Standard_Void_Type
);
1679 Set_Parameter_Associations
(N
, No_List
);
1680 Analyze_Call_And_Resolve
;
1682 elsif Nkind
(P
) = N_Explicit_Dereference
then
1683 if Ekind
(Etype
(P
)) = E_Subprogram_Type
then
1684 Analyze_Call_And_Resolve
;
1686 Error_Msg_N
("expect access to procedure in call", P
);
1689 -- The name can be a selected component or an indexed component that
1690 -- yields an access to subprogram. Such a prefix is legal if the call
1691 -- has parameter associations.
1693 elsif Is_Access_Type
(Etype
(P
))
1694 and then Ekind
(Designated_Type
(Etype
(P
))) = E_Subprogram_Type
1696 if Present
(Actuals
) then
1697 Analyze_Call_And_Resolve
;
1699 Error_Msg_N
("missing explicit dereference in call ", N
);
1702 -- If not an access to subprogram, then the prefix must resolve to the
1703 -- name of an entry, entry family, or protected operation.
1705 -- For the case of a simple entry call, P is a selected component where
1706 -- the prefix is the task and the selector name is the entry. A call to
1707 -- a protected procedure will have the same syntax. If the protected
1708 -- object contains overloaded operations, the entity may appear as a
1709 -- function, the context will select the operation whose type is Void.
1711 elsif Nkind
(P
) = N_Selected_Component
1712 and then Ekind_In
(Entity
(Selector_Name
(P
)), E_Entry
,
1716 Analyze_Call_And_Resolve
;
1718 elsif Nkind
(P
) = N_Selected_Component
1719 and then Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
1720 and then Present
(Actuals
)
1721 and then No
(Next
(First
(Actuals
)))
1723 -- Can be call to parameterless entry family. What appears to be the
1724 -- sole argument is in fact the entry index. Rewrite prefix of node
1725 -- accordingly. Source representation is unchanged by this
1729 Make_Indexed_Component
(Loc
,
1730 Prefix
=> New_Copy
(P
),
1731 Expressions
=> Actuals
);
1732 Set_Name
(N
, New_N
);
1733 Set_Etype
(New_N
, Standard_Void_Type
);
1734 Set_Parameter_Associations
(N
, No_List
);
1735 Analyze_Call_And_Resolve
;
1737 -- For the case of a reference to an element of an entry family, P is
1738 -- an indexed component whose prefix is a selected component (task and
1739 -- entry family), and whose index is the entry family index.
1741 elsif Nkind
(P
) = N_Indexed_Component
1742 and then Nkind
(Prefix
(P
)) = N_Selected_Component
1743 and then Ekind
(Entity
(Selector_Name
(Prefix
(P
)))) = E_Entry_Family
1745 Analyze_Call_And_Resolve
;
1747 -- If the prefix is the name of an entry family, it is a call from
1748 -- within the task body itself.
1750 elsif Nkind
(P
) = N_Indexed_Component
1751 and then Nkind
(Prefix
(P
)) = N_Identifier
1752 and then Ekind
(Entity
(Prefix
(P
))) = E_Entry_Family
1755 Make_Selected_Component
(Loc
,
1756 Prefix
=> New_Occurrence_Of
(Scope
(Entity
(Prefix
(P
))), Loc
),
1757 Selector_Name
=> New_Occurrence_Of
(Entity
(Prefix
(P
)), Loc
));
1758 Rewrite
(Prefix
(P
), New_N
);
1760 Analyze_Call_And_Resolve
;
1762 -- In Ada 2012. a qualified expression is a name, but it cannot be a
1763 -- procedure name, so the construct can only be a qualified expression.
1765 elsif Nkind
(P
) = N_Qualified_Expression
1766 and then Ada_Version
>= Ada_2012
1768 Rewrite
(N
, Make_Code_Statement
(Loc
, Expression
=> P
));
1771 -- Anything else is an error
1774 Error_Msg_N
("invalid procedure or entry call", N
);
1777 Ghost_Mode
:= Save_Ghost_Mode
;
1778 end Analyze_Procedure_Call
;
1780 ------------------------------
1781 -- Analyze_Return_Statement --
1782 ------------------------------
1784 procedure Analyze_Return_Statement
(N
: Node_Id
) is
1786 pragma Assert
(Nkind_In
(N
, N_Simple_Return_Statement
,
1787 N_Extended_Return_Statement
));
1789 Returns_Object
: constant Boolean :=
1790 Nkind
(N
) = N_Extended_Return_Statement
1792 (Nkind
(N
) = N_Simple_Return_Statement
1793 and then Present
(Expression
(N
)));
1794 -- True if we're returning something; that is, "return <expression>;"
1795 -- or "return Result : T [:= ...]". False for "return;". Used for error
1796 -- checking: If Returns_Object is True, N should apply to a function
1797 -- body; otherwise N should apply to a procedure body, entry body,
1798 -- accept statement, or extended return statement.
1800 function Find_What_It_Applies_To
return Entity_Id
;
1801 -- Find the entity representing the innermost enclosing body, accept
1802 -- statement, or extended return statement. If the result is a callable
1803 -- construct or extended return statement, then this will be the value
1804 -- of the Return_Applies_To attribute. Otherwise, the program is
1805 -- illegal. See RM-6.5(4/2).
1807 -----------------------------
1808 -- Find_What_It_Applies_To --
1809 -----------------------------
1811 function Find_What_It_Applies_To
return Entity_Id
is
1812 Result
: Entity_Id
:= Empty
;
1815 -- Loop outward through the Scope_Stack, skipping blocks, loops,
1816 -- and postconditions.
1818 for J
in reverse 0 .. Scope_Stack
.Last
loop
1819 Result
:= Scope_Stack
.Table
(J
).Entity
;
1820 exit when not Ekind_In
(Result
, E_Block
, E_Loop
)
1821 and then Chars
(Result
) /= Name_uPostconditions
;
1824 pragma Assert
(Present
(Result
));
1826 end Find_What_It_Applies_To
;
1828 -- Local declarations
1830 Scope_Id
: constant Entity_Id
:= Find_What_It_Applies_To
;
1831 Kind
: constant Entity_Kind
:= Ekind
(Scope_Id
);
1832 Loc
: constant Source_Ptr
:= Sloc
(N
);
1833 Stm_Entity
: constant Entity_Id
:=
1835 (E_Return_Statement
, Current_Scope
, Loc
, 'R');
1837 -- Start of processing for Analyze_Return_Statement
1840 Set_Return_Statement_Entity
(N
, Stm_Entity
);
1842 Set_Etype
(Stm_Entity
, Standard_Void_Type
);
1843 Set_Return_Applies_To
(Stm_Entity
, Scope_Id
);
1845 -- Place Return entity on scope stack, to simplify enforcement of 6.5
1846 -- (4/2): an inner return statement will apply to this extended return.
1848 if Nkind
(N
) = N_Extended_Return_Statement
then
1849 Push_Scope
(Stm_Entity
);
1852 -- Check that pragma No_Return is obeyed. Don't complain about the
1853 -- implicitly-generated return that is placed at the end.
1855 if No_Return
(Scope_Id
) and then Comes_From_Source
(N
) then
1856 Error_Msg_N
("RETURN statement not allowed (No_Return)", N
);
1859 -- Warn on any unassigned OUT parameters if in procedure
1861 if Ekind
(Scope_Id
) = E_Procedure
then
1862 Warn_On_Unassigned_Out_Parameter
(N
, Scope_Id
);
1865 -- Check that functions return objects, and other things do not
1867 if Kind
= E_Function
or else Kind
= E_Generic_Function
then
1868 if not Returns_Object
then
1869 Error_Msg_N
("missing expression in return from function", N
);
1872 elsif Kind
= E_Procedure
or else Kind
= E_Generic_Procedure
then
1873 if Returns_Object
then
1874 Error_Msg_N
("procedure cannot return value (use function)", N
);
1877 elsif Kind
= E_Entry
or else Kind
= E_Entry_Family
then
1878 if Returns_Object
then
1879 if Is_Protected_Type
(Scope
(Scope_Id
)) then
1880 Error_Msg_N
("entry body cannot return value", N
);
1882 Error_Msg_N
("accept statement cannot return value", N
);
1886 elsif Kind
= E_Return_Statement
then
1888 -- We are nested within another return statement, which must be an
1889 -- extended_return_statement.
1891 if Returns_Object
then
1892 if Nkind
(N
) = N_Extended_Return_Statement
then
1894 ("extended return statement cannot be nested (use `RETURN;`)",
1897 -- Case of a simple return statement with a value inside extended
1898 -- return statement.
1902 ("return nested in extended return statement cannot return "
1903 & "value (use `RETURN;`)", N
);
1908 Error_Msg_N
("illegal context for return statement", N
);
1911 if Ekind_In
(Kind
, E_Function
, E_Generic_Function
) then
1912 Analyze_Function_Return
(N
);
1914 elsif Ekind_In
(Kind
, E_Procedure
, E_Generic_Procedure
) then
1915 Set_Return_Present
(Scope_Id
);
1918 if Nkind
(N
) = N_Extended_Return_Statement
then
1922 Kill_Current_Values
(Last_Assignment_Only
=> True);
1923 Check_Unreachable_Code
(N
);
1925 Analyze_Dimension
(N
);
1926 end Analyze_Return_Statement
;
1928 -------------------------------------
1929 -- Analyze_Simple_Return_Statement --
1930 -------------------------------------
1932 procedure Analyze_Simple_Return_Statement
(N
: Node_Id
) is
1934 if Present
(Expression
(N
)) then
1935 Mark_Coextensions
(N
, Expression
(N
));
1938 Analyze_Return_Statement
(N
);
1939 end Analyze_Simple_Return_Statement
;
1941 -------------------------
1942 -- Analyze_Return_Type --
1943 -------------------------
1945 procedure Analyze_Return_Type
(N
: Node_Id
) is
1946 Designator
: constant Entity_Id
:= Defining_Entity
(N
);
1947 Typ
: Entity_Id
:= Empty
;
1950 -- Normal case where result definition does not indicate an error
1952 if Result_Definition
(N
) /= Error
then
1953 if Nkind
(Result_Definition
(N
)) = N_Access_Definition
then
1954 Check_SPARK_05_Restriction
1955 ("access result is not allowed", Result_Definition
(N
));
1957 -- Ada 2005 (AI-254): Handle anonymous access to subprograms
1960 AD
: constant Node_Id
:=
1961 Access_To_Subprogram_Definition
(Result_Definition
(N
));
1963 if Present
(AD
) and then Protected_Present
(AD
) then
1964 Typ
:= Replace_Anonymous_Access_To_Protected_Subprogram
(N
);
1966 Typ
:= Access_Definition
(N
, Result_Definition
(N
));
1970 Set_Parent
(Typ
, Result_Definition
(N
));
1971 Set_Is_Local_Anonymous_Access
(Typ
);
1972 Set_Etype
(Designator
, Typ
);
1974 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1976 Null_Exclusion_Static_Checks
(N
);
1978 -- Subtype_Mark case
1981 Find_Type
(Result_Definition
(N
));
1982 Typ
:= Entity
(Result_Definition
(N
));
1983 Set_Etype
(Designator
, Typ
);
1985 -- Unconstrained array as result is not allowed in SPARK
1987 if Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
1988 Check_SPARK_05_Restriction
1989 ("returning an unconstrained array is not allowed",
1990 Result_Definition
(N
));
1993 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1995 Null_Exclusion_Static_Checks
(N
);
1997 -- If a null exclusion is imposed on the result type, then create
1998 -- a null-excluding itype (an access subtype) and use it as the
1999 -- function's Etype. Note that the null exclusion checks are done
2000 -- right before this, because they don't get applied to types that
2001 -- do not come from source.
2003 if Is_Access_Type
(Typ
) and then Null_Exclusion_Present
(N
) then
2004 Set_Etype
(Designator
,
2005 Create_Null_Excluding_Itype
2008 Scope_Id
=> Scope
(Current_Scope
)));
2010 -- The new subtype must be elaborated before use because
2011 -- it is visible outside of the function. However its base
2012 -- type may not be frozen yet, so the reference that will
2013 -- force elaboration must be attached to the freezing of
2016 -- If the return specification appears on a proper body,
2017 -- the subtype will have been created already on the spec.
2019 if Is_Frozen
(Typ
) then
2020 if Nkind
(Parent
(N
)) = N_Subprogram_Body
2021 and then Nkind
(Parent
(Parent
(N
))) = N_Subunit
2025 Build_Itype_Reference
(Etype
(Designator
), Parent
(N
));
2029 Ensure_Freeze_Node
(Typ
);
2032 IR
: constant Node_Id
:= Make_Itype_Reference
(Sloc
(N
));
2034 Set_Itype
(IR
, Etype
(Designator
));
2035 Append_Freeze_Actions
(Typ
, New_List
(IR
));
2040 Set_Etype
(Designator
, Typ
);
2043 if Ekind
(Typ
) = E_Incomplete_Type
2044 or else (Is_Class_Wide_Type
(Typ
)
2045 and then Ekind
(Root_Type
(Typ
)) = E_Incomplete_Type
)
2047 -- AI05-0151: Tagged incomplete types are allowed in all formal
2048 -- parts. Untagged incomplete types are not allowed in bodies.
2049 -- As a consequence, limited views cannot appear in a basic
2050 -- declaration that is itself within a body, because there is
2051 -- no point at which the non-limited view will become visible.
2053 if Ada_Version
>= Ada_2012
then
2054 if From_Limited_With
(Typ
) and then In_Package_Body
then
2056 ("invalid use of incomplete type&",
2057 Result_Definition
(N
), Typ
);
2059 -- The return type of a subprogram body cannot be of a
2060 -- formal incomplete type.
2062 elsif Is_Generic_Type
(Typ
)
2063 and then Nkind
(Parent
(N
)) = N_Subprogram_Body
2066 ("return type cannot be a formal incomplete type",
2067 Result_Definition
(N
));
2069 elsif Is_Class_Wide_Type
(Typ
)
2070 and then Is_Generic_Type
(Root_Type
(Typ
))
2071 and then Nkind
(Parent
(N
)) = N_Subprogram_Body
2074 ("return type cannot be a formal incomplete type",
2075 Result_Definition
(N
));
2077 elsif Is_Tagged_Type
(Typ
) then
2080 -- Use is legal in a thunk generated for an operation
2081 -- inherited from a progenitor.
2083 elsif Is_Thunk
(Designator
)
2084 and then Present
(Non_Limited_View
(Typ
))
2088 elsif Nkind
(Parent
(N
)) = N_Subprogram_Body
2089 or else Nkind_In
(Parent
(Parent
(N
)), N_Accept_Statement
,
2093 ("invalid use of untagged incomplete type&",
2097 -- The type must be completed in the current package. This
2098 -- is checked at the end of the package declaration when
2099 -- Taft-amendment types are identified. If the return type
2100 -- is class-wide, there is no required check, the type can
2101 -- be a bona fide TAT.
2103 if Ekind
(Scope
(Current_Scope
)) = E_Package
2104 and then In_Private_Part
(Scope
(Current_Scope
))
2105 and then not Is_Class_Wide_Type
(Typ
)
2107 Append_Elmt
(Designator
, Private_Dependents
(Typ
));
2112 ("invalid use of incomplete type&", Designator
, Typ
);
2117 -- Case where result definition does indicate an error
2120 Set_Etype
(Designator
, Any_Type
);
2122 end Analyze_Return_Type
;
2124 -----------------------------
2125 -- Analyze_Subprogram_Body --
2126 -----------------------------
2128 procedure Analyze_Subprogram_Body
(N
: Node_Id
) is
2129 Loc
: constant Source_Ptr
:= Sloc
(N
);
2130 Body_Spec
: constant Node_Id
:= Specification
(N
);
2131 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Spec
);
2134 if Debug_Flag_C
then
2135 Write_Str
("==> subprogram body ");
2136 Write_Name
(Chars
(Body_Id
));
2137 Write_Str
(" from ");
2138 Write_Location
(Loc
);
2143 Trace_Scope
(N
, Body_Id
, " Analyze subprogram: ");
2145 -- The real work is split out into the helper, so it can do "return;"
2146 -- without skipping the debug output:
2148 Analyze_Subprogram_Body_Helper
(N
);
2150 if Debug_Flag_C
then
2152 Write_Str
("<== subprogram body ");
2153 Write_Name
(Chars
(Body_Id
));
2154 Write_Str
(" from ");
2155 Write_Location
(Loc
);
2158 end Analyze_Subprogram_Body
;
2160 ------------------------------------
2161 -- Analyze_Subprogram_Body_Helper --
2162 ------------------------------------
2164 -- This procedure is called for regular subprogram bodies, generic bodies,
2165 -- and for subprogram stubs of both kinds. In the case of stubs, only the
2166 -- specification matters, and is used to create a proper declaration for
2167 -- the subprogram, or to perform conformance checks.
2169 procedure Analyze_Subprogram_Body_Helper
(N
: Node_Id
) is
2170 Body_Spec
: Node_Id
:= Specification
(N
);
2171 Body_Id
: Entity_Id
:= Defining_Entity
(Body_Spec
);
2172 Loc
: constant Source_Ptr
:= Sloc
(N
);
2173 Prev_Id
: constant Entity_Id
:= Current_Entity_In_Scope
(Body_Id
);
2175 Conformant
: Boolean;
2176 Desig_View
: Entity_Id
:= Empty
;
2177 Exch_Views
: Elist_Id
:= No_Elist
;
2179 Prot_Typ
: Entity_Id
:= Empty
;
2180 Spec_Decl
: Node_Id
:= Empty
;
2181 Spec_Id
: Entity_Id
;
2183 Last_Real_Spec_Entity
: Entity_Id
:= Empty
;
2184 -- When we analyze a separate spec, the entity chain ends up containing
2185 -- the formals, as well as any itypes generated during analysis of the
2186 -- default expressions for parameters, or the arguments of associated
2187 -- precondition/postcondition pragmas (which are analyzed in the context
2188 -- of the spec since they have visibility on formals).
2190 -- These entities belong with the spec and not the body. However we do
2191 -- the analysis of the body in the context of the spec (again to obtain
2192 -- visibility to the formals), and all the entities generated during
2193 -- this analysis end up also chained to the entity chain of the spec.
2194 -- But they really belong to the body, and there is circuitry to move
2195 -- them from the spec to the body.
2197 -- However, when we do this move, we don't want to move the real spec
2198 -- entities (first para above) to the body. The Last_Real_Spec_Entity
2199 -- variable points to the last real spec entity, so we only move those
2200 -- chained beyond that point. It is initialized to Empty to deal with
2201 -- the case where there is no separate spec.
2203 function Body_Has_Contract
return Boolean;
2204 -- Check whether unanalyzed body has an aspect or pragma that may
2205 -- generate a SPARK contract.
2207 function Body_Has_SPARK_Mode_On
return Boolean;
2208 -- Check whether SPARK_Mode On applies to the subprogram body, either
2209 -- because it is specified directly on the body, or because it is
2210 -- inherited from the enclosing subprogram or package.
2212 procedure Build_Subprogram_Declaration
;
2213 -- Create a matching subprogram declaration for subprogram body N
2215 procedure Check_Anonymous_Return
;
2216 -- Ada 2005: if a function returns an access type that denotes a task,
2217 -- or a type that contains tasks, we must create a master entity for
2218 -- the anonymous type, which typically will be used in an allocator
2219 -- in the body of the function.
2221 procedure Check_Inline_Pragma
(Spec
: in out Node_Id
);
2222 -- Look ahead to recognize a pragma that may appear after the body.
2223 -- If there is a previous spec, check that it appears in the same
2224 -- declarative part. If the pragma is Inline_Always, perform inlining
2225 -- unconditionally, otherwise only if Front_End_Inlining is requested.
2226 -- If the body acts as a spec, and inlining is required, we create a
2227 -- subprogram declaration for it, in order to attach the body to inline.
2228 -- If pragma does not appear after the body, check whether there is
2229 -- an inline pragma before any local declarations.
2231 procedure Check_Missing_Return
;
2232 -- Checks for a function with a no return statements, and also performs
2233 -- the warning checks implemented by Check_Returns. In formal mode, also
2234 -- verify that a function ends with a RETURN and that a procedure does
2235 -- not contain any RETURN.
2237 function Disambiguate_Spec
return Entity_Id
;
2238 -- When a primitive is declared between the private view and the full
2239 -- view of a concurrent type which implements an interface, a special
2240 -- mechanism is used to find the corresponding spec of the primitive
2243 function Exchange_Limited_Views
(Subp_Id
: Entity_Id
) return Elist_Id
;
2244 -- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains
2245 -- incomplete types coming from a limited context and replace their
2246 -- limited views with the non-limited ones. Return the list of changes
2247 -- to be used to undo the transformation.
2249 function Is_Private_Concurrent_Primitive
2250 (Subp_Id
: Entity_Id
) return Boolean;
2251 -- Determine whether subprogram Subp_Id is a primitive of a concurrent
2252 -- type that implements an interface and has a private view.
2254 procedure Restore_Limited_Views
(Restore_List
: Elist_Id
);
2255 -- Undo the transformation done by Exchange_Limited_Views.
2257 procedure Set_Trivial_Subprogram
(N
: Node_Id
);
2258 -- Sets the Is_Trivial_Subprogram flag in both spec and body of the
2259 -- subprogram whose body is being analyzed. N is the statement node
2260 -- causing the flag to be set, if the following statement is a return
2261 -- of an entity, we mark the entity as set in source to suppress any
2262 -- warning on the stylized use of function stubs with a dummy return.
2264 procedure Verify_Overriding_Indicator
;
2265 -- If there was a previous spec, the entity has been entered in the
2266 -- current scope previously. If the body itself carries an overriding
2267 -- indicator, check that it is consistent with the known status of the
2270 -----------------------
2271 -- Body_Has_Contract --
2272 -----------------------
2274 function Body_Has_Contract
return Boolean is
2275 Decls
: constant List_Id
:= Declarations
(N
);
2279 -- Check for aspects that may generate a contract
2281 if Present
(Aspect_Specifications
(N
)) then
2282 Item
:= First
(Aspect_Specifications
(N
));
2283 while Present
(Item
) loop
2284 if Is_Subprogram_Contract_Annotation
(Item
) then
2292 -- Check for pragmas that may generate a contract
2294 if Present
(Decls
) then
2295 Item
:= First
(Decls
);
2296 while Present
(Item
) loop
2297 if Nkind
(Item
) = N_Pragma
2298 and then Is_Subprogram_Contract_Annotation
(Item
)
2308 end Body_Has_Contract
;
2310 ----------------------------
2311 -- Body_Has_SPARK_Mode_On --
2312 ----------------------------
2314 function Body_Has_SPARK_Mode_On
return Boolean is
2315 Decls
: constant List_Id
:= Declarations
(N
);
2319 -- Check for SPARK_Mode aspect
2321 if Present
(Aspect_Specifications
(N
)) then
2322 Item
:= First
(Aspect_Specifications
(N
));
2323 while Present
(Item
) loop
2324 if Get_Aspect_Id
(Item
) = Aspect_SPARK_Mode
then
2325 return Get_SPARK_Mode_From_Annotation
(Item
) = On
;
2332 -- Check for SPARK_Mode pragma
2334 if Present
(Decls
) then
2335 Item
:= First
(Decls
);
2336 while Present
(Item
) loop
2338 -- Pragmas that apply to a subprogram body are usually grouped
2339 -- together. Look for a potential pragma SPARK_Mode among them.
2341 if Nkind
(Item
) = N_Pragma
then
2342 if Get_Pragma_Id
(Item
) = Pragma_SPARK_Mode
then
2343 return Get_SPARK_Mode_From_Annotation
(Item
) = On
;
2346 -- Otherwise the first non-pragma declarative item terminates
2347 -- the region where pragma SPARK_Mode may appear.
2357 -- Otherwise, the applicable SPARK_Mode is inherited from the
2358 -- enclosing subprogram or package.
2360 return SPARK_Mode
= On
;
2361 end Body_Has_SPARK_Mode_On
;
2363 ----------------------------------
2364 -- Build_Subprogram_Declaration --
2365 ----------------------------------
2367 procedure Build_Subprogram_Declaration
is
2368 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
);
2369 -- Relocate certain categorization pragmas from the declarative list
2370 -- of subprogram body From and insert them after node To. The pragmas
2374 -- Volatile_Function
2380 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
) is
2382 Next_Decl
: Node_Id
;
2385 pragma Assert
(Nkind
(From
) = N_Subprogram_Body
);
2387 -- The destination node must be part of a list, as the pragmas are
2388 -- inserted after it.
2390 pragma Assert
(Is_List_Member
(To
));
2392 -- Inspect the declarations of the subprogram body looking for
2393 -- specific pragmas.
2395 Decl
:= First
(Declarations
(N
));
2396 while Present
(Decl
) loop
2397 Next_Decl
:= Next
(Decl
);
2399 if Nkind
(Decl
) = N_Pragma
2400 and then Nam_In
(Pragma_Name
(Decl
), Name_Ghost
,
2402 Name_Volatile_Function
)
2405 Insert_After
(To
, Decl
);
2415 Subp_Decl
: Node_Id
;
2417 -- Start of processing for Build_Subprogram_Declaration
2420 -- Create a matching subprogram spec using the profile of the body.
2421 -- The structure of the tree is identical, but has new entities for
2422 -- the defining unit name and formal parameters.
2425 Make_Subprogram_Declaration
(Loc
,
2426 Specification
=> Copy_Subprogram_Spec
(Body_Spec
));
2427 Set_Comes_From_Source
(Subp_Decl
, True);
2429 -- Relocate the aspects and relevant pragmas from the subprogram body
2430 -- to the generated spec because it acts as the initial declaration.
2432 Insert_Before
(N
, Subp_Decl
);
2433 Move_Aspects
(N
, To
=> Subp_Decl
);
2434 Move_Pragmas
(N
, To
=> Subp_Decl
);
2436 Analyze
(Subp_Decl
);
2438 -- Propagate the attributes Rewritten_For_C and Corresponding_Proc to
2439 -- the body since the expander may generate calls using that entity.
2440 -- Required to ensure that Expand_Call rewrites calls to this
2441 -- function by calls to the built procedure.
2443 if Modify_Tree_For_C
2444 and then Nkind
(Body_Spec
) = N_Function_Specification
2446 Rewritten_For_C
(Defining_Entity
(Specification
(Subp_Decl
)))
2448 Set_Rewritten_For_C
(Defining_Entity
(Body_Spec
));
2449 Set_Corresponding_Procedure
(Defining_Entity
(Body_Spec
),
2450 Corresponding_Procedure
2451 (Defining_Entity
(Specification
(Subp_Decl
))));
2454 -- Analyze any relocated source pragmas or pragmas created for aspect
2457 Decl
:= Next
(Subp_Decl
);
2458 while Present
(Decl
) loop
2460 -- Stop the search for pragmas once the body has been reached as
2461 -- this terminates the region where pragmas may appear.
2466 elsif Nkind
(Decl
) = N_Pragma
then
2473 Spec_Id
:= Defining_Entity
(Subp_Decl
);
2474 Set_Corresponding_Spec
(N
, Spec_Id
);
2476 -- Mark the generated spec as a source construct to ensure that all
2477 -- calls to it are properly registered in ALI files for GNATprove.
2479 Set_Comes_From_Source
(Spec_Id
, True);
2481 -- Ensure that the specs of the subprogram declaration and its body
2482 -- are identical, otherwise they will appear non-conformant due to
2483 -- rewritings in the default values of formal parameters.
2485 Body_Spec
:= Copy_Subprogram_Spec
(Body_Spec
);
2486 Set_Specification
(N
, Body_Spec
);
2487 Body_Id
:= Analyze_Subprogram_Specification
(Body_Spec
);
2489 -- Ensure that the generated corresponding spec and original body
2490 -- share the same Ghost and SPARK_Mode attributes.
2492 Set_Is_Checked_Ghost_Entity
2493 (Body_Id
, Is_Checked_Ghost_Entity
(Spec_Id
));
2494 Set_Is_Ignored_Ghost_Entity
2495 (Body_Id
, Is_Ignored_Ghost_Entity
(Spec_Id
));
2497 Set_SPARK_Pragma
(Body_Id
, SPARK_Pragma
(Spec_Id
));
2498 Set_SPARK_Pragma_Inherited
2499 (Body_Id
, SPARK_Pragma_Inherited
(Spec_Id
));
2500 end Build_Subprogram_Declaration
;
2502 ----------------------------
2503 -- Check_Anonymous_Return --
2504 ----------------------------
2506 procedure Check_Anonymous_Return
is
2512 if Present
(Spec_Id
) then
2518 if Ekind
(Scop
) = E_Function
2519 and then Ekind
(Etype
(Scop
)) = E_Anonymous_Access_Type
2520 and then not Is_Thunk
(Scop
)
2522 -- Skip internally built functions which handle the case of
2523 -- a null access (see Expand_Interface_Conversion)
2525 and then not (Is_Interface
(Designated_Type
(Etype
(Scop
)))
2526 and then not Comes_From_Source
(Parent
(Scop
)))
2528 and then (Has_Task
(Designated_Type
(Etype
(Scop
)))
2530 (Is_Class_Wide_Type
(Designated_Type
(Etype
(Scop
)))
2532 Is_Limited_Record
(Designated_Type
(Etype
(Scop
)))))
2533 and then Expander_Active
2535 -- Avoid cases with no tasking support
2537 and then RTE_Available
(RE_Current_Master
)
2538 and then not Restriction_Active
(No_Task_Hierarchy
)
2541 Make_Object_Declaration
(Loc
,
2542 Defining_Identifier
=>
2543 Make_Defining_Identifier
(Loc
, Name_uMaster
),
2544 Constant_Present
=> True,
2545 Object_Definition
=>
2546 New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
2548 Make_Explicit_Dereference
(Loc
,
2549 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
2551 if Present
(Declarations
(N
)) then
2552 Prepend
(Decl
, Declarations
(N
));
2554 Set_Declarations
(N
, New_List
(Decl
));
2557 Set_Master_Id
(Etype
(Scop
), Defining_Identifier
(Decl
));
2558 Set_Has_Master_Entity
(Scop
);
2560 -- Now mark the containing scope as a task master
2563 while Nkind
(Par
) /= N_Compilation_Unit
loop
2564 Par
:= Parent
(Par
);
2565 pragma Assert
(Present
(Par
));
2567 -- If we fall off the top, we are at the outer level, and
2568 -- the environment task is our effective master, so nothing
2572 (Par
, N_Task_Body
, N_Block_Statement
, N_Subprogram_Body
)
2574 Set_Is_Task_Master
(Par
, True);
2579 end Check_Anonymous_Return
;
2581 -------------------------
2582 -- Check_Inline_Pragma --
2583 -------------------------
2585 procedure Check_Inline_Pragma
(Spec
: in out Node_Id
) is
2589 function Is_Inline_Pragma
(N
: Node_Id
) return Boolean;
2590 -- True when N is a pragma Inline or Inline_Always that applies
2591 -- to this subprogram.
2593 -----------------------
2594 -- Is_Inline_Pragma --
2595 -----------------------
2597 function Is_Inline_Pragma
(N
: Node_Id
) return Boolean is
2599 if Nkind
(N
) = N_Pragma
2601 (Pragma_Name
(N
) = Name_Inline_Always
2602 or else (Pragma_Name
(N
) = Name_Inline
2604 (Front_End_Inlining
or else Optimization_Level
> 0)))
2605 and then Present
(Pragma_Argument_Associations
(N
))
2608 Pragma_Arg
: Node_Id
:=
2609 Expression
(First
(Pragma_Argument_Associations
(N
)));
2611 if Nkind
(Pragma_Arg
) = N_Selected_Component
then
2612 Pragma_Arg
:= Selector_Name
(Pragma_Arg
);
2615 return Chars
(Pragma_Arg
) = Chars
(Body_Id
);
2621 end Is_Inline_Pragma
;
2623 -- Start of processing for Check_Inline_Pragma
2626 if not Expander_Active
then
2630 if Is_List_Member
(N
)
2631 and then Present
(Next
(N
))
2632 and then Is_Inline_Pragma
(Next
(N
))
2636 elsif Nkind
(N
) /= N_Subprogram_Body_Stub
2637 and then Present
(Declarations
(N
))
2638 and then Is_Inline_Pragma
(First
(Declarations
(N
)))
2640 Prag
:= First
(Declarations
(N
));
2646 if Present
(Prag
) then
2647 if Present
(Spec_Id
) then
2648 if Is_List_Member
(N
)
2649 and then Is_List_Member
(Unit_Declaration_Node
(Spec_Id
))
2650 and then In_Same_List
(N
, Unit_Declaration_Node
(Spec_Id
))
2656 -- Create a subprogram declaration, to make treatment uniform.
2657 -- Make the sloc of the subprogram name that of the entity in
2658 -- the body, so that style checks find identical strings.
2661 Subp
: constant Entity_Id
:=
2662 Make_Defining_Identifier
2663 (Sloc
(Body_Id
), Chars
(Body_Id
));
2664 Decl
: constant Node_Id
:=
2665 Make_Subprogram_Declaration
(Loc
,
2667 New_Copy_Tree
(Specification
(N
)));
2670 Set_Defining_Unit_Name
(Specification
(Decl
), Subp
);
2672 -- To ensure proper coverage when body is inlined, indicate
2673 -- whether the subprogram comes from source.
2675 Set_Comes_From_Source
(Subp
, Comes_From_Source
(N
));
2677 if Present
(First_Formal
(Body_Id
)) then
2678 Plist
:= Copy_Parameter_List
(Body_Id
);
2679 Set_Parameter_Specifications
2680 (Specification
(Decl
), Plist
);
2683 -- Move aspects to the new spec
2685 if Has_Aspects
(N
) then
2686 Move_Aspects
(N
, To
=> Decl
);
2689 Insert_Before
(N
, Decl
);
2692 Set_Has_Pragma_Inline
(Subp
);
2694 if Pragma_Name
(Prag
) = Name_Inline_Always
then
2695 Set_Is_Inlined
(Subp
);
2696 Set_Has_Pragma_Inline_Always
(Subp
);
2699 -- Prior to copying the subprogram body to create a template
2700 -- for it for subsequent inlining, remove the pragma from
2701 -- the current body so that the copy that will produce the
2702 -- new body will start from a completely unanalyzed tree.
2704 if Nkind
(Parent
(Prag
)) = N_Subprogram_Body
then
2705 Rewrite
(Prag
, Make_Null_Statement
(Sloc
(Prag
)));
2712 end Check_Inline_Pragma
;
2714 --------------------------
2715 -- Check_Missing_Return --
2716 --------------------------
2718 procedure Check_Missing_Return
is
2720 Missing_Ret
: Boolean;
2723 if Nkind
(Body_Spec
) = N_Function_Specification
then
2724 if Present
(Spec_Id
) then
2730 if Return_Present
(Id
) then
2731 Check_Returns
(HSS
, 'F', Missing_Ret
);
2734 Set_Has_Missing_Return
(Id
);
2737 -- Within a premature instantiation of a package with no body, we
2738 -- build completions of the functions therein, with a Raise
2739 -- statement. No point in complaining about a missing return in
2742 elsif Ekind
(Id
) = E_Function
2743 and then In_Instance
2744 and then Present
(Statements
(HSS
))
2745 and then Nkind
(First
(Statements
(HSS
))) = N_Raise_Program_Error
2749 elsif Is_Generic_Subprogram
(Id
)
2750 or else not Is_Machine_Code_Subprogram
(Id
)
2752 Error_Msg_N
("missing RETURN statement in function body", N
);
2755 -- If procedure with No_Return, check returns
2757 elsif Nkind
(Body_Spec
) = N_Procedure_Specification
2758 and then Present
(Spec_Id
)
2759 and then No_Return
(Spec_Id
)
2761 Check_Returns
(HSS
, 'P', Missing_Ret
, Spec_Id
);
2764 -- Special checks in SPARK mode
2766 if Nkind
(Body_Spec
) = N_Function_Specification
then
2768 -- In SPARK mode, last statement of a function should be a return
2771 Stat
: constant Node_Id
:= Last_Source_Statement
(HSS
);
2774 and then not Nkind_In
(Stat
, N_Simple_Return_Statement
,
2775 N_Extended_Return_Statement
)
2777 Check_SPARK_05_Restriction
2778 ("last statement in function should be RETURN", Stat
);
2782 -- In SPARK mode, verify that a procedure has no return
2784 elsif Nkind
(Body_Spec
) = N_Procedure_Specification
then
2785 if Present
(Spec_Id
) then
2791 -- Would be nice to point to return statement here, can we
2792 -- borrow the Check_Returns procedure here ???
2794 if Return_Present
(Id
) then
2795 Check_SPARK_05_Restriction
2796 ("procedure should not have RETURN", N
);
2799 end Check_Missing_Return
;
2801 -----------------------
2802 -- Disambiguate_Spec --
2803 -----------------------
2805 function Disambiguate_Spec
return Entity_Id
is
2806 Priv_Spec
: Entity_Id
;
2809 procedure Replace_Types
(To_Corresponding
: Boolean);
2810 -- Depending on the flag, replace the type of formal parameters of
2811 -- Body_Id if it is a concurrent type implementing interfaces with
2812 -- the corresponding record type or the other way around.
2814 procedure Replace_Types
(To_Corresponding
: Boolean) is
2816 Formal_Typ
: Entity_Id
;
2819 Formal
:= First_Formal
(Body_Id
);
2820 while Present
(Formal
) loop
2821 Formal_Typ
:= Etype
(Formal
);
2823 if Is_Class_Wide_Type
(Formal_Typ
) then
2824 Formal_Typ
:= Root_Type
(Formal_Typ
);
2827 -- From concurrent type to corresponding record
2829 if To_Corresponding
then
2830 if Is_Concurrent_Type
(Formal_Typ
)
2831 and then Present
(Corresponding_Record_Type
(Formal_Typ
))
2834 (Corresponding_Record_Type
(Formal_Typ
)))
2837 Corresponding_Record_Type
(Formal_Typ
));
2840 -- From corresponding record to concurrent type
2843 if Is_Concurrent_Record_Type
(Formal_Typ
)
2844 and then Present
(Interfaces
(Formal_Typ
))
2847 Corresponding_Concurrent_Type
(Formal_Typ
));
2851 Next_Formal
(Formal
);
2855 -- Start of processing for Disambiguate_Spec
2858 -- Try to retrieve the specification of the body as is. All error
2859 -- messages are suppressed because the body may not have a spec in
2860 -- its current state.
2862 Spec_N
:= Find_Corresponding_Spec
(N
, False);
2864 -- It is possible that this is the body of a primitive declared
2865 -- between a private and a full view of a concurrent type. The
2866 -- controlling parameter of the spec carries the concurrent type,
2867 -- not the corresponding record type as transformed by Analyze_
2868 -- Subprogram_Specification. In such cases, we undo the change
2869 -- made by the analysis of the specification and try to find the
2872 -- Note that wrappers already have their corresponding specs and
2873 -- bodies set during their creation, so if the candidate spec is
2874 -- a wrapper, then we definitely need to swap all types to their
2875 -- original concurrent status.
2878 or else Is_Primitive_Wrapper
(Spec_N
)
2880 -- Restore all references of corresponding record types to the
2881 -- original concurrent types.
2883 Replace_Types
(To_Corresponding
=> False);
2884 Priv_Spec
:= Find_Corresponding_Spec
(N
, False);
2886 -- The current body truly belongs to a primitive declared between
2887 -- a private and a full view. We leave the modified body as is,
2888 -- and return the true spec.
2890 if Present
(Priv_Spec
)
2891 and then Is_Private_Primitive
(Priv_Spec
)
2896 -- In case that this is some sort of error, restore the original
2897 -- state of the body.
2899 Replace_Types
(To_Corresponding
=> True);
2903 end Disambiguate_Spec
;
2905 ----------------------------
2906 -- Exchange_Limited_Views --
2907 ----------------------------
2909 function Exchange_Limited_Views
(Subp_Id
: Entity_Id
) return Elist_Id
is
2910 Result
: Elist_Id
:= No_Elist
;
2912 procedure Detect_And_Exchange
(Id
: Entity_Id
);
2913 -- Determine whether Id's type denotes an incomplete type associated
2914 -- with a limited with clause and exchange the limited view with the
2915 -- non-limited one when available. Note that the non-limited view
2916 -- may exist because of a with_clause in another unit in the context,
2917 -- but cannot be used because the current view of the enclosing unit
2918 -- is still a limited view.
2920 -------------------------
2921 -- Detect_And_Exchange --
2922 -------------------------
2924 procedure Detect_And_Exchange
(Id
: Entity_Id
) is
2925 Typ
: constant Entity_Id
:= Etype
(Id
);
2927 if From_Limited_With
(Typ
)
2928 and then Has_Non_Limited_View
(Typ
)
2929 and then not From_Limited_With
(Scope
(Typ
))
2932 Result
:= New_Elmt_List
;
2935 Prepend_Elmt
(Typ
, Result
);
2936 Prepend_Elmt
(Id
, Result
);
2937 Set_Etype
(Id
, Non_Limited_View
(Typ
));
2939 end Detect_And_Exchange
;
2945 -- Start of processing for Exchange_Limited_Views
2948 -- Do not process subprogram bodies as they already use the non-
2949 -- limited view of types.
2951 if not Ekind_In
(Subp_Id
, E_Function
, E_Procedure
) then
2955 -- Examine all formals and swap views when applicable
2957 Formal
:= First_Formal
(Subp_Id
);
2958 while Present
(Formal
) loop
2959 Detect_And_Exchange
(Formal
);
2961 Next_Formal
(Formal
);
2964 -- Process the return type of a function
2966 if Ekind
(Subp_Id
) = E_Function
then
2967 Detect_And_Exchange
(Subp_Id
);
2971 end Exchange_Limited_Views
;
2973 -------------------------------------
2974 -- Is_Private_Concurrent_Primitive --
2975 -------------------------------------
2977 function Is_Private_Concurrent_Primitive
2978 (Subp_Id
: Entity_Id
) return Boolean
2980 Formal_Typ
: Entity_Id
;
2983 if Present
(First_Formal
(Subp_Id
)) then
2984 Formal_Typ
:= Etype
(First_Formal
(Subp_Id
));
2986 if Is_Concurrent_Record_Type
(Formal_Typ
) then
2987 if Is_Class_Wide_Type
(Formal_Typ
) then
2988 Formal_Typ
:= Root_Type
(Formal_Typ
);
2991 Formal_Typ
:= Corresponding_Concurrent_Type
(Formal_Typ
);
2994 -- The type of the first formal is a concurrent tagged type with
2998 Is_Concurrent_Type
(Formal_Typ
)
2999 and then Is_Tagged_Type
(Formal_Typ
)
3000 and then Has_Private_Declaration
(Formal_Typ
);
3004 end Is_Private_Concurrent_Primitive
;
3006 ---------------------------
3007 -- Restore_Limited_Views --
3008 ---------------------------
3010 procedure Restore_Limited_Views
(Restore_List
: Elist_Id
) is
3011 Elmt
: Elmt_Id
:= First_Elmt
(Restore_List
);
3015 while Present
(Elmt
) loop
3018 Set_Etype
(Id
, Node
(Elmt
));
3021 end Restore_Limited_Views
;
3023 ----------------------------
3024 -- Set_Trivial_Subprogram --
3025 ----------------------------
3027 procedure Set_Trivial_Subprogram
(N
: Node_Id
) is
3028 Nxt
: constant Node_Id
:= Next
(N
);
3031 Set_Is_Trivial_Subprogram
(Body_Id
);
3033 if Present
(Spec_Id
) then
3034 Set_Is_Trivial_Subprogram
(Spec_Id
);
3038 and then Nkind
(Nxt
) = N_Simple_Return_Statement
3039 and then No
(Next
(Nxt
))
3040 and then Present
(Expression
(Nxt
))
3041 and then Is_Entity_Name
(Expression
(Nxt
))
3043 Set_Never_Set_In_Source
(Entity
(Expression
(Nxt
)), False);
3045 end Set_Trivial_Subprogram
;
3047 ---------------------------------
3048 -- Verify_Overriding_Indicator --
3049 ---------------------------------
3051 procedure Verify_Overriding_Indicator
is
3053 if Must_Override
(Body_Spec
) then
3054 if Nkind
(Spec_Id
) = N_Defining_Operator_Symbol
3055 and then Operator_Matches_Spec
(Spec_Id
, Spec_Id
)
3059 elsif not Present
(Overridden_Operation
(Spec_Id
)) then
3061 ("subprogram& is not overriding", Body_Spec
, Spec_Id
);
3063 -- Overriding indicators aren't allowed for protected subprogram
3064 -- bodies (see the Confirmation in Ada Comment AC95-00213). Change
3065 -- this to a warning if -gnatd.E is enabled.
3067 elsif Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
3068 Error_Msg_Warn
:= Error_To_Warning
;
3070 ("<<overriding indicator not allowed for protected "
3071 & "subprogram body", Body_Spec
);
3074 elsif Must_Not_Override
(Body_Spec
) then
3075 if Present
(Overridden_Operation
(Spec_Id
)) then
3077 ("subprogram& overrides inherited operation",
3078 Body_Spec
, Spec_Id
);
3080 elsif Nkind
(Spec_Id
) = N_Defining_Operator_Symbol
3081 and then Operator_Matches_Spec
(Spec_Id
, Spec_Id
)
3084 ("subprogram& overrides predefined operator ",
3085 Body_Spec
, Spec_Id
);
3087 -- Overriding indicators aren't allowed for protected subprogram
3088 -- bodies (see the Confirmation in Ada Comment AC95-00213). Change
3089 -- this to a warning if -gnatd.E is enabled.
3091 elsif Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
3092 Error_Msg_Warn
:= Error_To_Warning
;
3095 ("<<overriding indicator not allowed "
3096 & "for protected subprogram body", Body_Spec
);
3098 -- If this is not a primitive operation, then the overriding
3099 -- indicator is altogether illegal.
3101 elsif not Is_Primitive
(Spec_Id
) then
3103 ("overriding indicator only allowed "
3104 & "if subprogram is primitive", Body_Spec
);
3107 -- If checking the style rule and the operation overrides, then
3108 -- issue a warning about a missing overriding_indicator. Protected
3109 -- subprogram bodies are excluded from this style checking, since
3110 -- they aren't primitives (even though their declarations can
3111 -- override) and aren't allowed to have an overriding_indicator.
3114 and then Present
(Overridden_Operation
(Spec_Id
))
3115 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
3117 pragma Assert
(Unit_Declaration_Node
(Body_Id
) = N
);
3118 Style
.Missing_Overriding
(N
, Body_Id
);
3121 and then Can_Override_Operator
(Spec_Id
)
3122 and then not Is_Predefined_File_Name
3123 (Unit_File_Name
(Get_Source_Unit
(Spec_Id
)))
3125 pragma Assert
(Unit_Declaration_Node
(Body_Id
) = N
);
3126 Style
.Missing_Overriding
(N
, Body_Id
);
3128 end Verify_Overriding_Indicator
;
3132 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
3134 -- Start of processing for Analyze_Subprogram_Body_Helper
3137 -- A [generic] subprogram body "freezes" the contract of the nearest
3138 -- enclosing package body and all other contracts encountered in the
3139 -- same declarative part up to and excluding the subprogram body:
3141 -- package body Nearest_Enclosing_Package
3142 -- with Refined_State => (State => Constit)
3146 -- procedure Freezes_Enclosing_Package_Body
3147 -- with Refined_Depends => (Input => Constit) ...
3149 -- This ensures that any annotations referenced by the contract of the
3150 -- [generic] subprogram body are available. This form of "freezing" is
3151 -- decoupled from the usual Freeze_xxx mechanism because it must also
3152 -- work in the context of generics where normal freezing is disabled.
3154 -- Only bodies coming from source should cause this type of "freezing".
3155 -- Expression functions that act as bodies and complete an initial
3156 -- declaration must be included in this category, hence the use of
3159 if Comes_From_Source
(Original_Node
(N
)) then
3160 Analyze_Previous_Contracts
(N
);
3163 -- Generic subprograms are handled separately. They always have a
3164 -- generic specification. Determine whether current scope has a
3165 -- previous declaration.
3167 -- If the subprogram body is defined within an instance of the same
3168 -- name, the instance appears as a package renaming, and will be hidden
3169 -- within the subprogram.
3171 if Present
(Prev_Id
)
3172 and then not Is_Overloadable
(Prev_Id
)
3173 and then (Nkind
(Parent
(Prev_Id
)) /= N_Package_Renaming_Declaration
3174 or else Comes_From_Source
(Prev_Id
))
3176 if Is_Generic_Subprogram
(Prev_Id
) then
3179 -- A subprogram body is Ghost when it is stand alone and subject
3180 -- to pragma Ghost or when the corresponding spec is Ghost. Set
3181 -- the mode now to ensure that any nodes generated during analysis
3182 -- and expansion are properly marked as Ghost.
3184 Set_Ghost_Mode
(N
, Spec_Id
);
3185 Set_Is_Compilation_Unit
(Body_Id
, Is_Compilation_Unit
(Spec_Id
));
3186 Set_Is_Child_Unit
(Body_Id
, Is_Child_Unit
(Spec_Id
));
3188 Analyze_Generic_Subprogram_Body
(N
, Spec_Id
);
3190 if Nkind
(N
) = N_Subprogram_Body
then
3191 HSS
:= Handled_Statement_Sequence
(N
);
3192 Check_Missing_Return
;
3195 Ghost_Mode
:= Save_Ghost_Mode
;
3199 -- Previous entity conflicts with subprogram name. Attempting to
3200 -- enter name will post error.
3202 Enter_Name
(Body_Id
);
3203 Ghost_Mode
:= Save_Ghost_Mode
;
3207 -- Non-generic case, find the subprogram declaration, if one was seen,
3208 -- or enter new overloaded entity in the current scope. If the
3209 -- Current_Entity is the Body_Id itself, the unit is being analyzed as
3210 -- part of the context of one of its subunits. No need to redo the
3213 elsif Prev_Id
= Body_Id
and then Has_Completion
(Body_Id
) then
3214 Ghost_Mode
:= Save_Ghost_Mode
;
3218 Body_Id
:= Analyze_Subprogram_Specification
(Body_Spec
);
3220 if Nkind
(N
) = N_Subprogram_Body_Stub
3221 or else No
(Corresponding_Spec
(N
))
3223 if Is_Private_Concurrent_Primitive
(Body_Id
) then
3224 Spec_Id
:= Disambiguate_Spec
;
3226 -- A subprogram body is Ghost when it is stand alone and
3227 -- subject to pragma Ghost or when the corresponding spec is
3228 -- Ghost. Set the mode now to ensure that any nodes generated
3229 -- during analysis and expansion are properly marked as Ghost.
3231 Set_Ghost_Mode
(N
, Spec_Id
);
3234 Spec_Id
:= Find_Corresponding_Spec
(N
);
3236 -- A subprogram body is Ghost when it is stand alone and
3237 -- subject to pragma Ghost or when the corresponding spec is
3238 -- Ghost. Set the mode now to ensure that any nodes generated
3239 -- during analysis and expansion are properly marked as Ghost.
3241 Set_Ghost_Mode
(N
, Spec_Id
);
3243 -- In GNATprove mode, if the body has no previous spec, create
3244 -- one so that the inlining machinery can operate properly.
3245 -- Transfer aspects, if any, to the new spec, so that they
3246 -- are legal and can be processed ahead of the body.
3247 -- We make two copies of the given spec, one for the new
3248 -- declaration, and one for the body.
3250 if No
(Spec_Id
) and then GNATprove_Mode
3252 -- Inlining does not apply during pre-analysis of code
3254 and then Full_Analysis
3256 -- Inlining only applies to full bodies, not stubs
3258 and then Nkind
(N
) /= N_Subprogram_Body_Stub
3260 -- Inlining only applies to bodies in the source code, not to
3261 -- those generated by the compiler. In particular, expression
3262 -- functions, whose body is generated by the compiler, are
3263 -- treated specially by GNATprove.
3265 and then Comes_From_Source
(Body_Id
)
3267 -- This cannot be done for a compilation unit, which is not
3268 -- in a context where we can insert a new spec.
3270 and then Is_List_Member
(N
)
3272 -- Inlining only applies to subprograms without contracts,
3273 -- as a contract is a sign that GNATprove should perform a
3274 -- modular analysis of the subprogram instead of a contextual
3275 -- analysis at each call site. The same test is performed in
3276 -- Inline.Can_Be_Inlined_In_GNATprove_Mode. It is repeated
3277 -- here in another form (because the contract has not been
3278 -- attached to the body) to avoid front-end errors in case
3279 -- pragmas are used instead of aspects, because the
3280 -- corresponding pragmas in the body would not be transferred
3281 -- to the spec, leading to legality errors.
3283 and then not Body_Has_Contract
3284 and then not Inside_A_Generic
3286 Build_Subprogram_Declaration
;
3288 -- If this is a function that returns a constrained array, and
3289 -- we are generating SPARK_For_C, create subprogram declaration
3290 -- to simplify subsequent C generation.
3293 and then Modify_Tree_For_C
3294 and then Nkind
(Body_Spec
) = N_Function_Specification
3295 and then Is_Array_Type
(Etype
(Body_Id
))
3296 and then Is_Constrained
(Etype
(Body_Id
))
3298 Build_Subprogram_Declaration
;
3302 -- If this is a duplicate body, no point in analyzing it
3304 if Error_Posted
(N
) then
3305 Ghost_Mode
:= Save_Ghost_Mode
;
3309 -- A subprogram body should cause freezing of its own declaration,
3310 -- but if there was no previous explicit declaration, then the
3311 -- subprogram will get frozen too late (there may be code within
3312 -- the body that depends on the subprogram having been frozen,
3313 -- such as uses of extra formals), so we force it to be frozen
3314 -- here. Same holds if the body and spec are compilation units.
3315 -- Finally, if the return type is an anonymous access to protected
3316 -- subprogram, it must be frozen before the body because its
3317 -- expansion has generated an equivalent type that is used when
3318 -- elaborating the body.
3320 -- An exception in the case of Ada 2012, AI05-177: The bodies
3321 -- created for expression functions do not freeze.
3324 and then Nkind
(Original_Node
(N
)) /= N_Expression_Function
3326 Freeze_Before
(N
, Body_Id
);
3328 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3329 Freeze_Before
(N
, Spec_Id
);
3331 elsif Is_Access_Subprogram_Type
(Etype
(Body_Id
)) then
3332 Freeze_Before
(N
, Etype
(Body_Id
));
3336 Spec_Id
:= Corresponding_Spec
(N
);
3338 -- A subprogram body is Ghost when it is stand alone and subject
3339 -- to pragma Ghost or when the corresponding spec is Ghost. Set
3340 -- the mode now to ensure that any nodes generated during analysis
3341 -- and expansion are properly marked as Ghost.
3343 Set_Ghost_Mode
(N
, Spec_Id
);
3347 -- Previously we scanned the body to look for nested subprograms, and
3348 -- rejected an inline directive if nested subprograms were present,
3349 -- because the back-end would generate conflicting symbols for the
3350 -- nested bodies. This is now unnecessary.
3352 -- Look ahead to recognize a pragma Inline that appears after the body
3354 Check_Inline_Pragma
(Spec_Id
);
3356 -- Deal with special case of a fully private operation in the body of
3357 -- the protected type. We must create a declaration for the subprogram,
3358 -- in order to attach the protected subprogram that will be used in
3359 -- internal calls. We exclude compiler generated bodies from the
3360 -- expander since the issue does not arise for those cases.
3363 and then Comes_From_Source
(N
)
3364 and then Is_Protected_Type
(Current_Scope
)
3366 Spec_Id
:= Build_Private_Protected_Declaration
(N
);
3369 -- If we are generating C and this is a function returning a constrained
3370 -- array type for which we must create a procedure with an extra out
3371 -- parameter, build and analyze the body now. The procedure declaration
3372 -- has already been created. We reuse the source body of the function,
3373 -- because in an instance it may contain global references that cannot
3374 -- be reanalyzed. The source function itself is not used any further,
3375 -- so we mark it as having a completion. If the subprogram is a stub the
3376 -- transformation is done later, when the proper body is analyzed.
3379 and then Modify_Tree_For_C
3380 and then Present
(Spec_Id
)
3381 and then Ekind
(Spec_Id
) = E_Function
3382 and then Nkind
(N
) /= N_Subprogram_Body_Stub
3383 and then Rewritten_For_C
(Spec_Id
)
3385 Set_Has_Completion
(Spec_Id
);
3387 Rewrite
(N
, Build_Procedure_Body_Form
(Spec_Id
, N
));
3390 -- The entity for the created procedure must remain invisible, so it
3391 -- does not participate in resolution of subsequent references to the
3394 Set_Is_Immediately_Visible
(Corresponding_Spec
(N
), False);
3398 -- If a separate spec is present, then deal with freezing issues
3400 if Present
(Spec_Id
) then
3401 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
3402 Verify_Overriding_Indicator
;
3404 -- In general, the spec will be frozen when we start analyzing the
3405 -- body. However, for internally generated operations, such as
3406 -- wrapper functions for inherited operations with controlling
3407 -- results, the spec may not have been frozen by the time we expand
3408 -- the freeze actions that include the bodies. In particular, extra
3409 -- formals for accessibility or for return-in-place may need to be
3410 -- generated. Freeze nodes, if any, are inserted before the current
3411 -- body. These freeze actions are also needed in ASIS mode and in
3412 -- Compile_Only mode to enable the proper back-end type annotations.
3413 -- They are necessary in any case to insure order of elaboration
3416 if not Is_Frozen
(Spec_Id
)
3417 and then (Expander_Active
3419 or else (Operating_Mode
= Check_Semantics
3420 and then Serious_Errors_Detected
= 0))
3422 Set_Has_Delayed_Freeze
(Spec_Id
);
3423 Freeze_Before
(N
, Spec_Id
);
3427 -- Place subprogram on scope stack, and make formals visible. If there
3428 -- is a spec, the visible entity remains that of the spec.
3430 if Present
(Spec_Id
) then
3431 Generate_Reference
(Spec_Id
, Body_Id
, 'b', Set_Ref
=> False);
3433 if Is_Child_Unit
(Spec_Id
) then
3434 Generate_Reference
(Spec_Id
, Scope
(Spec_Id
), 'k', False);
3438 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
3441 Set_Is_Compilation_Unit
(Body_Id
, Is_Compilation_Unit
(Spec_Id
));
3442 Set_Is_Child_Unit
(Body_Id
, Is_Child_Unit
(Spec_Id
));
3444 if Is_Abstract_Subprogram
(Spec_Id
) then
3445 Error_Msg_N
("an abstract subprogram cannot have a body", N
);
3446 Ghost_Mode
:= Save_Ghost_Mode
;
3450 Set_Convention
(Body_Id
, Convention
(Spec_Id
));
3451 Set_Has_Completion
(Spec_Id
);
3453 -- Inherit the "ghostness" of the subprogram spec. Note that this
3454 -- property is not directly inherited as the body may be subject
3455 -- to a different Ghost assertion policy.
3457 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Spec_Id
) then
3458 Set_Is_Ghost_Entity
(Body_Id
);
3460 -- The Ghost policy in effect at the point of declaration and
3461 -- at the point of completion must match (SPARK RM 6.9(14)).
3463 Check_Ghost_Completion
(Spec_Id
, Body_Id
);
3466 if Is_Protected_Type
(Scope
(Spec_Id
)) then
3467 Prot_Typ
:= Scope
(Spec_Id
);
3470 -- If this is a body generated for a renaming, do not check for
3471 -- full conformance. The check is redundant, because the spec of
3472 -- the body is a copy of the spec in the renaming declaration,
3473 -- and the test can lead to spurious errors on nested defaults.
3475 if Present
(Spec_Decl
)
3476 and then not Comes_From_Source
(N
)
3478 (Nkind
(Original_Node
(Spec_Decl
)) =
3479 N_Subprogram_Renaming_Declaration
3480 or else (Present
(Corresponding_Body
(Spec_Decl
))
3482 Nkind
(Unit_Declaration_Node
3483 (Corresponding_Body
(Spec_Decl
))) =
3484 N_Subprogram_Renaming_Declaration
))
3488 -- Conversely, the spec may have been generated for specless body
3489 -- with an inline pragma. The entity comes from source, which is
3490 -- both semantically correct and necessary for proper inlining.
3491 -- The subprogram declaration itself is not in the source.
3493 elsif Comes_From_Source
(N
)
3494 and then Present
(Spec_Decl
)
3495 and then not Comes_From_Source
(Spec_Decl
)
3496 and then Has_Pragma_Inline
(Spec_Id
)
3503 Fully_Conformant
, True, Conformant
, Body_Id
);
3506 -- If the body is not fully conformant, we have to decide if we
3507 -- should analyze it or not. If it has a really messed up profile
3508 -- then we probably should not analyze it, since we will get too
3509 -- many bogus messages.
3511 -- Our decision is to go ahead in the non-fully conformant case
3512 -- only if it is at least mode conformant with the spec. Note
3513 -- that the call to Check_Fully_Conformant has issued the proper
3514 -- error messages to complain about the lack of conformance.
3517 and then not Mode_Conformant
(Body_Id
, Spec_Id
)
3519 Ghost_Mode
:= Save_Ghost_Mode
;
3524 if Spec_Id
/= Body_Id
then
3525 Reference_Body_Formals
(Spec_Id
, Body_Id
);
3528 Set_Ekind
(Body_Id
, E_Subprogram_Body
);
3530 if Nkind
(N
) = N_Subprogram_Body_Stub
then
3531 Set_Corresponding_Spec_Of_Stub
(N
, Spec_Id
);
3536 Set_Corresponding_Spec
(N
, Spec_Id
);
3538 -- Ada 2005 (AI-345): If the operation is a primitive operation
3539 -- of a concurrent type, the type of the first parameter has been
3540 -- replaced with the corresponding record, which is the proper
3541 -- run-time structure to use. However, within the body there may
3542 -- be uses of the formals that depend on primitive operations
3543 -- of the type (in particular calls in prefixed form) for which
3544 -- we need the original concurrent type. The operation may have
3545 -- several controlling formals, so the replacement must be done
3548 if Comes_From_Source
(Spec_Id
)
3549 and then Present
(First_Entity
(Spec_Id
))
3550 and then Ekind
(Etype
(First_Entity
(Spec_Id
))) = E_Record_Type
3551 and then Is_Tagged_Type
(Etype
(First_Entity
(Spec_Id
)))
3552 and then Present
(Interfaces
(Etype
(First_Entity
(Spec_Id
))))
3553 and then Present
(Corresponding_Concurrent_Type
3554 (Etype
(First_Entity
(Spec_Id
))))
3557 Typ
: constant Entity_Id
:= Etype
(First_Entity
(Spec_Id
));
3561 Form
:= First_Formal
(Spec_Id
);
3562 while Present
(Form
) loop
3563 if Etype
(Form
) = Typ
then
3564 Set_Etype
(Form
, Corresponding_Concurrent_Type
(Typ
));
3572 -- Make the formals visible, and place subprogram on scope stack.
3573 -- This is also the point at which we set Last_Real_Spec_Entity
3574 -- to mark the entities which will not be moved to the body.
3576 Install_Formals
(Spec_Id
);
3577 Last_Real_Spec_Entity
:= Last_Entity
(Spec_Id
);
3579 -- Within an instance, add local renaming declarations so that
3580 -- gdb can retrieve the values of actuals more easily. This is
3581 -- only relevant if generating code (and indeed we definitely
3582 -- do not want these definitions -gnatc mode, because that would
3585 if Is_Generic_Instance
(Spec_Id
)
3586 and then Is_Wrapper_Package
(Current_Scope
)
3587 and then Expander_Active
3589 Build_Subprogram_Instance_Renamings
(N
, Current_Scope
);
3592 Push_Scope
(Spec_Id
);
3594 -- Make sure that the subprogram is immediately visible. For
3595 -- child units that have no separate spec this is indispensable.
3596 -- Otherwise it is safe albeit redundant.
3598 Set_Is_Immediately_Visible
(Spec_Id
);
3601 Set_Corresponding_Body
(Unit_Declaration_Node
(Spec_Id
), Body_Id
);
3602 Set_Is_Obsolescent
(Body_Id
, Is_Obsolescent
(Spec_Id
));
3603 Set_Scope
(Body_Id
, Scope
(Spec_Id
));
3605 -- Case of subprogram body with no previous spec
3608 -- Check for style warning required
3612 -- Only apply check for source level subprograms for which checks
3613 -- have not been suppressed.
3615 and then Comes_From_Source
(Body_Id
)
3616 and then not Suppress_Style_Checks
(Body_Id
)
3618 -- No warnings within an instance
3620 and then not In_Instance
3622 -- No warnings for expression functions
3624 and then Nkind
(Original_Node
(N
)) /= N_Expression_Function
3626 Style
.Body_With_No_Spec
(N
);
3629 New_Overloaded_Entity
(Body_Id
);
3631 -- A subprogram body declared within a Ghost region is automatically
3632 -- Ghost (SPARK RM 6.9(2)).
3634 if Ghost_Mode
> None
then
3635 Set_Is_Ghost_Entity
(Body_Id
);
3638 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
3639 Set_Acts_As_Spec
(N
);
3640 Generate_Definition
(Body_Id
);
3642 (Body_Id
, Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
3643 Install_Formals
(Body_Id
);
3645 Push_Scope
(Body_Id
);
3648 -- For stubs and bodies with no previous spec, generate references to
3651 Generate_Reference_To_Formals
(Body_Id
);
3654 -- Entry barrier functions are generated outside the protected type and
3655 -- should not carry the SPARK_Mode of the enclosing context.
3657 if Nkind
(N
) = N_Subprogram_Body
3658 and then Is_Entry_Barrier_Function
(N
)
3662 -- The body is generated as part of expression function expansion. When
3663 -- the expression function appears in the visible declarations of a
3664 -- package, the body is added to the private declarations. Since both
3665 -- declarative lists may be subject to a different SPARK_Mode, inherit
3666 -- the mode of the spec.
3668 -- package P with SPARK_Mode is
3669 -- function Expr_Func ... is (...); -- original
3670 -- [function Expr_Func ...;] -- generated spec
3673 -- pragma SPARK_Mode (Off);
3674 -- [function Expr_Func ... is return ...;] -- generated body
3675 -- end P; -- mode is ON
3677 elsif not Comes_From_Source
(N
)
3678 and then Present
(Prev_Id
)
3679 and then Is_Expression_Function
(Prev_Id
)
3681 Set_SPARK_Pragma
(Body_Id
, SPARK_Pragma
(Prev_Id
));
3682 Set_SPARK_Pragma_Inherited
3683 (Body_Id
, SPARK_Pragma_Inherited
(Prev_Id
));
3685 -- Set the SPARK_Mode from the current context (may be overwritten later
3686 -- with explicit pragma). Exclude the case where the SPARK_Mode appears
3687 -- initially on a stand-alone subprogram body, but is then relocated to
3688 -- a generated corresponding spec. In this scenario the mode is shared
3689 -- between the spec and body.
3691 elsif No
(SPARK_Pragma
(Body_Id
)) then
3692 Set_SPARK_Pragma
(Body_Id
, SPARK_Mode_Pragma
);
3693 Set_SPARK_Pragma_Inherited
(Body_Id
);
3696 -- If this is the proper body of a stub, we must verify that the stub
3697 -- conforms to the body, and to the previous spec if one was present.
3698 -- We know already that the body conforms to that spec. This test is
3699 -- only required for subprograms that come from source.
3701 if Nkind
(Parent
(N
)) = N_Subunit
3702 and then Comes_From_Source
(N
)
3703 and then not Error_Posted
(Body_Id
)
3704 and then Nkind
(Corresponding_Stub
(Parent
(N
))) =
3705 N_Subprogram_Body_Stub
3708 Old_Id
: constant Entity_Id
:=
3710 (Specification
(Corresponding_Stub
(Parent
(N
))));
3712 Conformant
: Boolean := False;
3715 if No
(Spec_Id
) then
3716 Check_Fully_Conformant
(Body_Id
, Old_Id
);
3720 (Body_Id
, Old_Id
, Fully_Conformant
, False, Conformant
);
3722 if not Conformant
then
3724 -- The stub was taken to be a new declaration. Indicate that
3727 Set_Has_Completion
(Old_Id
, False);
3733 Set_Has_Completion
(Body_Id
);
3734 Check_Eliminated
(Body_Id
);
3736 -- Analyze any aspect specifications that appear on the subprogram body
3737 -- stub. Stop the analysis now as the stub does not have a declarative
3738 -- or a statement part, and it cannot be inlined.
3740 if Nkind
(N
) = N_Subprogram_Body_Stub
then
3741 if Has_Aspects
(N
) then
3742 Analyze_Aspect_Specifications_On_Body_Or_Stub
(N
);
3745 Ghost_Mode
:= Save_Ghost_Mode
;
3751 -- Note: Normally we don't do any inlining if expansion is off, since
3752 -- we won't generate code in any case. An exception arises in GNATprove
3753 -- mode where we want to expand some calls in place, even with expansion
3754 -- disabled, since the inlining eases formal verification.
3756 if not GNATprove_Mode
3757 and then Expander_Active
3758 and then Serious_Errors_Detected
= 0
3759 and then Present
(Spec_Id
)
3760 and then Has_Pragma_Inline
(Spec_Id
)
3762 -- Legacy implementation (relying on front-end inlining)
3764 if not Back_End_Inlining
then
3765 if (Has_Pragma_Inline_Always
(Spec_Id
)
3766 and then not Opt
.Disable_FE_Inline_Always
)
3767 or else (Front_End_Inlining
3768 and then not Opt
.Disable_FE_Inline
)
3770 Build_Body_To_Inline
(N
, Spec_Id
);
3773 -- New implementation (relying on back-end inlining)
3776 if Has_Pragma_Inline_Always
(Spec_Id
)
3777 or else Optimization_Level
> 0
3779 -- Handle function returning an unconstrained type
3781 if Comes_From_Source
(Body_Id
)
3782 and then Ekind
(Spec_Id
) = E_Function
3783 and then Returns_Unconstrained_Type
(Spec_Id
)
3785 -- If function builds in place, i.e. returns a limited type,
3786 -- inlining cannot be done.
3788 and then not Is_Limited_Type
(Etype
(Spec_Id
))
3790 Check_And_Split_Unconstrained_Function
(N
, Spec_Id
, Body_Id
);
3794 Subp_Body
: constant Node_Id
:=
3795 Unit_Declaration_Node
(Body_Id
);
3796 Subp_Decl
: constant List_Id
:= Declarations
(Subp_Body
);
3799 -- Do not pass inlining to the backend if the subprogram
3800 -- has declarations or statements which cannot be inlined
3801 -- by the backend. This check is done here to emit an
3802 -- error instead of the generic warning message reported
3803 -- by the GCC backend (ie. "function might not be
3806 if Present
(Subp_Decl
)
3807 and then Has_Excluded_Declaration
(Spec_Id
, Subp_Decl
)
3811 elsif Has_Excluded_Statement
3814 (Handled_Statement_Sequence
(Subp_Body
)))
3818 -- If the backend inlining is available then at this
3819 -- stage we only have to mark the subprogram as inlined.
3820 -- The expander will take care of registering it in the
3821 -- table of subprograms inlined by the backend a part of
3822 -- processing calls to it (cf. Expand_Call)
3825 Set_Is_Inlined
(Spec_Id
);
3832 -- In GNATprove mode, inline only when there is a separate subprogram
3833 -- declaration for now, as inlining of subprogram bodies acting as
3834 -- declarations, or subprogram stubs, are not supported by front-end
3835 -- inlining. This inlining should occur after analysis of the body, so
3836 -- that it is known whether the value of SPARK_Mode, which can be
3837 -- defined by a pragma inside the body, is applicable to the body.
3839 elsif GNATprove_Mode
3840 and then Full_Analysis
3841 and then not Inside_A_Generic
3842 and then Present
(Spec_Id
)
3844 Nkind
(Unit_Declaration_Node
(Spec_Id
)) = N_Subprogram_Declaration
3845 and then Body_Has_SPARK_Mode_On
3846 and then Can_Be_Inlined_In_GNATprove_Mode
(Spec_Id
, Body_Id
)
3847 and then not Body_Has_Contract
3849 Build_Body_To_Inline
(N
, Spec_Id
);
3852 -- When generating code, inherited pre/postconditions are handled when
3853 -- expanding the corresponding contract.
3855 -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
3856 -- of the specification we have to install the private withed units.
3857 -- This holds for child units as well.
3859 if Is_Compilation_Unit
(Body_Id
)
3860 or else Nkind
(Parent
(N
)) = N_Compilation_Unit
3862 Install_Private_With_Clauses
(Body_Id
);
3865 Check_Anonymous_Return
;
3867 -- Set the Protected_Formal field of each extra formal of the protected
3868 -- subprogram to reference the corresponding extra formal of the
3869 -- subprogram that implements it. For regular formals this occurs when
3870 -- the protected subprogram's declaration is expanded, but the extra
3871 -- formals don't get created until the subprogram is frozen. We need to
3872 -- do this before analyzing the protected subprogram's body so that any
3873 -- references to the original subprogram's extra formals will be changed
3874 -- refer to the implementing subprogram's formals (see Expand_Formal).
3876 if Present
(Spec_Id
)
3877 and then Is_Protected_Type
(Scope
(Spec_Id
))
3878 and then Present
(Protected_Body_Subprogram
(Spec_Id
))
3881 Impl_Subp
: constant Entity_Id
:=
3882 Protected_Body_Subprogram
(Spec_Id
);
3883 Prot_Ext_Formal
: Entity_Id
:= Extra_Formals
(Spec_Id
);
3884 Impl_Ext_Formal
: Entity_Id
:= Extra_Formals
(Impl_Subp
);
3886 while Present
(Prot_Ext_Formal
) loop
3887 pragma Assert
(Present
(Impl_Ext_Formal
));
3888 Set_Protected_Formal
(Prot_Ext_Formal
, Impl_Ext_Formal
);
3889 Next_Formal_With_Extras
(Prot_Ext_Formal
);
3890 Next_Formal_With_Extras
(Impl_Ext_Formal
);
3895 -- Now we can go on to analyze the body
3897 HSS
:= Handled_Statement_Sequence
(N
);
3898 Set_Actual_Subtypes
(N
, Current_Scope
);
3900 -- Add a declaration for the Protection object, renaming declarations
3901 -- for discriminals and privals and finally a declaration for the entry
3902 -- family index (if applicable). This form of early expansion is done
3903 -- when the Expander is active because Install_Private_Data_Declarations
3904 -- references entities which were created during regular expansion. The
3905 -- subprogram entity must come from source, and not be an internally
3906 -- generated subprogram.
3909 and then Present
(Prot_Typ
)
3910 and then Present
(Spec_Id
)
3911 and then Comes_From_Source
(Spec_Id
)
3912 and then not Is_Eliminated
(Spec_Id
)
3914 Install_Private_Data_Declarations
3915 (Sloc
(N
), Spec_Id
, Prot_Typ
, N
, Declarations
(N
));
3918 -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context
3919 -- may now appear in parameter and result profiles. Since the analysis
3920 -- of a subprogram body may use the parameter and result profile of the
3921 -- spec, swap any limited views with their non-limited counterpart.
3923 if Ada_Version
>= Ada_2012
and then Present
(Spec_Id
) then
3924 Exch_Views
:= Exchange_Limited_Views
(Spec_Id
);
3927 -- If the return type is an anonymous access type whose designated type
3928 -- is the limited view of a class-wide type and the non-limited view is
3929 -- available, update the return type accordingly.
3931 if Ada_Version
>= Ada_2005
and then Present
(Spec_Id
) then
3937 Rtyp
:= Etype
(Spec_Id
);
3939 if Ekind
(Rtyp
) = E_Anonymous_Access_Type
then
3940 Etyp
:= Directly_Designated_Type
(Rtyp
);
3942 if Is_Class_Wide_Type
(Etyp
)
3943 and then From_Limited_With
(Etyp
)
3946 Set_Directly_Designated_Type
(Rtyp
, Available_View
(Etyp
));
3952 -- Analyze any aspect specifications that appear on the subprogram body
3954 if Has_Aspects
(N
) then
3955 Analyze_Aspect_Specifications_On_Body_Or_Stub
(N
);
3958 Analyze_Declarations
(Declarations
(N
));
3960 -- Verify that the SPARK_Mode of the body agrees with that of its spec
3962 if Present
(Spec_Id
) and then Present
(SPARK_Pragma
(Body_Id
)) then
3963 if Present
(SPARK_Pragma
(Spec_Id
)) then
3964 if Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Spec_Id
)) = Off
3966 Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Body_Id
)) = On
3968 Error_Msg_Sloc
:= Sloc
(SPARK_Pragma
(Body_Id
));
3969 Error_Msg_N
("incorrect application of SPARK_Mode#", N
);
3970 Error_Msg_Sloc
:= Sloc
(SPARK_Pragma
(Spec_Id
));
3972 ("\value Off was set for SPARK_Mode on & #", N
, Spec_Id
);
3975 elsif Nkind
(Parent
(Parent
(Spec_Id
))) = N_Subprogram_Body_Stub
then
3979 Error_Msg_Sloc
:= Sloc
(SPARK_Pragma
(Body_Id
));
3980 Error_Msg_N
("incorrect application of SPARK_Mode #", N
);
3981 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
3983 ("\no value was set for SPARK_Mode on & #", N
, Spec_Id
);
3987 -- A subprogram body "freezes" its own contract. Analyze the contract
3988 -- after the declarations of the body have been processed as pragmas
3989 -- are now chained on the contract of the subprogram body.
3991 Analyze_Entry_Or_Subprogram_Body_Contract
(Body_Id
);
3993 -- Check completion, and analyze the statements
3996 Inspect_Deferred_Constant_Completion
(Declarations
(N
));
3999 -- Deal with end of scope processing for the body
4001 Process_End_Label
(HSS
, 't', Current_Scope
);
4003 Check_Subprogram_Order
(N
);
4004 Set_Analyzed
(Body_Id
);
4006 -- If we have a separate spec, then the analysis of the declarations
4007 -- caused the entities in the body to be chained to the spec id, but
4008 -- we want them chained to the body id. Only the formal parameters
4009 -- end up chained to the spec id in this case.
4011 if Present
(Spec_Id
) then
4013 -- We must conform to the categorization of our spec
4015 Validate_Categorization_Dependency
(N
, Spec_Id
);
4017 -- And if this is a child unit, the parent units must conform
4019 if Is_Child_Unit
(Spec_Id
) then
4020 Validate_Categorization_Dependency
4021 (Unit_Declaration_Node
(Spec_Id
), Spec_Id
);
4024 -- Here is where we move entities from the spec to the body
4026 -- Case where there are entities that stay with the spec
4028 if Present
(Last_Real_Spec_Entity
) then
4030 -- No body entities (happens when the only real spec entities come
4031 -- from precondition and postcondition pragmas).
4033 if No
(Last_Entity
(Body_Id
)) then
4034 Set_First_Entity
(Body_Id
, Next_Entity
(Last_Real_Spec_Entity
));
4036 -- Body entities present (formals), so chain stuff past them
4040 (Last_Entity
(Body_Id
), Next_Entity
(Last_Real_Spec_Entity
));
4043 Set_Next_Entity
(Last_Real_Spec_Entity
, Empty
);
4044 Set_Last_Entity
(Body_Id
, Last_Entity
(Spec_Id
));
4045 Set_Last_Entity
(Spec_Id
, Last_Real_Spec_Entity
);
4047 -- Case where there are no spec entities, in this case there can be
4048 -- no body entities either, so just move everything.
4050 -- If the body is generated for an expression function, it may have
4051 -- been preanalyzed already, if 'access was applied to it.
4054 if Nkind
(Original_Node
(Unit_Declaration_Node
(Spec_Id
))) /=
4055 N_Expression_Function
4057 pragma Assert
(No
(Last_Entity
(Body_Id
)));
4061 Set_First_Entity
(Body_Id
, First_Entity
(Spec_Id
));
4062 Set_Last_Entity
(Body_Id
, Last_Entity
(Spec_Id
));
4063 Set_First_Entity
(Spec_Id
, Empty
);
4064 Set_Last_Entity
(Spec_Id
, Empty
);
4068 Check_Missing_Return
;
4070 -- Now we are going to check for variables that are never modified in
4071 -- the body of the procedure. But first we deal with a special case
4072 -- where we want to modify this check. If the body of the subprogram
4073 -- starts with a raise statement or its equivalent, or if the body
4074 -- consists entirely of a null statement, then it is pretty obvious that
4075 -- it is OK to not reference the parameters. For example, this might be
4076 -- the following common idiom for a stubbed function: statement of the
4077 -- procedure raises an exception. In particular this deals with the
4078 -- common idiom of a stubbed function, which appears something like:
4080 -- function F (A : Integer) return Some_Type;
4083 -- raise Program_Error;
4087 -- Here the purpose of X is simply to satisfy the annoying requirement
4088 -- in Ada that there be at least one return, and we certainly do not
4089 -- want to go posting warnings on X that it is not initialized. On
4090 -- the other hand, if X is entirely unreferenced that should still
4093 -- What we do is to detect these cases, and if we find them, flag the
4094 -- subprogram as being Is_Trivial_Subprogram and then use that flag to
4095 -- suppress unwanted warnings. For the case of the function stub above
4096 -- we have a special test to set X as apparently assigned to suppress
4103 -- Skip initial labels (for one thing this occurs when we are in
4104 -- front-end ZCX mode, but in any case it is irrelevant), and also
4105 -- initial Push_xxx_Error_Label nodes, which are also irrelevant.
4107 Stm
:= First
(Statements
(HSS
));
4108 while Nkind
(Stm
) = N_Label
4109 or else Nkind
(Stm
) in N_Push_xxx_Label
4114 -- Do the test on the original statement before expansion
4117 Ostm
: constant Node_Id
:= Original_Node
(Stm
);
4120 -- If explicit raise statement, turn on flag
4122 if Nkind
(Ostm
) = N_Raise_Statement
then
4123 Set_Trivial_Subprogram
(Stm
);
4125 -- If null statement, and no following statements, turn on flag
4127 elsif Nkind
(Stm
) = N_Null_Statement
4128 and then Comes_From_Source
(Stm
)
4129 and then No
(Next
(Stm
))
4131 Set_Trivial_Subprogram
(Stm
);
4133 -- Check for explicit call cases which likely raise an exception
4135 elsif Nkind
(Ostm
) = N_Procedure_Call_Statement
then
4136 if Is_Entity_Name
(Name
(Ostm
)) then
4138 Ent
: constant Entity_Id
:= Entity
(Name
(Ostm
));
4141 -- If the procedure is marked No_Return, then likely it
4142 -- raises an exception, but in any case it is not coming
4143 -- back here, so turn on the flag.
4146 and then Ekind
(Ent
) = E_Procedure
4147 and then No_Return
(Ent
)
4149 Set_Trivial_Subprogram
(Stm
);
4157 -- Check for variables that are never modified
4163 -- If there is a separate spec, then transfer Never_Set_In_Source
4164 -- flags from out parameters to the corresponding entities in the
4165 -- body. The reason we do that is we want to post error flags on
4166 -- the body entities, not the spec entities.
4168 if Present
(Spec_Id
) then
4169 E1
:= First_Entity
(Spec_Id
);
4170 while Present
(E1
) loop
4171 if Ekind
(E1
) = E_Out_Parameter
then
4172 E2
:= First_Entity
(Body_Id
);
4173 while Present
(E2
) loop
4174 exit when Chars
(E1
) = Chars
(E2
);
4178 if Present
(E2
) then
4179 Set_Never_Set_In_Source
(E2
, Never_Set_In_Source
(E1
));
4187 -- Check references in body
4189 Check_References
(Body_Id
);
4192 -- Check for nested subprogram, and mark outer level subprogram if so
4198 if Present
(Spec_Id
) then
4205 Ent
:= Enclosing_Subprogram
(Ent
);
4206 exit when No
(Ent
) or else Is_Subprogram
(Ent
);
4209 if Present
(Ent
) then
4210 Set_Has_Nested_Subprogram
(Ent
);
4214 -- Restore the limited views in the spec, if any, to let the back end
4215 -- process it without running into circularities.
4217 if Exch_Views
/= No_Elist
then
4218 Restore_Limited_Views
(Exch_Views
);
4221 if Present
(Desig_View
) then
4222 Set_Directly_Designated_Type
(Etype
(Spec_Id
), Desig_View
);
4225 Ghost_Mode
:= Save_Ghost_Mode
;
4226 end Analyze_Subprogram_Body_Helper
;
4228 ------------------------------------
4229 -- Analyze_Subprogram_Declaration --
4230 ------------------------------------
4232 procedure Analyze_Subprogram_Declaration
(N
: Node_Id
) is
4233 Scop
: constant Entity_Id
:= Current_Scope
;
4234 Designator
: Entity_Id
;
4236 Is_Completion
: Boolean;
4237 -- Indicates whether a null procedure declaration is a completion
4240 -- Null procedures are not allowed in SPARK
4242 if Nkind
(Specification
(N
)) = N_Procedure_Specification
4243 and then Null_Present
(Specification
(N
))
4245 Check_SPARK_05_Restriction
("null procedure is not allowed", N
);
4247 -- Null procedures are allowed in protected types, following the
4248 -- recent AI12-0147.
4250 if Is_Protected_Type
(Current_Scope
)
4251 and then Ada_Version
< Ada_2012
4253 Error_Msg_N
("protected operation cannot be a null procedure", N
);
4256 Analyze_Null_Procedure
(N
, Is_Completion
);
4258 -- The null procedure acts as a body, nothing further is needed
4260 if Is_Completion
then
4265 Designator
:= Analyze_Subprogram_Specification
(Specification
(N
));
4267 -- A reference may already have been generated for the unit name, in
4268 -- which case the following call is redundant. However it is needed for
4269 -- declarations that are the rewriting of an expression function.
4271 Generate_Definition
(Designator
);
4273 -- Set the SPARK mode from the current context (may be overwritten later
4274 -- with explicit pragma). This is not done for entry barrier functions
4275 -- because they are generated outside the protected type and should not
4276 -- carry the mode of the enclosing context.
4278 if Nkind
(N
) = N_Subprogram_Declaration
4279 and then Is_Entry_Barrier_Function
(N
)
4283 Set_SPARK_Pragma
(Designator
, SPARK_Mode_Pragma
);
4284 Set_SPARK_Pragma_Inherited
(Designator
);
4287 -- A subprogram declared within a Ghost region is automatically Ghost
4288 -- (SPARK RM 6.9(2)).
4290 if Ghost_Mode
> None
then
4291 Set_Is_Ghost_Entity
(Designator
);
4294 if Debug_Flag_C
then
4295 Write_Str
("==> subprogram spec ");
4296 Write_Name
(Chars
(Designator
));
4297 Write_Str
(" from ");
4298 Write_Location
(Sloc
(N
));
4303 Validate_RCI_Subprogram_Declaration
(N
);
4304 New_Overloaded_Entity
(Designator
);
4305 Check_Delayed_Subprogram
(Designator
);
4307 -- If the type of the first formal of the current subprogram is a non-
4308 -- generic tagged private type, mark the subprogram as being a private
4309 -- primitive. Ditto if this is a function with controlling result, and
4310 -- the return type is currently private. In both cases, the type of the
4311 -- controlling argument or result must be in the current scope for the
4312 -- operation to be primitive.
4314 if Has_Controlling_Result
(Designator
)
4315 and then Is_Private_Type
(Etype
(Designator
))
4316 and then Scope
(Etype
(Designator
)) = Current_Scope
4317 and then not Is_Generic_Actual_Type
(Etype
(Designator
))
4319 Set_Is_Private_Primitive
(Designator
);
4321 elsif Present
(First_Formal
(Designator
)) then
4323 Formal_Typ
: constant Entity_Id
:=
4324 Etype
(First_Formal
(Designator
));
4326 Set_Is_Private_Primitive
(Designator
,
4327 Is_Tagged_Type
(Formal_Typ
)
4328 and then Scope
(Formal_Typ
) = Current_Scope
4329 and then Is_Private_Type
(Formal_Typ
)
4330 and then not Is_Generic_Actual_Type
(Formal_Typ
));
4334 -- Ada 2005 (AI-251): Abstract interface primitives must be abstract
4337 if Ada_Version
>= Ada_2005
4338 and then Comes_From_Source
(N
)
4339 and then Is_Dispatching_Operation
(Designator
)
4346 if Has_Controlling_Result
(Designator
) then
4347 Etyp
:= Etype
(Designator
);
4350 E
:= First_Entity
(Designator
);
4352 and then Is_Formal
(E
)
4353 and then not Is_Controlling_Formal
(E
)
4361 if Is_Access_Type
(Etyp
) then
4362 Etyp
:= Directly_Designated_Type
(Etyp
);
4365 if Is_Interface
(Etyp
)
4366 and then not Is_Abstract_Subprogram
(Designator
)
4367 and then not (Ekind
(Designator
) = E_Procedure
4368 and then Null_Present
(Specification
(N
)))
4370 Error_Msg_Name_1
:= Chars
(Defining_Entity
(N
));
4372 -- Specialize error message based on procedures vs. functions,
4373 -- since functions can't be null subprograms.
4375 if Ekind
(Designator
) = E_Procedure
then
4377 ("interface procedure % must be abstract or null", N
);
4380 ("interface function % must be abstract", N
);
4386 -- What is the following code for, it used to be
4388 -- ??? Set_Suppress_Elaboration_Checks
4389 -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
4391 -- The following seems equivalent, but a bit dubious
4393 if Elaboration_Checks_Suppressed
(Designator
) then
4394 Set_Kill_Elaboration_Checks
(Designator
);
4397 if Scop
/= Standard_Standard
and then not Is_Child_Unit
(Designator
) then
4398 Set_Categorization_From_Scope
(Designator
, Scop
);
4401 -- For a compilation unit, check for library-unit pragmas
4403 Push_Scope
(Designator
);
4404 Set_Categorization_From_Pragmas
(N
);
4405 Validate_Categorization_Dependency
(N
, Designator
);
4409 -- For a compilation unit, set body required. This flag will only be
4410 -- reset if a valid Import or Interface pragma is processed later on.
4412 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4413 Set_Body_Required
(Parent
(N
), True);
4415 if Ada_Version
>= Ada_2005
4416 and then Nkind
(Specification
(N
)) = N_Procedure_Specification
4417 and then Null_Present
(Specification
(N
))
4420 ("null procedure cannot be declared at library level", N
);
4424 Generate_Reference_To_Formals
(Designator
);
4425 Check_Eliminated
(Designator
);
4427 if Debug_Flag_C
then
4429 Write_Str
("<== subprogram spec ");
4430 Write_Name
(Chars
(Designator
));
4431 Write_Str
(" from ");
4432 Write_Location
(Sloc
(N
));
4436 if Is_Protected_Type
(Current_Scope
) then
4438 -- Indicate that this is a protected operation, because it may be
4439 -- used in subsequent declarations within the protected type.
4441 Set_Convention
(Designator
, Convention_Protected
);
4444 List_Inherited_Pre_Post_Aspects
(Designator
);
4446 if Has_Aspects
(N
) then
4447 Analyze_Aspect_Specifications
(N
, Designator
);
4449 end Analyze_Subprogram_Declaration
;
4451 --------------------------------------
4452 -- Analyze_Subprogram_Specification --
4453 --------------------------------------
4455 -- Reminder: N here really is a subprogram specification (not a subprogram
4456 -- declaration). This procedure is called to analyze the specification in
4457 -- both subprogram bodies and subprogram declarations (specs).
4459 function Analyze_Subprogram_Specification
(N
: Node_Id
) return Entity_Id
is
4460 function Is_Invariant_Procedure_Or_Body
(E
: Entity_Id
) return Boolean;
4461 -- Determine whether entity E denotes the spec or body of an invariant
4464 ------------------------------------
4465 -- Is_Invariant_Procedure_Or_Body --
4466 ------------------------------------
4468 function Is_Invariant_Procedure_Or_Body
(E
: Entity_Id
) return Boolean is
4469 Decl
: constant Node_Id
:= Unit_Declaration_Node
(E
);
4473 if Nkind
(Decl
) = N_Subprogram_Body
then
4474 Spec
:= Corresponding_Spec
(Decl
);
4481 and then Ekind
(Spec
) = E_Procedure
4482 and then (Is_Partial_Invariant_Procedure
(Spec
)
4483 or else Is_Invariant_Procedure
(Spec
));
4484 end Is_Invariant_Procedure_Or_Body
;
4488 Designator
: constant Entity_Id
:= Defining_Entity
(N
);
4489 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
4491 -- Start of processing for Analyze_Subprogram_Specification
4494 -- User-defined operator is not allowed in SPARK, except as a renaming
4496 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Operator_Symbol
4497 and then Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
4499 Check_SPARK_05_Restriction
4500 ("user-defined operator is not allowed", N
);
4503 -- Proceed with analysis. Do not emit a cross-reference entry if the
4504 -- specification comes from an expression function, because it may be
4505 -- the completion of a previous declaration. It is not, the cross-
4506 -- reference entry will be emitted for the new subprogram declaration.
4508 if Nkind
(Parent
(N
)) /= N_Expression_Function
then
4509 Generate_Definition
(Designator
);
4512 if Nkind
(N
) = N_Function_Specification
then
4513 Set_Ekind
(Designator
, E_Function
);
4514 Set_Mechanism
(Designator
, Default_Mechanism
);
4516 Set_Ekind
(Designator
, E_Procedure
);
4517 Set_Etype
(Designator
, Standard_Void_Type
);
4520 -- Flag Is_Inlined_Always is True by default, and reversed to False for
4521 -- those subprograms which could be inlined in GNATprove mode (because
4522 -- Body_To_Inline is non-Empty) but should not be inlined.
4524 if GNATprove_Mode
then
4525 Set_Is_Inlined_Always
(Designator
);
4528 -- Introduce new scope for analysis of the formals and the return type
4530 Set_Scope
(Designator
, Current_Scope
);
4532 if Present
(Formals
) then
4533 Push_Scope
(Designator
);
4534 Process_Formals
(Formals
, N
);
4536 -- Check dimensions in N for formals with default expression
4538 Analyze_Dimension_Formals
(N
, Formals
);
4540 -- Ada 2005 (AI-345): If this is an overriding operation of an
4541 -- inherited interface operation, and the controlling type is
4542 -- a synchronized type, replace the type with its corresponding
4543 -- record, to match the proper signature of an overriding operation.
4544 -- Same processing for an access parameter whose designated type is
4545 -- derived from a synchronized interface.
4547 -- This modification is not done for invariant procedures because
4548 -- the corresponding record may not necessarely be visible when the
4549 -- concurrent type acts as the full view of a private type.
4552 -- type Prot is private with Type_Invariant => ...;
4553 -- procedure ConcInvariant (Obj : Prot);
4555 -- protected type Prot is ...;
4556 -- type Concurrent_Record_Prot is record ...;
4557 -- procedure ConcInvariant (Obj : Prot) is
4559 -- end ConcInvariant;
4562 -- In the example above, both the spec and body of the invariant
4563 -- procedure must utilize the private type as the controlling type.
4565 if Ada_Version
>= Ada_2005
4566 and then not Is_Invariant_Procedure_Or_Body
(Designator
)
4570 Formal_Typ
: Entity_Id
;
4571 Rec_Typ
: Entity_Id
;
4572 Desig_Typ
: Entity_Id
;
4575 Formal
:= First_Formal
(Designator
);
4576 while Present
(Formal
) loop
4577 Formal_Typ
:= Etype
(Formal
);
4579 if Is_Concurrent_Type
(Formal_Typ
)
4580 and then Present
(Corresponding_Record_Type
(Formal_Typ
))
4582 Rec_Typ
:= Corresponding_Record_Type
(Formal_Typ
);
4584 if Present
(Interfaces
(Rec_Typ
)) then
4585 Set_Etype
(Formal
, Rec_Typ
);
4588 elsif Ekind
(Formal_Typ
) = E_Anonymous_Access_Type
then
4589 Desig_Typ
:= Designated_Type
(Formal_Typ
);
4591 if Is_Concurrent_Type
(Desig_Typ
)
4592 and then Present
(Corresponding_Record_Type
(Desig_Typ
))
4594 Rec_Typ
:= Corresponding_Record_Type
(Desig_Typ
);
4596 if Present
(Interfaces
(Rec_Typ
)) then
4597 Set_Directly_Designated_Type
(Formal_Typ
, Rec_Typ
);
4602 Next_Formal
(Formal
);
4609 -- The subprogram scope is pushed and popped around the processing of
4610 -- the return type for consistency with call above to Process_Formals
4611 -- (which itself can call Analyze_Return_Type), and to ensure that any
4612 -- itype created for the return type will be associated with the proper
4615 elsif Nkind
(N
) = N_Function_Specification
then
4616 Push_Scope
(Designator
);
4617 Analyze_Return_Type
(N
);
4623 if Nkind
(N
) = N_Function_Specification
then
4625 -- Deal with operator symbol case
4627 if Nkind
(Designator
) = N_Defining_Operator_Symbol
then
4628 Valid_Operator_Definition
(Designator
);
4631 May_Need_Actuals
(Designator
);
4633 -- Ada 2005 (AI-251): If the return type is abstract, verify that
4634 -- the subprogram is abstract also. This does not apply to renaming
4635 -- declarations, where abstractness is inherited, and to subprogram
4636 -- bodies generated for stream operations, which become renamings as
4639 -- In case of primitives associated with abstract interface types
4640 -- the check is applied later (see Analyze_Subprogram_Declaration).
4642 if not Nkind_In
(Original_Node
(Parent
(N
)),
4643 N_Abstract_Subprogram_Declaration
,
4644 N_Formal_Abstract_Subprogram_Declaration
,
4645 N_Subprogram_Renaming_Declaration
)
4647 if Is_Abstract_Type
(Etype
(Designator
))
4648 and then not Is_Interface
(Etype
(Designator
))
4651 ("function that returns abstract type must be abstract", N
);
4653 -- Ada 2012 (AI-0073): Extend this test to subprograms with an
4654 -- access result whose designated type is abstract.
4656 elsif Ada_Version
>= Ada_2012
4657 and then Nkind
(Result_Definition
(N
)) = N_Access_Definition
4659 not Is_Class_Wide_Type
(Designated_Type
(Etype
(Designator
)))
4660 and then Is_Abstract_Type
(Designated_Type
(Etype
(Designator
)))
4663 ("function whose access result designates abstract type "
4664 & "must be abstract", N
);
4670 end Analyze_Subprogram_Specification
;
4672 -----------------------
4673 -- Check_Conformance --
4674 -----------------------
4676 procedure Check_Conformance
4677 (New_Id
: Entity_Id
;
4679 Ctype
: Conformance_Type
;
4681 Conforms
: out Boolean;
4682 Err_Loc
: Node_Id
:= Empty
;
4683 Get_Inst
: Boolean := False;
4684 Skip_Controlling_Formals
: Boolean := False)
4686 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
);
4687 -- Sets Conforms to False. If Errmsg is False, then that's all it does.
4688 -- If Errmsg is True, then processing continues to post an error message
4689 -- for conformance error on given node. Two messages are output. The
4690 -- first message points to the previous declaration with a general "no
4691 -- conformance" message. The second is the detailed reason, supplied as
4692 -- Msg. The parameter N provide information for a possible & insertion
4693 -- in the message, and also provides the location for posting the
4694 -- message in the absence of a specified Err_Loc location.
4696 -----------------------
4697 -- Conformance_Error --
4698 -----------------------
4700 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
) is
4707 if No
(Err_Loc
) then
4713 Error_Msg_Sloc
:= Sloc
(Old_Id
);
4716 when Type_Conformant
=>
4717 Error_Msg_N
-- CODEFIX
4718 ("not type conformant with declaration#!", Enode
);
4720 when Mode_Conformant
=>
4721 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
4723 ("not mode conformant with operation inherited#!",
4727 ("not mode conformant with declaration#!", Enode
);
4730 when Subtype_Conformant
=>
4731 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
4733 ("not subtype conformant with operation inherited#!",
4737 ("not subtype conformant with declaration#!", Enode
);
4740 when Fully_Conformant
=>
4741 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
4742 Error_Msg_N
-- CODEFIX
4743 ("not fully conformant with operation inherited#!",
4746 Error_Msg_N
-- CODEFIX
4747 ("not fully conformant with declaration#!", Enode
);
4751 Error_Msg_NE
(Msg
, Enode
, N
);
4753 end Conformance_Error
;
4757 Old_Type
: constant Entity_Id
:= Etype
(Old_Id
);
4758 New_Type
: constant Entity_Id
:= Etype
(New_Id
);
4759 Old_Formal
: Entity_Id
;
4760 New_Formal
: Entity_Id
;
4761 Access_Types_Match
: Boolean;
4762 Old_Formal_Base
: Entity_Id
;
4763 New_Formal_Base
: Entity_Id
;
4765 -- Start of processing for Check_Conformance
4770 -- We need a special case for operators, since they don't appear
4773 if Ctype
= Type_Conformant
then
4774 if Ekind
(New_Id
) = E_Operator
4775 and then Operator_Matches_Spec
(New_Id
, Old_Id
)
4781 -- If both are functions/operators, check return types conform
4783 if Old_Type
/= Standard_Void_Type
4785 New_Type
/= Standard_Void_Type
4787 -- If we are checking interface conformance we omit controlling
4788 -- arguments and result, because we are only checking the conformance
4789 -- of the remaining parameters.
4791 if Has_Controlling_Result
(Old_Id
)
4792 and then Has_Controlling_Result
(New_Id
)
4793 and then Skip_Controlling_Formals
4797 elsif not Conforming_Types
(Old_Type
, New_Type
, Ctype
, Get_Inst
) then
4798 if Ctype
>= Subtype_Conformant
4799 and then not Predicates_Match
(Old_Type
, New_Type
)
4802 ("\predicate of return type does not match!", New_Id
);
4805 ("\return type does not match!", New_Id
);
4811 -- Ada 2005 (AI-231): In case of anonymous access types check the
4812 -- null-exclusion and access-to-constant attributes match.
4814 if Ada_Version
>= Ada_2005
4815 and then Ekind
(Etype
(Old_Type
)) = E_Anonymous_Access_Type
4817 (Can_Never_Be_Null
(Old_Type
) /= Can_Never_Be_Null
(New_Type
)
4818 or else Is_Access_Constant
(Etype
(Old_Type
)) /=
4819 Is_Access_Constant
(Etype
(New_Type
)))
4821 Conformance_Error
("\return type does not match!", New_Id
);
4825 -- If either is a function/operator and the other isn't, error
4827 elsif Old_Type
/= Standard_Void_Type
4828 or else New_Type
/= Standard_Void_Type
4830 Conformance_Error
("\functions can only match functions!", New_Id
);
4834 -- In subtype conformant case, conventions must match (RM 6.3.1(16)).
4835 -- If this is a renaming as body, refine error message to indicate that
4836 -- the conflict is with the original declaration. If the entity is not
4837 -- frozen, the conventions don't have to match, the one of the renamed
4838 -- entity is inherited.
4840 if Ctype
>= Subtype_Conformant
then
4841 if Convention
(Old_Id
) /= Convention
(New_Id
) then
4842 if not Is_Frozen
(New_Id
) then
4845 elsif Present
(Err_Loc
)
4846 and then Nkind
(Err_Loc
) = N_Subprogram_Renaming_Declaration
4847 and then Present
(Corresponding_Spec
(Err_Loc
))
4849 Error_Msg_Name_1
:= Chars
(New_Id
);
4851 Name_Ada
+ Convention_Id
'Pos (Convention
(New_Id
));
4852 Conformance_Error
("\prior declaration for% has convention %!");
4855 Conformance_Error
("\calling conventions do not match!");
4860 elsif Is_Formal_Subprogram
(Old_Id
)
4861 or else Is_Formal_Subprogram
(New_Id
)
4863 Conformance_Error
("\formal subprograms not allowed!");
4868 -- Deal with parameters
4870 -- Note: we use the entity information, rather than going directly
4871 -- to the specification in the tree. This is not only simpler, but
4872 -- absolutely necessary for some cases of conformance tests between
4873 -- operators, where the declaration tree simply does not exist.
4875 Old_Formal
:= First_Formal
(Old_Id
);
4876 New_Formal
:= First_Formal
(New_Id
);
4877 while Present
(Old_Formal
) and then Present
(New_Formal
) loop
4878 if Is_Controlling_Formal
(Old_Formal
)
4879 and then Is_Controlling_Formal
(New_Formal
)
4880 and then Skip_Controlling_Formals
4882 -- The controlling formals will have different types when
4883 -- comparing an interface operation with its match, but both
4884 -- or neither must be access parameters.
4886 if Is_Access_Type
(Etype
(Old_Formal
))
4888 Is_Access_Type
(Etype
(New_Formal
))
4890 goto Skip_Controlling_Formal
;
4893 ("\access parameter does not match!", New_Formal
);
4897 -- Ada 2012: Mode conformance also requires that formal parameters
4898 -- be both aliased, or neither.
4900 if Ctype
>= Mode_Conformant
and then Ada_Version
>= Ada_2012
then
4901 if Is_Aliased
(Old_Formal
) /= Is_Aliased
(New_Formal
) then
4903 ("\aliased parameter mismatch!", New_Formal
);
4907 if Ctype
= Fully_Conformant
then
4909 -- Names must match. Error message is more accurate if we do
4910 -- this before checking that the types of the formals match.
4912 if Chars
(Old_Formal
) /= Chars
(New_Formal
) then
4913 Conformance_Error
("\name& does not match!", New_Formal
);
4915 -- Set error posted flag on new formal as well to stop
4916 -- junk cascaded messages in some cases.
4918 Set_Error_Posted
(New_Formal
);
4922 -- Null exclusion must match
4924 if Null_Exclusion_Present
(Parent
(Old_Formal
))
4926 Null_Exclusion_Present
(Parent
(New_Formal
))
4928 -- Only give error if both come from source. This should be
4929 -- investigated some time, since it should not be needed ???
4931 if Comes_From_Source
(Old_Formal
)
4933 Comes_From_Source
(New_Formal
)
4936 ("\null exclusion for& does not match", New_Formal
);
4938 -- Mark error posted on the new formal to avoid duplicated
4939 -- complaint about types not matching.
4941 Set_Error_Posted
(New_Formal
);
4946 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
4947 -- case occurs whenever a subprogram is being renamed and one of its
4948 -- parameters imposes a null exclusion. For example:
4950 -- type T is null record;
4951 -- type Acc_T is access T;
4952 -- subtype Acc_T_Sub is Acc_T;
4954 -- procedure P (Obj : not null Acc_T_Sub); -- itype
4955 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype
4958 Old_Formal_Base
:= Etype
(Old_Formal
);
4959 New_Formal_Base
:= Etype
(New_Formal
);
4962 Old_Formal_Base
:= Get_Instance_Of
(Old_Formal_Base
);
4963 New_Formal_Base
:= Get_Instance_Of
(New_Formal_Base
);
4966 Access_Types_Match
:= Ada_Version
>= Ada_2005
4968 -- Ensure that this rule is only applied when New_Id is a
4969 -- renaming of Old_Id.
4971 and then Nkind
(Parent
(Parent
(New_Id
))) =
4972 N_Subprogram_Renaming_Declaration
4973 and then Nkind
(Name
(Parent
(Parent
(New_Id
)))) in N_Has_Entity
4974 and then Present
(Entity
(Name
(Parent
(Parent
(New_Id
)))))
4975 and then Entity
(Name
(Parent
(Parent
(New_Id
)))) = Old_Id
4977 -- Now handle the allowed access-type case
4979 and then Is_Access_Type
(Old_Formal_Base
)
4980 and then Is_Access_Type
(New_Formal_Base
)
4982 -- The type kinds must match. The only exception occurs with
4983 -- multiple generics of the form:
4986 -- type F is private; type A is private;
4987 -- type F_Ptr is access F; type A_Ptr is access A;
4988 -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
4989 -- package F_Pack is ... package A_Pack is
4990 -- package F_Inst is
4991 -- new F_Pack (A, A_Ptr, A_P);
4993 -- When checking for conformance between the parameters of A_P
4994 -- and F_P, the type kinds of F_Ptr and A_Ptr will not match
4995 -- because the compiler has transformed A_Ptr into a subtype of
4996 -- F_Ptr. We catch this case in the code below.
4998 and then (Ekind
(Old_Formal_Base
) = Ekind
(New_Formal_Base
)
5000 (Is_Generic_Type
(Old_Formal_Base
)
5001 and then Is_Generic_Type
(New_Formal_Base
)
5002 and then Is_Internal
(New_Formal_Base
)
5003 and then Etype
(Etype
(New_Formal_Base
)) =
5005 and then Directly_Designated_Type
(Old_Formal_Base
) =
5006 Directly_Designated_Type
(New_Formal_Base
)
5007 and then ((Is_Itype
(Old_Formal_Base
)
5008 and then Can_Never_Be_Null
(Old_Formal_Base
))
5010 (Is_Itype
(New_Formal_Base
)
5011 and then Can_Never_Be_Null
(New_Formal_Base
)));
5013 -- Types must always match. In the visible part of an instance,
5014 -- usual overloading rules for dispatching operations apply, and
5015 -- we check base types (not the actual subtypes).
5017 if In_Instance_Visible_Part
5018 and then Is_Dispatching_Operation
(New_Id
)
5020 if not Conforming_Types
5021 (T1
=> Base_Type
(Etype
(Old_Formal
)),
5022 T2
=> Base_Type
(Etype
(New_Formal
)),
5024 Get_Inst
=> Get_Inst
)
5025 and then not Access_Types_Match
5027 Conformance_Error
("\type of & does not match!", New_Formal
);
5031 elsif not Conforming_Types
5032 (T1
=> Old_Formal_Base
,
5033 T2
=> New_Formal_Base
,
5035 Get_Inst
=> Get_Inst
)
5036 and then not Access_Types_Match
5038 -- Don't give error message if old type is Any_Type. This test
5039 -- avoids some cascaded errors, e.g. in case of a bad spec.
5041 if Errmsg
and then Old_Formal_Base
= Any_Type
then
5044 if Ctype
>= Subtype_Conformant
5046 not Predicates_Match
(Old_Formal_Base
, New_Formal_Base
)
5049 ("\predicate of & does not match!", New_Formal
);
5052 ("\type of & does not match!", New_Formal
);
5059 -- For mode conformance, mode must match
5061 if Ctype
>= Mode_Conformant
then
5062 if Parameter_Mode
(Old_Formal
) /= Parameter_Mode
(New_Formal
) then
5063 if not Ekind_In
(New_Id
, E_Function
, E_Procedure
)
5064 or else not Is_Primitive_Wrapper
(New_Id
)
5066 Conformance_Error
("\mode of & does not match!", New_Formal
);
5070 T
: constant Entity_Id
:= Find_Dispatching_Type
(New_Id
);
5072 if Is_Protected_Type
(Corresponding_Concurrent_Type
(T
))
5074 Error_Msg_PT
(New_Id
, Ultimate_Alias
(Old_Id
));
5077 ("\mode of & does not match!", New_Formal
);
5084 -- Part of mode conformance for access types is having the same
5085 -- constant modifier.
5087 elsif Access_Types_Match
5088 and then Is_Access_Constant
(Old_Formal_Base
) /=
5089 Is_Access_Constant
(New_Formal_Base
)
5092 ("\constant modifier does not match!", New_Formal
);
5097 if Ctype
>= Subtype_Conformant
then
5099 -- Ada 2005 (AI-231): In case of anonymous access types check
5100 -- the null-exclusion and access-to-constant attributes must
5101 -- match. For null exclusion, we test the types rather than the
5102 -- formals themselves, since the attribute is only set reliably
5103 -- on the formals in the Ada 95 case, and we exclude the case
5104 -- where Old_Formal is marked as controlling, to avoid errors
5105 -- when matching completing bodies with dispatching declarations
5106 -- (access formals in the bodies aren't marked Can_Never_Be_Null).
5108 if Ada_Version
>= Ada_2005
5109 and then Ekind
(Etype
(Old_Formal
)) = E_Anonymous_Access_Type
5110 and then Ekind
(Etype
(New_Formal
)) = E_Anonymous_Access_Type
5112 ((Can_Never_Be_Null
(Etype
(Old_Formal
)) /=
5113 Can_Never_Be_Null
(Etype
(New_Formal
))
5115 not Is_Controlling_Formal
(Old_Formal
))
5117 Is_Access_Constant
(Etype
(Old_Formal
)) /=
5118 Is_Access_Constant
(Etype
(New_Formal
)))
5120 -- Do not complain if error already posted on New_Formal. This
5121 -- avoids some redundant error messages.
5123 and then not Error_Posted
(New_Formal
)
5125 -- It is allowed to omit the null-exclusion in case of stream
5126 -- attribute subprograms. We recognize stream subprograms
5127 -- through their TSS-generated suffix.
5130 TSS_Name
: constant TSS_Name_Type
:= Get_TSS_Name
(New_Id
);
5133 if TSS_Name
/= TSS_Stream_Read
5134 and then TSS_Name
/= TSS_Stream_Write
5135 and then TSS_Name
/= TSS_Stream_Input
5136 and then TSS_Name
/= TSS_Stream_Output
5138 -- Here we have a definite conformance error. It is worth
5139 -- special casing the error message for the case of a
5140 -- controlling formal (which excludes null).
5142 if Is_Controlling_Formal
(New_Formal
) then
5143 Error_Msg_Node_2
:= Scope
(New_Formal
);
5145 ("\controlling formal & of & excludes null, "
5146 & "declaration must exclude null as well",
5149 -- Normal case (couldn't we give more detail here???)
5153 ("\type of & does not match!", New_Formal
);
5162 -- Full conformance checks
5164 if Ctype
= Fully_Conformant
then
5166 -- We have checked already that names match
5168 if Parameter_Mode
(Old_Formal
) = E_In_Parameter
then
5170 -- Check default expressions for in parameters
5173 NewD
: constant Boolean :=
5174 Present
(Default_Value
(New_Formal
));
5175 OldD
: constant Boolean :=
5176 Present
(Default_Value
(Old_Formal
));
5178 if NewD
or OldD
then
5180 -- The old default value has been analyzed because the
5181 -- current full declaration will have frozen everything
5182 -- before. The new default value has not been analyzed,
5183 -- so analyze it now before we check for conformance.
5186 Push_Scope
(New_Id
);
5187 Preanalyze_Spec_Expression
5188 (Default_Value
(New_Formal
), Etype
(New_Formal
));
5192 if not (NewD
and OldD
)
5193 or else not Fully_Conformant_Expressions
5194 (Default_Value
(Old_Formal
),
5195 Default_Value
(New_Formal
))
5198 ("\default expression for & does not match!",
5207 -- A couple of special checks for Ada 83 mode. These checks are
5208 -- skipped if either entity is an operator in package Standard,
5209 -- or if either old or new instance is not from the source program.
5211 if Ada_Version
= Ada_83
5212 and then Sloc
(Old_Id
) > Standard_Location
5213 and then Sloc
(New_Id
) > Standard_Location
5214 and then Comes_From_Source
(Old_Id
)
5215 and then Comes_From_Source
(New_Id
)
5218 Old_Param
: constant Node_Id
:= Declaration_Node
(Old_Formal
);
5219 New_Param
: constant Node_Id
:= Declaration_Node
(New_Formal
);
5222 -- Explicit IN must be present or absent in both cases. This
5223 -- test is required only in the full conformance case.
5225 if In_Present
(Old_Param
) /= In_Present
(New_Param
)
5226 and then Ctype
= Fully_Conformant
5229 ("\(Ada 83) IN must appear in both declarations",
5234 -- Grouping (use of comma in param lists) must be the same
5235 -- This is where we catch a misconformance like:
5238 -- A : Integer; B : Integer
5240 -- which are represented identically in the tree except
5241 -- for the setting of the flags More_Ids and Prev_Ids.
5243 if More_Ids
(Old_Param
) /= More_Ids
(New_Param
)
5244 or else Prev_Ids
(Old_Param
) /= Prev_Ids
(New_Param
)
5247 ("\grouping of & does not match!", New_Formal
);
5253 -- This label is required when skipping controlling formals
5255 <<Skip_Controlling_Formal
>>
5257 Next_Formal
(Old_Formal
);
5258 Next_Formal
(New_Formal
);
5261 if Present
(Old_Formal
) then
5262 Conformance_Error
("\too few parameters!");
5265 elsif Present
(New_Formal
) then
5266 Conformance_Error
("\too many parameters!", New_Formal
);
5269 end Check_Conformance
;
5271 -----------------------
5272 -- Check_Conventions --
5273 -----------------------
5275 procedure Check_Conventions
(Typ
: Entity_Id
) is
5276 Ifaces_List
: Elist_Id
;
5278 procedure Check_Convention
(Op
: Entity_Id
);
5279 -- Verify that the convention of inherited dispatching operation Op is
5280 -- consistent among all subprograms it overrides. In order to minimize
5281 -- the search, Search_From is utilized to designate a specific point in
5282 -- the list rather than iterating over the whole list once more.
5284 ----------------------
5285 -- Check_Convention --
5286 ----------------------
5288 procedure Check_Convention
(Op
: Entity_Id
) is
5289 Op_Conv
: constant Convention_Id
:= Convention
(Op
);
5290 Iface_Conv
: Convention_Id
;
5291 Iface_Elmt
: Elmt_Id
;
5292 Iface_Prim_Elmt
: Elmt_Id
;
5293 Iface_Prim
: Entity_Id
;
5296 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
5297 while Present
(Iface_Elmt
) loop
5299 First_Elmt
(Primitive_Operations
(Node
(Iface_Elmt
)));
5300 while Present
(Iface_Prim_Elmt
) loop
5301 Iface_Prim
:= Node
(Iface_Prim_Elmt
);
5302 Iface_Conv
:= Convention
(Iface_Prim
);
5304 if Is_Interface_Conformant
(Typ
, Iface_Prim
, Op
)
5305 and then Iface_Conv
/= Op_Conv
5308 ("inconsistent conventions in primitive operations", Typ
);
5310 Error_Msg_Name_1
:= Chars
(Op
);
5311 Error_Msg_Name_2
:= Get_Convention_Name
(Op_Conv
);
5312 Error_Msg_Sloc
:= Sloc
(Op
);
5314 if Comes_From_Source
(Op
) or else No
(Alias
(Op
)) then
5315 if not Present
(Overridden_Operation
(Op
)) then
5316 Error_Msg_N
("\\primitive % defined #", Typ
);
5319 ("\\overriding operation % with "
5320 & "convention % defined #", Typ
);
5323 else pragma Assert
(Present
(Alias
(Op
)));
5324 Error_Msg_Sloc
:= Sloc
(Alias
(Op
));
5325 Error_Msg_N
("\\inherited operation % with "
5326 & "convention % defined #", Typ
);
5329 Error_Msg_Name_1
:= Chars
(Op
);
5330 Error_Msg_Name_2
:= Get_Convention_Name
(Iface_Conv
);
5331 Error_Msg_Sloc
:= Sloc
(Iface_Prim
);
5332 Error_Msg_N
("\\overridden operation % with "
5333 & "convention % defined #", Typ
);
5335 -- Avoid cascading errors
5340 Next_Elmt
(Iface_Prim_Elmt
);
5343 Next_Elmt
(Iface_Elmt
);
5345 end Check_Convention
;
5349 Prim_Op
: Entity_Id
;
5350 Prim_Op_Elmt
: Elmt_Id
;
5352 -- Start of processing for Check_Conventions
5355 if not Has_Interfaces
(Typ
) then
5359 Collect_Interfaces
(Typ
, Ifaces_List
);
5361 -- The algorithm checks every overriding dispatching operation against
5362 -- all the corresponding overridden dispatching operations, detecting
5363 -- differences in conventions.
5365 Prim_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5366 while Present
(Prim_Op_Elmt
) loop
5367 Prim_Op
:= Node
(Prim_Op_Elmt
);
5369 -- A small optimization: skip the predefined dispatching operations
5370 -- since they always have the same convention.
5372 if not Is_Predefined_Dispatching_Operation
(Prim_Op
) then
5373 Check_Convention
(Prim_Op
);
5376 Next_Elmt
(Prim_Op_Elmt
);
5378 end Check_Conventions
;
5380 ------------------------------
5381 -- Check_Delayed_Subprogram --
5382 ------------------------------
5384 procedure Check_Delayed_Subprogram
(Designator
: Entity_Id
) is
5387 procedure Possible_Freeze
(T
: Entity_Id
);
5388 -- T is the type of either a formal parameter or of the return type.
5389 -- If T is not yet frozen and needs a delayed freeze, then the
5390 -- subprogram itself must be delayed.
5392 ---------------------
5393 -- Possible_Freeze --
5394 ---------------------
5396 procedure Possible_Freeze
(T
: Entity_Id
) is
5398 if Has_Delayed_Freeze
(T
) and then not Is_Frozen
(T
) then
5399 Set_Has_Delayed_Freeze
(Designator
);
5401 elsif Is_Access_Type
(T
)
5402 and then Has_Delayed_Freeze
(Designated_Type
(T
))
5403 and then not Is_Frozen
(Designated_Type
(T
))
5405 Set_Has_Delayed_Freeze
(Designator
);
5408 end Possible_Freeze
;
5410 -- Start of processing for Check_Delayed_Subprogram
5413 -- All subprograms, including abstract subprograms, may need a freeze
5414 -- node if some formal type or the return type needs one.
5416 Possible_Freeze
(Etype
(Designator
));
5417 Possible_Freeze
(Base_Type
(Etype
(Designator
))); -- needed ???
5419 -- Need delayed freeze if any of the formal types themselves need
5420 -- a delayed freeze and are not yet frozen.
5422 F
:= First_Formal
(Designator
);
5423 while Present
(F
) loop
5424 Possible_Freeze
(Etype
(F
));
5425 Possible_Freeze
(Base_Type
(Etype
(F
))); -- needed ???
5429 -- Mark functions that return by reference. Note that it cannot be
5430 -- done for delayed_freeze subprograms because the underlying
5431 -- returned type may not be known yet (for private types)
5433 if not Has_Delayed_Freeze
(Designator
) and then Expander_Active
then
5435 Typ
: constant Entity_Id
:= Etype
(Designator
);
5436 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
5438 if Is_Limited_View
(Typ
) then
5439 Set_Returns_By_Ref
(Designator
);
5440 elsif Present
(Utyp
) and then CW_Or_Has_Controlled_Part
(Utyp
) then
5441 Set_Returns_By_Ref
(Designator
);
5445 end Check_Delayed_Subprogram
;
5447 ------------------------------------
5448 -- Check_Discriminant_Conformance --
5449 ------------------------------------
5451 procedure Check_Discriminant_Conformance
5456 Old_Discr
: Entity_Id
:= First_Discriminant
(Prev
);
5457 New_Discr
: Node_Id
:= First
(Discriminant_Specifications
(N
));
5458 New_Discr_Id
: Entity_Id
;
5459 New_Discr_Type
: Entity_Id
;
5461 procedure Conformance_Error
(Msg
: String; N
: Node_Id
);
5462 -- Post error message for conformance error on given node. Two messages
5463 -- are output. The first points to the previous declaration with a
5464 -- general "no conformance" message. The second is the detailed reason,
5465 -- supplied as Msg. The parameter N provide information for a possible
5466 -- & insertion in the message.
5468 -----------------------
5469 -- Conformance_Error --
5470 -----------------------
5472 procedure Conformance_Error
(Msg
: String; N
: Node_Id
) is
5474 Error_Msg_Sloc
:= Sloc
(Prev_Loc
);
5475 Error_Msg_N
-- CODEFIX
5476 ("not fully conformant with declaration#!", N
);
5477 Error_Msg_NE
(Msg
, N
, N
);
5478 end Conformance_Error
;
5480 -- Start of processing for Check_Discriminant_Conformance
5483 while Present
(Old_Discr
) and then Present
(New_Discr
) loop
5484 New_Discr_Id
:= Defining_Identifier
(New_Discr
);
5486 -- The subtype mark of the discriminant on the full type has not
5487 -- been analyzed so we do it here. For an access discriminant a new
5490 if Nkind
(Discriminant_Type
(New_Discr
)) = N_Access_Definition
then
5492 Access_Definition
(N
, Discriminant_Type
(New_Discr
));
5495 Analyze
(Discriminant_Type
(New_Discr
));
5496 New_Discr_Type
:= Etype
(Discriminant_Type
(New_Discr
));
5498 -- Ada 2005: if the discriminant definition carries a null
5499 -- exclusion, create an itype to check properly for consistency
5500 -- with partial declaration.
5502 if Is_Access_Type
(New_Discr_Type
)
5503 and then Null_Exclusion_Present
(New_Discr
)
5506 Create_Null_Excluding_Itype
5507 (T
=> New_Discr_Type
,
5508 Related_Nod
=> New_Discr
,
5509 Scope_Id
=> Current_Scope
);
5513 if not Conforming_Types
5514 (Etype
(Old_Discr
), New_Discr_Type
, Fully_Conformant
)
5516 Conformance_Error
("type of & does not match!", New_Discr_Id
);
5519 -- Treat the new discriminant as an occurrence of the old one,
5520 -- for navigation purposes, and fill in some semantic
5521 -- information, for completeness.
5523 Generate_Reference
(Old_Discr
, New_Discr_Id
, 'r');
5524 Set_Etype
(New_Discr_Id
, Etype
(Old_Discr
));
5525 Set_Scope
(New_Discr_Id
, Scope
(Old_Discr
));
5530 if Chars
(Old_Discr
) /= Chars
(Defining_Identifier
(New_Discr
)) then
5531 Conformance_Error
("name & does not match!", New_Discr_Id
);
5535 -- Default expressions must match
5538 NewD
: constant Boolean :=
5539 Present
(Expression
(New_Discr
));
5540 OldD
: constant Boolean :=
5541 Present
(Expression
(Parent
(Old_Discr
)));
5544 if NewD
or OldD
then
5546 -- The old default value has been analyzed and expanded,
5547 -- because the current full declaration will have frozen
5548 -- everything before. The new default values have not been
5549 -- expanded, so expand now to check conformance.
5552 Preanalyze_Spec_Expression
5553 (Expression
(New_Discr
), New_Discr_Type
);
5556 if not (NewD
and OldD
)
5557 or else not Fully_Conformant_Expressions
5558 (Expression
(Parent
(Old_Discr
)),
5559 Expression
(New_Discr
))
5563 ("default expression for & does not match!",
5570 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
5572 if Ada_Version
= Ada_83
then
5574 Old_Disc
: constant Node_Id
:= Declaration_Node
(Old_Discr
);
5577 -- Grouping (use of comma in param lists) must be the same
5578 -- This is where we catch a misconformance like:
5581 -- A : Integer; B : Integer
5583 -- which are represented identically in the tree except
5584 -- for the setting of the flags More_Ids and Prev_Ids.
5586 if More_Ids
(Old_Disc
) /= More_Ids
(New_Discr
)
5587 or else Prev_Ids
(Old_Disc
) /= Prev_Ids
(New_Discr
)
5590 ("grouping of & does not match!", New_Discr_Id
);
5596 Next_Discriminant
(Old_Discr
);
5600 if Present
(Old_Discr
) then
5601 Conformance_Error
("too few discriminants!", Defining_Identifier
(N
));
5604 elsif Present
(New_Discr
) then
5606 ("too many discriminants!", Defining_Identifier
(New_Discr
));
5609 end Check_Discriminant_Conformance
;
5611 ----------------------------
5612 -- Check_Fully_Conformant --
5613 ----------------------------
5615 procedure Check_Fully_Conformant
5616 (New_Id
: Entity_Id
;
5618 Err_Loc
: Node_Id
:= Empty
)
5621 pragma Warnings
(Off
, Result
);
5624 (New_Id
, Old_Id
, Fully_Conformant
, True, Result
, Err_Loc
);
5625 end Check_Fully_Conformant
;
5627 --------------------------
5628 -- Check_Limited_Return --
5629 --------------------------
5631 procedure Check_Limited_Return
5637 -- Ada 2005 (AI-318-02): Return-by-reference types have been removed and
5638 -- replaced by anonymous access results. This is an incompatibility with
5639 -- Ada 95. Not clear whether this should be enforced yet or perhaps
5640 -- controllable with special switch. ???
5642 -- A limited interface that is not immutably limited is OK
5644 if Is_Limited_Interface
(R_Type
)
5646 not (Is_Task_Interface
(R_Type
)
5647 or else Is_Protected_Interface
(R_Type
)
5648 or else Is_Synchronized_Interface
(R_Type
))
5652 elsif Is_Limited_Type
(R_Type
)
5653 and then not Is_Interface
(R_Type
)
5654 and then Comes_From_Source
(N
)
5655 and then not In_Instance_Body
5656 and then not OK_For_Limited_Init_In_05
(R_Type
, Expr
)
5658 -- Error in Ada 2005
5660 if Ada_Version
>= Ada_2005
5661 and then not Debug_Flag_Dot_L
5662 and then not GNAT_Mode
5665 ("(Ada 2005) cannot copy object of a limited type "
5666 & "(RM-2005 6.5(5.5/2))", Expr
);
5668 if Is_Limited_View
(R_Type
) then
5670 ("\return by reference not permitted in Ada 2005", Expr
);
5673 -- Warn in Ada 95 mode, to give folks a heads up about this
5676 -- In GNAT mode, this is just a warning, to allow it to be evilly
5677 -- turned off. Otherwise it is a real error.
5679 -- In a generic context, simplify the warning because it makes no
5680 -- sense to discuss pass-by-reference or copy.
5682 elsif Warn_On_Ada_2005_Compatibility
or GNAT_Mode
then
5683 if Inside_A_Generic
then
5685 ("return of limited object not permitted in Ada 2005 "
5686 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
5688 elsif Is_Limited_View
(R_Type
) then
5690 ("return by reference not permitted in Ada 2005 "
5691 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
5694 ("cannot copy object of a limited type in Ada 2005 "
5695 & "(RM-2005 6.5(5.5/2))?y?", Expr
);
5698 -- Ada 95 mode, compatibility warnings disabled
5701 return; -- skip continuation messages below
5704 if not Inside_A_Generic
then
5706 ("\consider switching to return of access type", Expr
);
5707 Explain_Limited_Type
(R_Type
, Expr
);
5710 end Check_Limited_Return
;
5712 ---------------------------
5713 -- Check_Mode_Conformant --
5714 ---------------------------
5716 procedure Check_Mode_Conformant
5717 (New_Id
: Entity_Id
;
5719 Err_Loc
: Node_Id
:= Empty
;
5720 Get_Inst
: Boolean := False)
5723 pragma Warnings
(Off
, Result
);
5726 (New_Id
, Old_Id
, Mode_Conformant
, True, Result
, Err_Loc
, Get_Inst
);
5727 end Check_Mode_Conformant
;
5729 --------------------------------
5730 -- Check_Overriding_Indicator --
5731 --------------------------------
5733 procedure Check_Overriding_Indicator
5735 Overridden_Subp
: Entity_Id
;
5736 Is_Primitive
: Boolean)
5742 -- No overriding indicator for literals
5744 if Ekind
(Subp
) = E_Enumeration_Literal
then
5747 elsif Ekind
(Subp
) = E_Entry
then
5748 Decl
:= Parent
(Subp
);
5750 -- No point in analyzing a malformed operator
5752 elsif Nkind
(Subp
) = N_Defining_Operator_Symbol
5753 and then Error_Posted
(Subp
)
5758 Decl
:= Unit_Declaration_Node
(Subp
);
5761 if Nkind_In
(Decl
, N_Subprogram_Body
,
5762 N_Subprogram_Body_Stub
,
5763 N_Subprogram_Declaration
,
5764 N_Abstract_Subprogram_Declaration
,
5765 N_Subprogram_Renaming_Declaration
)
5767 Spec
:= Specification
(Decl
);
5769 elsif Nkind
(Decl
) = N_Entry_Declaration
then
5776 -- The overriding operation is type conformant with the overridden one,
5777 -- but the names of the formals are not required to match. If the names
5778 -- appear permuted in the overriding operation, this is a possible
5779 -- source of confusion that is worth diagnosing. Controlling formals
5780 -- often carry names that reflect the type, and it is not worthwhile
5781 -- requiring that their names match.
5783 if Present
(Overridden_Subp
)
5784 and then Nkind
(Subp
) /= N_Defining_Operator_Symbol
5791 Form1
:= First_Formal
(Subp
);
5792 Form2
:= First_Formal
(Overridden_Subp
);
5794 -- If the overriding operation is a synchronized operation, skip
5795 -- the first parameter of the overridden operation, which is
5796 -- implicit in the new one. If the operation is declared in the
5797 -- body it is not primitive and all formals must match.
5799 if Is_Concurrent_Type
(Scope
(Subp
))
5800 and then Is_Tagged_Type
(Scope
(Subp
))
5801 and then not Has_Completion
(Scope
(Subp
))
5803 Form2
:= Next_Formal
(Form2
);
5806 if Present
(Form1
) then
5807 Form1
:= Next_Formal
(Form1
);
5808 Form2
:= Next_Formal
(Form2
);
5811 while Present
(Form1
) loop
5812 if not Is_Controlling_Formal
(Form1
)
5813 and then Present
(Next_Formal
(Form2
))
5814 and then Chars
(Form1
) = Chars
(Next_Formal
(Form2
))
5816 Error_Msg_Node_2
:= Alias
(Overridden_Subp
);
5817 Error_Msg_Sloc
:= Sloc
(Error_Msg_Node_2
);
5819 ("& does not match corresponding formal of&#",
5824 Next_Formal
(Form1
);
5825 Next_Formal
(Form2
);
5830 -- If there is an overridden subprogram, then check that there is no
5831 -- "not overriding" indicator, and mark the subprogram as overriding.
5832 -- This is not done if the overridden subprogram is marked as hidden,
5833 -- which can occur for the case of inherited controlled operations
5834 -- (see Derive_Subprogram), unless the inherited subprogram's parent
5835 -- subprogram is not itself hidden. (Note: This condition could probably
5836 -- be simplified, leaving out the testing for the specific controlled
5837 -- cases, but it seems safer and clearer this way, and echoes similar
5838 -- special-case tests of this kind in other places.)
5840 if Present
(Overridden_Subp
)
5841 and then (not Is_Hidden
(Overridden_Subp
)
5843 (Nam_In
(Chars
(Overridden_Subp
), Name_Initialize
,
5846 and then Present
(Alias
(Overridden_Subp
))
5847 and then not Is_Hidden
(Alias
(Overridden_Subp
))))
5849 if Must_Not_Override
(Spec
) then
5850 Error_Msg_Sloc
:= Sloc
(Overridden_Subp
);
5852 if Ekind
(Subp
) = E_Entry
then
5854 ("entry & overrides inherited operation #", Spec
, Subp
);
5857 ("subprogram & overrides inherited operation #", Spec
, Subp
);
5860 -- Special-case to fix a GNAT oddity: Limited_Controlled is declared
5861 -- as an extension of Root_Controlled, and thus has a useless Adjust
5862 -- operation. This operation should not be inherited by other limited
5863 -- controlled types. An explicit Adjust for them is not overriding.
5865 elsif Must_Override
(Spec
)
5866 and then Chars
(Overridden_Subp
) = Name_Adjust
5867 and then Is_Limited_Type
(Etype
(First_Formal
(Subp
)))
5868 and then Present
(Alias
(Overridden_Subp
))
5870 Is_Predefined_File_Name
5871 (Unit_File_Name
(Get_Source_Unit
(Alias
(Overridden_Subp
))))
5873 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
5875 elsif Is_Subprogram
(Subp
) then
5876 if Is_Init_Proc
(Subp
) then
5879 elsif No
(Overridden_Operation
(Subp
)) then
5881 -- For entities generated by Derive_Subprograms the overridden
5882 -- operation is the inherited primitive (which is available
5883 -- through the attribute alias)
5885 if (Is_Dispatching_Operation
(Subp
)
5886 or else Is_Dispatching_Operation
(Overridden_Subp
))
5887 and then not Comes_From_Source
(Overridden_Subp
)
5888 and then Find_Dispatching_Type
(Overridden_Subp
) =
5889 Find_Dispatching_Type
(Subp
)
5890 and then Present
(Alias
(Overridden_Subp
))
5891 and then Comes_From_Source
(Alias
(Overridden_Subp
))
5893 Set_Overridden_Operation
(Subp
, Alias
(Overridden_Subp
));
5894 Inherit_Subprogram_Contract
(Subp
, Alias
(Overridden_Subp
));
5897 Set_Overridden_Operation
(Subp
, Overridden_Subp
);
5898 Inherit_Subprogram_Contract
(Subp
, Overridden_Subp
);
5903 -- If primitive flag is set or this is a protected operation, then
5904 -- the operation is overriding at the point of its declaration, so
5905 -- warn if necessary. Otherwise it may have been declared before the
5906 -- operation it overrides and no check is required.
5909 and then not Must_Override
(Spec
)
5910 and then (Is_Primitive
5911 or else Ekind
(Scope
(Subp
)) = E_Protected_Type
)
5913 Style
.Missing_Overriding
(Decl
, Subp
);
5916 -- If Subp is an operator, it may override a predefined operation, if
5917 -- it is defined in the same scope as the type to which it applies.
5918 -- In that case Overridden_Subp is empty because of our implicit
5919 -- representation for predefined operators. We have to check whether the
5920 -- signature of Subp matches that of a predefined operator. Note that
5921 -- first argument provides the name of the operator, and the second
5922 -- argument the signature that may match that of a standard operation.
5923 -- If the indicator is overriding, then the operator must match a
5924 -- predefined signature, because we know already that there is no
5925 -- explicit overridden operation.
5927 elsif Nkind
(Subp
) = N_Defining_Operator_Symbol
then
5928 if Must_Not_Override
(Spec
) then
5930 -- If this is not a primitive or a protected subprogram, then
5931 -- "not overriding" is illegal.
5934 and then Ekind
(Scope
(Subp
)) /= E_Protected_Type
5936 Error_Msg_N
("overriding indicator only allowed "
5937 & "if subprogram is primitive", Subp
);
5939 elsif Can_Override_Operator
(Subp
) then
5941 ("subprogram& overrides predefined operator ", Spec
, Subp
);
5944 elsif Must_Override
(Spec
) then
5945 if No
(Overridden_Operation
(Subp
))
5946 and then not Can_Override_Operator
(Subp
)
5948 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
5951 elsif not Error_Posted
(Subp
)
5952 and then Style_Check
5953 and then Can_Override_Operator
(Subp
)
5955 not Is_Predefined_File_Name
5956 (Unit_File_Name
(Get_Source_Unit
(Subp
)))
5958 -- If style checks are enabled, indicate that the indicator is
5959 -- missing. However, at the point of declaration, the type of
5960 -- which this is a primitive operation may be private, in which
5961 -- case the indicator would be premature.
5963 if Has_Private_Declaration
(Etype
(Subp
))
5964 or else Has_Private_Declaration
(Etype
(First_Formal
(Subp
)))
5968 Style
.Missing_Overriding
(Decl
, Subp
);
5972 elsif Must_Override
(Spec
) then
5973 if Ekind
(Subp
) = E_Entry
then
5974 Error_Msg_NE
("entry & is not overriding", Spec
, Subp
);
5976 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
5979 -- If the operation is marked "not overriding" and it's not primitive
5980 -- then an error is issued, unless this is an operation of a task or
5981 -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
5982 -- has been specified have already been checked above.
5984 elsif Must_Not_Override
(Spec
)
5985 and then not Is_Primitive
5986 and then Ekind
(Subp
) /= E_Entry
5987 and then Ekind
(Scope
(Subp
)) /= E_Protected_Type
5990 ("overriding indicator only allowed if subprogram is primitive",
5994 end Check_Overriding_Indicator
;
6000 -- Note: this procedure needs to know far too much about how the expander
6001 -- messes with exceptions. The use of the flag Exception_Junk and the
6002 -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
6003 -- works, but is not very clean. It would be better if the expansion
6004 -- routines would leave Original_Node working nicely, and we could use
6005 -- Original_Node here to ignore all the peculiar expander messing ???
6007 procedure Check_Returns
6011 Proc
: Entity_Id
:= Empty
)
6015 procedure Check_Statement_Sequence
(L
: List_Id
);
6016 -- Internal recursive procedure to check a list of statements for proper
6017 -- termination by a return statement (or a transfer of control or a
6018 -- compound statement that is itself internally properly terminated).
6020 ------------------------------
6021 -- Check_Statement_Sequence --
6022 ------------------------------
6024 procedure Check_Statement_Sequence
(L
: List_Id
) is
6029 function Assert_False
return Boolean;
6030 -- Returns True if Last_Stm is a pragma Assert (False) that has been
6031 -- rewritten as a null statement when assertions are off. The assert
6032 -- is not active, but it is still enough to kill the warning.
6038 function Assert_False
return Boolean is
6039 Orig
: constant Node_Id
:= Original_Node
(Last_Stm
);
6042 if Nkind
(Orig
) = N_Pragma
6043 and then Pragma_Name
(Orig
) = Name_Assert
6044 and then not Error_Posted
(Orig
)
6047 Arg
: constant Node_Id
:=
6048 First
(Pragma_Argument_Associations
(Orig
));
6049 Exp
: constant Node_Id
:= Expression
(Arg
);
6051 return Nkind
(Exp
) = N_Identifier
6052 and then Chars
(Exp
) = Name_False
;
6062 Raise_Exception_Call
: Boolean;
6063 -- Set True if statement sequence terminated by Raise_Exception call
6064 -- or a Reraise_Occurrence call.
6066 -- Start of processing for Check_Statement_Sequence
6069 Raise_Exception_Call
:= False;
6071 -- Get last real statement
6073 Last_Stm
:= Last
(L
);
6075 -- Deal with digging out exception handler statement sequences that
6076 -- have been transformed by the local raise to goto optimization.
6077 -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
6078 -- optimization has occurred, we are looking at something like:
6081 -- original stmts in block
6085 -- goto L1; | omitted if No_Exception_Propagation
6090 -- goto L3; -- skip handler when exception not raised
6092 -- <<L1>> -- target label for local exception
6106 -- and what we have to do is to dig out the estmts1 and estmts2
6107 -- sequences (which were the original sequences of statements in
6108 -- the exception handlers) and check them.
6110 if Nkind
(Last_Stm
) = N_Label
and then Exception_Junk
(Last_Stm
) then
6115 exit when Nkind
(Stm
) /= N_Block_Statement
;
6116 exit when not Exception_Junk
(Stm
);
6119 exit when Nkind
(Stm
) /= N_Label
;
6120 exit when not Exception_Junk
(Stm
);
6121 Check_Statement_Sequence
6122 (Statements
(Handled_Statement_Sequence
(Next
(Stm
))));
6127 exit when Nkind
(Stm
) /= N_Goto_Statement
;
6128 exit when not Exception_Junk
(Stm
);
6132 -- Don't count pragmas
6134 while Nkind
(Last_Stm
) = N_Pragma
6136 -- Don't count call to SS_Release (can happen after Raise_Exception)
6139 (Nkind
(Last_Stm
) = N_Procedure_Call_Statement
6141 Nkind
(Name
(Last_Stm
)) = N_Identifier
6143 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_SS_Release
))
6145 -- Don't count exception junk
6148 (Nkind_In
(Last_Stm
, N_Goto_Statement
,
6150 N_Object_Declaration
)
6151 and then Exception_Junk
(Last_Stm
))
6152 or else Nkind
(Last_Stm
) in N_Push_xxx_Label
6153 or else Nkind
(Last_Stm
) in N_Pop_xxx_Label
6155 -- Inserted code, such as finalization calls, is irrelevant: we only
6156 -- need to check original source.
6158 or else Is_Rewrite_Insertion
(Last_Stm
)
6163 -- Here we have the "real" last statement
6165 Kind
:= Nkind
(Last_Stm
);
6167 -- Transfer of control, OK. Note that in the No_Return procedure
6168 -- case, we already diagnosed any explicit return statements, so
6169 -- we can treat them as OK in this context.
6171 if Is_Transfer
(Last_Stm
) then
6174 -- Check cases of explicit non-indirect procedure calls
6176 elsif Kind
= N_Procedure_Call_Statement
6177 and then Is_Entity_Name
(Name
(Last_Stm
))
6179 -- Check call to Raise_Exception procedure which is treated
6180 -- specially, as is a call to Reraise_Occurrence.
6182 -- We suppress the warning in these cases since it is likely that
6183 -- the programmer really does not expect to deal with the case
6184 -- of Null_Occurrence, and thus would find a warning about a
6185 -- missing return curious, and raising Program_Error does not
6186 -- seem such a bad behavior if this does occur.
6188 -- Note that in the Ada 2005 case for Raise_Exception, the actual
6189 -- behavior will be to raise Constraint_Error (see AI-329).
6191 if Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Raise_Exception
)
6193 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Reraise_Occurrence
)
6195 Raise_Exception_Call
:= True;
6197 -- For Raise_Exception call, test first argument, if it is
6198 -- an attribute reference for a 'Identity call, then we know
6199 -- that the call cannot possibly return.
6202 Arg
: constant Node_Id
:=
6203 Original_Node
(First_Actual
(Last_Stm
));
6205 if Nkind
(Arg
) = N_Attribute_Reference
6206 and then Attribute_Name
(Arg
) = Name_Identity
6213 -- If statement, need to look inside if there is an else and check
6214 -- each constituent statement sequence for proper termination.
6216 elsif Kind
= N_If_Statement
6217 and then Present
(Else_Statements
(Last_Stm
))
6219 Check_Statement_Sequence
(Then_Statements
(Last_Stm
));
6220 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
6222 if Present
(Elsif_Parts
(Last_Stm
)) then
6224 Elsif_Part
: Node_Id
:= First
(Elsif_Parts
(Last_Stm
));
6227 while Present
(Elsif_Part
) loop
6228 Check_Statement_Sequence
(Then_Statements
(Elsif_Part
));
6236 -- Case statement, check each case for proper termination
6238 elsif Kind
= N_Case_Statement
then
6242 Case_Alt
:= First_Non_Pragma
(Alternatives
(Last_Stm
));
6243 while Present
(Case_Alt
) loop
6244 Check_Statement_Sequence
(Statements
(Case_Alt
));
6245 Next_Non_Pragma
(Case_Alt
);
6251 -- Block statement, check its handled sequence of statements
6253 elsif Kind
= N_Block_Statement
then
6259 (Handled_Statement_Sequence
(Last_Stm
), Mode
, Err1
);
6268 -- Loop statement. If there is an iteration scheme, we can definitely
6269 -- fall out of the loop. Similarly if there is an exit statement, we
6270 -- can fall out. In either case we need a following return.
6272 elsif Kind
= N_Loop_Statement
then
6273 if Present
(Iteration_Scheme
(Last_Stm
))
6274 or else Has_Exit
(Entity
(Identifier
(Last_Stm
)))
6278 -- A loop with no exit statement or iteration scheme is either
6279 -- an infinite loop, or it has some other exit (raise/return).
6280 -- In either case, no warning is required.
6286 -- Timed entry call, check entry call and delay alternatives
6288 -- Note: in expanded code, the timed entry call has been converted
6289 -- to a set of expanded statements on which the check will work
6290 -- correctly in any case.
6292 elsif Kind
= N_Timed_Entry_Call
then
6294 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
6295 DCA
: constant Node_Id
:= Delay_Alternative
(Last_Stm
);
6298 -- If statement sequence of entry call alternative is missing,
6299 -- then we can definitely fall through, and we post the error
6300 -- message on the entry call alternative itself.
6302 if No
(Statements
(ECA
)) then
6305 -- If statement sequence of delay alternative is missing, then
6306 -- we can definitely fall through, and we post the error
6307 -- message on the delay alternative itself.
6309 -- Note: if both ECA and DCA are missing the return, then we
6310 -- post only one message, should be enough to fix the bugs.
6311 -- If not we will get a message next time on the DCA when the
6314 elsif No
(Statements
(DCA
)) then
6317 -- Else check both statement sequences
6320 Check_Statement_Sequence
(Statements
(ECA
));
6321 Check_Statement_Sequence
(Statements
(DCA
));
6326 -- Conditional entry call, check entry call and else part
6328 -- Note: in expanded code, the conditional entry call has been
6329 -- converted to a set of expanded statements on which the check
6330 -- will work correctly in any case.
6332 elsif Kind
= N_Conditional_Entry_Call
then
6334 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
6337 -- If statement sequence of entry call alternative is missing,
6338 -- then we can definitely fall through, and we post the error
6339 -- message on the entry call alternative itself.
6341 if No
(Statements
(ECA
)) then
6344 -- Else check statement sequence and else part
6347 Check_Statement_Sequence
(Statements
(ECA
));
6348 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
6354 -- If we fall through, issue appropriate message
6358 -- Kill warning if last statement is a raise exception call,
6359 -- or a pragma Assert (False). Note that with assertions enabled,
6360 -- such a pragma has been converted into a raise exception call
6361 -- already, so the Assert_False is for the assertions off case.
6363 if not Raise_Exception_Call
and then not Assert_False
then
6365 -- In GNATprove mode, it is an error to have a missing return
6367 Error_Msg_Warn
:= SPARK_Mode
/= On
;
6369 -- Issue error message or warning
6372 ("RETURN statement missing following this statement<<!",
6375 ("\Program_Error ]<<!", Last_Stm
);
6378 -- Note: we set Err even though we have not issued a warning
6379 -- because we still have a case of a missing return. This is
6380 -- an extremely marginal case, probably will never be noticed
6381 -- but we might as well get it right.
6385 -- Otherwise we have the case of a procedure marked No_Return
6388 if not Raise_Exception_Call
then
6389 if GNATprove_Mode
then
6391 ("implied return after this statement "
6392 & "would have raised Program_Error", Last_Stm
);
6395 ("implied return after this statement "
6396 & "will raise Program_Error??", Last_Stm
);
6399 Error_Msg_Warn
:= SPARK_Mode
/= On
;
6401 ("\procedure & is marked as No_Return<<!", Last_Stm
, Proc
);
6405 RE
: constant Node_Id
:=
6406 Make_Raise_Program_Error
(Sloc
(Last_Stm
),
6407 Reason
=> PE_Implicit_Return
);
6409 Insert_After
(Last_Stm
, RE
);
6413 end Check_Statement_Sequence
;
6415 -- Start of processing for Check_Returns
6419 Check_Statement_Sequence
(Statements
(HSS
));
6421 if Present
(Exception_Handlers
(HSS
)) then
6422 Handler
:= First_Non_Pragma
(Exception_Handlers
(HSS
));
6423 while Present
(Handler
) loop
6424 Check_Statement_Sequence
(Statements
(Handler
));
6425 Next_Non_Pragma
(Handler
);
6430 ----------------------------
6431 -- Check_Subprogram_Order --
6432 ----------------------------
6434 procedure Check_Subprogram_Order
(N
: Node_Id
) is
6436 function Subprogram_Name_Greater
(S1
, S2
: String) return Boolean;
6437 -- This is used to check if S1 > S2 in the sense required by this test,
6438 -- for example nameab < namec, but name2 < name10.
6440 -----------------------------
6441 -- Subprogram_Name_Greater --
6442 -----------------------------
6444 function Subprogram_Name_Greater
(S1
, S2
: String) return Boolean is
6449 -- Deal with special case where names are identical except for a
6450 -- numerical suffix. These are handled specially, taking the numeric
6451 -- ordering from the suffix into account.
6454 while S1
(L1
) in '0' .. '9' loop
6459 while S2
(L2
) in '0' .. '9' loop
6463 -- If non-numeric parts non-equal, do straight compare
6465 if S1
(S1
'First .. L1
) /= S2
(S2
'First .. L2
) then
6468 -- If non-numeric parts equal, compare suffixed numeric parts. Note
6469 -- that a missing suffix is treated as numeric zero in this test.
6473 while L1
< S1
'Last loop
6475 N1
:= N1
* 10 + Character'Pos (S1
(L1
)) - Character'Pos ('0');
6479 while L2
< S2
'Last loop
6481 N2
:= N2
* 10 + Character'Pos (S2
(L2
)) - Character'Pos ('0');
6486 end Subprogram_Name_Greater
;
6488 -- Start of processing for Check_Subprogram_Order
6491 -- Check body in alpha order if this is option
6494 and then Style_Check_Order_Subprograms
6495 and then Nkind
(N
) = N_Subprogram_Body
6496 and then Comes_From_Source
(N
)
6497 and then In_Extended_Main_Source_Unit
(N
)
6501 renames Scope_Stack
.Table
6502 (Scope_Stack
.Last
).Last_Subprogram_Name
;
6504 Body_Id
: constant Entity_Id
:=
6505 Defining_Entity
(Specification
(N
));
6508 Get_Decoded_Name_String
(Chars
(Body_Id
));
6511 if Subprogram_Name_Greater
6512 (LSN
.all, Name_Buffer
(1 .. Name_Len
))
6514 Style
.Subprogram_Not_In_Alpha_Order
(Body_Id
);
6520 LSN
:= new String'(Name_Buffer (1 .. Name_Len));
6523 end Check_Subprogram_Order;
6525 ------------------------------
6526 -- Check_Subtype_Conformant --
6527 ------------------------------
6529 procedure Check_Subtype_Conformant
6530 (New_Id : Entity_Id;
6532 Err_Loc : Node_Id := Empty;
6533 Skip_Controlling_Formals : Boolean := False;
6534 Get_Inst : Boolean := False)
6537 pragma Warnings (Off, Result);
6540 (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
6541 Skip_Controlling_Formals => Skip_Controlling_Formals,
6542 Get_Inst => Get_Inst);
6543 end Check_Subtype_Conformant;
6545 -----------------------------------
6546 -- Check_Synchronized_Overriding --
6547 -----------------------------------
6549 procedure Check_Synchronized_Overriding
6550 (Def_Id : Entity_Id;
6551 Overridden_Subp : out Entity_Id)
6553 Ifaces_List : Elist_Id;
6557 function Matches_Prefixed_View_Profile
6558 (Prim_Params : List_Id;
6559 Iface_Params : List_Id) return Boolean;
6560 -- Determine whether a subprogram's parameter profile Prim_Params
6561 -- matches that of a potentially overridden interface subprogram
6562 -- Iface_Params. Also determine if the type of first parameter of
6563 -- Iface_Params is an implemented interface.
6565 -----------------------------------
6566 -- Matches_Prefixed_View_Profile --
6567 -----------------------------------
6569 function Matches_Prefixed_View_Profile
6570 (Prim_Params : List_Id;
6571 Iface_Params : List_Id) return Boolean
6573 function Is_Implemented
6574 (Ifaces_List : Elist_Id;
6575 Iface : Entity_Id) return Boolean;
6576 -- Determine if Iface is implemented by the current task or
6579 --------------------
6580 -- Is_Implemented --
6581 --------------------
6583 function Is_Implemented
6584 (Ifaces_List : Elist_Id;
6585 Iface : Entity_Id) return Boolean
6587 Iface_Elmt : Elmt_Id;
6590 Iface_Elmt := First_Elmt (Ifaces_List);
6591 while Present (Iface_Elmt) loop
6592 if Node (Iface_Elmt) = Iface then
6596 Next_Elmt (Iface_Elmt);
6604 Iface_Id : Entity_Id;
6605 Iface_Param : Node_Id;
6606 Iface_Typ : Entity_Id;
6607 Prim_Id : Entity_Id;
6608 Prim_Param : Node_Id;
6609 Prim_Typ : Entity_Id;
6611 -- Start of processing for Matches_Prefixed_View_Profile
6614 Iface_Param := First (Iface_Params);
6615 Iface_Typ := Etype (Defining_Identifier (Iface_Param));
6617 if Is_Access_Type (Iface_Typ) then
6618 Iface_Typ := Designated_Type (Iface_Typ);
6621 Prim_Param := First (Prim_Params);
6623 -- The first parameter of the potentially overridden subprogram must
6624 -- be an interface implemented by Prim.
6626 if not Is_Interface (Iface_Typ)
6627 or else not Is_Implemented (Ifaces_List, Iface_Typ)
6632 -- The checks on the object parameters are done, so move on to the
6633 -- rest of the parameters.
6635 if not In_Scope then
6636 Prim_Param := Next (Prim_Param);
6639 Iface_Param := Next (Iface_Param);
6640 while Present (Iface_Param) and then Present (Prim_Param) loop
6641 Iface_Id := Defining_Identifier (Iface_Param);
6642 Iface_Typ := Find_Parameter_Type (Iface_Param);
6644 Prim_Id := Defining_Identifier (Prim_Param);
6645 Prim_Typ := Find_Parameter_Type (Prim_Param);
6647 if Ekind (Iface_Typ) = E_Anonymous_Access_Type
6648 and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
6649 and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
6651 Iface_Typ := Designated_Type (Iface_Typ);
6652 Prim_Typ := Designated_Type (Prim_Typ);
6655 -- Case of multiple interface types inside a parameter profile
6657 -- (Obj_Param : in out Iface; ...; Param : Iface)
6659 -- If the interface type is implemented, then the matching type in
6660 -- the primitive should be the implementing record type.
6662 if Ekind (Iface_Typ) = E_Record_Type
6663 and then Is_Interface (Iface_Typ)
6664 and then Is_Implemented (Ifaces_List, Iface_Typ)
6666 if Prim_Typ /= Typ then
6670 -- The two parameters must be both mode and subtype conformant
6672 elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
6674 Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
6683 -- One of the two lists contains more parameters than the other
6685 if Present (Iface_Param) or else Present (Prim_Param) then
6690 end Matches_Prefixed_View_Profile;
6692 -- Start of processing for Check_Synchronized_Overriding
6695 Overridden_Subp := Empty;
6697 -- Def_Id must be an entry or a subprogram. We should skip predefined
6698 -- primitives internally generated by the front end; however at this
6699 -- stage predefined primitives are still not fully decorated. As a
6700 -- minor optimization we skip here internally generated subprograms.
6702 if (Ekind (Def_Id) /= E_Entry
6703 and then Ekind (Def_Id) /= E_Function
6704 and then Ekind (Def_Id) /= E_Procedure)
6705 or else not Comes_From_Source (Def_Id)
6710 -- Search for the concurrent declaration since it contains the list of
6711 -- all implemented interfaces. In this case, the subprogram is declared
6712 -- within the scope of a protected or a task type.
6714 if Present (Scope (Def_Id))
6715 and then Is_Concurrent_Type (Scope (Def_Id))
6716 and then not Is_Generic_Actual_Type (Scope (Def_Id))
6718 Typ := Scope (Def_Id);
6721 -- The enclosing scope is not a synchronized type and the subprogram
6724 elsif No (First_Formal (Def_Id)) then
6727 -- The subprogram has formals and hence it may be a primitive of a
6731 Typ := Etype (First_Formal (Def_Id));
6733 if Is_Access_Type (Typ) then
6734 Typ := Directly_Designated_Type (Typ);
6737 if Is_Concurrent_Type (Typ)
6738 and then not Is_Generic_Actual_Type (Typ)
6742 -- This case occurs when the concurrent type is declared within a
6743 -- generic unit. As a result the corresponding record has been built
6744 -- and used as the type of the first formal, we just have to retrieve
6745 -- the corresponding concurrent type.
6747 elsif Is_Concurrent_Record_Type (Typ)
6748 and then not Is_Class_Wide_Type (Typ)
6749 and then Present (Corresponding_Concurrent_Type (Typ))
6751 Typ := Corresponding_Concurrent_Type (Typ);
6759 -- There is no overriding to check if this is an inherited operation in
6760 -- a type derivation for a generic actual.
6762 Collect_Interfaces (Typ, Ifaces_List);
6764 if Is_Empty_Elmt_List (Ifaces_List) then
6768 -- Determine whether entry or subprogram Def_Id overrides a primitive
6769 -- operation that belongs to one of the interfaces in Ifaces_List.
6772 Candidate : Entity_Id := Empty;
6773 Hom : Entity_Id := Empty;
6774 Subp : Entity_Id := Empty;
6777 -- Traverse the homonym chain, looking for a potentially overridden
6778 -- subprogram that belongs to an implemented interface.
6780 Hom := Current_Entity_In_Scope (Def_Id);
6781 while Present (Hom) loop
6785 or else not Is_Overloadable (Subp)
6786 or else not Is_Primitive (Subp)
6787 or else not Is_Dispatching_Operation (Subp)
6788 or else not Present (Find_Dispatching_Type (Subp))
6789 or else not Is_Interface (Find_Dispatching_Type (Subp))
6793 -- Entries and procedures can override abstract or null interface
6796 elsif Ekind_In (Def_Id, E_Entry, E_Procedure)
6797 and then Ekind (Subp) = E_Procedure
6798 and then Matches_Prefixed_View_Profile
6799 (Parameter_Specifications (Parent (Def_Id)),
6800 Parameter_Specifications (Parent (Subp)))
6804 -- For an overridden subprogram Subp, check whether the mode
6805 -- of its first parameter is correct depending on the kind of
6806 -- synchronized type.
6809 Formal : constant Node_Id := First_Formal (Candidate);
6812 -- In order for an entry or a protected procedure to
6813 -- override, the first parameter of the overridden routine
6814 -- must be of mode "out", "in out", or access-to-variable.
6816 if Ekind_In (Candidate, E_Entry, E_Procedure)
6817 and then Is_Protected_Type (Typ)
6818 and then Ekind (Formal) /= E_In_Out_Parameter
6819 and then Ekind (Formal) /= E_Out_Parameter
6820 and then Nkind (Parameter_Type (Parent (Formal))) /=
6825 -- All other cases are OK since a task entry or routine does
6826 -- not have a restriction on the mode of the first parameter
6827 -- of the overridden interface routine.
6830 Overridden_Subp := Candidate;
6835 -- Functions can override abstract interface functions
6837 elsif Ekind (Def_Id) = E_Function
6838 and then Ekind (Subp) = E_Function
6839 and then Matches_Prefixed_View_Profile
6840 (Parameter_Specifications (Parent (Def_Id)),
6841 Parameter_Specifications (Parent (Subp)))
6842 and then Etype (Def_Id) = Etype (Subp)
6846 -- If an inherited subprogram is implemented by a protected
6847 -- function, then the first parameter of the inherited
6848 -- subprogram shall be of mode in, but not an access-to-
6849 -- variable parameter (RM 9.4(11/9)).
6851 if Present (First_Formal (Subp))
6852 and then Ekind (First_Formal (Subp)) = E_In_Parameter
6854 (not Is_Access_Type (Etype (First_Formal (Subp)))
6856 Is_Access_Constant (Etype (First_Formal (Subp))))
6858 Overridden_Subp := Subp;
6863 Hom := Homonym (Hom);
6866 -- After examining all candidates for overriding, we are left with
6867 -- the best match, which is a mode-incompatible interface routine.
6869 if In_Scope and then Present (Candidate) then
6870 Error_Msg_PT (Def_Id, Candidate);
6873 Overridden_Subp := Candidate;
6876 end Check_Synchronized_Overriding;
6878 ---------------------------
6879 -- Check_Type_Conformant --
6880 ---------------------------
6882 procedure Check_Type_Conformant
6883 (New_Id : Entity_Id;
6885 Err_Loc : Node_Id := Empty)
6888 pragma Warnings (Off, Result);
6891 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
6892 end Check_Type_Conformant;
6894 ---------------------------
6895 -- Can_Override_Operator --
6896 ---------------------------
6898 function Can_Override_Operator (Subp : Entity_Id) return Boolean is
6902 if Nkind (Subp) /= N_Defining_Operator_Symbol then
6906 Typ := Base_Type (Etype (First_Formal (Subp)));
6908 -- Check explicitly that the operation is a primitive of the type
6910 return Operator_Matches_Spec (Subp, Subp)
6911 and then not Is_Generic_Type (Typ)
6912 and then Scope (Subp) = Scope (Typ)
6913 and then not Is_Class_Wide_Type (Typ);
6915 end Can_Override_Operator;
6917 ----------------------
6918 -- Conforming_Types --
6919 ----------------------
6921 function Conforming_Types
6924 Ctype : Conformance_Type;
6925 Get_Inst : Boolean := False) return Boolean
6927 function Base_Types_Match
6929 Typ_2 : Entity_Id) return Boolean;
6930 -- If neither Typ_1 nor Typ_2 are generic actual types, or if they are
6931 -- in different scopes (e.g. parent and child instances), then verify
6932 -- that the base types are equal. Otherwise Typ_1 and Typ_2 must be on
6933 -- the same subtype chain. The whole purpose of this procedure is to
6934 -- prevent spurious ambiguities in an instantiation that may arise if
6935 -- two distinct generic types are instantiated with the same actual.
6937 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id;
6938 -- An access parameter can designate an incomplete type. If the
6939 -- incomplete type is the limited view of a type from a limited_
6940 -- with_clause, check whether the non-limited view is available.
6941 -- If it is a (non-limited) incomplete type, get the full view.
6943 function Matches_Limited_With_View
6945 Typ_2 : Entity_Id) return Boolean;
6946 -- Returns True if and only if either Typ_1 denotes a limited view of
6947 -- Typ_2 or Typ_2 denotes a limited view of Typ_1. This can arise when
6948 -- the limited with view of a type is used in a subprogram declaration
6949 -- and the subprogram body is in the scope of a regular with clause for
6950 -- the same unit. In such a case, the two type entities are considered
6951 -- identical for purposes of conformance checking.
6953 ----------------------
6954 -- Base_Types_Match --
6955 ----------------------
6957 function Base_Types_Match
6959 Typ_2 : Entity_Id) return Boolean
6961 Base_1 : constant Entity_Id := Base_Type (Typ_1);
6962 Base_2 : constant Entity_Id := Base_Type (Typ_2);
6965 if Typ_1 = Typ_2 then
6968 elsif Base_1 = Base_2 then
6970 -- The following is too permissive. A more precise test should
6971 -- check that the generic actual is an ancestor subtype of the
6974 -- See code in Find_Corresponding_Spec that applies an additional
6975 -- filter to handle accidental amiguities in instances.
6978 not Is_Generic_Actual_Type (Typ_1)
6979 or else not Is_Generic_Actual_Type (Typ_2)
6980 or else Scope (Typ_1) /= Scope (Typ_2);
6982 -- If Typ_2 is a generic actual type it is declared as the subtype of
6983 -- the actual. If that actual is itself a subtype we need to use its
6984 -- own base type to check for compatibility.
6986 elsif Ekind (Base_2) = Ekind (Typ_2)
6987 and then Base_1 = Base_Type (Base_2)
6991 elsif Ekind (Base_1) = Ekind (Typ_1)
6992 and then Base_2 = Base_Type (Base_1)
6999 end Base_Types_Match;
7001 --------------------------
7002 -- Find_Designated_Type --
7003 --------------------------
7005 function Find_Designated_Type (Typ : Entity_Id) return Entity_Id is
7009 Desig := Directly_Designated_Type (Typ);
7011 if Ekind (Desig) = E_Incomplete_Type then
7013 -- If regular incomplete type, get full view if available
7015 if Present (Full_View (Desig)) then
7016 Desig := Full_View (Desig);
7018 -- If limited view of a type, get non-limited view if available,
7019 -- and check again for a regular incomplete type.
7021 elsif Present (Non_Limited_View (Desig)) then
7022 Desig := Get_Full_View (Non_Limited_View (Desig));
7027 end Find_Designated_Type;
7029 -------------------------------
7030 -- Matches_Limited_With_View --
7031 -------------------------------
7033 function Matches_Limited_With_View
7035 Typ_2 : Entity_Id) return Boolean
7037 function Is_Matching_Limited_View
7039 View : Entity_Id) return Boolean;
7040 -- Determine whether non-limited view View denotes type Typ in some
7041 -- conformant fashion.
7043 ------------------------------
7044 -- Is_Matching_Limited_View --
7045 ------------------------------
7047 function Is_Matching_Limited_View
7049 View : Entity_Id) return Boolean
7051 Root_Typ : Entity_Id;
7052 Root_View : Entity_Id;
7055 -- The non-limited view directly denotes the type
7060 -- The type is a subtype of the non-limited view
7062 elsif Is_Subtype_Of (Typ, View) then
7065 -- Both the non-limited view and the type denote class-wide types
7067 elsif Is_Class_Wide_Type (Typ)
7068 and then Is_Class_Wide_Type (View)
7070 Root_Typ := Root_Type (Typ);
7071 Root_View := Root_Type (View);
7073 if Root_Typ = Root_View then
7076 -- An incomplete tagged type and its full view may receive two
7077 -- distinct class-wide types when the related package has not
7078 -- been analyzed yet.
7081 -- type T is tagged; -- CW_1
7082 -- type T is tagged null record; -- CW_2
7085 -- This is because the package lacks any semantic information
7086 -- that may eventually link both views of T. As a consequence,
7087 -- a client of the limited view of Pack will see CW_2 while a
7088 -- client of the non-limited view of Pack will see CW_1.
7090 elsif Is_Incomplete_Type (Root_Typ)
7091 and then Present (Full_View (Root_Typ))
7092 and then Full_View (Root_Typ) = Root_View
7096 elsif Is_Incomplete_Type (Root_View)
7097 and then Present (Full_View (Root_View))
7098 and then Full_View (Root_View) = Root_Typ
7105 end Is_Matching_Limited_View;
7107 -- Start of processing for Matches_Limited_With_View
7110 -- In some cases a type imported through a limited_with clause, and
7111 -- its non-limited view are both visible, for example in an anonymous
7112 -- access-to-class-wide type in a formal, or when building the body
7113 -- for a subprogram renaming after the subprogram has been frozen.
7114 -- In these cases both entities designate the same type. In addition,
7115 -- if one of them is an actual in an instance, it may be a subtype of
7116 -- the non-limited view of the other.
7118 if From_Limited_With (Typ_1)
7119 and then From_Limited_With (Typ_2)
7120 and then Available_View (Typ_1) = Available_View (Typ_2)
7124 elsif From_Limited_With (Typ_1) then
7125 return Is_Matching_Limited_View (Typ_2, Available_View (Typ_1));
7127 elsif From_Limited_With (Typ_2) then
7128 return Is_Matching_Limited_View (Typ_1, Available_View (Typ_2));
7133 end Matches_Limited_With_View;
7137 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
7139 Type_1 : Entity_Id := T1;
7140 Type_2 : Entity_Id := T2;
7142 -- Start of processing for Conforming_Types
7145 -- The context is an instance association for a formal access-to-
7146 -- subprogram type; the formal parameter types require mapping because
7147 -- they may denote other formal parameters of the generic unit.
7150 Type_1 := Get_Instance_Of (T1);
7151 Type_2 := Get_Instance_Of (T2);
7154 -- If one of the types is a view of the other introduced by a limited
7155 -- with clause, treat these as conforming for all purposes.
7157 if Matches_Limited_With_View (T1, T2) then
7160 elsif Base_Types_Match (Type_1, Type_2) then
7161 return Ctype <= Mode_Conformant
7162 or else Subtypes_Statically_Match (Type_1, Type_2);
7164 elsif Is_Incomplete_Or_Private_Type (Type_1)
7165 and then Present (Full_View (Type_1))
7166 and then Base_Types_Match (Full_View (Type_1), Type_2)
7168 return Ctype <= Mode_Conformant
7169 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
7171 elsif Ekind (Type_2) = E_Incomplete_Type
7172 and then Present (Full_View (Type_2))
7173 and then Base_Types_Match (Type_1, Full_View (Type_2))
7175 return Ctype <= Mode_Conformant
7176 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
7178 elsif Is_Private_Type (Type_2)
7179 and then In_Instance
7180 and then Present (Full_View (Type_2))
7181 and then Base_Types_Match (Type_1, Full_View (Type_2))
7183 return Ctype <= Mode_Conformant
7184 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
7186 -- In Ada 2012, incomplete types (including limited views) can appear
7187 -- as actuals in instantiations.
7189 elsif Is_Incomplete_Type (Type_1)
7190 and then Is_Incomplete_Type (Type_2)
7191 and then (Used_As_Generic_Actual (Type_1)
7192 or else Used_As_Generic_Actual (Type_2))
7197 -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
7198 -- treated recursively because they carry a signature. As far as
7199 -- conformance is concerned, convention plays no role, and either
7200 -- or both could be access to protected subprograms.
7202 Are_Anonymous_Access_To_Subprogram_Types :=
7203 Ekind_In (Type_1, E_Anonymous_Access_Subprogram_Type,
7204 E_Anonymous_Access_Protected_Subprogram_Type)
7206 Ekind_In (Type_2, E_Anonymous_Access_Subprogram_Type,
7207 E_Anonymous_Access_Protected_Subprogram_Type);
7209 -- Test anonymous access type case. For this case, static subtype
7210 -- matching is required for mode conformance (RM 6.3.1(15)). We check
7211 -- the base types because we may have built internal subtype entities
7212 -- to handle null-excluding types (see Process_Formals).
7214 if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
7216 Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
7218 -- Ada 2005 (AI-254)
7220 or else Are_Anonymous_Access_To_Subprogram_Types
7223 Desig_1 : Entity_Id;
7224 Desig_2 : Entity_Id;
7227 -- In Ada 2005, access constant indicators must match for
7228 -- subtype conformance.
7230 if Ada_Version >= Ada_2005
7231 and then Ctype >= Subtype_Conformant
7233 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
7238 Desig_1 := Find_Designated_Type (Type_1);
7239 Desig_2 := Find_Designated_Type (Type_2);
7241 -- If the context is an instance association for a formal
7242 -- access-to-subprogram type; formal access parameter designated
7243 -- types require mapping because they may denote other formal
7244 -- parameters of the generic unit.
7247 Desig_1 := Get_Instance_Of (Desig_1);
7248 Desig_2 := Get_Instance_Of (Desig_2);
7251 -- It is possible for a Class_Wide_Type to be introduced for an
7252 -- incomplete type, in which case there is a separate class_ wide
7253 -- type for the full view. The types conform if their Etypes
7254 -- conform, i.e. one may be the full view of the other. This can
7255 -- only happen in the context of an access parameter, other uses
7256 -- of an incomplete Class_Wide_Type are illegal.
7258 if Is_Class_Wide_Type (Desig_1)
7260 Is_Class_Wide_Type (Desig_2)
7264 (Etype (Base_Type (Desig_1)),
7265 Etype (Base_Type (Desig_2)), Ctype);
7267 elsif Are_Anonymous_Access_To_Subprogram_Types then
7268 if Ada_Version < Ada_2005 then
7269 return Ctype = Type_Conformant
7271 Subtypes_Statically_Match (Desig_1, Desig_2);
7273 -- We must check the conformance of the signatures themselves
7277 Conformant : Boolean;
7280 (Desig_1, Desig_2, Ctype, False, Conformant);
7285 -- A limited view of an actual matches the corresponding
7286 -- incomplete formal.
7288 elsif Ekind (Desig_2) = E_Incomplete_Subtype
7289 and then From_Limited_With (Desig_2)
7290 and then Used_As_Generic_Actual (Etype (Desig_2))
7295 return Base_Type (Desig_1) = Base_Type (Desig_2)
7296 and then (Ctype = Type_Conformant
7298 Subtypes_Statically_Match (Desig_1, Desig_2));
7302 -- Otherwise definitely no match
7305 if ((Ekind (Type_1) = E_Anonymous_Access_Type
7306 and then Is_Access_Type (Type_2))
7307 or else (Ekind (Type_2) = E_Anonymous_Access_Type
7308 and then Is_Access_Type (Type_1)))
7311 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
7313 May_Hide_Profile := True;
7318 end Conforming_Types;
7320 --------------------------
7321 -- Create_Extra_Formals --
7322 --------------------------
7324 procedure Create_Extra_Formals (E : Entity_Id) is
7325 First_Extra : Entity_Id := Empty;
7327 Last_Extra : Entity_Id := Empty;
7329 function Add_Extra_Formal
7330 (Assoc_Entity : Entity_Id;
7333 Suffix : String) return Entity_Id;
7334 -- Add an extra formal to the current list of formals and extra formals.
7335 -- The extra formal is added to the end of the list of extra formals,
7336 -- and also returned as the result. These formals are always of mode IN.
7337 -- The new formal has the type Typ, is declared in Scope, and its name
7338 -- is given by a concatenation of the name of Assoc_Entity and Suffix.
7339 -- The following suffixes are currently used. They should not be changed
7340 -- without coordinating with CodePeer, which makes use of these to
7341 -- provide better messages.
7343 -- O denotes the Constrained bit.
7344 -- L denotes the accessibility level.
7345 -- BIP_xxx denotes an extra formal for a build-in-place function. See
7346 -- the full list in exp_ch6.BIP_Formal_Kind.
7348 ----------------------
7349 -- Add_Extra_Formal --
7350 ----------------------
7352 function Add_Extra_Formal
7353 (Assoc_Entity : Entity_Id;
7356 Suffix : String) return Entity_Id
7358 EF : constant Entity_Id :=
7359 Make_Defining_Identifier (Sloc (Assoc_Entity),
7360 Chars => New_External_Name (Chars (Assoc_Entity),
7364 -- A little optimization. Never generate an extra formal for the
7365 -- _init operand of an initialization procedure, since it could
7368 if Chars (Formal) = Name_uInit then
7372 Set_Ekind (EF, E_In_Parameter);
7373 Set_Actual_Subtype (EF, Typ);
7374 Set_Etype (EF, Typ);
7375 Set_Scope (EF, Scope);
7376 Set_Mechanism (EF, Default_Mechanism);
7377 Set_Formal_Validity (EF);
7379 if No (First_Extra) then
7381 Set_Extra_Formals (Scope, First_Extra);
7384 if Present (Last_Extra) then
7385 Set_Extra_Formal (Last_Extra, EF);
7391 end Add_Extra_Formal;
7395 Formal_Type : Entity_Id;
7396 P_Formal : Entity_Id := Empty;
7398 -- Start of processing for Create_Extra_Formals
7401 -- We never generate extra formals if expansion is not active because we
7402 -- don't need them unless we are generating code.
7404 if not Expander_Active then
7408 -- No need to generate extra formals in interface thunks whose target
7409 -- primitive has no extra formals.
7411 if Is_Thunk (E) and then No (Extra_Formals (Thunk_Entity (E))) then
7415 -- If this is a derived subprogram then the subtypes of the parent
7416 -- subprogram's formal parameters will be used to determine the need
7417 -- for extra formals.
7419 if Is_Overloadable (E) and then Present (Alias (E)) then
7420 P_Formal := First_Formal (Alias (E));
7423 Formal := First_Formal (E);
7424 while Present (Formal) loop
7425 Last_Extra := Formal;
7426 Next_Formal (Formal);
7429 -- If Extra_Formals were already created, don't do it again. This
7430 -- situation may arise for subprogram types created as part of
7431 -- dispatching calls (see Expand_Dispatching_Call)
7433 if Present (Last_Extra) and then Present (Extra_Formal (Last_Extra)) then
7437 -- If the subprogram is a predefined dispatching subprogram then don't
7438 -- generate any extra constrained or accessibility level formals. In
7439 -- general we suppress these for internal subprograms (by not calling
7440 -- Freeze_Subprogram and Create_Extra_Formals at all), but internally
7441 -- generated stream attributes do get passed through because extra
7442 -- build-in-place formals are needed in some cases (limited 'Input
).
7444 if Is_Predefined_Internal_Operation
(E
) then
7445 goto Test_For_Func_Result_Extras
;
7448 Formal
:= First_Formal
(E
);
7449 while Present
(Formal
) loop
7451 -- Create extra formal for supporting the attribute 'Constrained.
7452 -- The case of a private type view without discriminants also
7453 -- requires the extra formal if the underlying type has defaulted
7456 if Ekind
(Formal
) /= E_In_Parameter
then
7457 if Present
(P_Formal
) then
7458 Formal_Type
:= Etype
(P_Formal
);
7460 Formal_Type
:= Etype
(Formal
);
7463 -- Do not produce extra formals for Unchecked_Union parameters.
7464 -- Jump directly to the end of the loop.
7466 if Is_Unchecked_Union
(Base_Type
(Formal_Type
)) then
7467 goto Skip_Extra_Formal_Generation
;
7470 if not Has_Discriminants
(Formal_Type
)
7471 and then Ekind
(Formal_Type
) in Private_Kind
7472 and then Present
(Underlying_Type
(Formal_Type
))
7474 Formal_Type
:= Underlying_Type
(Formal_Type
);
7477 -- Suppress the extra formal if formal's subtype is constrained or
7478 -- indefinite, or we're compiling for Ada 2012 and the underlying
7479 -- type is tagged and limited. In Ada 2012, a limited tagged type
7480 -- can have defaulted discriminants, but 'Constrained is required
7481 -- to return True, so the formal is never needed (see AI05-0214).
7482 -- Note that this ensures consistency of calling sequences for
7483 -- dispatching operations when some types in a class have defaults
7484 -- on discriminants and others do not (and requiring the extra
7485 -- formal would introduce distributed overhead).
7487 -- If the type does not have a completion yet, treat as prior to
7488 -- Ada 2012 for consistency.
7490 if Has_Discriminants
(Formal_Type
)
7491 and then not Is_Constrained
(Formal_Type
)
7492 and then Is_Definite_Subtype
(Formal_Type
)
7493 and then (Ada_Version
< Ada_2012
7494 or else No
(Underlying_Type
(Formal_Type
))
7496 (Is_Limited_Type
(Formal_Type
)
7499 (Underlying_Type
(Formal_Type
)))))
7501 Set_Extra_Constrained
7502 (Formal
, Add_Extra_Formal
(Formal
, Standard_Boolean
, E
, "O"));
7506 -- Create extra formal for supporting accessibility checking. This
7507 -- is done for both anonymous access formals and formals of named
7508 -- access types that are marked as controlling formals. The latter
7509 -- case can occur when Expand_Dispatching_Call creates a subprogram
7510 -- type and substitutes the types of access-to-class-wide actuals
7511 -- for the anonymous access-to-specific-type of controlling formals.
7512 -- Base_Type is applied because in cases where there is a null
7513 -- exclusion the formal may have an access subtype.
7515 -- This is suppressed if we specifically suppress accessibility
7516 -- checks at the package level for either the subprogram, or the
7517 -- package in which it resides. However, we do not suppress it
7518 -- simply if the scope has accessibility checks suppressed, since
7519 -- this could cause trouble when clients are compiled with a
7520 -- different suppression setting. The explicit checks at the
7521 -- package level are safe from this point of view.
7523 if (Ekind
(Base_Type
(Etype
(Formal
))) = E_Anonymous_Access_Type
7524 or else (Is_Controlling_Formal
(Formal
)
7525 and then Is_Access_Type
(Base_Type
(Etype
(Formal
)))))
7527 (Explicit_Suppress
(E
, Accessibility_Check
)
7529 Explicit_Suppress
(Scope
(E
), Accessibility_Check
))
7532 or else Present
(Extra_Accessibility
(P_Formal
)))
7534 Set_Extra_Accessibility
7535 (Formal
, Add_Extra_Formal
(Formal
, Standard_Natural
, E
, "L"));
7538 -- This label is required when skipping extra formal generation for
7539 -- Unchecked_Union parameters.
7541 <<Skip_Extra_Formal_Generation
>>
7543 if Present
(P_Formal
) then
7544 Next_Formal
(P_Formal
);
7547 Next_Formal
(Formal
);
7550 <<Test_For_Func_Result_Extras
>>
7552 -- Ada 2012 (AI05-234): "the accessibility level of the result of a
7553 -- function call is ... determined by the point of call ...".
7555 if Needs_Result_Accessibility_Level
(E
) then
7556 Set_Extra_Accessibility_Of_Result
7557 (E
, Add_Extra_Formal
(E
, Standard_Natural
, E
, "L"));
7560 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
7561 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
7563 if Ada_Version
>= Ada_2005
and then Is_Build_In_Place_Function
(E
) then
7565 Result_Subt
: constant Entity_Id
:= Etype
(E
);
7566 Full_Subt
: constant Entity_Id
:= Available_View
(Result_Subt
);
7567 Formal_Typ
: Entity_Id
;
7568 Subp_Decl
: Node_Id
;
7570 Discard
: Entity_Id
;
7571 pragma Warnings
(Off
, Discard
);
7574 -- In the case of functions with unconstrained result subtypes,
7575 -- add a 4-state formal indicating whether the return object is
7576 -- allocated by the caller (1), or should be allocated by the
7577 -- callee on the secondary stack (2), in the global heap (3), or
7578 -- in a user-defined storage pool (4). For the moment we just use
7579 -- Natural for the type of this formal. Note that this formal
7580 -- isn't usually needed in the case where the result subtype is
7581 -- constrained, but it is needed when the function has a tagged
7582 -- result, because generally such functions can be called in a
7583 -- dispatching context and such calls must be handled like calls
7584 -- to a class-wide function.
7586 if Needs_BIP_Alloc_Form
(E
) then
7589 (E
, Standard_Natural
,
7590 E
, BIP_Formal_Suffix
(BIP_Alloc_Form
));
7592 -- Add BIP_Storage_Pool, in case BIP_Alloc_Form indicates to
7593 -- use a user-defined pool. This formal is not added on
7594 -- ZFP as those targets do not support pools.
7596 if RTE_Available
(RE_Root_Storage_Pool_Ptr
) then
7599 (E
, RTE
(RE_Root_Storage_Pool_Ptr
),
7600 E
, BIP_Formal_Suffix
(BIP_Storage_Pool
));
7604 -- In the case of functions whose result type needs finalization,
7605 -- add an extra formal which represents the finalization master.
7607 if Needs_BIP_Finalization_Master
(E
) then
7610 (E
, RTE
(RE_Finalization_Master_Ptr
),
7611 E
, BIP_Formal_Suffix
(BIP_Finalization_Master
));
7614 -- When the result type contains tasks, add two extra formals: the
7615 -- master of the tasks to be created, and the caller's activation
7618 if Has_Task
(Full_Subt
) then
7621 (E
, RTE
(RE_Master_Id
),
7622 E
, BIP_Formal_Suffix
(BIP_Task_Master
));
7625 (E
, RTE
(RE_Activation_Chain_Access
),
7626 E
, BIP_Formal_Suffix
(BIP_Activation_Chain
));
7629 -- All build-in-place functions get an extra formal that will be
7630 -- passed the address of the return object within the caller.
7633 Create_Itype
(E_Anonymous_Access_Type
, E
, Scope_Id
=> Scope
(E
));
7635 Set_Directly_Designated_Type
(Formal_Typ
, Result_Subt
);
7636 Set_Etype
(Formal_Typ
, Formal_Typ
);
7637 Set_Depends_On_Private
7638 (Formal_Typ
, Has_Private_Component
(Formal_Typ
));
7639 Set_Is_Public
(Formal_Typ
, Is_Public
(Scope
(Formal_Typ
)));
7640 Set_Is_Access_Constant
(Formal_Typ
, False);
7642 -- Ada 2005 (AI-50217): Propagate the attribute that indicates
7643 -- the designated type comes from the limited view (for back-end
7646 Set_From_Limited_With
7647 (Formal_Typ
, From_Limited_With
(Result_Subt
));
7649 Layout_Type
(Formal_Typ
);
7651 -- Force the definition of the Itype in case of internal function
7652 -- calls within the same or nested scope.
7654 if Is_Subprogram_Or_Generic_Subprogram
(E
) then
7655 Subp_Decl
:= Parent
(E
);
7657 -- The insertion point for an Itype reference should be after
7658 -- the unit declaration node of the subprogram. An exception
7659 -- to this are inherited operations from a parent type in which
7660 -- case the derived type acts as their parent.
7662 if Nkind_In
(Subp_Decl
, N_Function_Specification
,
7663 N_Procedure_Specification
)
7665 Subp_Decl
:= Parent
(Subp_Decl
);
7668 Build_Itype_Reference
(Formal_Typ
, Subp_Decl
);
7673 (E
, Formal_Typ
, E
, BIP_Formal_Suffix
(BIP_Object_Access
));
7676 end Create_Extra_Formals
;
7678 -----------------------------
7679 -- Enter_Overloaded_Entity --
7680 -----------------------------
7682 procedure Enter_Overloaded_Entity
(S
: Entity_Id
) is
7683 function Matches_Predefined_Op
return Boolean;
7684 -- This returns an approximation of whether S matches a predefined
7685 -- operator, based on the operator symbol, and the parameter and result
7686 -- types. The rules are scattered throughout chapter 4 of the Ada RM.
7688 ---------------------------
7689 -- Matches_Predefined_Op --
7690 ---------------------------
7692 function Matches_Predefined_Op
return Boolean is
7693 Formal_1
: constant Entity_Id
:= First_Formal
(S
);
7694 Formal_2
: constant Entity_Id
:= Next_Formal
(Formal_1
);
7695 Op
: constant Name_Id
:= Chars
(S
);
7696 Result_Type
: constant Entity_Id
:= Base_Type
(Etype
(S
));
7697 Type_1
: constant Entity_Id
:= Base_Type
(Etype
(Formal_1
));
7702 if Present
(Formal_2
) then
7704 Type_2
: constant Entity_Id
:= Base_Type
(Etype
(Formal_2
));
7707 -- All but "&" and "**" have same-types parameters
7710 when Name_Op_Concat |
7715 if Type_1
/= Type_2
then
7720 -- Check parameter and result types
7727 Is_Boolean_Type
(Result_Type
)
7728 and then Result_Type
= Type_1
;
7733 Is_Integer_Type
(Result_Type
)
7734 and then Result_Type
= Type_1
;
7741 Is_Numeric_Type
(Result_Type
)
7742 and then Result_Type
= Type_1
;
7747 Is_Boolean_Type
(Result_Type
)
7748 and then not Is_Limited_Type
(Type_1
);
7755 Is_Boolean_Type
(Result_Type
)
7756 and then (Is_Array_Type
(Type_1
)
7757 or else Is_Scalar_Type
(Type_1
));
7759 when Name_Op_Concat
=>
7760 return Is_Array_Type
(Result_Type
);
7762 when Name_Op_Expon
=>
7764 (Is_Integer_Type
(Result_Type
)
7765 or else Is_Floating_Point_Type
(Result_Type
))
7766 and then Result_Type
= Type_1
7767 and then Type_2
= Standard_Integer
;
7770 raise Program_Error
;
7782 Is_Numeric_Type
(Result_Type
)
7783 and then Result_Type
= Type_1
;
7787 Is_Boolean_Type
(Result_Type
)
7788 and then Result_Type
= Type_1
;
7791 raise Program_Error
;
7794 end Matches_Predefined_Op
;
7798 E
: Entity_Id
:= Current_Entity_In_Scope
(S
);
7799 C_E
: Entity_Id
:= Current_Entity
(S
);
7801 -- Start of processing for Enter_Overloaded_Entity
7805 Set_Has_Homonym
(E
);
7806 Set_Has_Homonym
(S
);
7809 Set_Is_Immediately_Visible
(S
);
7810 Set_Scope
(S
, Current_Scope
);
7812 -- Chain new entity if front of homonym in current scope, so that
7813 -- homonyms are contiguous.
7815 if Present
(E
) and then E
/= C_E
then
7816 while Homonym
(C_E
) /= E
loop
7817 C_E
:= Homonym
(C_E
);
7820 Set_Homonym
(C_E
, S
);
7824 Set_Current_Entity
(S
);
7829 if Is_Inherited_Operation
(S
) then
7830 Append_Inherited_Subprogram
(S
);
7832 Append_Entity
(S
, Current_Scope
);
7835 Set_Public_Status
(S
);
7837 if Debug_Flag_E
then
7838 Write_Str
("New overloaded entity chain: ");
7839 Write_Name
(Chars
(S
));
7842 while Present
(E
) loop
7843 Write_Str
(" "); Write_Int
(Int
(E
));
7850 -- Generate warning for hiding
7853 and then Comes_From_Source
(S
)
7854 and then In_Extended_Main_Source_Unit
(S
)
7861 -- Warn unless genuine overloading. Do not emit warning on
7862 -- hiding predefined operators in Standard (these are either an
7863 -- (artifact of our implicit declarations, or simple noise) but
7864 -- keep warning on a operator defined on a local subtype, because
7865 -- of the real danger that different operators may be applied in
7866 -- various parts of the program.
7868 -- Note that if E and S have the same scope, there is never any
7869 -- hiding. Either the two conflict, and the program is illegal,
7870 -- or S is overriding an implicit inherited subprogram.
7872 if Scope
(E
) /= Scope
(S
)
7873 and then (not Is_Overloadable
(E
)
7874 or else Subtype_Conformant
(E
, S
))
7875 and then (Is_Immediately_Visible
(E
)
7876 or else Is_Potentially_Use_Visible
(S
))
7878 if Scope
(E
) = Standard_Standard
then
7879 if Nkind
(S
) = N_Defining_Operator_Symbol
7880 and then Scope
(Base_Type
(Etype
(First_Formal
(S
)))) /=
7882 and then Matches_Predefined_Op
7885 ("declaration of & hides predefined operator?h?", S
);
7888 -- E not immediately within Standard
7891 Error_Msg_Sloc
:= Sloc
(E
);
7892 Error_Msg_N
("declaration of & hides one #?h?", S
);
7897 end Enter_Overloaded_Entity
;
7899 -----------------------------
7900 -- Check_Untagged_Equality --
7901 -----------------------------
7903 procedure Check_Untagged_Equality
(Eq_Op
: Entity_Id
) is
7904 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
7905 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Eq_Op
);
7909 -- This check applies only if we have a subprogram declaration with an
7910 -- untagged record type.
7912 if Nkind
(Decl
) /= N_Subprogram_Declaration
7913 or else not Is_Record_Type
(Typ
)
7914 or else Is_Tagged_Type
(Typ
)
7919 -- In Ada 2012 case, we will output errors or warnings depending on
7920 -- the setting of debug flag -gnatd.E.
7922 if Ada_Version
>= Ada_2012
then
7923 Error_Msg_Warn
:= Debug_Flag_Dot_EE
;
7925 -- In earlier versions of Ada, nothing to do unless we are warning on
7926 -- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set).
7929 if not Warn_On_Ada_2012_Compatibility
then
7934 -- Cases where the type has already been frozen
7936 if Is_Frozen
(Typ
) then
7938 -- If the type is not declared in a package, or if we are in the body
7939 -- of the package or in some other scope, the new operation is not
7940 -- primitive, and therefore legal, though suspicious. Should we
7941 -- generate a warning in this case ???
7943 if Ekind
(Scope
(Typ
)) /= E_Package
7944 or else Scope
(Typ
) /= Current_Scope
7948 -- If the type is a generic actual (sub)type, the operation is not
7949 -- primitive either because the base type is declared elsewhere.
7951 elsif Is_Generic_Actual_Type
(Typ
) then
7954 -- Here we have a definite error of declaration after freezing
7957 if Ada_Version
>= Ada_2012
then
7959 ("equality operator must be declared before type & is "
7960 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op
, Typ
);
7962 -- In Ada 2012 mode with error turned to warning, output one
7963 -- more warning to warn that the equality operation may not
7964 -- compose. This is the consequence of ignoring the error.
7966 if Error_Msg_Warn
then
7967 Error_Msg_N
("\equality operation may not compose??", Eq_Op
);
7972 ("equality operator must be declared before type& is "
7973 & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op
, Typ
);
7976 -- If we are in the package body, we could just move the
7977 -- declaration to the package spec, so add a message saying that.
7979 if In_Package_Body
(Scope
(Typ
)) then
7980 if Ada_Version
>= Ada_2012
then
7982 ("\move declaration to package spec<<", Eq_Op
);
7985 ("\move declaration to package spec (Ada 2012)?y?", Eq_Op
);
7988 -- Otherwise try to find the freezing point
7991 Obj_Decl
:= Next
(Parent
(Typ
));
7992 while Present
(Obj_Decl
) and then Obj_Decl
/= Decl
loop
7993 if Nkind
(Obj_Decl
) = N_Object_Declaration
7994 and then Etype
(Defining_Identifier
(Obj_Decl
)) = Typ
7996 -- Freezing point, output warnings
7998 if Ada_Version
>= Ada_2012
then
8000 ("type& is frozen by declaration??", Obj_Decl
, Typ
);
8002 ("\an equality operator cannot be declared after "
8007 ("type& is frozen by declaration (Ada 2012)?y?",
8010 ("\an equality operator cannot be declared after "
8011 & "this point (Ada 2012)?y?",
8023 -- Here if type is not frozen yet. It is illegal to have a primitive
8024 -- equality declared in the private part if the type is visible.
8026 elsif not In_Same_List
(Parent
(Typ
), Decl
)
8027 and then not Is_Limited_Type
(Typ
)
8029 -- Shouldn't we give an RM reference here???
8031 if Ada_Version
>= Ada_2012
then
8033 ("equality operator appears too late<<", Eq_Op
);
8036 ("equality operator appears too late (Ada 2012)?y?", Eq_Op
);
8039 -- No error detected
8044 end Check_Untagged_Equality
;
8046 -----------------------------
8047 -- Find_Corresponding_Spec --
8048 -----------------------------
8050 function Find_Corresponding_Spec
8052 Post_Error
: Boolean := True) return Entity_Id
8054 Spec
: constant Node_Id
:= Specification
(N
);
8055 Designator
: constant Entity_Id
:= Defining_Entity
(Spec
);
8059 function Different_Generic_Profile
(E
: Entity_Id
) return Boolean;
8060 -- Even if fully conformant, a body may depend on a generic actual when
8061 -- the spec does not, or vice versa, in which case they were distinct
8062 -- entities in the generic.
8064 -------------------------------
8065 -- Different_Generic_Profile --
8066 -------------------------------
8068 function Different_Generic_Profile
(E
: Entity_Id
) return Boolean is
8071 function Same_Generic_Actual
(T1
, T2
: Entity_Id
) return Boolean;
8072 -- Check that the types of corresponding formals have the same
8073 -- generic actual if any. We have to account for subtypes of a
8074 -- generic formal, declared between a spec and a body, which may
8075 -- appear distinct in an instance but matched in the generic, and
8076 -- the subtype may be used either in the spec or the body of the
8077 -- subprogram being checked.
8079 -------------------------
8080 -- Same_Generic_Actual --
8081 -------------------------
8083 function Same_Generic_Actual
(T1
, T2
: Entity_Id
) return Boolean is
8085 function Is_Declared_Subtype
(S1
, S2
: Entity_Id
) return Boolean;
8086 -- Predicate to check whether S1 is a subtype of S2 in the source
8089 -------------------------
8090 -- Is_Declared_Subtype --
8091 -------------------------
8093 function Is_Declared_Subtype
(S1
, S2
: Entity_Id
) return Boolean is
8095 return Comes_From_Source
(Parent
(S1
))
8096 and then Nkind
(Parent
(S1
)) = N_Subtype_Declaration
8097 and then Is_Entity_Name
(Subtype_Indication
(Parent
(S1
)))
8098 and then Entity
(Subtype_Indication
(Parent
(S1
))) = S2
;
8099 end Is_Declared_Subtype
;
8101 -- Start of processing for Same_Generic_Actual
8104 return Is_Generic_Actual_Type
(T1
) = Is_Generic_Actual_Type
(T2
)
8105 or else Is_Declared_Subtype
(T1
, T2
)
8106 or else Is_Declared_Subtype
(T2
, T1
);
8107 end Same_Generic_Actual
;
8109 -- Start of processing for Different_Generic_Profile
8112 if not In_Instance
then
8115 elsif Ekind
(E
) = E_Function
8116 and then not Same_Generic_Actual
(Etype
(E
), Etype
(Designator
))
8121 F1
:= First_Formal
(Designator
);
8122 F2
:= First_Formal
(E
);
8123 while Present
(F1
) loop
8124 if not Same_Generic_Actual
(Etype
(F1
), Etype
(F2
)) then
8133 end Different_Generic_Profile
;
8135 -- Start of processing for Find_Corresponding_Spec
8138 E
:= Current_Entity
(Designator
);
8139 while Present
(E
) loop
8141 -- We are looking for a matching spec. It must have the same scope,
8142 -- and the same name, and either be type conformant, or be the case
8143 -- of a library procedure spec and its body (which belong to one
8144 -- another regardless of whether they are type conformant or not).
8146 if Scope
(E
) = Current_Scope
then
8147 if Current_Scope
= Standard_Standard
8148 or else (Ekind
(E
) = Ekind
(Designator
)
8149 and then Type_Conformant
(E
, Designator
))
8151 -- Within an instantiation, we know that spec and body are
8152 -- subtype conformant, because they were subtype conformant in
8153 -- the generic. We choose the subtype-conformant entity here as
8154 -- well, to resolve spurious ambiguities in the instance that
8155 -- were not present in the generic (i.e. when two different
8156 -- types are given the same actual). If we are looking for a
8157 -- spec to match a body, full conformance is expected.
8161 -- Inherit the convention and "ghostness" of the matching
8162 -- spec to ensure proper full and subtype conformance.
8164 Set_Convention
(Designator
, Convention
(E
));
8166 if Is_Ghost_Entity
(E
) then
8167 Set_Is_Ghost_Entity
(Designator
);
8170 -- Skip past subprogram bodies and subprogram renamings that
8171 -- may appear to have a matching spec, but that aren't fully
8172 -- conformant with it. That can occur in cases where an
8173 -- actual type causes unrelated homographs in the instance.
8175 if Nkind_In
(N
, N_Subprogram_Body
,
8176 N_Subprogram_Renaming_Declaration
)
8177 and then Present
(Homonym
(E
))
8178 and then not Fully_Conformant
(Designator
, E
)
8182 elsif not Subtype_Conformant
(Designator
, E
) then
8185 elsif Different_Generic_Profile
(E
) then
8190 -- Ada 2012 (AI05-0165): For internally generated bodies of
8191 -- null procedures locate the internally generated spec. We
8192 -- enforce mode conformance since a tagged type may inherit
8193 -- from interfaces several null primitives which differ only
8194 -- in the mode of the formals.
8196 if not (Comes_From_Source
(E
))
8197 and then Is_Null_Procedure
(E
)
8198 and then not Mode_Conformant
(Designator
, E
)
8202 -- For null procedures coming from source that are completions,
8203 -- analysis of the generated body will establish the link.
8205 elsif Comes_From_Source
(E
)
8206 and then Nkind
(Spec
) = N_Procedure_Specification
8207 and then Null_Present
(Spec
)
8211 -- Expression functions can be completions, but cannot be
8212 -- completed by an explicit body.
8214 elsif Comes_From_Source
(E
)
8215 and then Comes_From_Source
(N
)
8216 and then Nkind
(N
) = N_Subprogram_Body
8217 and then Nkind
(Original_Node
(Unit_Declaration_Node
(E
))) =
8218 N_Expression_Function
8220 Error_Msg_Sloc
:= Sloc
(E
);
8221 Error_Msg_N
("body conflicts with expression function#", N
);
8224 elsif not Has_Completion
(E
) then
8225 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
8226 Set_Corresponding_Spec
(N
, E
);
8229 Set_Has_Completion
(E
);
8232 elsif Nkind
(Parent
(N
)) = N_Subunit
then
8234 -- If this is the proper body of a subunit, the completion
8235 -- flag is set when analyzing the stub.
8239 -- If E is an internal function with a controlling result that
8240 -- was created for an operation inherited by a null extension,
8241 -- it may be overridden by a body without a previous spec (one
8242 -- more reason why these should be shunned). In that case we
8243 -- remove the generated body if present, because the current
8244 -- one is the explicit overriding.
8246 elsif Ekind
(E
) = E_Function
8247 and then Ada_Version
>= Ada_2005
8248 and then not Comes_From_Source
(E
)
8249 and then Has_Controlling_Result
(E
)
8250 and then Is_Null_Extension
(Etype
(E
))
8251 and then Comes_From_Source
(Spec
)
8253 Set_Has_Completion
(E
, False);
8256 and then Nkind
(Parent
(E
)) = N_Function_Specification
8259 (Unit_Declaration_Node
8260 (Corresponding_Body
(Unit_Declaration_Node
(E
))));
8264 -- If expansion is disabled, or if the wrapper function has
8265 -- not been generated yet, this a late body overriding an
8266 -- inherited operation, or it is an overriding by some other
8267 -- declaration before the controlling result is frozen. In
8268 -- either case this is a declaration of a new entity.
8274 -- If the body already exists, then this is an error unless
8275 -- the previous declaration is the implicit declaration of a
8276 -- derived subprogram. It is also legal for an instance to
8277 -- contain type conformant overloadable declarations (but the
8278 -- generic declaration may not), per 8.3(26/2).
8280 elsif No
(Alias
(E
))
8281 and then not Is_Intrinsic_Subprogram
(E
)
8282 and then not In_Instance
8285 Error_Msg_Sloc
:= Sloc
(E
);
8287 if Is_Imported
(E
) then
8289 ("body not allowed for imported subprogram & declared#",
8292 Error_Msg_NE
("duplicate body for & declared#", N
, E
);
8296 -- Child units cannot be overloaded, so a conformance mismatch
8297 -- between body and a previous spec is an error.
8299 elsif Is_Child_Unit
(E
)
8301 Nkind
(Unit_Declaration_Node
(Designator
)) = N_Subprogram_Body
8303 Nkind
(Parent
(Unit_Declaration_Node
(Designator
))) =
8308 ("body of child unit does not match previous declaration", N
);
8316 -- On exit, we know that no previous declaration of subprogram exists
8319 end Find_Corresponding_Spec
;
8321 ----------------------
8322 -- Fully_Conformant --
8323 ----------------------
8325 function Fully_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
8328 Check_Conformance
(New_Id
, Old_Id
, Fully_Conformant
, False, Result
);
8330 end Fully_Conformant
;
8332 ----------------------------------
8333 -- Fully_Conformant_Expressions --
8334 ----------------------------------
8336 function Fully_Conformant_Expressions
8337 (Given_E1
: Node_Id
;
8338 Given_E2
: Node_Id
) return Boolean
8340 E1
: constant Node_Id
:= Original_Node
(Given_E1
);
8341 E2
: constant Node_Id
:= Original_Node
(Given_E2
);
8342 -- We always test conformance on original nodes, since it is possible
8343 -- for analysis and/or expansion to make things look as though they
8344 -- conform when they do not, e.g. by converting 1+2 into 3.
8346 function FCE
(Given_E1
, Given_E2
: Node_Id
) return Boolean
8347 renames Fully_Conformant_Expressions
;
8349 function FCL
(L1
, L2
: List_Id
) return Boolean;
8350 -- Compare elements of two lists for conformance. Elements have to be
8351 -- conformant, and actuals inserted as default parameters do not match
8352 -- explicit actuals with the same value.
8354 function FCO
(Op_Node
, Call_Node
: Node_Id
) return Boolean;
8355 -- Compare an operator node with a function call
8361 function FCL
(L1
, L2
: List_Id
) return Boolean is
8365 if L1
= No_List
then
8371 if L2
= No_List
then
8377 -- Compare two lists, skipping rewrite insertions (we want to compare
8378 -- the original trees, not the expanded versions).
8381 if Is_Rewrite_Insertion
(N1
) then
8383 elsif Is_Rewrite_Insertion
(N2
) then
8389 elsif not FCE
(N1
, N2
) then
8402 function FCO
(Op_Node
, Call_Node
: Node_Id
) return Boolean is
8403 Actuals
: constant List_Id
:= Parameter_Associations
(Call_Node
);
8408 or else Entity
(Op_Node
) /= Entity
(Name
(Call_Node
))
8413 Act
:= First
(Actuals
);
8415 if Nkind
(Op_Node
) in N_Binary_Op
then
8416 if not FCE
(Left_Opnd
(Op_Node
), Act
) then
8423 return Present
(Act
)
8424 and then FCE
(Right_Opnd
(Op_Node
), Act
)
8425 and then No
(Next
(Act
));
8429 -- Start of processing for Fully_Conformant_Expressions
8432 -- Non-conformant if paren count does not match. Note: if some idiot
8433 -- complains that we don't do this right for more than 3 levels of
8434 -- parentheses, they will be treated with the respect they deserve.
8436 if Paren_Count
(E1
) /= Paren_Count
(E2
) then
8439 -- If same entities are referenced, then they are conformant even if
8440 -- they have different forms (RM 8.3.1(19-20)).
8442 elsif Is_Entity_Name
(E1
) and then Is_Entity_Name
(E2
) then
8443 if Present
(Entity
(E1
)) then
8444 return Entity
(E1
) = Entity
(E2
)
8445 or else (Chars
(Entity
(E1
)) = Chars
(Entity
(E2
))
8446 and then Ekind
(Entity
(E1
)) = E_Discriminant
8447 and then Ekind
(Entity
(E2
)) = E_In_Parameter
);
8449 elsif Nkind
(E1
) = N_Expanded_Name
8450 and then Nkind
(E2
) = N_Expanded_Name
8451 and then Nkind
(Selector_Name
(E1
)) = N_Character_Literal
8452 and then Nkind
(Selector_Name
(E2
)) = N_Character_Literal
8454 return Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
));
8457 -- Identifiers in component associations don't always have
8458 -- entities, but their names must conform.
8460 return Nkind
(E1
) = N_Identifier
8461 and then Nkind
(E2
) = N_Identifier
8462 and then Chars
(E1
) = Chars
(E2
);
8465 elsif Nkind
(E1
) = N_Character_Literal
8466 and then Nkind
(E2
) = N_Expanded_Name
8468 return Nkind
(Selector_Name
(E2
)) = N_Character_Literal
8469 and then Chars
(E1
) = Chars
(Selector_Name
(E2
));
8471 elsif Nkind
(E2
) = N_Character_Literal
8472 and then Nkind
(E1
) = N_Expanded_Name
8474 return Nkind
(Selector_Name
(E1
)) = N_Character_Literal
8475 and then Chars
(E2
) = Chars
(Selector_Name
(E1
));
8477 elsif Nkind
(E1
) in N_Op
and then Nkind
(E2
) = N_Function_Call
then
8478 return FCO
(E1
, E2
);
8480 elsif Nkind
(E2
) in N_Op
and then Nkind
(E1
) = N_Function_Call
then
8481 return FCO
(E2
, E1
);
8483 -- Otherwise we must have the same syntactic entity
8485 elsif Nkind
(E1
) /= Nkind
(E2
) then
8488 -- At this point, we specialize by node type
8495 FCL
(Expressions
(E1
), Expressions
(E2
))
8497 FCL
(Component_Associations
(E1
),
8498 Component_Associations
(E2
));
8501 if Nkind
(Expression
(E1
)) = N_Qualified_Expression
8503 Nkind
(Expression
(E2
)) = N_Qualified_Expression
8505 return FCE
(Expression
(E1
), Expression
(E2
));
8507 -- Check that the subtype marks and any constraints
8512 Indic1
: constant Node_Id
:= Expression
(E1
);
8513 Indic2
: constant Node_Id
:= Expression
(E2
);
8518 if Nkind
(Indic1
) /= N_Subtype_Indication
then
8520 Nkind
(Indic2
) /= N_Subtype_Indication
8521 and then Entity
(Indic1
) = Entity
(Indic2
);
8523 elsif Nkind
(Indic2
) /= N_Subtype_Indication
then
8525 Nkind
(Indic1
) /= N_Subtype_Indication
8526 and then Entity
(Indic1
) = Entity
(Indic2
);
8529 if Entity
(Subtype_Mark
(Indic1
)) /=
8530 Entity
(Subtype_Mark
(Indic2
))
8535 Elt1
:= First
(Constraints
(Constraint
(Indic1
)));
8536 Elt2
:= First
(Constraints
(Constraint
(Indic2
)));
8537 while Present
(Elt1
) and then Present
(Elt2
) loop
8538 if not FCE
(Elt1
, Elt2
) then
8551 when N_Attribute_Reference
=>
8553 Attribute_Name
(E1
) = Attribute_Name
(E2
)
8554 and then FCL
(Expressions
(E1
), Expressions
(E2
));
8558 Entity
(E1
) = Entity
(E2
)
8559 and then FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
8560 and then FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
8562 when N_Short_Circuit | N_Membership_Test
=>
8564 FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
8566 FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
8568 when N_Case_Expression
=>
8574 if not FCE
(Expression
(E1
), Expression
(E2
)) then
8578 Alt1
:= First
(Alternatives
(E1
));
8579 Alt2
:= First
(Alternatives
(E2
));
8581 if Present
(Alt1
) /= Present
(Alt2
) then
8583 elsif No
(Alt1
) then
8587 if not FCE
(Expression
(Alt1
), Expression
(Alt2
))
8588 or else not FCL
(Discrete_Choices
(Alt1
),
8589 Discrete_Choices
(Alt2
))
8600 when N_Character_Literal
=>
8602 Char_Literal_Value
(E1
) = Char_Literal_Value
(E2
);
8604 when N_Component_Association
=>
8606 FCL
(Choices
(E1
), Choices
(E2
))
8608 FCE
(Expression
(E1
), Expression
(E2
));
8610 when N_Explicit_Dereference
=>
8612 FCE
(Prefix
(E1
), Prefix
(E2
));
8614 when N_Extension_Aggregate
=>
8616 FCL
(Expressions
(E1
), Expressions
(E2
))
8617 and then Null_Record_Present
(E1
) =
8618 Null_Record_Present
(E2
)
8619 and then FCL
(Component_Associations
(E1
),
8620 Component_Associations
(E2
));
8622 when N_Function_Call
=>
8624 FCE
(Name
(E1
), Name
(E2
))
8626 FCL
(Parameter_Associations
(E1
),
8627 Parameter_Associations
(E2
));
8629 when N_If_Expression
=>
8631 FCL
(Expressions
(E1
), Expressions
(E2
));
8633 when N_Indexed_Component
=>
8635 FCE
(Prefix
(E1
), Prefix
(E2
))
8637 FCL
(Expressions
(E1
), Expressions
(E2
));
8639 when N_Integer_Literal
=>
8640 return (Intval
(E1
) = Intval
(E2
));
8645 when N_Operator_Symbol
=>
8647 Chars
(E1
) = Chars
(E2
);
8649 when N_Others_Choice
=>
8652 when N_Parameter_Association
=>
8654 Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
))
8655 and then FCE
(Explicit_Actual_Parameter
(E1
),
8656 Explicit_Actual_Parameter
(E2
));
8658 when N_Qualified_Expression
=>
8660 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
8662 FCE
(Expression
(E1
), Expression
(E2
));
8664 when N_Quantified_Expression
=>
8665 if not FCE
(Condition
(E1
), Condition
(E2
)) then
8669 if Present
(Loop_Parameter_Specification
(E1
))
8670 and then Present
(Loop_Parameter_Specification
(E2
))
8673 L1
: constant Node_Id
:=
8674 Loop_Parameter_Specification
(E1
);
8675 L2
: constant Node_Id
:=
8676 Loop_Parameter_Specification
(E2
);
8680 Reverse_Present
(L1
) = Reverse_Present
(L2
)
8682 FCE
(Defining_Identifier
(L1
),
8683 Defining_Identifier
(L2
))
8685 FCE
(Discrete_Subtype_Definition
(L1
),
8686 Discrete_Subtype_Definition
(L2
));
8689 elsif Present
(Iterator_Specification
(E1
))
8690 and then Present
(Iterator_Specification
(E2
))
8693 I1
: constant Node_Id
:= Iterator_Specification
(E1
);
8694 I2
: constant Node_Id
:= Iterator_Specification
(E2
);
8698 FCE
(Defining_Identifier
(I1
),
8699 Defining_Identifier
(I2
))
8701 Of_Present
(I1
) = Of_Present
(I2
)
8703 Reverse_Present
(I1
) = Reverse_Present
(I2
)
8704 and then FCE
(Name
(I1
), Name
(I2
))
8705 and then FCE
(Subtype_Indication
(I1
),
8706 Subtype_Indication
(I2
));
8709 -- The quantified expressions used different specifications to
8710 -- walk their respective ranges.
8718 FCE
(Low_Bound
(E1
), Low_Bound
(E2
))
8720 FCE
(High_Bound
(E1
), High_Bound
(E2
));
8722 when N_Real_Literal
=>
8723 return (Realval
(E1
) = Realval
(E2
));
8725 when N_Selected_Component
=>
8727 FCE
(Prefix
(E1
), Prefix
(E2
))
8729 FCE
(Selector_Name
(E1
), Selector_Name
(E2
));
8733 FCE
(Prefix
(E1
), Prefix
(E2
))
8735 FCE
(Discrete_Range
(E1
), Discrete_Range
(E2
));
8737 when N_String_Literal
=>
8739 S1
: constant String_Id
:= Strval
(E1
);
8740 S2
: constant String_Id
:= Strval
(E2
);
8741 L1
: constant Nat
:= String_Length
(S1
);
8742 L2
: constant Nat
:= String_Length
(S2
);
8749 for J
in 1 .. L1
loop
8750 if Get_String_Char
(S1
, J
) /=
8751 Get_String_Char
(S2
, J
)
8761 when N_Type_Conversion
=>
8763 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
8765 FCE
(Expression
(E1
), Expression
(E2
));
8769 Entity
(E1
) = Entity
(E2
)
8771 FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
8773 when N_Unchecked_Type_Conversion
=>
8775 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
8777 FCE
(Expression
(E1
), Expression
(E2
));
8779 -- All other node types cannot appear in this context. Strictly
8780 -- we should raise a fatal internal error. Instead we just ignore
8781 -- the nodes. This means that if anyone makes a mistake in the
8782 -- expander and mucks an expression tree irretrievably, the result
8783 -- will be a failure to detect a (probably very obscure) case
8784 -- of non-conformance, which is better than bombing on some
8785 -- case where two expressions do in fact conform.
8792 end Fully_Conformant_Expressions
;
8794 ----------------------------------------
8795 -- Fully_Conformant_Discrete_Subtypes --
8796 ----------------------------------------
8798 function Fully_Conformant_Discrete_Subtypes
8799 (Given_S1
: Node_Id
;
8800 Given_S2
: Node_Id
) return Boolean
8802 S1
: constant Node_Id
:= Original_Node
(Given_S1
);
8803 S2
: constant Node_Id
:= Original_Node
(Given_S2
);
8805 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean;
8806 -- Special-case for a bound given by a discriminant, which in the body
8807 -- is replaced with the discriminal of the enclosing type.
8809 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean;
8810 -- Check both bounds
8812 -----------------------
8813 -- Conforming_Bounds --
8814 -----------------------
8816 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean is
8818 if Is_Entity_Name
(B1
)
8819 and then Is_Entity_Name
(B2
)
8820 and then Ekind
(Entity
(B1
)) = E_Discriminant
8822 return Chars
(B1
) = Chars
(B2
);
8825 return Fully_Conformant_Expressions
(B1
, B2
);
8827 end Conforming_Bounds
;
8829 -----------------------
8830 -- Conforming_Ranges --
8831 -----------------------
8833 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean is
8836 Conforming_Bounds
(Low_Bound
(R1
), Low_Bound
(R2
))
8838 Conforming_Bounds
(High_Bound
(R1
), High_Bound
(R2
));
8839 end Conforming_Ranges
;
8841 -- Start of processing for Fully_Conformant_Discrete_Subtypes
8844 if Nkind
(S1
) /= Nkind
(S2
) then
8847 elsif Is_Entity_Name
(S1
) then
8848 return Entity
(S1
) = Entity
(S2
);
8850 elsif Nkind
(S1
) = N_Range
then
8851 return Conforming_Ranges
(S1
, S2
);
8853 elsif Nkind
(S1
) = N_Subtype_Indication
then
8855 Entity
(Subtype_Mark
(S1
)) = Entity
(Subtype_Mark
(S2
))
8858 (Range_Expression
(Constraint
(S1
)),
8859 Range_Expression
(Constraint
(S2
)));
8863 end Fully_Conformant_Discrete_Subtypes
;
8865 --------------------
8866 -- Install_Entity --
8867 --------------------
8869 procedure Install_Entity
(E
: Entity_Id
) is
8870 Prev
: constant Entity_Id
:= Current_Entity
(E
);
8872 Set_Is_Immediately_Visible
(E
);
8873 Set_Current_Entity
(E
);
8874 Set_Homonym
(E
, Prev
);
8877 ---------------------
8878 -- Install_Formals --
8879 ---------------------
8881 procedure Install_Formals
(Id
: Entity_Id
) is
8884 F
:= First_Formal
(Id
);
8885 while Present
(F
) loop
8889 end Install_Formals
;
8891 -----------------------------
8892 -- Is_Interface_Conformant --
8893 -----------------------------
8895 function Is_Interface_Conformant
8896 (Tagged_Type
: Entity_Id
;
8897 Iface_Prim
: Entity_Id
;
8898 Prim
: Entity_Id
) return Boolean
8900 -- The operation may in fact be an inherited (implicit) operation
8901 -- rather than the original interface primitive, so retrieve the
8902 -- ultimate ancestor.
8904 Iface
: constant Entity_Id
:=
8905 Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
));
8906 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
8908 function Controlling_Formal
(Prim
: Entity_Id
) return Entity_Id
;
8909 -- Return the controlling formal of Prim
8911 ------------------------
8912 -- Controlling_Formal --
8913 ------------------------
8915 function Controlling_Formal
(Prim
: Entity_Id
) return Entity_Id
is
8919 E
:= First_Entity
(Prim
);
8920 while Present
(E
) loop
8921 if Is_Formal
(E
) and then Is_Controlling_Formal
(E
) then
8929 end Controlling_Formal
;
8933 Iface_Ctrl_F
: constant Entity_Id
:= Controlling_Formal
(Iface_Prim
);
8934 Prim_Ctrl_F
: constant Entity_Id
:= Controlling_Formal
(Prim
);
8936 -- Start of processing for Is_Interface_Conformant
8939 pragma Assert
(Is_Subprogram
(Iface_Prim
)
8940 and then Is_Subprogram
(Prim
)
8941 and then Is_Dispatching_Operation
(Iface_Prim
)
8942 and then Is_Dispatching_Operation
(Prim
));
8944 pragma Assert
(Is_Interface
(Iface
)
8945 or else (Present
(Alias
(Iface_Prim
))
8948 (Find_Dispatching_Type
(Ultimate_Alias
(Iface_Prim
)))));
8950 if Prim
= Iface_Prim
8951 or else not Is_Subprogram
(Prim
)
8952 or else Ekind
(Prim
) /= Ekind
(Iface_Prim
)
8953 or else not Is_Dispatching_Operation
(Prim
)
8954 or else Scope
(Prim
) /= Scope
(Tagged_Type
)
8956 or else Base_Type
(Typ
) /= Base_Type
(Tagged_Type
)
8957 or else not Primitive_Names_Match
(Iface_Prim
, Prim
)
8961 -- The mode of the controlling formals must match
8963 elsif Present
(Iface_Ctrl_F
)
8964 and then Present
(Prim_Ctrl_F
)
8965 and then Ekind
(Iface_Ctrl_F
) /= Ekind
(Prim_Ctrl_F
)
8969 -- Case of a procedure, or a function whose result type matches the
8970 -- result type of the interface primitive, or a function that has no
8971 -- controlling result (I or access I).
8973 elsif Ekind
(Iface_Prim
) = E_Procedure
8974 or else Etype
(Prim
) = Etype
(Iface_Prim
)
8975 or else not Has_Controlling_Result
(Prim
)
8977 return Type_Conformant
8978 (Iface_Prim
, Prim
, Skip_Controlling_Formals
=> True);
8980 -- Case of a function returning an interface, or an access to one. Check
8981 -- that the return types correspond.
8983 elsif Implements_Interface
(Typ
, Iface
) then
8984 if (Ekind
(Etype
(Prim
)) = E_Anonymous_Access_Type
)
8986 (Ekind
(Etype
(Iface_Prim
)) = E_Anonymous_Access_Type
)
8991 Type_Conformant
(Prim
, Ultimate_Alias
(Iface_Prim
),
8992 Skip_Controlling_Formals
=> True);
8998 end Is_Interface_Conformant
;
9000 ---------------------------------
9001 -- Is_Non_Overriding_Operation --
9002 ---------------------------------
9004 function Is_Non_Overriding_Operation
9005 (Prev_E
: Entity_Id
;
9006 New_E
: Entity_Id
) return Boolean
9010 G_Typ
: Entity_Id
:= Empty
;
9012 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
;
9013 -- If F_Type is a derived type associated with a generic actual subtype,
9014 -- then return its Generic_Parent_Type attribute, else return Empty.
9016 function Types_Correspond
9017 (P_Type
: Entity_Id
;
9018 N_Type
: Entity_Id
) return Boolean;
9019 -- Returns true if and only if the types (or designated types in the
9020 -- case of anonymous access types) are the same or N_Type is derived
9021 -- directly or indirectly from P_Type.
9023 -----------------------------
9024 -- Get_Generic_Parent_Type --
9025 -----------------------------
9027 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
is
9033 if Is_Derived_Type
(F_Typ
)
9034 and then Nkind
(Parent
(F_Typ
)) = N_Full_Type_Declaration
9036 -- The tree must be traversed to determine the parent subtype in
9037 -- the generic unit, which unfortunately isn't always available
9038 -- via semantic attributes. ??? (Note: The use of Original_Node
9039 -- is needed for cases where a full derived type has been
9042 -- If the parent type is a scalar type, the derivation creates
9043 -- an anonymous base type for it, and the source type is its
9046 if Is_Scalar_Type
(F_Typ
)
9047 and then not Comes_From_Source
(F_Typ
)
9051 (Original_Node
(Parent
(First_Subtype
(F_Typ
))));
9053 Defn
:= Type_Definition
(Original_Node
(Parent
(F_Typ
)));
9055 if Nkind
(Defn
) = N_Derived_Type_Definition
then
9056 Indic
:= Subtype_Indication
(Defn
);
9058 if Nkind
(Indic
) = N_Subtype_Indication
then
9059 G_Typ
:= Entity
(Subtype_Mark
(Indic
));
9061 G_Typ
:= Entity
(Indic
);
9064 if Nkind
(Parent
(G_Typ
)) = N_Subtype_Declaration
9065 and then Present
(Generic_Parent_Type
(Parent
(G_Typ
)))
9067 return Generic_Parent_Type
(Parent
(G_Typ
));
9073 end Get_Generic_Parent_Type
;
9075 ----------------------
9076 -- Types_Correspond --
9077 ----------------------
9079 function Types_Correspond
9080 (P_Type
: Entity_Id
;
9081 N_Type
: Entity_Id
) return Boolean
9083 Prev_Type
: Entity_Id
:= Base_Type
(P_Type
);
9084 New_Type
: Entity_Id
:= Base_Type
(N_Type
);
9087 if Ekind
(Prev_Type
) = E_Anonymous_Access_Type
then
9088 Prev_Type
:= Designated_Type
(Prev_Type
);
9091 if Ekind
(New_Type
) = E_Anonymous_Access_Type
then
9092 New_Type
:= Designated_Type
(New_Type
);
9095 if Prev_Type
= New_Type
then
9098 elsif not Is_Class_Wide_Type
(New_Type
) then
9099 while Etype
(New_Type
) /= New_Type
loop
9100 New_Type
:= Etype
(New_Type
);
9102 if New_Type
= Prev_Type
then
9108 end Types_Correspond
;
9110 -- Start of processing for Is_Non_Overriding_Operation
9113 -- In the case where both operations are implicit derived subprograms
9114 -- then neither overrides the other. This can only occur in certain
9115 -- obscure cases (e.g., derivation from homographs created in a generic
9118 if Present
(Alias
(Prev_E
)) and then Present
(Alias
(New_E
)) then
9121 elsif Ekind
(Current_Scope
) = E_Package
9122 and then Is_Generic_Instance
(Current_Scope
)
9123 and then In_Private_Part
(Current_Scope
)
9124 and then Comes_From_Source
(New_E
)
9126 -- We examine the formals and result type of the inherited operation,
9127 -- to determine whether their type is derived from (the instance of)
9128 -- a generic type. The first such formal or result type is the one
9131 Formal
:= First_Formal
(Prev_E
);
9133 while Present
(Formal
) loop
9134 F_Typ
:= Base_Type
(Etype
(Formal
));
9136 if Ekind
(F_Typ
) = E_Anonymous_Access_Type
then
9137 F_Typ
:= Designated_Type
(F_Typ
);
9140 G_Typ
:= Get_Generic_Parent_Type
(F_Typ
);
9141 exit when Present
(G_Typ
);
9143 Next_Formal
(Formal
);
9146 -- If the function dispatches on result check the result type
9148 if No
(G_Typ
) and then Ekind
(Prev_E
) = E_Function
then
9149 G_Typ
:= Get_Generic_Parent_Type
(Base_Type
(Etype
(Prev_E
)));
9156 -- If the generic type is a private type, then the original operation
9157 -- was not overriding in the generic, because there was no primitive
9158 -- operation to override.
9160 if Nkind
(Parent
(G_Typ
)) = N_Formal_Type_Declaration
9161 and then Nkind
(Formal_Type_Definition
(Parent
(G_Typ
))) =
9162 N_Formal_Private_Type_Definition
9166 -- The generic parent type is the ancestor of a formal derived
9167 -- type declaration. We need to check whether it has a primitive
9168 -- operation that should be overridden by New_E in the generic.
9172 P_Formal
: Entity_Id
;
9173 N_Formal
: Entity_Id
;
9177 Prim_Elt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(G_Typ
));
9180 while Present
(Prim_Elt
) loop
9181 P_Prim
:= Node
(Prim_Elt
);
9183 if Chars
(P_Prim
) = Chars
(New_E
)
9184 and then Ekind
(P_Prim
) = Ekind
(New_E
)
9186 P_Formal
:= First_Formal
(P_Prim
);
9187 N_Formal
:= First_Formal
(New_E
);
9188 while Present
(P_Formal
) and then Present
(N_Formal
) loop
9189 P_Typ
:= Etype
(P_Formal
);
9190 N_Typ
:= Etype
(N_Formal
);
9192 if not Types_Correspond
(P_Typ
, N_Typ
) then
9196 Next_Entity
(P_Formal
);
9197 Next_Entity
(N_Formal
);
9200 -- Found a matching primitive operation belonging to the
9201 -- formal ancestor type, so the new subprogram is
9205 and then No
(N_Formal
)
9206 and then (Ekind
(New_E
) /= E_Function
9209 (Etype
(P_Prim
), Etype
(New_E
)))
9215 Next_Elmt
(Prim_Elt
);
9218 -- If no match found, then the new subprogram does not override
9219 -- in the generic (nor in the instance).
9221 -- If the type in question is not abstract, and the subprogram
9222 -- is, this will be an error if the new operation is in the
9223 -- private part of the instance. Emit a warning now, which will
9224 -- make the subsequent error message easier to understand.
9226 if Present
(F_Typ
) and then not Is_Abstract_Type
(F_Typ
)
9227 and then Is_Abstract_Subprogram
(Prev_E
)
9228 and then In_Private_Part
(Current_Scope
)
9230 Error_Msg_Node_2
:= F_Typ
;
9232 ("private operation& in generic unit does not override "
9233 & "any primitive operation of& (RM 12.3 (18))??",
9243 end Is_Non_Overriding_Operation
;
9245 -------------------------------------
9246 -- List_Inherited_Pre_Post_Aspects --
9247 -------------------------------------
9249 procedure List_Inherited_Pre_Post_Aspects
(E
: Entity_Id
) is
9251 if Opt
.List_Inherited_Aspects
9252 and then Is_Subprogram_Or_Generic_Subprogram
(E
)
9255 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(E
);
9260 for Index
in Subps
'Range loop
9261 Items
:= Contract
(Subps
(Index
));
9263 if Present
(Items
) then
9264 Prag
:= Pre_Post_Conditions
(Items
);
9265 while Present
(Prag
) loop
9266 Error_Msg_Sloc
:= Sloc
(Prag
);
9268 if Class_Present
(Prag
)
9269 and then not Split_PPC
(Prag
)
9271 if Pragma_Name
(Prag
) = Name_Precondition
then
9273 ("info: & inherits `Pre''Class` aspect from "
9277 ("info: & inherits `Post''Class` aspect from "
9282 Prag
:= Next_Pragma
(Prag
);
9288 end List_Inherited_Pre_Post_Aspects
;
9290 ------------------------------
9291 -- Make_Inequality_Operator --
9292 ------------------------------
9294 -- S is the defining identifier of an equality operator. We build a
9295 -- subprogram declaration with the right signature. This operation is
9296 -- intrinsic, because it is always expanded as the negation of the
9297 -- call to the equality function.
9299 procedure Make_Inequality_Operator
(S
: Entity_Id
) is
9300 Loc
: constant Source_Ptr
:= Sloc
(S
);
9303 Op_Name
: Entity_Id
;
9305 FF
: constant Entity_Id
:= First_Formal
(S
);
9306 NF
: constant Entity_Id
:= Next_Formal
(FF
);
9309 -- Check that equality was properly defined, ignore call if not
9316 A
: constant Entity_Id
:=
9317 Make_Defining_Identifier
(Sloc
(FF
),
9318 Chars
=> Chars
(FF
));
9320 B
: constant Entity_Id
:=
9321 Make_Defining_Identifier
(Sloc
(NF
),
9322 Chars
=> Chars
(NF
));
9325 Op_Name
:= Make_Defining_Operator_Symbol
(Loc
, Name_Op_Ne
);
9327 Formals
:= New_List
(
9328 Make_Parameter_Specification
(Loc
,
9329 Defining_Identifier
=> A
,
9331 New_Occurrence_Of
(Etype
(First_Formal
(S
)),
9332 Sloc
(Etype
(First_Formal
(S
))))),
9334 Make_Parameter_Specification
(Loc
,
9335 Defining_Identifier
=> B
,
9337 New_Occurrence_Of
(Etype
(Next_Formal
(First_Formal
(S
))),
9338 Sloc
(Etype
(Next_Formal
(First_Formal
(S
)))))));
9341 Make_Subprogram_Declaration
(Loc
,
9343 Make_Function_Specification
(Loc
,
9344 Defining_Unit_Name
=> Op_Name
,
9345 Parameter_Specifications
=> Formals
,
9346 Result_Definition
=>
9347 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
9349 -- Insert inequality right after equality if it is explicit or after
9350 -- the derived type when implicit. These entities are created only
9351 -- for visibility purposes, and eventually replaced in the course
9352 -- of expansion, so they do not need to be attached to the tree and
9353 -- seen by the back-end. Keeping them internal also avoids spurious
9354 -- freezing problems. The declaration is inserted in the tree for
9355 -- analysis, and removed afterwards. If the equality operator comes
9356 -- from an explicit declaration, attach the inequality immediately
9357 -- after. Else the equality is inherited from a derived type
9358 -- declaration, so insert inequality after that declaration.
9360 if No
(Alias
(S
)) then
9361 Insert_After
(Unit_Declaration_Node
(S
), Decl
);
9362 elsif Is_List_Member
(Parent
(S
)) then
9363 Insert_After
(Parent
(S
), Decl
);
9365 Insert_After
(Parent
(Etype
(First_Formal
(S
))), Decl
);
9368 Mark_Rewrite_Insertion
(Decl
);
9369 Set_Is_Intrinsic_Subprogram
(Op_Name
);
9372 Set_Has_Completion
(Op_Name
);
9373 Set_Corresponding_Equality
(Op_Name
, S
);
9374 Set_Is_Abstract_Subprogram
(Op_Name
, Is_Abstract_Subprogram
(S
));
9376 end Make_Inequality_Operator
;
9378 ----------------------
9379 -- May_Need_Actuals --
9380 ----------------------
9382 procedure May_Need_Actuals
(Fun
: Entity_Id
) is
9387 F
:= First_Formal
(Fun
);
9389 while Present
(F
) loop
9390 if No
(Default_Value
(F
)) then
9398 Set_Needs_No_Actuals
(Fun
, B
);
9399 end May_Need_Actuals
;
9401 ---------------------
9402 -- Mode_Conformant --
9403 ---------------------
9405 function Mode_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
9408 Check_Conformance
(New_Id
, Old_Id
, Mode_Conformant
, False, Result
);
9410 end Mode_Conformant
;
9412 ---------------------------
9413 -- New_Overloaded_Entity --
9414 ---------------------------
9416 procedure New_Overloaded_Entity
9418 Derived_Type
: Entity_Id
:= Empty
)
9420 Overridden_Subp
: Entity_Id
:= Empty
;
9421 -- Set if the current scope has an operation that is type-conformant
9422 -- with S, and becomes hidden by S.
9424 Is_Primitive_Subp
: Boolean;
9425 -- Set to True if the new subprogram is primitive
9428 -- Entity that S overrides
9430 Prev_Vis
: Entity_Id
:= Empty
;
9431 -- Predecessor of E in Homonym chain
9433 procedure Check_For_Primitive_Subprogram
9434 (Is_Primitive
: out Boolean;
9435 Is_Overriding
: Boolean := False);
9436 -- If the subprogram being analyzed is a primitive operation of the type
9437 -- of a formal or result, set the Has_Primitive_Operations flag on the
9438 -- type, and set Is_Primitive to True (otherwise set to False). Set the
9439 -- corresponding flag on the entity itself for later use.
9441 function Has_Matching_Entry_Or_Subprogram
(E
: Entity_Id
) return Boolean;
9442 -- True if a) E is a subprogram whose first formal is a concurrent type
9443 -- defined in the scope of E that has some entry or subprogram whose
9444 -- profile matches E, or b) E is an internally built dispatching
9445 -- subprogram of a protected type and there is a matching subprogram
9446 -- defined in the enclosing scope of the protected type, or c) E is
9447 -- an entry of a synchronized type and a matching procedure has been
9448 -- previously defined in the enclosing scope of the synchronized type.
9450 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean;
9451 -- Check that E is declared in the private part of the current package,
9452 -- or in the package body, where it may hide a previous declaration.
9453 -- We can't use In_Private_Part by itself because this flag is also
9454 -- set when freezing entities, so we must examine the place of the
9455 -- declaration in the tree, and recognize wrapper packages as well.
9457 function Is_Overriding_Alias
9459 New_E
: Entity_Id
) return Boolean;
9460 -- Check whether new subprogram and old subprogram are both inherited
9461 -- from subprograms that have distinct dispatch table entries. This can
9462 -- occur with derivations from instances with accidental homonyms. The
9463 -- function is conservative given that the converse is only true within
9464 -- instances that contain accidental overloadings.
9466 procedure Report_Conflict
(S
: Entity_Id
; E
: Entity_Id
);
9467 -- Report conflict between entities S and E
9469 ------------------------------------
9470 -- Check_For_Primitive_Subprogram --
9471 ------------------------------------
9473 procedure Check_For_Primitive_Subprogram
9474 (Is_Primitive
: out Boolean;
9475 Is_Overriding
: Boolean := False)
9481 function Visible_Part_Type
(T
: Entity_Id
) return Boolean;
9482 -- Returns true if T is declared in the visible part of the current
9483 -- package scope; otherwise returns false. Assumes that T is declared
9486 procedure Check_Private_Overriding
(T
: Entity_Id
);
9487 -- Checks that if a primitive abstract subprogram of a visible
9488 -- abstract type is declared in a private part, then it must override
9489 -- an abstract subprogram declared in the visible part. Also checks
9490 -- that if a primitive function with a controlling result is declared
9491 -- in a private part, then it must override a function declared in
9492 -- the visible part.
9494 ------------------------------
9495 -- Check_Private_Overriding --
9496 ------------------------------
9498 procedure Check_Private_Overriding
(T
: Entity_Id
) is
9499 function Overrides_Private_Part_Op
return Boolean;
9500 -- This detects the special case where the overriding subprogram
9501 -- is overriding a subprogram that was declared in the same
9502 -- private part. That case is illegal by 3.9.3(10).
9504 function Overrides_Visible_Function
9505 (Partial_View
: Entity_Id
) return Boolean;
9506 -- True if S overrides a function in the visible part. The
9507 -- overridden function could be explicitly or implicitly declared.
9509 -------------------------------
9510 -- Overrides_Private_Part_Op --
9511 -------------------------------
9513 function Overrides_Private_Part_Op
return Boolean is
9514 Over_Decl
: constant Node_Id
:=
9515 Unit_Declaration_Node
(Overridden_Operation
(S
));
9516 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(S
);
9519 pragma Assert
(Is_Overriding
);
9521 (Nkind
(Over_Decl
) = N_Abstract_Subprogram_Declaration
);
9523 (Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
);
9525 return In_Same_List
(Over_Decl
, Subp_Decl
);
9526 end Overrides_Private_Part_Op
;
9528 --------------------------------
9529 -- Overrides_Visible_Function --
9530 --------------------------------
9532 function Overrides_Visible_Function
9533 (Partial_View
: Entity_Id
) return Boolean
9536 if not Is_Overriding
or else not Has_Homonym
(S
) then
9540 if not Present
(Partial_View
) then
9544 -- Search through all the homonyms H of S in the current
9545 -- package spec, and return True if we find one that matches.
9546 -- Note that Parent (H) will be the declaration of the
9547 -- partial view of T for a match.
9554 exit when not Present
(H
) or else Scope
(H
) /= Scope
(S
);
9558 N_Private_Extension_Declaration
,
9559 N_Private_Type_Declaration
)
9560 and then Defining_Identifier
(Parent
(H
)) = Partial_View
9568 end Overrides_Visible_Function
;
9570 -- Start of processing for Check_Private_Overriding
9573 if Is_Package_Or_Generic_Package
(Current_Scope
)
9574 and then In_Private_Part
(Current_Scope
)
9575 and then Visible_Part_Type
(T
)
9576 and then not In_Instance
9578 if Is_Abstract_Type
(T
)
9579 and then Is_Abstract_Subprogram
(S
)
9580 and then (not Is_Overriding
9581 or else not Is_Abstract_Subprogram
(E
)
9582 or else Overrides_Private_Part_Op
)
9585 ("abstract subprograms must be visible (RM 3.9.3(10))!",
9588 elsif Ekind
(S
) = E_Function
then
9590 Partial_View
: constant Entity_Id
:=
9591 Incomplete_Or_Partial_View
(T
);
9594 if not Overrides_Visible_Function
(Partial_View
) then
9596 -- Here, S is "function ... return T;" declared in
9597 -- the private part, not overriding some visible
9598 -- operation. That's illegal in the tagged case
9599 -- (but not if the private type is untagged).
9601 if ((Present
(Partial_View
)
9602 and then Is_Tagged_Type
(Partial_View
))
9603 or else (not Present
(Partial_View
)
9604 and then Is_Tagged_Type
(T
)))
9605 and then T
= Base_Type
(Etype
(S
))
9608 ("private function with tagged result must"
9609 & " override visible-part function", S
);
9611 ("\move subprogram to the visible part"
9612 & " (RM 3.9.3(10))", S
);
9614 -- AI05-0073: extend this test to the case of a
9615 -- function with a controlling access result.
9617 elsif Ekind
(Etype
(S
)) = E_Anonymous_Access_Type
9618 and then Is_Tagged_Type
(Designated_Type
(Etype
(S
)))
9620 not Is_Class_Wide_Type
9621 (Designated_Type
(Etype
(S
)))
9622 and then Ada_Version
>= Ada_2012
9625 ("private function with controlling access "
9626 & "result must override visible-part function",
9629 ("\move subprogram to the visible part"
9630 & " (RM 3.9.3(10))", S
);
9636 end Check_Private_Overriding
;
9638 -----------------------
9639 -- Visible_Part_Type --
9640 -----------------------
9642 function Visible_Part_Type
(T
: Entity_Id
) return Boolean is
9643 P
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(T
));
9647 -- If the entity is a private type, then it must be declared in a
9650 if Ekind
(T
) in Private_Kind
then
9654 -- Otherwise, we traverse the visible part looking for its
9655 -- corresponding declaration. We cannot use the declaration
9656 -- node directly because in the private part the entity of a
9657 -- private type is the one in the full view, which does not
9658 -- indicate that it is the completion of something visible.
9660 N
:= First
(Visible_Declarations
(Specification
(P
)));
9661 while Present
(N
) loop
9662 if Nkind
(N
) = N_Full_Type_Declaration
9663 and then Present
(Defining_Identifier
(N
))
9664 and then T
= Defining_Identifier
(N
)
9668 elsif Nkind_In
(N
, N_Private_Type_Declaration
,
9669 N_Private_Extension_Declaration
)
9670 and then Present
(Defining_Identifier
(N
))
9671 and then T
= Full_View
(Defining_Identifier
(N
))
9680 end Visible_Part_Type
;
9682 -- Start of processing for Check_For_Primitive_Subprogram
9685 Is_Primitive
:= False;
9687 if not Comes_From_Source
(S
) then
9690 -- If subprogram is at library level, it is not primitive operation
9692 elsif Current_Scope
= Standard_Standard
then
9695 elsif (Is_Package_Or_Generic_Package
(Current_Scope
)
9696 and then not In_Package_Body
(Current_Scope
))
9697 or else Is_Overriding
9699 -- For function, check return type
9701 if Ekind
(S
) = E_Function
then
9702 if Ekind
(Etype
(S
)) = E_Anonymous_Access_Type
then
9703 F_Typ
:= Designated_Type
(Etype
(S
));
9708 B_Typ
:= Base_Type
(F_Typ
);
9710 if Scope
(B_Typ
) = Current_Scope
9711 and then not Is_Class_Wide_Type
(B_Typ
)
9712 and then not Is_Generic_Type
(B_Typ
)
9714 Is_Primitive
:= True;
9715 Set_Has_Primitive_Operations
(B_Typ
);
9716 Set_Is_Primitive
(S
);
9717 Check_Private_Overriding
(B_Typ
);
9719 -- The Ghost policy in effect at the point of declaration of
9720 -- a tagged type and a primitive operation must match
9721 -- (SPARK RM 6.9(16)).
9723 Check_Ghost_Primitive
(S
, B_Typ
);
9727 -- For all subprograms, check formals
9729 Formal
:= First_Formal
(S
);
9730 while Present
(Formal
) loop
9731 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
9732 F_Typ
:= Designated_Type
(Etype
(Formal
));
9734 F_Typ
:= Etype
(Formal
);
9737 B_Typ
:= Base_Type
(F_Typ
);
9739 if Ekind
(B_Typ
) = E_Access_Subtype
then
9740 B_Typ
:= Base_Type
(B_Typ
);
9743 if Scope
(B_Typ
) = Current_Scope
9744 and then not Is_Class_Wide_Type
(B_Typ
)
9745 and then not Is_Generic_Type
(B_Typ
)
9747 Is_Primitive
:= True;
9748 Set_Is_Primitive
(S
);
9749 Set_Has_Primitive_Operations
(B_Typ
);
9750 Check_Private_Overriding
(B_Typ
);
9752 -- The Ghost policy in effect at the point of declaration of
9753 -- a tagged type and a primitive operation must match
9754 -- (SPARK RM 6.9(16)).
9756 Check_Ghost_Primitive
(S
, B_Typ
);
9759 Next_Formal
(Formal
);
9762 -- Special case: An equality function can be redefined for a type
9763 -- occurring in a declarative part, and won't otherwise be treated as
9764 -- a primitive because it doesn't occur in a package spec and doesn't
9765 -- override an inherited subprogram. It's important that we mark it
9766 -- primitive so it can be returned by Collect_Primitive_Operations
9767 -- and be used in composing the equality operation of later types
9768 -- that have a component of the type.
9770 elsif Chars
(S
) = Name_Op_Eq
9771 and then Etype
(S
) = Standard_Boolean
9773 B_Typ
:= Base_Type
(Etype
(First_Formal
(S
)));
9775 if Scope
(B_Typ
) = Current_Scope
9777 Base_Type
(Etype
(Next_Formal
(First_Formal
(S
)))) = B_Typ
9778 and then not Is_Limited_Type
(B_Typ
)
9780 Is_Primitive
:= True;
9781 Set_Is_Primitive
(S
);
9782 Set_Has_Primitive_Operations
(B_Typ
);
9783 Check_Private_Overriding
(B_Typ
);
9785 -- The Ghost policy in effect at the point of declaration of a
9786 -- tagged type and a primitive operation must match
9787 -- (SPARK RM 6.9(16)).
9789 Check_Ghost_Primitive
(S
, B_Typ
);
9792 end Check_For_Primitive_Subprogram
;
9794 --------------------------------------
9795 -- Has_Matching_Entry_Or_Subprogram --
9796 --------------------------------------
9798 function Has_Matching_Entry_Or_Subprogram
9799 (E
: Entity_Id
) return Boolean
9801 function Check_Conforming_Parameters
9802 (E1_Param
: Node_Id
;
9803 E2_Param
: Node_Id
) return Boolean;
9804 -- Starting from the given parameters, check that all the parameters
9805 -- of two entries or subprograms are subtype conformant. Used to skip
9806 -- the check on the controlling argument.
9808 function Matching_Entry_Or_Subprogram
9809 (Conc_Typ
: Entity_Id
;
9810 Subp
: Entity_Id
) return Entity_Id
;
9811 -- Return the first entry or subprogram of the given concurrent type
9812 -- whose name matches the name of Subp and has a profile conformant
9813 -- with Subp; return Empty if not found.
9815 function Matching_Dispatching_Subprogram
9816 (Conc_Typ
: Entity_Id
;
9817 Ent
: Entity_Id
) return Entity_Id
;
9818 -- Return the first dispatching primitive of Conc_Type defined in the
9819 -- enclosing scope of Conc_Type (i.e. before the full definition of
9820 -- this concurrent type) whose name matches the entry Ent and has a
9821 -- profile conformant with the profile of the corresponding (not yet
9822 -- built) dispatching primitive of Ent; return Empty if not found.
9824 function Matching_Original_Protected_Subprogram
9825 (Prot_Typ
: Entity_Id
;
9826 Subp
: Entity_Id
) return Entity_Id
;
9827 -- Return the first subprogram defined in the enclosing scope of
9828 -- Prot_Typ (before the full definition of this protected type)
9829 -- whose name matches the original name of Subp and has a profile
9830 -- conformant with the profile of Subp; return Empty if not found.
9832 ---------------------------------
9833 -- Check_Confirming_Parameters --
9834 ---------------------------------
9836 function Check_Conforming_Parameters
9837 (E1_Param
: Node_Id
;
9838 E2_Param
: Node_Id
) return Boolean
9840 Param_E1
: Node_Id
:= E1_Param
;
9841 Param_E2
: Node_Id
:= E2_Param
;
9844 while Present
(Param_E1
) and then Present
(Param_E2
) loop
9845 if Ekind
(Defining_Identifier
(Param_E1
)) /=
9846 Ekind
(Defining_Identifier
(Param_E2
))
9849 (Find_Parameter_Type
(Param_E1
),
9850 Find_Parameter_Type
(Param_E2
),
9860 -- The candidate is not valid if one of the two lists contains
9861 -- more parameters than the other
9863 return No
(Param_E1
) and then No
(Param_E2
);
9864 end Check_Conforming_Parameters
;
9866 ----------------------------------
9867 -- Matching_Entry_Or_Subprogram --
9868 ----------------------------------
9870 function Matching_Entry_Or_Subprogram
9871 (Conc_Typ
: Entity_Id
;
9872 Subp
: Entity_Id
) return Entity_Id
9877 E
:= First_Entity
(Conc_Typ
);
9878 while Present
(E
) loop
9879 if Chars
(Subp
) = Chars
(E
)
9880 and then (Ekind
(E
) = E_Entry
or else Is_Subprogram
(E
))
9882 Check_Conforming_Parameters
9883 (First
(Parameter_Specifications
(Parent
(E
))),
9884 Next
(First
(Parameter_Specifications
(Parent
(Subp
)))))
9893 end Matching_Entry_Or_Subprogram
;
9895 -------------------------------------
9896 -- Matching_Dispatching_Subprogram --
9897 -------------------------------------
9899 function Matching_Dispatching_Subprogram
9900 (Conc_Typ
: Entity_Id
;
9901 Ent
: Entity_Id
) return Entity_Id
9906 -- Search for entities in the enclosing scope of this synchonized
9909 pragma Assert
(Is_Concurrent_Type
(Conc_Typ
));
9910 Push_Scope
(Scope
(Conc_Typ
));
9911 E
:= Current_Entity_In_Scope
(Ent
);
9914 while Present
(E
) loop
9915 if Scope
(E
) = Scope
(Conc_Typ
)
9916 and then Comes_From_Source
(E
)
9917 and then Ekind
(E
) = E_Procedure
9918 and then Present
(First_Entity
(E
))
9919 and then Is_Controlling_Formal
(First_Entity
(E
))
9920 and then Etype
(First_Entity
(E
)) = Conc_Typ
9922 Check_Conforming_Parameters
9923 (First
(Parameter_Specifications
(Parent
(Ent
))),
9924 Next
(First
(Parameter_Specifications
(Parent
(E
)))))
9933 end Matching_Dispatching_Subprogram
;
9935 --------------------------------------------
9936 -- Matching_Original_Protected_Subprogram --
9937 --------------------------------------------
9939 function Matching_Original_Protected_Subprogram
9940 (Prot_Typ
: Entity_Id
;
9941 Subp
: Entity_Id
) return Entity_Id
9943 ICF
: constant Boolean :=
9944 Is_Controlling_Formal
(First_Entity
(Subp
));
9948 -- Temporarily decorate the first parameter of Subp as controlling
9949 -- formal, required to invoke Subtype_Conformant.
9951 Set_Is_Controlling_Formal
(First_Entity
(Subp
));
9954 Current_Entity_In_Scope
(Original_Protected_Subprogram
(Subp
));
9956 while Present
(E
) loop
9957 if Scope
(E
) = Scope
(Prot_Typ
)
9958 and then Comes_From_Source
(E
)
9959 and then Ekind
(Subp
) = Ekind
(E
)
9960 and then Present
(First_Entity
(E
))
9961 and then Is_Controlling_Formal
(First_Entity
(E
))
9962 and then Etype
(First_Entity
(E
)) = Prot_Typ
9963 and then Subtype_Conformant
(Subp
, E
,
9964 Skip_Controlling_Formals
=> True)
9966 Set_Is_Controlling_Formal
(First_Entity
(Subp
), ICF
);
9973 Set_Is_Controlling_Formal
(First_Entity
(Subp
), ICF
);
9976 end Matching_Original_Protected_Subprogram
;
9978 -- Start of processing for Has_Matching_Entry_Or_Subprogram
9981 -- Case 1: E is a subprogram whose first formal is a concurrent type
9982 -- defined in the scope of E that has an entry or subprogram whose
9983 -- profile matches E.
9985 if Comes_From_Source
(E
)
9986 and then Is_Subprogram
(E
)
9987 and then Present
(First_Entity
(E
))
9988 and then Is_Concurrent_Record_Type
(Etype
(First_Entity
(E
)))
9991 Scope
(Corresponding_Concurrent_Type
9992 (Etype
(First_Entity
(E
))))
9995 (Matching_Entry_Or_Subprogram
9996 (Corresponding_Concurrent_Type
(Etype
(First_Entity
(E
))),
10000 Matching_Entry_Or_Subprogram
10001 (Corresponding_Concurrent_Type
(Etype
(First_Entity
(E
))),
10006 -- Case 2: E is an internally built dispatching subprogram of a
10007 -- protected type and there is a subprogram defined in the enclosing
10008 -- scope of the protected type that has the original name of E and
10009 -- its profile is conformant with the profile of E. We check the
10010 -- name of the original protected subprogram associated with E since
10011 -- the expander builds dispatching primitives of protected functions
10012 -- and procedures with other names (see Exp_Ch9.Build_Selected_Name).
10014 elsif not Comes_From_Source
(E
)
10015 and then Is_Subprogram
(E
)
10016 and then Present
(First_Entity
(E
))
10017 and then Is_Concurrent_Record_Type
(Etype
(First_Entity
(E
)))
10018 and then Present
(Original_Protected_Subprogram
(E
))
10021 (Matching_Original_Protected_Subprogram
10022 (Corresponding_Concurrent_Type
(Etype
(First_Entity
(E
))),
10025 Report_Conflict
(E
,
10026 Matching_Original_Protected_Subprogram
10027 (Corresponding_Concurrent_Type
(Etype
(First_Entity
(E
))),
10031 -- Case 3: E is an entry of a synchronized type and a matching
10032 -- procedure has been previously defined in the enclosing scope
10033 -- of the synchronized type.
10035 elsif Comes_From_Source
(E
)
10036 and then Ekind
(E
) = E_Entry
10038 Present
(Matching_Dispatching_Subprogram
(Current_Scope
, E
))
10040 Report_Conflict
(E
,
10041 Matching_Dispatching_Subprogram
(Current_Scope
, E
));
10046 end Has_Matching_Entry_Or_Subprogram
;
10048 ----------------------------
10049 -- Is_Private_Declaration --
10050 ----------------------------
10052 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean is
10053 Decl
: constant Node_Id
:= Unit_Declaration_Node
(E
);
10054 Priv_Decls
: List_Id
;
10057 if Is_Package_Or_Generic_Package
(Current_Scope
)
10058 and then In_Private_Part
(Current_Scope
)
10061 Private_Declarations
(Package_Specification
(Current_Scope
));
10063 return In_Package_Body
(Current_Scope
)
10065 (Is_List_Member
(Decl
)
10066 and then List_Containing
(Decl
) = Priv_Decls
)
10067 or else (Nkind
(Parent
(Decl
)) = N_Package_Specification
10069 Is_Compilation_Unit
10070 (Defining_Entity
(Parent
(Decl
)))
10071 and then List_Containing
(Parent
(Parent
(Decl
))) =
10076 end Is_Private_Declaration
;
10078 --------------------------
10079 -- Is_Overriding_Alias --
10080 --------------------------
10082 function Is_Overriding_Alias
10083 (Old_E
: Entity_Id
;
10084 New_E
: Entity_Id
) return Boolean
10086 AO
: constant Entity_Id
:= Alias
(Old_E
);
10087 AN
: constant Entity_Id
:= Alias
(New_E
);
10090 return Scope
(AO
) /= Scope
(AN
)
10091 or else No
(DTC_Entity
(AO
))
10092 or else No
(DTC_Entity
(AN
))
10093 or else DT_Position
(AO
) = DT_Position
(AN
);
10094 end Is_Overriding_Alias
;
10096 ---------------------
10097 -- Report_Conflict --
10098 ---------------------
10100 procedure Report_Conflict
(S
: Entity_Id
; E
: Entity_Id
) is
10102 Error_Msg_Sloc
:= Sloc
(E
);
10104 -- Generate message, with useful additional warning if in generic
10106 if Is_Generic_Unit
(E
) then
10107 Error_Msg_N
("previous generic unit cannot be overloaded", S
);
10108 Error_Msg_N
("\& conflicts with declaration#", S
);
10110 Error_Msg_N
("& conflicts with declaration#", S
);
10112 end Report_Conflict
;
10114 -- Start of processing for New_Overloaded_Entity
10117 -- We need to look for an entity that S may override. This must be a
10118 -- homonym in the current scope, so we look for the first homonym of
10119 -- S in the current scope as the starting point for the search.
10121 E
:= Current_Entity_In_Scope
(S
);
10123 -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
10124 -- They are directly added to the list of primitive operations of
10125 -- Derived_Type, unless this is a rederivation in the private part
10126 -- of an operation that was already derived in the visible part of
10127 -- the current package.
10129 if Ada_Version
>= Ada_2005
10130 and then Present
(Derived_Type
)
10131 and then Present
(Alias
(S
))
10132 and then Is_Dispatching_Operation
(Alias
(S
))
10133 and then Present
(Find_Dispatching_Type
(Alias
(S
)))
10134 and then Is_Interface
(Find_Dispatching_Type
(Alias
(S
)))
10136 -- For private types, when the full-view is processed we propagate to
10137 -- the full view the non-overridden entities whose attribute "alias"
10138 -- references an interface primitive. These entities were added by
10139 -- Derive_Subprograms to ensure that interface primitives are
10142 -- Inside_Freeze_Actions is non zero when S corresponds with an
10143 -- internal entity that links an interface primitive with its
10144 -- covering primitive through attribute Interface_Alias (see
10145 -- Add_Internal_Interface_Entities).
10147 if Inside_Freezing_Actions
= 0
10148 and then Is_Package_Or_Generic_Package
(Current_Scope
)
10149 and then In_Private_Part
(Current_Scope
)
10150 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
10151 and then Nkind
(Parent
(S
)) = N_Full_Type_Declaration
10152 and then Full_View
(Defining_Identifier
(Parent
(E
)))
10153 = Defining_Identifier
(Parent
(S
))
10154 and then Alias
(E
) = Alias
(S
)
10156 Check_Operation_From_Private_View
(S
, E
);
10157 Set_Is_Dispatching_Operation
(S
);
10162 Enter_Overloaded_Entity
(S
);
10163 Check_Dispatching_Operation
(S
, Empty
);
10164 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
10170 -- For synchronized types check conflicts of this entity with previously
10171 -- defined entities.
10173 if Ada_Version
>= Ada_2005
10174 and then Has_Matching_Entry_Or_Subprogram
(S
)
10179 -- If there is no homonym then this is definitely not overriding
10182 Enter_Overloaded_Entity
(S
);
10183 Check_Dispatching_Operation
(S
, Empty
);
10184 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
10186 -- If subprogram has an explicit declaration, check whether it has an
10187 -- overriding indicator.
10189 if Comes_From_Source
(S
) then
10190 Check_Synchronized_Overriding
(S
, Overridden_Subp
);
10192 -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then
10193 -- it may have overridden some hidden inherited primitive. Update
10194 -- Overridden_Subp to avoid spurious errors when checking the
10195 -- overriding indicator.
10197 if Ada_Version
>= Ada_2012
10198 and then No
(Overridden_Subp
)
10199 and then Is_Dispatching_Operation
(S
)
10200 and then Present
(Overridden_Operation
(S
))
10202 Overridden_Subp
:= Overridden_Operation
(S
);
10205 Check_Overriding_Indicator
10206 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
10208 -- The Ghost policy in effect at the point of declaration of a
10209 -- parent subprogram and an overriding subprogram must match
10210 -- (SPARK RM 6.9(17)).
10212 Check_Ghost_Overriding
(S
, Overridden_Subp
);
10215 -- If there is a homonym that is not overloadable, then we have an
10216 -- error, except for the special cases checked explicitly below.
10218 elsif not Is_Overloadable
(E
) then
10220 -- Check for spurious conflict produced by a subprogram that has the
10221 -- same name as that of the enclosing generic package. The conflict
10222 -- occurs within an instance, between the subprogram and the renaming
10223 -- declaration for the package. After the subprogram, the package
10224 -- renaming declaration becomes hidden.
10226 if Ekind
(E
) = E_Package
10227 and then Present
(Renamed_Object
(E
))
10228 and then Renamed_Object
(E
) = Current_Scope
10229 and then Nkind
(Parent
(Renamed_Object
(E
))) =
10230 N_Package_Specification
10231 and then Present
(Generic_Parent
(Parent
(Renamed_Object
(E
))))
10234 Set_Is_Immediately_Visible
(E
, False);
10235 Enter_Overloaded_Entity
(S
);
10236 Set_Homonym
(S
, Homonym
(E
));
10237 Check_Dispatching_Operation
(S
, Empty
);
10238 Check_Overriding_Indicator
(S
, Empty
, Is_Primitive
=> False);
10240 -- If the subprogram is implicit it is hidden by the previous
10241 -- declaration. However if it is dispatching, it must appear in the
10242 -- dispatch table anyway, because it can be dispatched to even if it
10243 -- cannot be called directly.
10245 elsif Present
(Alias
(S
)) and then not Comes_From_Source
(S
) then
10246 Set_Scope
(S
, Current_Scope
);
10248 if Is_Dispatching_Operation
(Alias
(S
)) then
10249 Check_Dispatching_Operation
(S
, Empty
);
10255 Report_Conflict
(S
, E
);
10259 -- E exists and is overloadable
10262 Check_Synchronized_Overriding
(S
, Overridden_Subp
);
10264 -- Loop through E and its homonyms to determine if any of them is
10265 -- the candidate for overriding by S.
10267 while Present
(E
) loop
10269 -- Definitely not interesting if not in the current scope
10271 if Scope
(E
) /= Current_Scope
then
10274 -- A function can overload the name of an abstract state. The
10275 -- state can be viewed as a function with a profile that cannot
10276 -- be matched by anything.
10278 elsif Ekind
(S
) = E_Function
10279 and then Ekind
(E
) = E_Abstract_State
10281 Enter_Overloaded_Entity
(S
);
10284 -- Ada 2012 (AI05-0165): For internally generated bodies of null
10285 -- procedures locate the internally generated spec. We enforce
10286 -- mode conformance since a tagged type may inherit from
10287 -- interfaces several null primitives which differ only in
10288 -- the mode of the formals.
10290 elsif not Comes_From_Source
(S
)
10291 and then Is_Null_Procedure
(S
)
10292 and then not Mode_Conformant
(E
, S
)
10296 -- Check if we have type conformance
10298 elsif Type_Conformant
(E
, S
) then
10300 -- If the old and new entities have the same profile and one
10301 -- is not the body of the other, then this is an error, unless
10302 -- one of them is implicitly declared.
10304 -- There are some cases when both can be implicit, for example
10305 -- when both a literal and a function that overrides it are
10306 -- inherited in a derivation, or when an inherited operation
10307 -- of a tagged full type overrides the inherited operation of
10308 -- a private extension. Ada 83 had a special rule for the
10309 -- literal case. In Ada 95, the later implicit operation hides
10310 -- the former, and the literal is always the former. In the
10311 -- odd case where both are derived operations declared at the
10312 -- same point, both operations should be declared, and in that
10313 -- case we bypass the following test and proceed to the next
10314 -- part. This can only occur for certain obscure cases in
10315 -- instances, when an operation on a type derived from a formal
10316 -- private type does not override a homograph inherited from
10317 -- the actual. In subsequent derivations of such a type, the
10318 -- DT positions of these operations remain distinct, if they
10321 if Present
(Alias
(S
))
10322 and then (No
(Alias
(E
))
10323 or else Comes_From_Source
(E
)
10324 or else Is_Abstract_Subprogram
(S
)
10326 (Is_Dispatching_Operation
(E
)
10327 and then Is_Overriding_Alias
(E
, S
)))
10328 and then Ekind
(E
) /= E_Enumeration_Literal
10330 -- When an derived operation is overloaded it may be due to
10331 -- the fact that the full view of a private extension
10332 -- re-inherits. It has to be dealt with.
10334 if Is_Package_Or_Generic_Package
(Current_Scope
)
10335 and then In_Private_Part
(Current_Scope
)
10337 Check_Operation_From_Private_View
(S
, E
);
10340 -- In any case the implicit operation remains hidden by the
10341 -- existing declaration, which is overriding. Indicate that
10342 -- E overrides the operation from which S is inherited.
10344 if Present
(Alias
(S
)) then
10345 Set_Overridden_Operation
(E
, Alias
(S
));
10346 Inherit_Subprogram_Contract
(E
, Alias
(S
));
10349 Set_Overridden_Operation
(E
, S
);
10350 Inherit_Subprogram_Contract
(E
, S
);
10353 if Comes_From_Source
(E
) then
10354 Check_Overriding_Indicator
(E
, S
, Is_Primitive
=> False);
10356 -- The Ghost policy in effect at the point of declaration
10357 -- of a parent subprogram and an overriding subprogram
10358 -- must match (SPARK RM 6.9(17)).
10360 Check_Ghost_Overriding
(E
, S
);
10365 -- Within an instance, the renaming declarations for actual
10366 -- subprograms may become ambiguous, but they do not hide each
10369 elsif Ekind
(E
) /= E_Entry
10370 and then not Comes_From_Source
(E
)
10371 and then not Is_Generic_Instance
(E
)
10372 and then (Present
(Alias
(E
))
10373 or else Is_Intrinsic_Subprogram
(E
))
10374 and then (not In_Instance
10375 or else No
(Parent
(E
))
10376 or else Nkind
(Unit_Declaration_Node
(E
)) /=
10377 N_Subprogram_Renaming_Declaration
)
10379 -- A subprogram child unit is not allowed to override an
10380 -- inherited subprogram (10.1.1(20)).
10382 if Is_Child_Unit
(S
) then
10384 ("child unit overrides inherited subprogram in parent",
10389 if Is_Non_Overriding_Operation
(E
, S
) then
10390 Enter_Overloaded_Entity
(S
);
10392 if No
(Derived_Type
)
10393 or else Is_Tagged_Type
(Derived_Type
)
10395 Check_Dispatching_Operation
(S
, Empty
);
10401 -- E is a derived operation or an internal operator which
10402 -- is being overridden. Remove E from further visibility.
10403 -- Furthermore, if E is a dispatching operation, it must be
10404 -- replaced in the list of primitive operations of its type
10405 -- (see Override_Dispatching_Operation).
10407 Overridden_Subp
:= E
;
10413 Prev
:= First_Entity
(Current_Scope
);
10414 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
10415 Next_Entity
(Prev
);
10418 -- It is possible for E to be in the current scope and
10419 -- yet not in the entity chain. This can only occur in a
10420 -- generic context where E is an implicit concatenation
10421 -- in the formal part, because in a generic body the
10422 -- entity chain starts with the formals.
10424 -- In GNATprove mode, a wrapper for an operation with
10425 -- axiomatization may be a homonym of another declaration
10426 -- for an actual subprogram (needs refinement ???).
10430 and then GNATprove_Mode
10432 Nkind
(Original_Node
(Unit_Declaration_Node
(S
))) =
10433 N_Subprogram_Renaming_Declaration
10437 pragma Assert
(Chars
(E
) = Name_Op_Concat
);
10442 -- E must be removed both from the entity_list of the
10443 -- current scope, and from the visibility chain.
10445 if Debug_Flag_E
then
10446 Write_Str
("Override implicit operation ");
10447 Write_Int
(Int
(E
));
10451 -- If E is a predefined concatenation, it stands for four
10452 -- different operations. As a result, a single explicit
10453 -- declaration does not hide it. In a possible ambiguous
10454 -- situation, Disambiguate chooses the user-defined op,
10455 -- so it is correct to retain the previous internal one.
10457 if Chars
(E
) /= Name_Op_Concat
10458 or else Ekind
(E
) /= E_Operator
10460 -- For nondispatching derived operations that are
10461 -- overridden by a subprogram declared in the private
10462 -- part of a package, we retain the derived subprogram
10463 -- but mark it as not immediately visible. If the
10464 -- derived operation was declared in the visible part
10465 -- then this ensures that it will still be visible
10466 -- outside the package with the proper signature
10467 -- (calls from outside must also be directed to this
10468 -- version rather than the overriding one, unlike the
10469 -- dispatching case). Calls from inside the package
10470 -- will still resolve to the overriding subprogram
10471 -- since the derived one is marked as not visible
10472 -- within the package.
10474 -- If the private operation is dispatching, we achieve
10475 -- the overriding by keeping the implicit operation
10476 -- but setting its alias to be the overriding one. In
10477 -- this fashion the proper body is executed in all
10478 -- cases, but the original signature is used outside
10481 -- If the overriding is not in the private part, we
10482 -- remove the implicit operation altogether.
10484 if Is_Private_Declaration
(S
) then
10485 if not Is_Dispatching_Operation
(E
) then
10486 Set_Is_Immediately_Visible
(E
, False);
10488 -- Work done in Override_Dispatching_Operation,
10489 -- so nothing else needs to be done here.
10495 -- Find predecessor of E in Homonym chain
10497 if E
= Current_Entity
(E
) then
10500 Prev_Vis
:= Current_Entity
(E
);
10501 while Homonym
(Prev_Vis
) /= E
loop
10502 Prev_Vis
:= Homonym
(Prev_Vis
);
10506 if Prev_Vis
/= Empty
then
10508 -- Skip E in the visibility chain
10510 Set_Homonym
(Prev_Vis
, Homonym
(E
));
10513 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
10516 Set_Next_Entity
(Prev
, Next_Entity
(E
));
10518 if No
(Next_Entity
(Prev
)) then
10519 Set_Last_Entity
(Current_Scope
, Prev
);
10524 Enter_Overloaded_Entity
(S
);
10526 -- For entities generated by Derive_Subprograms the
10527 -- overridden operation is the inherited primitive
10528 -- (which is available through the attribute alias).
10530 if not (Comes_From_Source
(E
))
10531 and then Is_Dispatching_Operation
(E
)
10532 and then Find_Dispatching_Type
(E
) =
10533 Find_Dispatching_Type
(S
)
10534 and then Present
(Alias
(E
))
10535 and then Comes_From_Source
(Alias
(E
))
10537 Set_Overridden_Operation
(S
, Alias
(E
));
10538 Inherit_Subprogram_Contract
(S
, Alias
(E
));
10540 -- Normal case of setting entity as overridden
10542 -- Note: Static_Initialization and Overridden_Operation
10543 -- attributes use the same field in subprogram entities.
10544 -- Static_Initialization is only defined for internal
10545 -- initialization procedures, where Overridden_Operation
10546 -- is irrelevant. Therefore the setting of this attribute
10547 -- must check whether the target is an init_proc.
10549 elsif not Is_Init_Proc
(S
) then
10550 Set_Overridden_Operation
(S
, E
);
10551 Inherit_Subprogram_Contract
(S
, E
);
10554 Check_Overriding_Indicator
(S
, E
, Is_Primitive
=> True);
10556 -- The Ghost policy in effect at the point of declaration
10557 -- of a parent subprogram and an overriding subprogram
10558 -- must match (SPARK RM 6.9(17)).
10560 Check_Ghost_Overriding
(S
, E
);
10562 -- If S is a user-defined subprogram or a null procedure
10563 -- expanded to override an inherited null procedure, or a
10564 -- predefined dispatching primitive then indicate that E
10565 -- overrides the operation from which S is inherited.
10567 if Comes_From_Source
(S
)
10569 (Present
(Parent
(S
))
10571 Nkind
(Parent
(S
)) = N_Procedure_Specification
10573 Null_Present
(Parent
(S
)))
10575 (Present
(Alias
(E
))
10577 Is_Predefined_Dispatching_Operation
(Alias
(E
)))
10579 if Present
(Alias
(E
)) then
10580 Set_Overridden_Operation
(S
, Alias
(E
));
10581 Inherit_Subprogram_Contract
(S
, Alias
(E
));
10585 if Is_Dispatching_Operation
(E
) then
10587 -- An overriding dispatching subprogram inherits the
10588 -- convention of the overridden subprogram (AI-117).
10590 Set_Convention
(S
, Convention
(E
));
10591 Check_Dispatching_Operation
(S
, E
);
10594 Check_Dispatching_Operation
(S
, Empty
);
10597 Check_For_Primitive_Subprogram
10598 (Is_Primitive_Subp
, Is_Overriding
=> True);
10599 goto Check_Inequality
;
10602 -- Apparent redeclarations in instances can occur when two
10603 -- formal types get the same actual type. The subprograms in
10604 -- in the instance are legal, even if not callable from the
10605 -- outside. Calls from within are disambiguated elsewhere.
10606 -- For dispatching operations in the visible part, the usual
10607 -- rules apply, and operations with the same profile are not
10608 -- legal (B830001).
10610 elsif (In_Instance_Visible_Part
10611 and then not Is_Dispatching_Operation
(E
))
10612 or else In_Instance_Not_Visible
10616 -- Here we have a real error (identical profile)
10619 Error_Msg_Sloc
:= Sloc
(E
);
10621 -- Avoid cascaded errors if the entity appears in
10622 -- subsequent calls.
10624 Set_Scope
(S
, Current_Scope
);
10626 -- Generate error, with extra useful warning for the case
10627 -- of a generic instance with no completion.
10629 if Is_Generic_Instance
(S
)
10630 and then not Has_Completion
(E
)
10633 ("instantiation cannot provide body for&", S
);
10634 Error_Msg_N
("\& conflicts with declaration#", S
);
10636 Error_Msg_N
("& conflicts with declaration#", S
);
10643 -- If one subprogram has an access parameter and the other
10644 -- a parameter of an access type, calls to either might be
10645 -- ambiguous. Verify that parameters match except for the
10646 -- access parameter.
10648 if May_Hide_Profile
then
10654 F1
:= First_Formal
(S
);
10655 F2
:= First_Formal
(E
);
10656 while Present
(F1
) and then Present
(F2
) loop
10657 if Is_Access_Type
(Etype
(F1
)) then
10658 if not Is_Access_Type
(Etype
(F2
))
10659 or else not Conforming_Types
10660 (Designated_Type
(Etype
(F1
)),
10661 Designated_Type
(Etype
(F2
)),
10664 May_Hide_Profile
:= False;
10668 not Conforming_Types
10669 (Etype
(F1
), Etype
(F2
), Type_Conformant
)
10671 May_Hide_Profile
:= False;
10678 if May_Hide_Profile
10682 Error_Msg_NE
("calls to& may be ambiguous??", S
, S
);
10691 -- On exit, we know that S is a new entity
10693 Enter_Overloaded_Entity
(S
);
10694 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
10695 Check_Overriding_Indicator
10696 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
10698 -- The Ghost policy in effect at the point of declaration of a parent
10699 -- subprogram and an overriding subprogram must match
10700 -- (SPARK RM 6.9(17)).
10702 Check_Ghost_Overriding
(S
, Overridden_Subp
);
10704 -- Overloading is not allowed in SPARK, except for operators
10706 if Nkind
(S
) /= N_Defining_Operator_Symbol
then
10707 Error_Msg_Sloc
:= Sloc
(Homonym
(S
));
10708 Check_SPARK_05_Restriction
10709 ("overloading not allowed with entity#", S
);
10712 -- If S is a derived operation for an untagged type then by
10713 -- definition it's not a dispatching operation (even if the parent
10714 -- operation was dispatching), so Check_Dispatching_Operation is not
10715 -- called in that case.
10717 if No
(Derived_Type
)
10718 or else Is_Tagged_Type
(Derived_Type
)
10720 Check_Dispatching_Operation
(S
, Empty
);
10724 -- If this is a user-defined equality operator that is not a derived
10725 -- subprogram, create the corresponding inequality. If the operation is
10726 -- dispatching, the expansion is done elsewhere, and we do not create
10727 -- an explicit inequality operation.
10729 <<Check_Inequality
>>
10730 if Chars
(S
) = Name_Op_Eq
10731 and then Etype
(S
) = Standard_Boolean
10732 and then Present
(Parent
(S
))
10733 and then not Is_Dispatching_Operation
(S
)
10735 Make_Inequality_Operator
(S
);
10736 Check_Untagged_Equality
(S
);
10738 end New_Overloaded_Entity
;
10740 ---------------------
10741 -- Process_Formals --
10742 ---------------------
10744 procedure Process_Formals
10746 Related_Nod
: Node_Id
)
10748 function Designates_From_Limited_With
(Typ
: Entity_Id
) return Boolean;
10749 -- Determine whether an access type designates a type coming from a
10752 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean;
10753 -- Check whether the default has a class-wide type. After analysis the
10754 -- default has the type of the formal, so we must also check explicitly
10755 -- for an access attribute.
10757 ----------------------------------
10758 -- Designates_From_Limited_With --
10759 ----------------------------------
10761 function Designates_From_Limited_With
(Typ
: Entity_Id
) return Boolean is
10762 Desig
: Entity_Id
:= Typ
;
10765 if Is_Access_Type
(Desig
) then
10766 Desig
:= Directly_Designated_Type
(Desig
);
10769 if Is_Class_Wide_Type
(Desig
) then
10770 Desig
:= Root_Type
(Desig
);
10774 Ekind
(Desig
) = E_Incomplete_Type
10775 and then From_Limited_With
(Desig
);
10776 end Designates_From_Limited_With
;
10778 ---------------------------
10779 -- Is_Class_Wide_Default --
10780 ---------------------------
10782 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean is
10784 return Is_Class_Wide_Type
(Designated_Type
(Etype
(D
)))
10785 or else (Nkind
(D
) = N_Attribute_Reference
10786 and then Attribute_Name
(D
) = Name_Access
10787 and then Is_Class_Wide_Type
(Etype
(Prefix
(D
))));
10788 end Is_Class_Wide_Default
;
10792 Context
: constant Node_Id
:= Parent
(Parent
(T
));
10794 Formal
: Entity_Id
;
10795 Formal_Type
: Entity_Id
;
10796 Param_Spec
: Node_Id
;
10799 Num_Out_Params
: Nat
:= 0;
10800 First_Out_Param
: Entity_Id
:= Empty
;
10801 -- Used for setting Is_Only_Out_Parameter
10803 -- Start of processing for Process_Formals
10806 -- In order to prevent premature use of the formals in the same formal
10807 -- part, the Ekind is left undefined until all default expressions are
10808 -- analyzed. The Ekind is established in a separate loop at the end.
10810 Param_Spec
:= First
(T
);
10811 while Present
(Param_Spec
) loop
10812 Formal
:= Defining_Identifier
(Param_Spec
);
10813 Set_Never_Set_In_Source
(Formal
, True);
10814 Enter_Name
(Formal
);
10816 -- Case of ordinary parameters
10818 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
10819 Find_Type
(Parameter_Type
(Param_Spec
));
10820 Ptype
:= Parameter_Type
(Param_Spec
);
10822 if Ptype
= Error
then
10826 Formal_Type
:= Entity
(Ptype
);
10828 if Is_Incomplete_Type
(Formal_Type
)
10830 (Is_Class_Wide_Type
(Formal_Type
)
10831 and then Is_Incomplete_Type
(Root_Type
(Formal_Type
)))
10833 -- Ada 2005 (AI-326): Tagged incomplete types allowed in
10834 -- primitive operations, as long as their completion is
10835 -- in the same declarative part. If in the private part
10836 -- this means that the type cannot be a Taft-amendment type.
10837 -- Check is done on package exit. For access to subprograms,
10838 -- the use is legal for Taft-amendment types.
10840 -- Ada 2012: tagged incomplete types are allowed as generic
10841 -- formal types. They do not introduce dependencies and the
10842 -- corresponding generic subprogram does not have a delayed
10843 -- freeze, because it does not need a freeze node. However,
10844 -- it is still the case that untagged incomplete types cannot
10845 -- be Taft-amendment types and must be completed in private
10846 -- part, so the subprogram must appear in the list of private
10847 -- dependents of the type.
10849 if Is_Tagged_Type
(Formal_Type
)
10850 or else (Ada_Version
>= Ada_2012
10851 and then not From_Limited_With
(Formal_Type
)
10852 and then not Is_Generic_Type
(Formal_Type
))
10854 if Ekind
(Scope
(Current_Scope
)) = E_Package
10855 and then not Is_Generic_Type
(Formal_Type
)
10856 and then not Is_Class_Wide_Type
(Formal_Type
)
10859 (Parent
(T
), N_Access_Function_Definition
,
10860 N_Access_Procedure_Definition
)
10862 Append_Elmt
(Current_Scope
,
10863 Private_Dependents
(Base_Type
(Formal_Type
)));
10865 -- Freezing is delayed to ensure that Register_Prim
10866 -- will get called for this operation, which is needed
10867 -- in cases where static dispatch tables aren't built.
10868 -- (Note that the same is done for controlling access
10869 -- parameter cases in function Access_Definition.)
10871 if not Is_Thunk
(Current_Scope
) then
10872 Set_Has_Delayed_Freeze
(Current_Scope
);
10877 elsif not Nkind_In
(Parent
(T
), N_Access_Function_Definition
,
10878 N_Access_Procedure_Definition
)
10880 -- AI05-0151: Tagged incomplete types are allowed in all
10881 -- formal parts. Untagged incomplete types are not allowed
10882 -- in bodies. Limited views of either kind are not allowed
10883 -- if there is no place at which the non-limited view can
10884 -- become available.
10886 -- Incomplete formal untagged types are not allowed in
10887 -- subprogram bodies (but are legal in their declarations).
10888 -- This excludes bodies created for null procedures, which
10889 -- are basic declarations.
10891 if Is_Generic_Type
(Formal_Type
)
10892 and then not Is_Tagged_Type
(Formal_Type
)
10893 and then Nkind
(Parent
(Related_Nod
)) = N_Subprogram_Body
10896 ("invalid use of formal incomplete type", Param_Spec
);
10898 elsif Ada_Version
>= Ada_2012
then
10899 if Is_Tagged_Type
(Formal_Type
)
10900 and then (not From_Limited_With
(Formal_Type
)
10901 or else not In_Package_Body
)
10905 elsif Nkind_In
(Context
, N_Accept_Statement
,
10906 N_Accept_Alternative
,
10908 or else (Nkind
(Context
) = N_Subprogram_Body
10909 and then Comes_From_Source
(Context
))
10912 ("invalid use of untagged incomplete type &",
10913 Ptype
, Formal_Type
);
10918 ("invalid use of incomplete type&",
10919 Param_Spec
, Formal_Type
);
10921 -- Further checks on the legality of incomplete types
10922 -- in formal parts are delayed until the freeze point
10923 -- of the enclosing subprogram or access to subprogram.
10927 elsif Ekind
(Formal_Type
) = E_Void
then
10929 ("premature use of&",
10930 Parameter_Type
(Param_Spec
), Formal_Type
);
10933 -- Ada 2012 (AI-142): Handle aliased parameters
10935 if Ada_Version
>= Ada_2012
10936 and then Aliased_Present
(Param_Spec
)
10938 Set_Is_Aliased
(Formal
);
10941 -- Ada 2005 (AI-231): Create and decorate an internal subtype
10942 -- declaration corresponding to the null-excluding type of the
10943 -- formal in the enclosing scope. Finally, replace the parameter
10944 -- type of the formal with the internal subtype.
10946 if Ada_Version
>= Ada_2005
10947 and then Null_Exclusion_Present
(Param_Spec
)
10949 if not Is_Access_Type
(Formal_Type
) then
10951 ("`NOT NULL` allowed only for an access type", Param_Spec
);
10954 if Can_Never_Be_Null
(Formal_Type
)
10955 and then Comes_From_Source
(Related_Nod
)
10958 ("`NOT NULL` not allowed (& already excludes null)",
10959 Param_Spec
, Formal_Type
);
10963 Create_Null_Excluding_Itype
10965 Related_Nod
=> Related_Nod
,
10966 Scope_Id
=> Scope
(Current_Scope
));
10968 -- If the designated type of the itype is an itype that is
10969 -- not frozen yet, we set the Has_Delayed_Freeze attribute
10970 -- on the access subtype, to prevent order-of-elaboration
10971 -- issues in the backend.
10974 -- type T is access procedure;
10975 -- procedure Op (O : not null T);
10977 if Is_Itype
(Directly_Designated_Type
(Formal_Type
))
10979 not Is_Frozen
(Directly_Designated_Type
(Formal_Type
))
10981 Set_Has_Delayed_Freeze
(Formal_Type
);
10986 -- An access formal type
10990 Access_Definition
(Related_Nod
, Parameter_Type
(Param_Spec
));
10992 -- No need to continue if we already notified errors
10994 if not Present
(Formal_Type
) then
10998 -- Ada 2005 (AI-254)
11001 AD
: constant Node_Id
:=
11002 Access_To_Subprogram_Definition
11003 (Parameter_Type
(Param_Spec
));
11005 if Present
(AD
) and then Protected_Present
(AD
) then
11007 Replace_Anonymous_Access_To_Protected_Subprogram
11013 Set_Etype
(Formal
, Formal_Type
);
11015 -- A formal parameter declared within a Ghost region is automatically
11016 -- Ghost (SPARK RM 6.9(2)).
11018 if Ghost_Mode
> None
then
11019 Set_Is_Ghost_Entity
(Formal
);
11022 -- Deal with default expression if present
11024 Default
:= Expression
(Param_Spec
);
11026 if Present
(Default
) then
11027 Check_SPARK_05_Restriction
11028 ("default expression is not allowed", Default
);
11030 if Out_Present
(Param_Spec
) then
11032 ("default initialization only allowed for IN parameters",
11036 -- Do the special preanalysis of the expression (see section on
11037 -- "Handling of Default Expressions" in the spec of package Sem).
11039 Preanalyze_Spec_Expression
(Default
, Formal_Type
);
11041 -- An access to constant cannot be the default for
11042 -- an access parameter that is an access to variable.
11044 if Ekind
(Formal_Type
) = E_Anonymous_Access_Type
11045 and then not Is_Access_Constant
(Formal_Type
)
11046 and then Is_Access_Type
(Etype
(Default
))
11047 and then Is_Access_Constant
(Etype
(Default
))
11050 ("formal that is access to variable cannot be initialized "
11051 & "with an access-to-constant expression", Default
);
11054 -- Check that the designated type of an access parameter's default
11055 -- is not a class-wide type unless the parameter's designated type
11056 -- is also class-wide.
11058 if Ekind
(Formal_Type
) = E_Anonymous_Access_Type
11059 and then not Designates_From_Limited_With
(Formal_Type
)
11060 and then Is_Class_Wide_Default
(Default
)
11061 and then not Is_Class_Wide_Type
(Designated_Type
(Formal_Type
))
11064 ("access to class-wide expression not allowed here", Default
);
11067 -- Check incorrect use of dynamically tagged expressions
11069 if Is_Tagged_Type
(Formal_Type
) then
11070 Check_Dynamically_Tagged_Expression
11072 Typ
=> Formal_Type
,
11073 Related_Nod
=> Default
);
11077 -- Ada 2005 (AI-231): Static checks
11079 if Ada_Version
>= Ada_2005
11080 and then Is_Access_Type
(Etype
(Formal
))
11081 and then Can_Never_Be_Null
(Etype
(Formal
))
11083 Null_Exclusion_Static_Checks
(Param_Spec
);
11086 -- The following checks are relevant only when SPARK_Mode is on as
11087 -- these are not standard Ada legality rules.
11089 if SPARK_Mode
= On
then
11090 if Ekind_In
(Scope
(Formal
), E_Function
, E_Generic_Function
) then
11092 -- A function cannot have a parameter of mode IN OUT or OUT
11095 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
11097 ("function cannot have parameter of mode `OUT` or "
11098 & "`IN OUT`", Formal
);
11101 -- A procedure cannot have an effectively volatile formal
11102 -- parameter of mode IN because it behaves as a constant
11103 -- (SPARK RM 7.1.3(6)). -- ??? maybe 7.1.3(4)
11105 elsif Ekind
(Scope
(Formal
)) = E_Procedure
11106 and then Ekind
(Formal
) = E_In_Parameter
11107 and then Is_Effectively_Volatile
(Formal
)
11110 ("formal parameter of mode `IN` cannot be volatile", Formal
);
11118 -- If this is the formal part of a function specification, analyze the
11119 -- subtype mark in the context where the formals are visible but not
11120 -- yet usable, and may hide outer homographs.
11122 if Nkind
(Related_Nod
) = N_Function_Specification
then
11123 Analyze_Return_Type
(Related_Nod
);
11126 -- Now set the kind (mode) of each formal
11128 Param_Spec
:= First
(T
);
11129 while Present
(Param_Spec
) loop
11130 Formal
:= Defining_Identifier
(Param_Spec
);
11131 Set_Formal_Mode
(Formal
);
11133 if Ekind
(Formal
) = E_In_Parameter
then
11134 Set_Default_Value
(Formal
, Expression
(Param_Spec
));
11136 if Present
(Expression
(Param_Spec
)) then
11137 Default
:= Expression
(Param_Spec
);
11139 if Is_Scalar_Type
(Etype
(Default
)) then
11140 if Nkind
(Parameter_Type
(Param_Spec
)) /=
11141 N_Access_Definition
11143 Formal_Type
:= Entity
(Parameter_Type
(Param_Spec
));
11147 (Related_Nod
, Parameter_Type
(Param_Spec
));
11150 Apply_Scalar_Range_Check
(Default
, Formal_Type
);
11154 elsif Ekind
(Formal
) = E_Out_Parameter
then
11155 Num_Out_Params
:= Num_Out_Params
+ 1;
11157 if Num_Out_Params
= 1 then
11158 First_Out_Param
:= Formal
;
11161 elsif Ekind
(Formal
) = E_In_Out_Parameter
then
11162 Num_Out_Params
:= Num_Out_Params
+ 1;
11165 -- Skip remaining processing if formal type was in error
11167 if Etype
(Formal
) = Any_Type
or else Error_Posted
(Formal
) then
11168 goto Next_Parameter
;
11171 -- Force call by reference if aliased
11174 Conv
: constant Convention_Id
:= Convention
(Etype
(Formal
));
11176 if Is_Aliased
(Formal
) then
11177 Set_Mechanism
(Formal
, By_Reference
);
11179 -- Warn if user asked this to be passed by copy
11181 if Conv
= Convention_Ada_Pass_By_Copy
then
11183 ("cannot pass aliased parameter & by copy??", Formal
);
11186 -- Force mechanism if type has Convention Ada_Pass_By_Ref/Copy
11188 elsif Conv
= Convention_Ada_Pass_By_Copy
then
11189 Set_Mechanism
(Formal
, By_Copy
);
11191 elsif Conv
= Convention_Ada_Pass_By_Reference
then
11192 Set_Mechanism
(Formal
, By_Reference
);
11200 if Present
(First_Out_Param
) and then Num_Out_Params
= 1 then
11201 Set_Is_Only_Out_Parameter
(First_Out_Param
);
11203 end Process_Formals
;
11205 ----------------------------
11206 -- Reference_Body_Formals --
11207 ----------------------------
11209 procedure Reference_Body_Formals
(Spec
: Entity_Id
; Bod
: Entity_Id
) is
11214 if Error_Posted
(Spec
) then
11218 -- Iterate over both lists. They may be of different lengths if the two
11219 -- specs are not conformant.
11221 Fs
:= First_Formal
(Spec
);
11222 Fb
:= First_Formal
(Bod
);
11223 while Present
(Fs
) and then Present
(Fb
) loop
11224 Generate_Reference
(Fs
, Fb
, 'b');
11226 if Style_Check
then
11227 Style
.Check_Identifier
(Fb
, Fs
);
11230 Set_Spec_Entity
(Fb
, Fs
);
11231 Set_Referenced
(Fs
, False);
11235 end Reference_Body_Formals
;
11237 -------------------------
11238 -- Set_Actual_Subtypes --
11239 -------------------------
11241 procedure Set_Actual_Subtypes
(N
: Node_Id
; Subp
: Entity_Id
) is
11243 Formal
: Entity_Id
;
11245 First_Stmt
: Node_Id
:= Empty
;
11246 AS_Needed
: Boolean;
11249 -- If this is an empty initialization procedure, no need to create
11250 -- actual subtypes (small optimization).
11252 if Ekind
(Subp
) = E_Procedure
and then Is_Null_Init_Proc
(Subp
) then
11256 -- The subtype declarations may freeze the formals. The body generated
11257 -- for an expression function is not a freeze point, so do not emit
11258 -- these declarations (small loss of efficiency in rare cases).
11260 if Nkind
(N
) = N_Subprogram_Body
11261 and then Was_Expression_Function
(N
)
11266 Formal
:= First_Formal
(Subp
);
11267 while Present
(Formal
) loop
11268 T
:= Etype
(Formal
);
11270 -- We never need an actual subtype for a constrained formal
11272 if Is_Constrained
(T
) then
11273 AS_Needed
:= False;
11275 -- If we have unknown discriminants, then we do not need an actual
11276 -- subtype, or more accurately we cannot figure it out. Note that
11277 -- all class-wide types have unknown discriminants.
11279 elsif Has_Unknown_Discriminants
(T
) then
11280 AS_Needed
:= False;
11282 -- At this stage we have an unconstrained type that may need an
11283 -- actual subtype. For sure the actual subtype is needed if we have
11284 -- an unconstrained array type. However, in an instance, the type
11285 -- may appear as a subtype of the full view, while the actual is
11286 -- in fact private (in which case no actual subtype is needed) so
11287 -- check the kind of the base type.
11289 elsif Is_Array_Type
(Base_Type
(T
)) then
11292 -- The only other case needing an actual subtype is an unconstrained
11293 -- record type which is an IN parameter (we cannot generate actual
11294 -- subtypes for the OUT or IN OUT case, since an assignment can
11295 -- change the discriminant values. However we exclude the case of
11296 -- initialization procedures, since discriminants are handled very
11297 -- specially in this context, see the section entitled "Handling of
11298 -- Discriminants" in Einfo.
11300 -- We also exclude the case of Discrim_SO_Functions (functions used
11301 -- in front-end layout mode for size/offset values), since in such
11302 -- functions only discriminants are referenced, and not only are such
11303 -- subtypes not needed, but they cannot always be generated, because
11304 -- of order of elaboration issues.
11306 elsif Is_Record_Type
(T
)
11307 and then Ekind
(Formal
) = E_In_Parameter
11308 and then Chars
(Formal
) /= Name_uInit
11309 and then not Is_Unchecked_Union
(T
)
11310 and then not Is_Discrim_SO_Function
(Subp
)
11314 -- All other cases do not need an actual subtype
11317 AS_Needed
:= False;
11320 -- Generate actual subtypes for unconstrained arrays and
11321 -- unconstrained discriminated records.
11324 if Nkind
(N
) = N_Accept_Statement
then
11326 -- If expansion is active, the formal is replaced by a local
11327 -- variable that renames the corresponding entry of the
11328 -- parameter block, and it is this local variable that may
11329 -- require an actual subtype.
11331 if Expander_Active
then
11332 Decl
:= Build_Actual_Subtype
(T
, Renamed_Object
(Formal
));
11334 Decl
:= Build_Actual_Subtype
(T
, Formal
);
11337 if Present
(Handled_Statement_Sequence
(N
)) then
11339 First
(Statements
(Handled_Statement_Sequence
(N
)));
11340 Prepend
(Decl
, Statements
(Handled_Statement_Sequence
(N
)));
11341 Mark_Rewrite_Insertion
(Decl
);
11343 -- If the accept statement has no body, there will be no
11344 -- reference to the actuals, so no need to compute actual
11351 Decl
:= Build_Actual_Subtype
(T
, Formal
);
11352 Prepend
(Decl
, Declarations
(N
));
11353 Mark_Rewrite_Insertion
(Decl
);
11356 -- The declaration uses the bounds of an existing object, and
11357 -- therefore needs no constraint checks.
11359 Analyze
(Decl
, Suppress
=> All_Checks
);
11360 Set_Is_Actual_Subtype
(Defining_Identifier
(Decl
));
11362 -- We need to freeze manually the generated type when it is
11363 -- inserted anywhere else than in a declarative part.
11365 if Present
(First_Stmt
) then
11366 Insert_List_Before_And_Analyze
(First_Stmt
,
11367 Freeze_Entity
(Defining_Identifier
(Decl
), N
));
11369 -- Ditto if the type has a dynamic predicate, because the
11370 -- generated function will mention the actual subtype. The
11371 -- predicate may come from an explicit aspect of be inherited.
11373 elsif Has_Predicates
(T
) then
11374 Insert_List_Before_And_Analyze
(Decl
,
11375 Freeze_Entity
(Defining_Identifier
(Decl
), N
));
11378 if Nkind
(N
) = N_Accept_Statement
11379 and then Expander_Active
11381 Set_Actual_Subtype
(Renamed_Object
(Formal
),
11382 Defining_Identifier
(Decl
));
11384 Set_Actual_Subtype
(Formal
, Defining_Identifier
(Decl
));
11388 Next_Formal
(Formal
);
11390 end Set_Actual_Subtypes
;
11392 ---------------------
11393 -- Set_Formal_Mode --
11394 ---------------------
11396 procedure Set_Formal_Mode
(Formal_Id
: Entity_Id
) is
11397 Spec
: constant Node_Id
:= Parent
(Formal_Id
);
11398 Id
: constant Entity_Id
:= Scope
(Formal_Id
);
11401 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
11402 -- since we ensure that corresponding actuals are always valid at the
11403 -- point of the call.
11405 if Out_Present
(Spec
) then
11406 if Ekind_In
(Id
, E_Entry
, E_Entry_Family
)
11407 or else Is_Subprogram_Or_Generic_Subprogram
(Id
)
11409 Set_Has_Out_Or_In_Out_Parameter
(Id
, True);
11412 if Ekind_In
(Id
, E_Function
, E_Generic_Function
) then
11414 -- [IN] OUT parameters allowed for functions in Ada 2012
11416 if Ada_Version
>= Ada_2012
then
11418 -- Even in Ada 2012 operators can only have IN parameters
11420 if Is_Operator_Symbol_Name
(Chars
(Scope
(Formal_Id
))) then
11421 Error_Msg_N
("operators can only have IN parameters", Spec
);
11424 if In_Present
(Spec
) then
11425 Set_Ekind
(Formal_Id
, E_In_Out_Parameter
);
11427 Set_Ekind
(Formal_Id
, E_Out_Parameter
);
11430 -- But not in earlier versions of Ada
11433 Error_Msg_N
("functions can only have IN parameters", Spec
);
11434 Set_Ekind
(Formal_Id
, E_In_Parameter
);
11437 elsif In_Present
(Spec
) then
11438 Set_Ekind
(Formal_Id
, E_In_Out_Parameter
);
11441 Set_Ekind
(Formal_Id
, E_Out_Parameter
);
11442 Set_Never_Set_In_Source
(Formal_Id
, True);
11443 Set_Is_True_Constant
(Formal_Id
, False);
11444 Set_Current_Value
(Formal_Id
, Empty
);
11448 Set_Ekind
(Formal_Id
, E_In_Parameter
);
11451 -- Set Is_Known_Non_Null for access parameters since the language
11452 -- guarantees that access parameters are always non-null. We also set
11453 -- Can_Never_Be_Null, since there is no way to change the value.
11455 if Nkind
(Parameter_Type
(Spec
)) = N_Access_Definition
then
11457 -- Ada 2005 (AI-231): In Ada 95, access parameters are always non-
11458 -- null; In Ada 2005, only if then null_exclusion is explicit.
11460 if Ada_Version
< Ada_2005
11461 or else Can_Never_Be_Null
(Etype
(Formal_Id
))
11463 Set_Is_Known_Non_Null
(Formal_Id
);
11464 Set_Can_Never_Be_Null
(Formal_Id
);
11467 -- Ada 2005 (AI-231): Null-exclusion access subtype
11469 elsif Is_Access_Type
(Etype
(Formal_Id
))
11470 and then Can_Never_Be_Null
(Etype
(Formal_Id
))
11472 Set_Is_Known_Non_Null
(Formal_Id
);
11474 -- We can also set Can_Never_Be_Null (thus preventing some junk
11475 -- access checks) for the case of an IN parameter, which cannot
11476 -- be changed, or for an IN OUT parameter, which can be changed but
11477 -- not to a null value. But for an OUT parameter, the initial value
11478 -- passed in can be null, so we can't set this flag in that case.
11480 if Ekind
(Formal_Id
) /= E_Out_Parameter
then
11481 Set_Can_Never_Be_Null
(Formal_Id
);
11485 Set_Mechanism
(Formal_Id
, Default_Mechanism
);
11486 Set_Formal_Validity
(Formal_Id
);
11487 end Set_Formal_Mode
;
11489 -------------------------
11490 -- Set_Formal_Validity --
11491 -------------------------
11493 procedure Set_Formal_Validity
(Formal_Id
: Entity_Id
) is
11495 -- If no validity checking, then we cannot assume anything about the
11496 -- validity of parameters, since we do not know there is any checking
11497 -- of the validity on the call side.
11499 if not Validity_Checks_On
then
11502 -- If validity checking for parameters is enabled, this means we are
11503 -- not supposed to make any assumptions about argument values.
11505 elsif Validity_Check_Parameters
then
11508 -- If we are checking in parameters, we will assume that the caller is
11509 -- also checking parameters, so we can assume the parameter is valid.
11511 elsif Ekind
(Formal_Id
) = E_In_Parameter
11512 and then Validity_Check_In_Params
11514 Set_Is_Known_Valid
(Formal_Id
, True);
11516 -- Similar treatment for IN OUT parameters
11518 elsif Ekind
(Formal_Id
) = E_In_Out_Parameter
11519 and then Validity_Check_In_Out_Params
11521 Set_Is_Known_Valid
(Formal_Id
, True);
11523 end Set_Formal_Validity
;
11525 ------------------------
11526 -- Subtype_Conformant --
11527 ------------------------
11529 function Subtype_Conformant
11530 (New_Id
: Entity_Id
;
11531 Old_Id
: Entity_Id
;
11532 Skip_Controlling_Formals
: Boolean := False) return Boolean
11536 Check_Conformance
(New_Id
, Old_Id
, Subtype_Conformant
, False, Result
,
11537 Skip_Controlling_Formals
=> Skip_Controlling_Formals
);
11539 end Subtype_Conformant
;
11541 ---------------------
11542 -- Type_Conformant --
11543 ---------------------
11545 function Type_Conformant
11546 (New_Id
: Entity_Id
;
11547 Old_Id
: Entity_Id
;
11548 Skip_Controlling_Formals
: Boolean := False) return Boolean
11552 May_Hide_Profile
:= False;
11554 (New_Id
, Old_Id
, Type_Conformant
, False, Result
,
11555 Skip_Controlling_Formals
=> Skip_Controlling_Formals
);
11557 end Type_Conformant
;
11559 -------------------------------
11560 -- Valid_Operator_Definition --
11561 -------------------------------
11563 procedure Valid_Operator_Definition
(Designator
: Entity_Id
) is
11566 Id
: constant Name_Id
:= Chars
(Designator
);
11570 F
:= First_Formal
(Designator
);
11571 while Present
(F
) loop
11574 if Present
(Default_Value
(F
)) then
11576 ("default values not allowed for operator parameters",
11579 -- For function instantiations that are operators, we must check
11580 -- separately that the corresponding generic only has in-parameters.
11581 -- For subprogram declarations this is done in Set_Formal_Mode. Such
11582 -- an error could not arise in earlier versions of the language.
11584 elsif Ekind
(F
) /= E_In_Parameter
then
11585 Error_Msg_N
("operators can only have IN parameters", F
);
11591 -- Verify that user-defined operators have proper number of arguments
11592 -- First case of operators which can only be unary
11594 if Nam_In
(Id
, Name_Op_Not
, Name_Op_Abs
) then
11597 -- Case of operators which can be unary or binary
11599 elsif Nam_In
(Id
, Name_Op_Add
, Name_Op_Subtract
) then
11600 N_OK
:= (N
in 1 .. 2);
11602 -- All other operators can only be binary
11610 ("incorrect number of arguments for operator", Designator
);
11614 and then Base_Type
(Etype
(Designator
)) = Standard_Boolean
11615 and then not Is_Intrinsic_Subprogram
(Designator
)
11618 ("explicit definition of inequality not allowed", Designator
);
11620 end Valid_Operator_Definition
;