1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Expander
; use Expander
;
33 with Exp_Ch6
; use Exp_Ch6
;
34 with Exp_Ch7
; use Exp_Ch7
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Fname
; use Fname
;
38 with Freeze
; use Freeze
;
39 with Itypes
; use Itypes
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Layout
; use Layout
;
42 with Namet
; use Namet
;
44 with Nlists
; use Nlists
;
45 with Nmake
; use Nmake
;
47 with Output
; use Output
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Cat
; use Sem_Cat
;
51 with Sem_Ch3
; use Sem_Ch3
;
52 with Sem_Ch4
; use Sem_Ch4
;
53 with Sem_Ch5
; use Sem_Ch5
;
54 with Sem_Ch8
; use Sem_Ch8
;
55 with Sem_Ch10
; use Sem_Ch10
;
56 with Sem_Ch12
; use Sem_Ch12
;
57 with Sem_Disp
; use Sem_Disp
;
58 with Sem_Dist
; use Sem_Dist
;
59 with Sem_Elim
; use Sem_Elim
;
60 with Sem_Eval
; use Sem_Eval
;
61 with Sem_Mech
; use Sem_Mech
;
62 with Sem_Prag
; use Sem_Prag
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Util
; use Sem_Util
;
65 with Sem_Type
; use Sem_Type
;
66 with Sem_Warn
; use Sem_Warn
;
67 with Sinput
; use Sinput
;
68 with Stand
; use Stand
;
69 with Sinfo
; use Sinfo
;
70 with Sinfo
.CN
; use Sinfo
.CN
;
71 with Snames
; use Snames
;
72 with Stringt
; use Stringt
;
74 with Stylesw
; use Stylesw
;
75 with Tbuild
; use Tbuild
;
76 with Uintp
; use Uintp
;
77 with Urealp
; use Urealp
;
78 with Validsw
; use Validsw
;
80 package body Sem_Ch6
is
82 May_Hide_Profile
: Boolean := False;
83 -- This flag is used to indicate that two formals in two subprograms being
84 -- checked for conformance differ only in that one is an access parameter
85 -- while the other is of a general access type with the same designated
86 -- type. In this case, if the rest of the signatures match, a call to
87 -- either subprogram may be ambiguous, which is worth a warning. The flag
88 -- is set in Compatible_Types, and the warning emitted in
89 -- New_Overloaded_Entity.
91 -----------------------
92 -- Local Subprograms --
93 -----------------------
95 procedure Analyze_Return_Statement
(N
: Node_Id
);
96 -- Common processing for simple_ and extended_return_statements
98 procedure Analyze_Function_Return
(N
: Node_Id
);
99 -- Subsidiary to Analyze_Return_Statement. Called when the return statement
100 -- applies to a [generic] function.
102 procedure Analyze_Return_Type
(N
: Node_Id
);
103 -- Subsidiary to Process_Formals: analyze subtype mark in function
104 -- specification, in a context where the formals are visible and hide
107 procedure Analyze_Generic_Subprogram_Body
(N
: Node_Id
; Gen_Id
: Entity_Id
);
108 -- Analyze a generic subprogram body. N is the body to be analyzed, and
109 -- Gen_Id is the defining entity Id for the corresponding spec.
111 procedure Build_Body_To_Inline
(N
: Node_Id
; Subp
: Entity_Id
);
112 -- If a subprogram has pragma Inline and inlining is active, use generic
113 -- machinery to build an unexpanded body for the subprogram. This body is
114 -- subsequenty used for inline expansions at call sites. If subprogram can
115 -- be inlined (depending on size and nature of local declarations) this
116 -- function returns true. Otherwise subprogram body is treated normally.
117 -- If proper warnings are enabled and the subprogram contains a construct
118 -- that cannot be inlined, the offending construct is flagged accordingly.
120 procedure Check_Conformance
123 Ctype
: Conformance_Type
;
125 Conforms
: out Boolean;
126 Err_Loc
: Node_Id
:= Empty
;
127 Get_Inst
: Boolean := False;
128 Skip_Controlling_Formals
: Boolean := False);
129 -- Given two entities, this procedure checks that the profiles associated
130 -- with these entities meet the conformance criterion given by the third
131 -- parameter. If they conform, Conforms is set True and control returns
132 -- to the caller. If they do not conform, Conforms is set to False, and
133 -- in addition, if Errmsg is True on the call, proper messages are output
134 -- to complain about the conformance failure. If Err_Loc is non_Empty
135 -- the error messages are placed on Err_Loc, if Err_Loc is empty, then
136 -- error messages are placed on the appropriate part of the construct
137 -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance
138 -- against a formal access-to-subprogram type so Get_Instance_Of must
141 procedure Check_Overriding_Indicator
143 Overridden_Subp
: Entity_Id
;
144 Is_Primitive
: Boolean);
145 -- Verify the consistency of an overriding_indicator given for subprogram
146 -- declaration, body, renaming, or instantiation. Overridden_Subp is set
147 -- if the scope where we are introducing the subprogram contains a
148 -- type-conformant subprogram that becomes hidden by the new subprogram.
149 -- Is_Primitive indicates whether the subprogram is primitive.
151 procedure Check_Subprogram_Order
(N
: Node_Id
);
152 -- N is the N_Subprogram_Body node for a subprogram. This routine applies
153 -- the alpha ordering rule for N if this ordering requirement applicable.
155 procedure Check_Returns
159 Proc
: Entity_Id
:= Empty
);
160 -- Called to check for missing return statements in a function body, or for
161 -- returns present in a procedure body which has No_Return set. HSS is the
162 -- handled statement sequence for the subprogram body. This procedure
163 -- checks all flow paths to make sure they either have return (Mode = 'F',
164 -- used for functions) or do not have a return (Mode = 'P', used for
165 -- No_Return procedures). The flag Err is set if there are any control
166 -- paths not explicitly terminated by a return in the function case, and is
167 -- True otherwise. Proc is the entity for the procedure case and is used
168 -- in posting the warning message.
170 procedure Enter_Overloaded_Entity
(S
: Entity_Id
);
171 -- This procedure makes S, a new overloaded entity, into the first visible
172 -- entity with that name.
174 procedure Install_Entity
(E
: Entity_Id
);
175 -- Make single entity visible. Used for generic formals as well
177 procedure Install_Formals
(Id
: Entity_Id
);
178 -- On entry to a subprogram body, make the formals visible. Note that
179 -- simply placing the subprogram on the scope stack is not sufficient:
180 -- the formals must become the current entities for their names.
182 function Is_Non_Overriding_Operation
184 New_E
: Entity_Id
) return Boolean;
185 -- Enforce the rule given in 12.3(18): a private operation in an instance
186 -- overrides an inherited operation only if the corresponding operation
187 -- was overriding in the generic. This can happen for primitive operations
188 -- of types derived (in the generic unit) from formal private or formal
191 procedure Make_Inequality_Operator
(S
: Entity_Id
);
192 -- Create the declaration for an inequality operator that is implicitly
193 -- created by a user-defined equality operator that yields a boolean.
195 procedure May_Need_Actuals
(Fun
: Entity_Id
);
196 -- Flag functions that can be called without parameters, i.e. those that
197 -- have no parameters, or those for which defaults exist for all parameters
199 procedure Reference_Body_Formals
(Spec
: Entity_Id
; Bod
: Entity_Id
);
200 -- If there is a separate spec for a subprogram or generic subprogram, the
201 -- formals of the body are treated as references to the corresponding
202 -- formals of the spec. This reference does not count as an actual use of
203 -- the formal, in order to diagnose formals that are unused in the body.
205 procedure Set_Formal_Validity
(Formal_Id
: Entity_Id
);
206 -- Formal_Id is an formal parameter entity. This procedure deals with
207 -- setting the proper validity status for this entity, which depends
208 -- on the kind of parameter and the validity checking mode.
210 ------------------------------
211 -- Analyze_Return_Statement --
212 ------------------------------
214 procedure Analyze_Return_Statement
(N
: Node_Id
) is
216 pragma Assert
(Nkind
(N
) = N_Simple_Return_Statement
218 Nkind
(N
) = N_Extended_Return_Statement
);
220 Returns_Object
: constant Boolean :=
221 Nkind
(N
) = N_Extended_Return_Statement
223 (Nkind
(N
) = N_Simple_Return_Statement
224 and then Present
(Expression
(N
)));
225 -- True if we're returning something; that is, "return <expression>;"
226 -- or "return Result : T [:= ...]". False for "return;". Used for error
227 -- checking: If Returns_Object is True, N should apply to a function
228 -- body; otherwise N should apply to a procedure body, entry body,
229 -- accept statement, or extended return statement.
231 function Find_What_It_Applies_To
return Entity_Id
;
232 -- Find the entity representing the innermost enclosing body, accept
233 -- statement, or extended return statement. If the result is a callable
234 -- construct or extended return statement, then this will be the value
235 -- of the Return_Applies_To attribute. Otherwise, the program is
236 -- illegal. See RM-6.5(4/2).
238 -----------------------------
239 -- Find_What_It_Applies_To --
240 -----------------------------
242 function Find_What_It_Applies_To
return Entity_Id
is
243 Result
: Entity_Id
:= Empty
;
246 -- Loop outward through the Scope_Stack, skipping blocks and loops
248 for J
in reverse 0 .. Scope_Stack
.Last
loop
249 Result
:= Scope_Stack
.Table
(J
).Entity
;
250 exit when Ekind
(Result
) /= E_Block
and then
251 Ekind
(Result
) /= E_Loop
;
254 pragma Assert
(Present
(Result
));
256 end Find_What_It_Applies_To
;
258 -- Local declarations
260 Scope_Id
: constant Entity_Id
:= Find_What_It_Applies_To
;
261 Kind
: constant Entity_Kind
:= Ekind
(Scope_Id
);
262 Loc
: constant Source_Ptr
:= Sloc
(N
);
263 Stm_Entity
: constant Entity_Id
:=
265 (E_Return_Statement
, Current_Scope
, Loc
, 'R');
267 -- Start of processing for Analyze_Return_Statement
270 Set_Return_Statement_Entity
(N
, Stm_Entity
);
272 Set_Etype
(Stm_Entity
, Standard_Void_Type
);
273 Set_Return_Applies_To
(Stm_Entity
, Scope_Id
);
275 -- Place Return entity on scope stack, to simplify enforcement of 6.5
276 -- (4/2): an inner return statement will apply to this extended return.
278 if Nkind
(N
) = N_Extended_Return_Statement
then
279 Push_Scope
(Stm_Entity
);
282 -- Check that pragma No_Return is obeyed
284 if No_Return
(Scope_Id
) then
285 Error_Msg_N
("RETURN statement not allowed (No_Return)", N
);
288 -- Warn on any unassigned OUT parameters if in procedure
290 if Ekind
(Scope_Id
) = E_Procedure
then
291 Warn_On_Unassigned_Out_Parameter
(N
, Scope_Id
);
294 -- Check that functions return objects, and other things do not
296 if Kind
= E_Function
or else Kind
= E_Generic_Function
then
297 if not Returns_Object
then
298 Error_Msg_N
("missing expression in return from function", N
);
301 elsif Kind
= E_Procedure
or else Kind
= E_Generic_Procedure
then
302 if Returns_Object
then
303 Error_Msg_N
("procedure cannot return value (use function)", N
);
306 elsif Kind
= E_Entry
or else Kind
= E_Entry_Family
then
307 if Returns_Object
then
308 if Is_Protected_Type
(Scope
(Scope_Id
)) then
309 Error_Msg_N
("entry body cannot return value", N
);
311 Error_Msg_N
("accept statement cannot return value", N
);
315 elsif Kind
= E_Return_Statement
then
317 -- We are nested within another return statement, which must be an
318 -- extended_return_statement.
320 if Returns_Object
then
322 ("extended_return_statement cannot return value; " &
323 "use `""RETURN;""`", N
);
327 Error_Msg_N
("illegal context for return statement", N
);
330 if Kind
= E_Function
or else Kind
= E_Generic_Function
then
331 Analyze_Function_Return
(N
);
334 if Nkind
(N
) = N_Extended_Return_Statement
then
338 Kill_Current_Values
(Last_Assignment_Only
=> True);
339 Check_Unreachable_Code
(N
);
340 end Analyze_Return_Statement
;
342 ---------------------------------------------
343 -- Analyze_Abstract_Subprogram_Declaration --
344 ---------------------------------------------
346 procedure Analyze_Abstract_Subprogram_Declaration
(N
: Node_Id
) is
347 Designator
: constant Entity_Id
:=
348 Analyze_Subprogram_Specification
(Specification
(N
));
349 Scop
: constant Entity_Id
:= Current_Scope
;
352 Generate_Definition
(Designator
);
353 Set_Is_Abstract_Subprogram
(Designator
);
354 New_Overloaded_Entity
(Designator
);
355 Check_Delayed_Subprogram
(Designator
);
357 Set_Categorization_From_Scope
(Designator
, Scop
);
359 if Ekind
(Scope
(Designator
)) = E_Protected_Type
then
361 ("abstract subprogram not allowed in protected type", N
);
363 -- Issue a warning if the abstract subprogram is neither a dispatching
364 -- operation nor an operation that overrides an inherited subprogram or
365 -- predefined operator, since this most likely indicates a mistake.
367 elsif Warn_On_Redundant_Constructs
368 and then not Is_Dispatching_Operation
(Designator
)
369 and then not Is_Overriding_Operation
(Designator
)
370 and then (not Is_Operator_Symbol_Name
(Chars
(Designator
))
371 or else Scop
/= Scope
(Etype
(First_Formal
(Designator
))))
374 ("?abstract subprogram is not dispatching or overriding", N
);
377 Generate_Reference_To_Formals
(Designator
);
378 end Analyze_Abstract_Subprogram_Declaration
;
380 ----------------------------------------
381 -- Analyze_Extended_Return_Statement --
382 ----------------------------------------
384 procedure Analyze_Extended_Return_Statement
(N
: Node_Id
) is
386 Analyze_Return_Statement
(N
);
387 end Analyze_Extended_Return_Statement
;
389 ----------------------------
390 -- Analyze_Function_Call --
391 ----------------------------
393 procedure Analyze_Function_Call
(N
: Node_Id
) is
394 P
: constant Node_Id
:= Name
(N
);
395 L
: constant List_Id
:= Parameter_Associations
(N
);
401 -- A call of the form A.B (X) may be an Ada05 call, which is rewritten
402 -- as B (A, X). If the rewriting is successful, the call has been
403 -- analyzed and we just return.
405 if Nkind
(P
) = N_Selected_Component
406 and then Name
(N
) /= P
407 and then Is_Rewrite_Substitution
(N
)
408 and then Present
(Etype
(N
))
413 -- If error analyzing name, then set Any_Type as result type and return
415 if Etype
(P
) = Any_Type
then
416 Set_Etype
(N
, Any_Type
);
420 -- Otherwise analyze the parameters
424 while Present
(Actual
) loop
426 Check_Parameterless_Call
(Actual
);
432 end Analyze_Function_Call
;
434 -----------------------------
435 -- Analyze_Function_Return --
436 -----------------------------
438 procedure Analyze_Function_Return
(N
: Node_Id
) is
439 Loc
: constant Source_Ptr
:= Sloc
(N
);
440 Stm_Entity
: constant Entity_Id
:= Return_Statement_Entity
(N
);
441 Scope_Id
: constant Entity_Id
:= Return_Applies_To
(Stm_Entity
);
443 R_Type
: constant Entity_Id
:= Etype
(Scope_Id
);
444 -- Function result subtype
446 procedure Check_Limited_Return
(Expr
: Node_Id
);
447 -- Check the appropriate (Ada 95 or Ada 2005) rules for returning
448 -- limited types. Used only for simple return statements.
449 -- Expr is the expression returned.
451 procedure Check_Return_Subtype_Indication
(Obj_Decl
: Node_Id
);
452 -- Check that the return_subtype_indication properly matches the result
453 -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
455 --------------------------
456 -- Check_Limited_Return --
457 --------------------------
459 procedure Check_Limited_Return
(Expr
: Node_Id
) is
461 -- Ada 2005 (AI-318-02): Return-by-reference types have been
462 -- removed and replaced by anonymous access results. This is an
463 -- incompatibility with Ada 95. Not clear whether this should be
464 -- enforced yet or perhaps controllable with special switch. ???
466 if Is_Limited_Type
(R_Type
)
467 and then Comes_From_Source
(N
)
468 and then not In_Instance_Body
469 and then not OK_For_Limited_Init_In_05
(Expr
)
473 if Ada_Version
>= Ada_05
474 and then not Debug_Flag_Dot_L
475 and then not GNAT_Mode
478 ("(Ada 2005) cannot copy object of a limited type " &
479 "(RM-2005 6.5(5.5/2))", Expr
);
480 if Is_Inherently_Limited_Type
(R_Type
) then
482 ("\return by reference not permitted in Ada 2005", Expr
);
485 -- Warn in Ada 95 mode, to give folks a heads up about this
488 -- In GNAT mode, this is just a warning, to allow it to be
489 -- evilly turned off. Otherwise it is a real error.
491 elsif Warn_On_Ada_2005_Compatibility
or GNAT_Mode
then
492 if Is_Inherently_Limited_Type
(R_Type
) then
494 ("return by reference not permitted in Ada 2005 " &
495 "(RM-2005 6.5(5.5/2))?", Expr
);
498 ("cannot copy object of a limited type in Ada 2005 " &
499 "(RM-2005 6.5(5.5/2))?", Expr
);
502 -- Ada 95 mode, compatibility warnings disabled
505 return; -- skip continuation messages below
509 ("\consider switching to return of access type", Expr
);
510 Explain_Limited_Type
(R_Type
, Expr
);
512 end Check_Limited_Return
;
514 -------------------------------------
515 -- Check_Return_Subtype_Indication --
516 -------------------------------------
518 procedure Check_Return_Subtype_Indication
(Obj_Decl
: Node_Id
) is
519 Return_Obj
: constant Node_Id
:= Defining_Identifier
(Obj_Decl
);
520 R_Stm_Type
: constant Entity_Id
:= Etype
(Return_Obj
);
521 -- Subtype given in the extended return statement;
522 -- this must match R_Type.
524 Subtype_Ind
: constant Node_Id
:=
525 Object_Definition
(Original_Node
(Obj_Decl
));
527 R_Type_Is_Anon_Access
:
529 Ekind
(R_Type
) = E_Anonymous_Access_Subprogram_Type
531 Ekind
(R_Type
) = E_Anonymous_Access_Protected_Subprogram_Type
533 Ekind
(R_Type
) = E_Anonymous_Access_Type
;
534 -- True if return type of the function is an anonymous access type
535 -- Can't we make Is_Anonymous_Access_Type in einfo ???
537 R_Stm_Type_Is_Anon_Access
:
539 Ekind
(R_Stm_Type
) = E_Anonymous_Access_Subprogram_Type
541 Ekind
(R_Stm_Type
) = E_Anonymous_Access_Protected_Subprogram_Type
543 Ekind
(R_Stm_Type
) = E_Anonymous_Access_Type
;
544 -- True if type of the return object is an anonymous access type
547 -- First, avoid cascade errors:
549 if Error_Posted
(Obj_Decl
) or else Error_Posted
(Subtype_Ind
) then
553 -- "return access T" case; check that the return statement also has
554 -- "access T", and that the subtypes statically match:
556 if R_Type_Is_Anon_Access
then
557 if R_Stm_Type_Is_Anon_Access
then
558 if Base_Type
(Designated_Type
(R_Stm_Type
)) /=
559 Base_Type
(Designated_Type
(R_Type
))
560 or else not Subtypes_Statically_Match
(R_Stm_Type
, R_Type
)
563 ("subtype must statically match function result subtype",
564 Subtype_Mark
(Subtype_Ind
));
568 Error_Msg_N
("must use anonymous access type", Subtype_Ind
);
571 -- Subtype_indication case; check that the types are the same, and
572 -- statically match if appropriate:
574 elsif Base_Type
(R_Stm_Type
) = Base_Type
(R_Type
) then
575 if Is_Constrained
(R_Type
) then
576 if not Subtypes_Statically_Match
(R_Stm_Type
, R_Type
) then
578 ("subtype must statically match function result subtype",
583 -- If the function's result type doesn't match the return object
584 -- entity's type, then we check for the case where the result type
585 -- is class-wide, and allow the declaration if the type of the object
586 -- definition matches the class-wide type. This prevents rejection
587 -- in the case where the object declaration is initialized by a call
588 -- to a build-in-place function with a specific result type and the
589 -- object entity had its type changed to that specific type. (Note
590 -- that the ARG believes that return objects should be allowed to
591 -- have a type covered by a class-wide result type in any case, so
592 -- once that relaxation is made (see AI05-32), the above check for
593 -- type compatibility should be changed to test Covers rather than
594 -- equality, and then the following special test will no longer be
597 elsif Is_Class_Wide_Type
(R_Type
)
599 R_Type
= Etype
(Object_Definition
(Original_Node
(Obj_Decl
)))
605 ("wrong type for return_subtype_indication", Subtype_Ind
);
607 end Check_Return_Subtype_Indication
;
609 ---------------------
610 -- Local Variables --
611 ---------------------
615 -- Start of processing for Analyze_Function_Return
618 Set_Return_Present
(Scope_Id
);
620 if Nkind
(N
) = N_Simple_Return_Statement
then
621 Expr
:= Expression
(N
);
622 Analyze_And_Resolve
(Expr
, R_Type
);
623 Check_Limited_Return
(Expr
);
626 -- Analyze parts specific to extended_return_statement:
629 Obj_Decl
: constant Node_Id
:=
630 Last
(Return_Object_Declarations
(N
));
632 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
635 Expr
:= Expression
(Obj_Decl
);
637 -- Note: The check for OK_For_Limited_Init will happen in
638 -- Analyze_Object_Declaration; we treat it as a normal
639 -- object declaration.
643 Set_Is_Return_Object
(Defining_Identifier
(Obj_Decl
));
644 Check_Return_Subtype_Indication
(Obj_Decl
);
646 if Present
(HSS
) then
649 if Present
(Exception_Handlers
(HSS
)) then
651 -- ???Has_Nested_Block_With_Handler needs to be set.
652 -- Probably by creating an actual N_Block_Statement.
653 -- Probably in Expand.
659 Check_References
(Stm_Entity
);
663 -- Case of Expr present (Etype check defends against previous errors)
666 and then Present
(Etype
(Expr
))
668 -- Apply constraint check. Note that this is done before the implicit
669 -- conversion of the expression done for anonymous access types to
670 -- ensure correct generation of the null-excluding check asssociated
671 -- with null-excluding expressions found in return statements.
673 Apply_Constraint_Check
(Expr
, R_Type
);
675 -- Ada 2005 (AI-318-02): When the result type is an anonymous access
676 -- type, apply an implicit conversion of the expression to that type
677 -- to force appropriate static and run-time accessibility checks.
679 if Ada_Version
>= Ada_05
680 and then Ekind
(R_Type
) = E_Anonymous_Access_Type
682 Rewrite
(Expr
, Convert_To
(R_Type
, Relocate_Node
(Expr
)));
683 Analyze_And_Resolve
(Expr
, R_Type
);
686 if (Is_Class_Wide_Type
(Etype
(Expr
))
687 or else Is_Dynamically_Tagged
(Expr
))
688 and then not Is_Class_Wide_Type
(R_Type
)
691 ("dynamically tagged expression not allowed!", Expr
);
694 -- ??? A real run-time accessibility check is needed in cases
695 -- involving dereferences of access parameters. For now we just
696 -- check the static cases.
698 if (Ada_Version
< Ada_05
or else Debug_Flag_Dot_L
)
699 and then Is_Inherently_Limited_Type
(Etype
(Scope_Id
))
700 and then Object_Access_Level
(Expr
) >
701 Subprogram_Access_Level
(Scope_Id
)
704 Make_Raise_Program_Error
(Loc
,
705 Reason
=> PE_Accessibility_Check_Failed
));
709 ("cannot return a local value by reference?", N
);
711 ("\& will be raised at run time?",
712 N
, Standard_Program_Error
);
716 and then Nkind
(Parent
(Scope_Id
)) = N_Function_Specification
717 and then Null_Exclusion_Present
(Parent
(Scope_Id
))
719 Apply_Compile_Time_Constraint_Error
721 Msg
=> "(Ada 2005) null not allowed for "
722 & "null-excluding return?",
723 Reason
=> CE_Null_Not_Allowed
);
726 end Analyze_Function_Return
;
728 -------------------------------------
729 -- Analyze_Generic_Subprogram_Body --
730 -------------------------------------
732 procedure Analyze_Generic_Subprogram_Body
736 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Id
);
737 Kind
: constant Entity_Kind
:= Ekind
(Gen_Id
);
743 -- Copy body and disable expansion while analyzing the generic For a
744 -- stub, do not copy the stub (which would load the proper body), this
745 -- will be done when the proper body is analyzed.
747 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
748 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
753 Spec
:= Specification
(N
);
755 -- Within the body of the generic, the subprogram is callable, and
756 -- behaves like the corresponding non-generic unit.
758 Body_Id
:= Defining_Entity
(Spec
);
760 if Kind
= E_Generic_Procedure
761 and then Nkind
(Spec
) /= N_Procedure_Specification
763 Error_Msg_N
("invalid body for generic procedure ", Body_Id
);
766 elsif Kind
= E_Generic_Function
767 and then Nkind
(Spec
) /= N_Function_Specification
769 Error_Msg_N
("invalid body for generic function ", Body_Id
);
773 Set_Corresponding_Body
(Gen_Decl
, Body_Id
);
775 if Has_Completion
(Gen_Id
)
776 and then Nkind
(Parent
(N
)) /= N_Subunit
778 Error_Msg_N
("duplicate generic body", N
);
781 Set_Has_Completion
(Gen_Id
);
784 if Nkind
(N
) = N_Subprogram_Body_Stub
then
785 Set_Ekind
(Defining_Entity
(Specification
(N
)), Kind
);
787 Set_Corresponding_Spec
(N
, Gen_Id
);
790 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
791 Set_Cunit_Entity
(Current_Sem_Unit
, Defining_Entity
(N
));
794 -- Make generic parameters immediately visible in the body. They are
795 -- needed to process the formals declarations. Then make the formals
796 -- visible in a separate step.
802 First_Ent
: Entity_Id
;
805 First_Ent
:= First_Entity
(Gen_Id
);
808 while Present
(E
) and then not Is_Formal
(E
) loop
813 Set_Use
(Generic_Formal_Declarations
(Gen_Decl
));
815 -- Now generic formals are visible, and the specification can be
816 -- analyzed, for subsequent conformance check.
818 Body_Id
:= Analyze_Subprogram_Specification
(Spec
);
820 -- Make formal parameters visible
824 -- E is the first formal parameter, we loop through the formals
825 -- installing them so that they will be visible.
827 Set_First_Entity
(Gen_Id
, E
);
828 while Present
(E
) loop
834 -- Visible generic entity is callable within its own body
836 Set_Ekind
(Gen_Id
, Ekind
(Body_Id
));
837 Set_Ekind
(Body_Id
, E_Subprogram_Body
);
838 Set_Convention
(Body_Id
, Convention
(Gen_Id
));
839 Set_Is_Obsolescent
(Body_Id
, Is_Obsolescent
(Gen_Id
));
840 Set_Scope
(Body_Id
, Scope
(Gen_Id
));
841 Check_Fully_Conformant
(Body_Id
, Gen_Id
, Body_Id
);
843 if Nkind
(N
) = N_Subprogram_Body_Stub
then
845 -- No body to analyze, so restore state of generic unit
847 Set_Ekind
(Gen_Id
, Kind
);
848 Set_Ekind
(Body_Id
, Kind
);
850 if Present
(First_Ent
) then
851 Set_First_Entity
(Gen_Id
, First_Ent
);
858 -- If this is a compilation unit, it must be made visible explicitly,
859 -- because the compilation of the declaration, unlike other library
860 -- unit declarations, does not. If it is not a unit, the following
861 -- is redundant but harmless.
863 Set_Is_Immediately_Visible
(Gen_Id
);
864 Reference_Body_Formals
(Gen_Id
, Body_Id
);
866 if Is_Child_Unit
(Gen_Id
) then
867 Generate_Reference
(Gen_Id
, Scope
(Gen_Id
), 'k', False);
870 Set_Actual_Subtypes
(N
, Current_Scope
);
871 Analyze_Declarations
(Declarations
(N
));
873 Analyze
(Handled_Statement_Sequence
(N
));
875 Save_Global_References
(Original_Node
(N
));
877 -- Prior to exiting the scope, include generic formals again (if any
878 -- are present) in the set of local entities.
880 if Present
(First_Ent
) then
881 Set_First_Entity
(Gen_Id
, First_Ent
);
884 Check_References
(Gen_Id
);
887 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Current_Scope
);
889 Check_Subprogram_Order
(N
);
891 -- Outside of its body, unit is generic again
893 Set_Ekind
(Gen_Id
, Kind
);
894 Generate_Reference
(Gen_Id
, Body_Id
, 'b', Set_Ref
=> False);
897 Style
.Check_Identifier
(Body_Id
, Gen_Id
);
900 end Analyze_Generic_Subprogram_Body
;
902 -----------------------------
903 -- Analyze_Operator_Symbol --
904 -----------------------------
906 -- An operator symbol such as "+" or "and" may appear in context where the
907 -- literal denotes an entity name, such as "+"(x, y) or in context when it
908 -- is just a string, as in (conjunction = "or"). In these cases the parser
909 -- generates this node, and the semantics does the disambiguation. Other
910 -- such case are actuals in an instantiation, the generic unit in an
911 -- instantiation, and pragma arguments.
913 procedure Analyze_Operator_Symbol
(N
: Node_Id
) is
914 Par
: constant Node_Id
:= Parent
(N
);
917 if (Nkind
(Par
) = N_Function_Call
and then N
= Name
(Par
))
918 or else Nkind
(Par
) = N_Function_Instantiation
919 or else (Nkind
(Par
) = N_Indexed_Component
and then N
= Prefix
(Par
))
920 or else (Nkind
(Par
) = N_Pragma_Argument_Association
921 and then not Is_Pragma_String_Literal
(Par
))
922 or else Nkind
(Par
) = N_Subprogram_Renaming_Declaration
923 or else (Nkind
(Par
) = N_Attribute_Reference
924 and then Attribute_Name
(Par
) /= Name_Value
)
926 Find_Direct_Name
(N
);
929 Change_Operator_Symbol_To_String_Literal
(N
);
932 end Analyze_Operator_Symbol
;
934 -----------------------------------
935 -- Analyze_Parameter_Association --
936 -----------------------------------
938 procedure Analyze_Parameter_Association
(N
: Node_Id
) is
940 Analyze
(Explicit_Actual_Parameter
(N
));
941 end Analyze_Parameter_Association
;
943 ----------------------------
944 -- Analyze_Procedure_Call --
945 ----------------------------
947 procedure Analyze_Procedure_Call
(N
: Node_Id
) is
948 Loc
: constant Source_Ptr
:= Sloc
(N
);
949 P
: constant Node_Id
:= Name
(N
);
950 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
954 procedure Analyze_Call_And_Resolve
;
955 -- Do Analyze and Resolve calls for procedure call
957 ------------------------------
958 -- Analyze_Call_And_Resolve --
959 ------------------------------
961 procedure Analyze_Call_And_Resolve
is
963 if Nkind
(N
) = N_Procedure_Call_Statement
then
965 Resolve
(N
, Standard_Void_Type
);
969 end Analyze_Call_And_Resolve
;
971 -- Start of processing for Analyze_Procedure_Call
974 -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
975 -- a procedure call or an entry call. The prefix may denote an access
976 -- to subprogram type, in which case an implicit dereference applies.
977 -- If the prefix is an indexed component (without implicit defererence)
978 -- then the construct denotes a call to a member of an entire family.
979 -- If the prefix is a simple name, it may still denote a call to a
980 -- parameterless member of an entry family. Resolution of these various
981 -- interpretations is delicate.
985 -- If this is a call of the form Obj.Op, the call may have been
986 -- analyzed and possibly rewritten into a block, in which case
993 -- If error analyzing prefix, then set Any_Type as result and return
995 if Etype
(P
) = Any_Type
then
996 Set_Etype
(N
, Any_Type
);
1000 -- Otherwise analyze the parameters
1002 if Present
(Actuals
) then
1003 Actual
:= First
(Actuals
);
1005 while Present
(Actual
) loop
1007 Check_Parameterless_Call
(Actual
);
1012 -- Special processing for Elab_Spec and Elab_Body calls
1014 if Nkind
(P
) = N_Attribute_Reference
1015 and then (Attribute_Name
(P
) = Name_Elab_Spec
1016 or else Attribute_Name
(P
) = Name_Elab_Body
)
1018 if Present
(Actuals
) then
1020 ("no parameters allowed for this call", First
(Actuals
));
1024 Set_Etype
(N
, Standard_Void_Type
);
1027 elsif Is_Entity_Name
(P
)
1028 and then Is_Record_Type
(Etype
(Entity
(P
)))
1029 and then Remote_AST_I_Dereference
(P
)
1033 elsif Is_Entity_Name
(P
)
1034 and then Ekind
(Entity
(P
)) /= E_Entry_Family
1036 if Is_Access_Type
(Etype
(P
))
1037 and then Ekind
(Designated_Type
(Etype
(P
))) = E_Subprogram_Type
1038 and then No
(Actuals
)
1039 and then Comes_From_Source
(N
)
1041 Error_Msg_N
("missing explicit dereference in call", N
);
1044 Analyze_Call_And_Resolve
;
1046 -- If the prefix is the simple name of an entry family, this is
1047 -- a parameterless call from within the task body itself.
1049 elsif Is_Entity_Name
(P
)
1050 and then Nkind
(P
) = N_Identifier
1051 and then Ekind
(Entity
(P
)) = E_Entry_Family
1052 and then Present
(Actuals
)
1053 and then No
(Next
(First
(Actuals
)))
1055 -- Can be call to parameterless entry family. What appears to be the
1056 -- sole argument is in fact the entry index. Rewrite prefix of node
1057 -- accordingly. Source representation is unchanged by this
1061 Make_Indexed_Component
(Loc
,
1063 Make_Selected_Component
(Loc
,
1064 Prefix
=> New_Occurrence_Of
(Scope
(Entity
(P
)), Loc
),
1065 Selector_Name
=> New_Occurrence_Of
(Entity
(P
), Loc
)),
1066 Expressions
=> Actuals
);
1067 Set_Name
(N
, New_N
);
1068 Set_Etype
(New_N
, Standard_Void_Type
);
1069 Set_Parameter_Associations
(N
, No_List
);
1070 Analyze_Call_And_Resolve
;
1072 elsif Nkind
(P
) = N_Explicit_Dereference
then
1073 if Ekind
(Etype
(P
)) = E_Subprogram_Type
then
1074 Analyze_Call_And_Resolve
;
1076 Error_Msg_N
("expect access to procedure in call", P
);
1079 -- The name can be a selected component or an indexed component that
1080 -- yields an access to subprogram. Such a prefix is legal if the call
1081 -- has parameter associations.
1083 elsif Is_Access_Type
(Etype
(P
))
1084 and then Ekind
(Designated_Type
(Etype
(P
))) = E_Subprogram_Type
1086 if Present
(Actuals
) then
1087 Analyze_Call_And_Resolve
;
1089 Error_Msg_N
("missing explicit dereference in call ", N
);
1092 -- If not an access to subprogram, then the prefix must resolve to the
1093 -- name of an entry, entry family, or protected operation.
1095 -- For the case of a simple entry call, P is a selected component where
1096 -- the prefix is the task and the selector name is the entry. A call to
1097 -- a protected procedure will have the same syntax. If the protected
1098 -- object contains overloaded operations, the entity may appear as a
1099 -- function, the context will select the operation whose type is Void.
1101 elsif Nkind
(P
) = N_Selected_Component
1102 and then (Ekind
(Entity
(Selector_Name
(P
))) = E_Entry
1104 Ekind
(Entity
(Selector_Name
(P
))) = E_Procedure
1106 Ekind
(Entity
(Selector_Name
(P
))) = E_Function
)
1108 Analyze_Call_And_Resolve
;
1110 elsif Nkind
(P
) = N_Selected_Component
1111 and then Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
1112 and then Present
(Actuals
)
1113 and then No
(Next
(First
(Actuals
)))
1115 -- Can be call to parameterless entry family. What appears to be the
1116 -- sole argument is in fact the entry index. Rewrite prefix of node
1117 -- accordingly. Source representation is unchanged by this
1121 Make_Indexed_Component
(Loc
,
1122 Prefix
=> New_Copy
(P
),
1123 Expressions
=> Actuals
);
1124 Set_Name
(N
, New_N
);
1125 Set_Etype
(New_N
, Standard_Void_Type
);
1126 Set_Parameter_Associations
(N
, No_List
);
1127 Analyze_Call_And_Resolve
;
1129 -- For the case of a reference to an element of an entry family, P is
1130 -- an indexed component whose prefix is a selected component (task and
1131 -- entry family), and whose index is the entry family index.
1133 elsif Nkind
(P
) = N_Indexed_Component
1134 and then Nkind
(Prefix
(P
)) = N_Selected_Component
1135 and then Ekind
(Entity
(Selector_Name
(Prefix
(P
)))) = E_Entry_Family
1137 Analyze_Call_And_Resolve
;
1139 -- If the prefix is the name of an entry family, it is a call from
1140 -- within the task body itself.
1142 elsif Nkind
(P
) = N_Indexed_Component
1143 and then Nkind
(Prefix
(P
)) = N_Identifier
1144 and then Ekind
(Entity
(Prefix
(P
))) = E_Entry_Family
1147 Make_Selected_Component
(Loc
,
1148 Prefix
=> New_Occurrence_Of
(Scope
(Entity
(Prefix
(P
))), Loc
),
1149 Selector_Name
=> New_Occurrence_Of
(Entity
(Prefix
(P
)), Loc
));
1150 Rewrite
(Prefix
(P
), New_N
);
1152 Analyze_Call_And_Resolve
;
1154 -- Anything else is an error
1157 Error_Msg_N
("invalid procedure or entry call", N
);
1159 end Analyze_Procedure_Call
;
1161 -------------------------------------
1162 -- Analyze_Simple_Return_Statement --
1163 -------------------------------------
1165 procedure Analyze_Simple_Return_Statement
(N
: Node_Id
) is
1167 if Present
(Expression
(N
)) then
1168 Mark_Coextensions
(N
, Expression
(N
));
1171 Analyze_Return_Statement
(N
);
1172 end Analyze_Simple_Return_Statement
;
1174 -------------------------
1175 -- Analyze_Return_Type --
1176 -------------------------
1178 procedure Analyze_Return_Type
(N
: Node_Id
) is
1179 Designator
: constant Entity_Id
:= Defining_Entity
(N
);
1180 Typ
: Entity_Id
:= Empty
;
1183 -- Normal case where result definition does not indicate an error
1185 if Result_Definition
(N
) /= Error
then
1186 if Nkind
(Result_Definition
(N
)) = N_Access_Definition
then
1187 Typ
:= Access_Definition
(N
, Result_Definition
(N
));
1188 Set_Parent
(Typ
, Result_Definition
(N
));
1189 Set_Is_Local_Anonymous_Access
(Typ
);
1190 Set_Etype
(Designator
, Typ
);
1192 -- Subtype_Mark case
1195 Find_Type
(Result_Definition
(N
));
1196 Typ
:= Entity
(Result_Definition
(N
));
1197 Set_Etype
(Designator
, Typ
);
1199 if Ekind
(Typ
) = E_Incomplete_Type
1200 and then Is_Value_Type
(Typ
)
1204 elsif Ekind
(Typ
) = E_Incomplete_Type
1205 or else (Is_Class_Wide_Type
(Typ
)
1207 Ekind
(Root_Type
(Typ
)) = E_Incomplete_Type
)
1210 ("invalid use of incomplete type", Result_Definition
(N
));
1214 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1216 Null_Exclusion_Static_Checks
(N
);
1218 -- Case where result definition does indicate an error
1221 Set_Etype
(Designator
, Any_Type
);
1223 end Analyze_Return_Type
;
1225 -----------------------------
1226 -- Analyze_Subprogram_Body --
1227 -----------------------------
1229 -- This procedure is called for regular subprogram bodies, generic bodies,
1230 -- and for subprogram stubs of both kinds. In the case of stubs, only the
1231 -- specification matters, and is used to create a proper declaration for
1232 -- the subprogram, or to perform conformance checks.
1234 procedure Analyze_Subprogram_Body
(N
: Node_Id
) is
1235 Loc
: constant Source_Ptr
:= Sloc
(N
);
1236 Body_Spec
: constant Node_Id
:= Specification
(N
);
1237 Body_Id
: Entity_Id
:= Defining_Entity
(Body_Spec
);
1238 Prev_Id
: constant Entity_Id
:= Current_Entity_In_Scope
(Body_Id
);
1239 Body_Deleted
: constant Boolean := False;
1242 Spec_Id
: Entity_Id
;
1243 Spec_Decl
: Node_Id
:= Empty
;
1244 Last_Formal
: Entity_Id
:= Empty
;
1245 Conformant
: Boolean;
1246 Missing_Ret
: Boolean;
1249 procedure Check_Anonymous_Return
;
1250 -- (Ada 2005): if a function returns an access type that denotes a task,
1251 -- or a type that contains tasks, we must create a master entity for
1252 -- the anonymous type, which typically will be used in an allocator
1253 -- in the body of the function.
1255 procedure Check_Inline_Pragma
(Spec
: in out Node_Id
);
1256 -- Look ahead to recognize a pragma that may appear after the body.
1257 -- If there is a previous spec, check that it appears in the same
1258 -- declarative part. If the pragma is Inline_Always, perform inlining
1259 -- unconditionally, otherwise only if Front_End_Inlining is requested.
1260 -- If the body acts as a spec, and inlining is required, we create a
1261 -- subprogram declaration for it, in order to attach the body to inline.
1263 procedure Copy_Parameter_List
(Plist
: List_Id
);
1264 -- Utility to create a parameter profile for a new subprogram spec,
1265 -- when the subprogram has a body that acts as spec. This is done for
1266 -- some cases of inlining, and for private protected ops.
1268 procedure Verify_Overriding_Indicator
;
1269 -- If there was a previous spec, the entity has been entered in the
1270 -- current scope previously. If the body itself carries an overriding
1271 -- indicator, check that it is consistent with the known status of the
1274 ----------------------------
1275 -- Check_Anonymous_Return --
1276 ----------------------------
1278 procedure Check_Anonymous_Return
is
1283 if Present
(Spec_Id
) then
1289 if Ekind
(Scop
) = E_Function
1290 and then Ekind
(Etype
(Scop
)) = E_Anonymous_Access_Type
1291 and then Has_Task
(Designated_Type
(Etype
(Scop
)))
1292 and then Expander_Active
1295 Make_Object_Declaration
(Loc
,
1296 Defining_Identifier
=>
1297 Make_Defining_Identifier
(Loc
, Name_uMaster
),
1298 Constant_Present
=> True,
1299 Object_Definition
=>
1300 New_Reference_To
(RTE
(RE_Master_Id
), Loc
),
1302 Make_Explicit_Dereference
(Loc
,
1303 New_Reference_To
(RTE
(RE_Current_Master
), Loc
)));
1305 if Present
(Declarations
(N
)) then
1306 Prepend
(Decl
, Declarations
(N
));
1308 Set_Declarations
(N
, New_List
(Decl
));
1311 Set_Master_Id
(Etype
(Scop
), Defining_Identifier
(Decl
));
1312 Set_Has_Master_Entity
(Scop
);
1314 end Check_Anonymous_Return
;
1316 -------------------------
1317 -- Check_Inline_Pragma --
1318 -------------------------
1320 procedure Check_Inline_Pragma
(Spec
: in out Node_Id
) is
1325 if not Expander_Active
then
1329 if Is_List_Member
(N
)
1330 and then Present
(Next
(N
))
1331 and then Nkind
(Next
(N
)) = N_Pragma
1335 if Nkind
(Prag
) = N_Pragma
1337 (Get_Pragma_Id
(Chars
(Prag
)) = Pragma_Inline_Always
1340 and then Get_Pragma_Id
(Chars
(Prag
)) = Pragma_Inline
))
1343 (Expression
(First
(Pragma_Argument_Associations
(Prag
))))
1354 if Present
(Prag
) then
1355 if Present
(Spec_Id
) then
1356 if List_Containing
(N
) =
1357 List_Containing
(Unit_Declaration_Node
(Spec_Id
))
1363 -- Create a subprogram declaration, to make treatment uniform
1366 Subp
: constant Entity_Id
:=
1367 Make_Defining_Identifier
(Loc
, Chars
(Body_Id
));
1368 Decl
: constant Node_Id
:=
1369 Make_Subprogram_Declaration
(Loc
,
1370 Specification
=> New_Copy_Tree
(Specification
(N
)));
1372 Set_Defining_Unit_Name
(Specification
(Decl
), Subp
);
1374 if Present
(First_Formal
(Body_Id
)) then
1376 Copy_Parameter_List
(Plist
);
1377 Set_Parameter_Specifications
1378 (Specification
(Decl
), Plist
);
1381 Insert_Before
(N
, Decl
);
1384 Set_Has_Pragma_Inline
(Subp
);
1386 if Get_Pragma_Id
(Chars
(Prag
)) = Pragma_Inline_Always
then
1387 Set_Is_Inlined
(Subp
);
1388 Set_Next_Rep_Item
(Prag
, First_Rep_Item
(Subp
));
1389 Set_First_Rep_Item
(Subp
, Prag
);
1396 end Check_Inline_Pragma
;
1398 -------------------------
1399 -- Copy_Parameter_List --
1400 -------------------------
1402 procedure Copy_Parameter_List
(Plist
: List_Id
) is
1406 Formal
:= First_Formal
(Body_Id
);
1408 while Present
(Formal
) loop
1410 (Make_Parameter_Specification
(Loc
,
1411 Defining_Identifier
=>
1412 Make_Defining_Identifier
(Sloc
(Formal
),
1413 Chars
=> Chars
(Formal
)),
1414 In_Present
=> In_Present
(Parent
(Formal
)),
1415 Out_Present
=> Out_Present
(Parent
(Formal
)),
1417 New_Reference_To
(Etype
(Formal
), Loc
),
1419 New_Copy_Tree
(Expression
(Parent
(Formal
)))),
1422 Next_Formal
(Formal
);
1424 end Copy_Parameter_List
;
1426 ---------------------------------
1427 -- Verify_Overriding_Indicator --
1428 ---------------------------------
1430 procedure Verify_Overriding_Indicator
is
1432 if Must_Override
(Body_Spec
)
1433 and then not Is_Overriding_Operation
(Spec_Id
)
1436 ("subprogram& is not overriding", Body_Spec
, Spec_Id
);
1438 elsif Must_Not_Override
(Body_Spec
) then
1439 if Is_Overriding_Operation
(Spec_Id
) then
1441 ("subprogram& overrides inherited operation",
1442 Body_Spec
, Spec_Id
);
1444 -- If this is not a primitive operation the overriding indicator
1445 -- is altogether illegal.
1447 elsif not Is_Primitive
(Spec_Id
) then
1448 Error_Msg_N
("overriding indicator only allowed " &
1449 "if subprogram is primitive",
1453 end Verify_Overriding_Indicator
;
1455 -- Start of processing for Analyze_Subprogram_Body
1458 if Debug_Flag_C
then
1459 Write_Str
("==== Compiling subprogram body ");
1460 Write_Name
(Chars
(Body_Id
));
1461 Write_Str
(" from ");
1462 Write_Location
(Loc
);
1466 Trace_Scope
(N
, Body_Id
, " Analyze subprogram");
1468 -- Generic subprograms are handled separately. They always have a
1469 -- generic specification. Determine whether current scope has a
1470 -- previous declaration.
1472 -- If the subprogram body is defined within an instance of the same
1473 -- name, the instance appears as a package renaming, and will be hidden
1474 -- within the subprogram.
1476 if Present
(Prev_Id
)
1477 and then not Is_Overloadable
(Prev_Id
)
1478 and then (Nkind
(Parent
(Prev_Id
)) /= N_Package_Renaming_Declaration
1479 or else Comes_From_Source
(Prev_Id
))
1481 if Is_Generic_Subprogram
(Prev_Id
) then
1483 Set_Is_Compilation_Unit
(Body_Id
, Is_Compilation_Unit
(Spec_Id
));
1484 Set_Is_Child_Unit
(Body_Id
, Is_Child_Unit
(Spec_Id
));
1486 Analyze_Generic_Subprogram_Body
(N
, Spec_Id
);
1490 -- Previous entity conflicts with subprogram name. Attempting to
1491 -- enter name will post error.
1493 Enter_Name
(Body_Id
);
1497 -- Non-generic case, find the subprogram declaration, if one was seen,
1498 -- or enter new overloaded entity in the current scope. If the
1499 -- Current_Entity is the Body_Id itself, the unit is being analyzed as
1500 -- part of the context of one of its subunits. No need to redo the
1503 elsif Prev_Id
= Body_Id
1504 and then Has_Completion
(Body_Id
)
1509 Body_Id
:= Analyze_Subprogram_Specification
(Body_Spec
);
1511 if Nkind
(N
) = N_Subprogram_Body_Stub
1512 or else No
(Corresponding_Spec
(N
))
1514 Spec_Id
:= Find_Corresponding_Spec
(N
);
1516 -- If this is a duplicate body, no point in analyzing it
1518 if Error_Posted
(N
) then
1522 -- A subprogram body should cause freezing of its own declaration,
1523 -- but if there was no previous explicit declaration, then the
1524 -- subprogram will get frozen too late (there may be code within
1525 -- the body that depends on the subprogram having been frozen,
1526 -- such as uses of extra formals), so we force it to be frozen
1527 -- here. Same holds if the body and the spec are compilation
1530 if No
(Spec_Id
) then
1531 Freeze_Before
(N
, Body_Id
);
1533 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
1534 Freeze_Before
(N
, Spec_Id
);
1537 Spec_Id
:= Corresponding_Spec
(N
);
1541 -- Do not inline any subprogram that contains nested subprograms, since
1542 -- the backend inlining circuit seems to generate uninitialized
1543 -- references in this case. We know this happens in the case of front
1544 -- end ZCX support, but it also appears it can happen in other cases as
1545 -- well. The backend often rejects attempts to inline in the case of
1546 -- nested procedures anyway, so little if anything is lost by this.
1547 -- Note that this is test is for the benefit of the back-end. There is
1548 -- a separate test for front-end inlining that also rejects nested
1551 -- Do not do this test if errors have been detected, because in some
1552 -- error cases, this code blows up, and we don't need it anyway if
1553 -- there have been errors, since we won't get to the linker anyway.
1555 if Comes_From_Source
(Body_Id
)
1556 and then Serious_Errors_Detected
= 0
1560 P_Ent
:= Scope
(P_Ent
);
1561 exit when No
(P_Ent
) or else P_Ent
= Standard_Standard
;
1563 if Is_Subprogram
(P_Ent
) then
1564 Set_Is_Inlined
(P_Ent
, False);
1566 if Comes_From_Source
(P_Ent
)
1567 and then Has_Pragma_Inline
(P_Ent
)
1570 ("cannot inline& (nested subprogram)?",
1577 Check_Inline_Pragma
(Spec_Id
);
1579 -- Case of fully private operation in the body of the protected type.
1580 -- We must create a declaration for the subprogram, in order to attach
1581 -- the protected subprogram that will be used in internal calls.
1584 and then Comes_From_Source
(N
)
1585 and then Is_Protected_Type
(Current_Scope
)
1594 Formal
:= First_Formal
(Body_Id
);
1596 -- The protected operation always has at least one formal, namely
1597 -- the object itself, but it is only placed in the parameter list
1598 -- if expansion is enabled.
1601 or else Expander_Active
1609 Copy_Parameter_List
(Plist
);
1611 if Nkind
(Body_Spec
) = N_Procedure_Specification
then
1613 Make_Procedure_Specification
(Loc
,
1614 Defining_Unit_Name
=>
1615 Make_Defining_Identifier
(Sloc
(Body_Id
),
1616 Chars
=> Chars
(Body_Id
)),
1617 Parameter_Specifications
=> Plist
);
1620 Make_Function_Specification
(Loc
,
1621 Defining_Unit_Name
=>
1622 Make_Defining_Identifier
(Sloc
(Body_Id
),
1623 Chars
=> Chars
(Body_Id
)),
1624 Parameter_Specifications
=> Plist
,
1625 Result_Definition
=>
1626 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
1630 Make_Subprogram_Declaration
(Loc
,
1631 Specification
=> New_Spec
);
1632 Insert_Before
(N
, Decl
);
1633 Spec_Id
:= Defining_Unit_Name
(New_Spec
);
1635 -- Indicate that the entity comes from source, to ensure that
1636 -- cross-reference information is properly generated. The body
1637 -- itself is rewritten during expansion, and the body entity will
1638 -- not appear in calls to the operation.
1640 Set_Comes_From_Source
(Spec_Id
, True);
1642 Set_Has_Completion
(Spec_Id
);
1643 Set_Convention
(Spec_Id
, Convention_Protected
);
1646 elsif Present
(Spec_Id
) then
1647 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
1648 Verify_Overriding_Indicator
;
1650 -- In general, the spec will be frozen when we start analyzing the
1651 -- body. However, for internally generated operations, such as
1652 -- wrapper functions for inherited operations with controlling
1653 -- results, the spec may not have been frozen by the time we
1654 -- expand the freeze actions that include the bodies. In particular,
1655 -- extra formals for accessibility or for return-in-place may need
1656 -- to be generated. Freeze nodes, if any, are inserted before the
1659 if not Is_Frozen
(Spec_Id
)
1660 and then Expander_Active
1662 -- Force the generation of its freezing node to ensure proper
1663 -- management of access types in the backend.
1665 -- This is definitely needed for some cases, but it is not clear
1666 -- why, to be investigated further???
1668 Set_Has_Delayed_Freeze
(Spec_Id
);
1669 Insert_Actions
(N
, Freeze_Entity
(Spec_Id
, Loc
));
1673 -- Place subprogram on scope stack, and make formals visible. If there
1674 -- is a spec, the visible entity remains that of the spec.
1676 if Present
(Spec_Id
) then
1677 Generate_Reference
(Spec_Id
, Body_Id
, 'b', Set_Ref
=> False);
1679 if Is_Child_Unit
(Spec_Id
) then
1680 Generate_Reference
(Spec_Id
, Scope
(Spec_Id
), 'k', False);
1684 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
1687 Set_Is_Compilation_Unit
(Body_Id
, Is_Compilation_Unit
(Spec_Id
));
1688 Set_Is_Child_Unit
(Body_Id
, Is_Child_Unit
(Spec_Id
));
1690 if Is_Abstract_Subprogram
(Spec_Id
) then
1691 Error_Msg_N
("an abstract subprogram cannot have a body", N
);
1694 Set_Convention
(Body_Id
, Convention
(Spec_Id
));
1695 Set_Has_Completion
(Spec_Id
);
1697 if Is_Protected_Type
(Scope
(Spec_Id
)) then
1698 Set_Privals_Chain
(Spec_Id
, New_Elmt_List
);
1701 -- If this is a body generated for a renaming, do not check for
1702 -- full conformance. The check is redundant, because the spec of
1703 -- the body is a copy of the spec in the renaming declaration,
1704 -- and the test can lead to spurious errors on nested defaults.
1706 if Present
(Spec_Decl
)
1707 and then not Comes_From_Source
(N
)
1709 (Nkind
(Original_Node
(Spec_Decl
)) =
1710 N_Subprogram_Renaming_Declaration
1711 or else (Present
(Corresponding_Body
(Spec_Decl
))
1713 Nkind
(Unit_Declaration_Node
1714 (Corresponding_Body
(Spec_Decl
))) =
1715 N_Subprogram_Renaming_Declaration
))
1721 Fully_Conformant
, True, Conformant
, Body_Id
);
1724 -- If the body is not fully conformant, we have to decide if we
1725 -- should analyze it or not. If it has a really messed up profile
1726 -- then we probably should not analyze it, since we will get too
1727 -- many bogus messages.
1729 -- Our decision is to go ahead in the non-fully conformant case
1730 -- only if it is at least mode conformant with the spec. Note
1731 -- that the call to Check_Fully_Conformant has issued the proper
1732 -- error messages to complain about the lack of conformance.
1735 and then not Mode_Conformant
(Body_Id
, Spec_Id
)
1741 if Spec_Id
/= Body_Id
then
1742 Reference_Body_Formals
(Spec_Id
, Body_Id
);
1745 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
1746 Set_Corresponding_Spec
(N
, Spec_Id
);
1748 -- Ada 2005 (AI-345): If the operation is a primitive operation
1749 -- of a concurrent type, the type of the first parameter has been
1750 -- replaced with the corresponding record, which is the proper
1751 -- run-time structure to use. However, within the body there may
1752 -- be uses of the formals that depend on primitive operations
1753 -- of the type (in particular calls in prefixed form) for which
1754 -- we need the original concurrent type. The operation may have
1755 -- several controlling formals, so the replacement must be done
1758 if Comes_From_Source
(Spec_Id
)
1759 and then Present
(First_Entity
(Spec_Id
))
1760 and then Ekind
(Etype
(First_Entity
(Spec_Id
))) = E_Record_Type
1761 and then Is_Tagged_Type
(Etype
(First_Entity
(Spec_Id
)))
1763 Present
(Abstract_Interfaces
(Etype
(First_Entity
(Spec_Id
))))
1766 (Corresponding_Concurrent_Type
1767 (Etype
(First_Entity
(Spec_Id
))))
1770 Typ
: constant Entity_Id
:= Etype
(First_Entity
(Spec_Id
));
1774 Form
:= First_Formal
(Spec_Id
);
1775 while Present
(Form
) loop
1776 if Etype
(Form
) = Typ
then
1777 Set_Etype
(Form
, Corresponding_Concurrent_Type
(Typ
));
1785 -- Now make the formals visible, and place subprogram
1788 Install_Formals
(Spec_Id
);
1789 Last_Formal
:= Last_Entity
(Spec_Id
);
1790 Push_Scope
(Spec_Id
);
1792 -- Make sure that the subprogram is immediately visible. For
1793 -- child units that have no separate spec this is indispensable.
1794 -- Otherwise it is safe albeit redundant.
1796 Set_Is_Immediately_Visible
(Spec_Id
);
1799 Set_Corresponding_Body
(Unit_Declaration_Node
(Spec_Id
), Body_Id
);
1800 Set_Ekind
(Body_Id
, E_Subprogram_Body
);
1801 Set_Scope
(Body_Id
, Scope
(Spec_Id
));
1802 Set_Is_Obsolescent
(Body_Id
, Is_Obsolescent
(Spec_Id
));
1804 -- Case of subprogram body with no previous spec
1808 and then Comes_From_Source
(Body_Id
)
1809 and then not Suppress_Style_Checks
(Body_Id
)
1810 and then not In_Instance
1812 Style
.Body_With_No_Spec
(N
);
1815 New_Overloaded_Entity
(Body_Id
);
1817 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
1818 Set_Acts_As_Spec
(N
);
1819 Generate_Definition
(Body_Id
);
1821 (Body_Id
, Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
1822 Generate_Reference_To_Formals
(Body_Id
);
1823 Install_Formals
(Body_Id
);
1824 Push_Scope
(Body_Id
);
1828 -- Ada 2005 (AI-251): Check wrong placement of abstract interface
1829 -- primitives, and update anonymous access returns with limited views.
1831 if Ada_Version
>= Ada_05
1832 and then Comes_From_Source
(N
)
1840 -- Check the type of the formals
1842 E
:= First_Entity
(Body_Id
);
1843 while Present
(E
) loop
1846 if Is_Access_Type
(Etyp
) then
1847 Etyp
:= Directly_Designated_Type
(Etyp
);
1850 if not Is_Class_Wide_Type
(Etyp
)
1851 and then Is_Interface
(Etyp
)
1853 Error_Msg_Name_1
:= Chars
(Defining_Entity
(N
));
1855 ("(Ada 2005) abstract interface primitives must be" &
1856 " defined in package specs", N
);
1863 -- In case of functions, check the type of the result
1865 if Ekind
(Body_Id
) = E_Function
then
1866 Etyp
:= Etype
(Body_Id
);
1868 if Is_Access_Type
(Etyp
) then
1869 Etyp
:= Directly_Designated_Type
(Etyp
);
1872 if not Is_Class_Wide_Type
(Etyp
)
1873 and then Is_Interface
(Etyp
)
1875 Error_Msg_Name_1
:= Chars
(Defining_Entity
(N
));
1877 ("(Ada 2005) abstract interface primitives must be" &
1878 " defined in package specs", N
);
1882 -- If the return type is an anonymous access type whose
1883 -- designated type is the limited view of a class-wide type
1884 -- and the non-limited view is available. update the return
1885 -- type accordingly.
1887 Rtyp
:= Etype
(Current_Scope
);
1889 if Ekind
(Rtyp
) = E_Anonymous_Access_Type
then
1890 Etyp
:= Directly_Designated_Type
(Rtyp
);
1892 if Is_Class_Wide_Type
(Etyp
)
1893 and then From_With_Type
(Etyp
)
1895 Set_Directly_Designated_Type
1896 (Etype
(Current_Scope
), Available_View
(Etyp
));
1902 -- If this is the proper body of a stub, we must verify that the stub
1903 -- conforms to the body, and to the previous spec if one was present.
1904 -- we know already that the body conforms to that spec. This test is
1905 -- only required for subprograms that come from source.
1907 if Nkind
(Parent
(N
)) = N_Subunit
1908 and then Comes_From_Source
(N
)
1909 and then not Error_Posted
(Body_Id
)
1910 and then Nkind
(Corresponding_Stub
(Parent
(N
))) =
1911 N_Subprogram_Body_Stub
1914 Old_Id
: constant Entity_Id
:=
1916 (Specification
(Corresponding_Stub
(Parent
(N
))));
1918 Conformant
: Boolean := False;
1921 if No
(Spec_Id
) then
1922 Check_Fully_Conformant
(Body_Id
, Old_Id
);
1926 (Body_Id
, Old_Id
, Fully_Conformant
, False, Conformant
);
1928 if not Conformant
then
1930 -- The stub was taken to be a new declaration. Indicate
1931 -- that it lacks a body.
1933 Set_Has_Completion
(Old_Id
, False);
1939 Set_Has_Completion
(Body_Id
);
1940 Check_Eliminated
(Body_Id
);
1942 if Nkind
(N
) = N_Subprogram_Body_Stub
then
1945 elsif Present
(Spec_Id
)
1946 and then Expander_Active
1948 (Is_Always_Inlined
(Spec_Id
)
1949 or else (Has_Pragma_Inline
(Spec_Id
) and Front_End_Inlining
))
1951 Build_Body_To_Inline
(N
, Spec_Id
);
1954 -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
1955 -- if its specification we have to install the private withed units.
1957 if Is_Compilation_Unit
(Body_Id
)
1958 and then Scope
(Body_Id
) = Standard_Standard
1960 Install_Private_With_Clauses
(Body_Id
);
1963 Check_Anonymous_Return
;
1965 -- Set the Protected_Formal field of each extra formal of the protected
1966 -- subprogram to reference the corresponding extra formal of the
1967 -- subprogram that implements it. For regular formals this occurs when
1968 -- the protected subprogram's declaration is expanded, but the extra
1969 -- formals don't get created until the subprogram is frozen. We need to
1970 -- do this before analyzing the protected subprogram's body so that any
1971 -- references to the original subprogram's extra formals will be changed
1972 -- refer to the implementing subprogram's formals (see Expand_Formal).
1974 if Present
(Spec_Id
)
1975 and then Is_Protected_Type
(Scope
(Spec_Id
))
1976 and then Present
(Protected_Body_Subprogram
(Spec_Id
))
1979 Impl_Subp
: constant Entity_Id
:=
1980 Protected_Body_Subprogram
(Spec_Id
);
1981 Prot_Ext_Formal
: Entity_Id
:= Extra_Formals
(Spec_Id
);
1982 Impl_Ext_Formal
: Entity_Id
:= Extra_Formals
(Impl_Subp
);
1984 while Present
(Prot_Ext_Formal
) loop
1985 pragma Assert
(Present
(Impl_Ext_Formal
));
1987 Set_Protected_Formal
(Prot_Ext_Formal
, Impl_Ext_Formal
);
1989 Next_Formal_With_Extras
(Prot_Ext_Formal
);
1990 Next_Formal_With_Extras
(Impl_Ext_Formal
);
1995 -- Now we can go on to analyze the body
1997 HSS
:= Handled_Statement_Sequence
(N
);
1998 Set_Actual_Subtypes
(N
, Current_Scope
);
1999 Analyze_Declarations
(Declarations
(N
));
2002 Process_End_Label
(HSS
, 't', Current_Scope
);
2004 Check_Subprogram_Order
(N
);
2005 Set_Analyzed
(Body_Id
);
2007 -- If we have a separate spec, then the analysis of the declarations
2008 -- caused the entities in the body to be chained to the spec id, but
2009 -- we want them chained to the body id. Only the formal parameters
2010 -- end up chained to the spec id in this case.
2012 if Present
(Spec_Id
) then
2014 -- We must conform to the categorization of our spec
2016 Validate_Categorization_Dependency
(N
, Spec_Id
);
2018 -- And if this is a child unit, the parent units must conform
2020 if Is_Child_Unit
(Spec_Id
) then
2021 Validate_Categorization_Dependency
2022 (Unit_Declaration_Node
(Spec_Id
), Spec_Id
);
2025 if Present
(Last_Formal
) then
2027 (Last_Entity
(Body_Id
), Next_Entity
(Last_Formal
));
2028 Set_Next_Entity
(Last_Formal
, Empty
);
2029 Set_Last_Entity
(Body_Id
, Last_Entity
(Spec_Id
));
2030 Set_Last_Entity
(Spec_Id
, Last_Formal
);
2033 Set_First_Entity
(Body_Id
, First_Entity
(Spec_Id
));
2034 Set_Last_Entity
(Body_Id
, Last_Entity
(Spec_Id
));
2035 Set_First_Entity
(Spec_Id
, Empty
);
2036 Set_Last_Entity
(Spec_Id
, Empty
);
2040 -- If function, check return statements
2042 if Nkind
(Body_Spec
) = N_Function_Specification
then
2047 if Present
(Spec_Id
) then
2053 if Return_Present
(Id
) then
2054 Check_Returns
(HSS
, 'F', Missing_Ret
);
2057 Set_Has_Missing_Return
(Id
);
2060 elsif not Is_Machine_Code_Subprogram
(Id
)
2061 and then not Body_Deleted
2063 Error_Msg_N
("missing RETURN statement in function body", N
);
2067 -- If procedure with No_Return, check returns
2069 elsif Nkind
(Body_Spec
) = N_Procedure_Specification
2070 and then Present
(Spec_Id
)
2071 and then No_Return
(Spec_Id
)
2073 Check_Returns
(HSS
, 'P', Missing_Ret
, Spec_Id
);
2076 -- Now we are going to check for variables that are never modified in
2077 -- the body of the procedure. We omit these checks if the first
2078 -- statement of the procedure raises an exception. In particular this
2079 -- deals with the common idiom of a stubbed function, which might
2080 -- appear as something like
2082 -- function F (A : Integer) return Some_Type;
2085 -- raise Program_Error;
2089 -- Here the purpose of X is simply to satisfy the (annoying)
2090 -- requirement in Ada that there be at least one return, and we
2091 -- certainly do not want to go posting warnings on X that it is not
2095 Stm
: Node_Id
:= First
(Statements
(HSS
));
2098 -- Skip initial labels (for one thing this occurs when we are in
2099 -- front end ZCX mode, but in any case it is irrelevant), and also
2100 -- initial Push_xxx_Error_Label nodes, which are also irrelevant.
2102 while Nkind
(Stm
) = N_Label
2103 or else Nkind
(Stm
) in N_Push_xxx_Label
2108 -- Do the test on the original statement before expansion
2111 Ostm
: constant Node_Id
:= Original_Node
(Stm
);
2114 -- If explicit raise statement, return with no checks
2116 if Nkind
(Ostm
) = N_Raise_Statement
then
2119 -- Check for explicit call cases which likely raise an exception
2121 elsif Nkind
(Ostm
) = N_Procedure_Call_Statement
then
2122 if Is_Entity_Name
(Name
(Ostm
)) then
2124 Ent
: constant Entity_Id
:= Entity
(Name
(Ostm
));
2127 -- If the procedure is marked No_Return, then likely it
2128 -- raises an exception, but in any case it is not coming
2129 -- back here, so no need to check beyond the call.
2131 if Ekind
(Ent
) = E_Procedure
2132 and then No_Return
(Ent
)
2136 -- If the procedure name is Raise_Exception, then also
2137 -- assume that it raises an exception. The main target
2138 -- here is Ada.Exceptions.Raise_Exception, but this name
2139 -- is pretty evocative in any context! Note that the
2140 -- procedure in Ada.Exceptions is not marked No_Return
2141 -- because of the annoying case of the null exception Id.
2143 elsif Chars
(Ent
) = Name_Raise_Exception
then
2152 -- Check for variables that are never modified
2158 -- If there is a separate spec, then transfer Never_Set_In_Source
2159 -- flags from out parameters to the corresponding entities in the
2160 -- body. The reason we do that is we want to post error flags on
2161 -- the body entities, not the spec entities.
2163 if Present
(Spec_Id
) then
2164 E1
:= First_Entity
(Spec_Id
);
2165 while Present
(E1
) loop
2166 if Ekind
(E1
) = E_Out_Parameter
then
2167 E2
:= First_Entity
(Body_Id
);
2168 while Present
(E2
) loop
2169 exit when Chars
(E1
) = Chars
(E2
);
2173 if Present
(E2
) then
2174 Set_Never_Set_In_Source
(E2
, Never_Set_In_Source
(E1
));
2182 -- Check references in body unless it was deleted. Note that the
2183 -- check of Body_Deleted here is not just for efficiency, it is
2184 -- necessary to avoid junk warnings on formal parameters.
2186 if not Body_Deleted
then
2187 Check_References
(Body_Id
);
2190 end Analyze_Subprogram_Body
;
2192 ------------------------------------
2193 -- Analyze_Subprogram_Declaration --
2194 ------------------------------------
2196 procedure Analyze_Subprogram_Declaration
(N
: Node_Id
) is
2197 Designator
: constant Entity_Id
:=
2198 Analyze_Subprogram_Specification
(Specification
(N
));
2199 Scop
: constant Entity_Id
:= Current_Scope
;
2201 -- Start of processing for Analyze_Subprogram_Declaration
2204 Generate_Definition
(Designator
);
2206 -- Check for RCI unit subprogram declarations for illegal inlined
2207 -- subprograms and subprograms having access parameter or limited
2208 -- parameter without Read and Write attributes (RM E.2.3(12-13)).
2210 Validate_RCI_Subprogram_Declaration
(N
);
2214 Defining_Entity
(N
),
2215 " Analyze subprogram spec. ");
2217 if Debug_Flag_C
then
2218 Write_Str
("==== Compiling subprogram spec ");
2219 Write_Name
(Chars
(Designator
));
2220 Write_Str
(" from ");
2221 Write_Location
(Sloc
(N
));
2225 New_Overloaded_Entity
(Designator
);
2226 Check_Delayed_Subprogram
(Designator
);
2228 -- Ada 2005 (AI-251): Abstract interface primitives must be abstract
2231 if Ada_Version
>= Ada_05
2232 and then Comes_From_Source
(N
)
2233 and then Is_Dispatching_Operation
(Designator
)
2240 if Has_Controlling_Result
(Designator
) then
2241 Etyp
:= Etype
(Designator
);
2244 E
:= First_Entity
(Designator
);
2246 and then Is_Formal
(E
)
2247 and then not Is_Controlling_Formal
(E
)
2255 if Is_Access_Type
(Etyp
) then
2256 Etyp
:= Directly_Designated_Type
(Etyp
);
2259 if Is_Interface
(Etyp
)
2260 and then not Is_Abstract_Subprogram
(Designator
)
2261 and then not (Ekind
(Designator
) = E_Procedure
2262 and then Null_Present
(Specification
(N
)))
2264 Error_Msg_Name_1
:= Chars
(Defining_Entity
(N
));
2266 ("(Ada 2005) interface subprogram % must be abstract or null",
2272 -- What is the following code for, it used to be
2274 -- ??? Set_Suppress_Elaboration_Checks
2275 -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
2277 -- The following seems equivalent, but a bit dubious
2279 if Elaboration_Checks_Suppressed
(Designator
) then
2280 Set_Kill_Elaboration_Checks
(Designator
);
2283 if Scop
/= Standard_Standard
2284 and then not Is_Child_Unit
(Designator
)
2286 Set_Categorization_From_Scope
(Designator
, Scop
);
2288 -- For a compilation unit, check for library-unit pragmas
2290 Push_Scope
(Designator
);
2291 Set_Categorization_From_Pragmas
(N
);
2292 Validate_Categorization_Dependency
(N
, Designator
);
2296 -- For a compilation unit, set body required. This flag will only be
2297 -- reset if a valid Import or Interface pragma is processed later on.
2299 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
2300 Set_Body_Required
(Parent
(N
), True);
2302 if Ada_Version
>= Ada_05
2303 and then Nkind
(Specification
(N
)) = N_Procedure_Specification
2304 and then Null_Present
(Specification
(N
))
2307 ("null procedure cannot be declared at library level", N
);
2311 Generate_Reference_To_Formals
(Designator
);
2312 Check_Eliminated
(Designator
);
2314 -- Ada 2005: if procedure is declared with "is null" qualifier,
2315 -- it requires no body.
2317 if Nkind
(Specification
(N
)) = N_Procedure_Specification
2318 and then Null_Present
(Specification
(N
))
2320 Set_Has_Completion
(Designator
);
2321 Set_Is_Inlined
(Designator
);
2323 if Is_Protected_Type
(Current_Scope
) then
2325 ("protected operation cannot be a null procedure", N
);
2328 end Analyze_Subprogram_Declaration
;
2330 --------------------------------------
2331 -- Analyze_Subprogram_Specification --
2332 --------------------------------------
2334 -- Reminder: N here really is a subprogram specification (not a subprogram
2335 -- declaration). This procedure is called to analyze the specification in
2336 -- both subprogram bodies and subprogram declarations (specs).
2338 function Analyze_Subprogram_Specification
(N
: Node_Id
) return Entity_Id
is
2339 Designator
: constant Entity_Id
:= Defining_Entity
(N
);
2341 Formal_Typ
: Entity_Id
;
2342 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
2344 -- Start of processing for Analyze_Subprogram_Specification
2347 Generate_Definition
(Designator
);
2349 if Nkind
(N
) = N_Function_Specification
then
2350 Set_Ekind
(Designator
, E_Function
);
2351 Set_Mechanism
(Designator
, Default_Mechanism
);
2354 Set_Ekind
(Designator
, E_Procedure
);
2355 Set_Etype
(Designator
, Standard_Void_Type
);
2358 -- Introduce new scope for analysis of the formals and of the
2361 Set_Scope
(Designator
, Current_Scope
);
2363 if Present
(Formals
) then
2364 Push_Scope
(Designator
);
2365 Process_Formals
(Formals
, N
);
2367 -- Ada 2005 (AI-345): Allow the overriding of interface primitives
2368 -- by subprograms which belong to a concurrent type implementing an
2369 -- interface. Set the parameter type of each controlling formal to
2370 -- the corresponding record type.
2372 if Ada_Version
>= Ada_05
then
2373 Formal
:= First_Formal
(Designator
);
2374 while Present
(Formal
) loop
2375 Formal_Typ
:= Etype
(Formal
);
2377 if (Ekind
(Formal_Typ
) = E_Protected_Type
2378 or else Ekind
(Formal_Typ
) = E_Task_Type
)
2379 and then Present
(Corresponding_Record_Type
(Formal_Typ
))
2380 and then Present
(Abstract_Interfaces
2381 (Corresponding_Record_Type
(Formal_Typ
)))
2384 Corresponding_Record_Type
(Formal_Typ
));
2387 Formal
:= Next_Formal
(Formal
);
2393 elsif Nkind
(N
) = N_Function_Specification
then
2394 Analyze_Return_Type
(N
);
2397 if Nkind
(N
) = N_Function_Specification
then
2398 if Nkind
(Designator
) = N_Defining_Operator_Symbol
then
2399 Valid_Operator_Definition
(Designator
);
2402 May_Need_Actuals
(Designator
);
2404 -- Ada 2005 (AI-251): In case of primitives associated with abstract
2405 -- interface types the following error message will be reported later
2406 -- (see Analyze_Subprogram_Declaration).
2408 if Is_Abstract_Type
(Etype
(Designator
))
2409 and then not Is_Interface
(Etype
(Designator
))
2410 and then Nkind
(Parent
(N
))
2411 /= N_Abstract_Subprogram_Declaration
2412 and then (Nkind
(Parent
(N
)))
2413 /= N_Formal_Abstract_Subprogram_Declaration
2414 and then (Nkind
(Parent
(N
)) /= N_Subprogram_Renaming_Declaration
2415 or else not Is_Entity_Name
(Name
(Parent
(N
)))
2416 or else not Is_Abstract_Subprogram
2417 (Entity
(Name
(Parent
(N
)))))
2420 ("function that returns abstract type must be abstract", N
);
2425 end Analyze_Subprogram_Specification
;
2427 --------------------------
2428 -- Build_Body_To_Inline --
2429 --------------------------
2431 procedure Build_Body_To_Inline
(N
: Node_Id
; Subp
: Entity_Id
) is
2432 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
2433 Original_Body
: Node_Id
;
2434 Body_To_Analyze
: Node_Id
;
2435 Max_Size
: constant := 10;
2436 Stat_Count
: Integer := 0;
2438 function Has_Excluded_Declaration
(Decls
: List_Id
) return Boolean;
2439 -- Check for declarations that make inlining not worthwhile
2441 function Has_Excluded_Statement
(Stats
: List_Id
) return Boolean;
2442 -- Check for statements that make inlining not worthwhile: any tasking
2443 -- statement, nested at any level. Keep track of total number of
2444 -- elementary statements, as a measure of acceptable size.
2446 function Has_Pending_Instantiation
return Boolean;
2447 -- If some enclosing body contains instantiations that appear before the
2448 -- corresponding generic body, the enclosing body has a freeze node so
2449 -- that it can be elaborated after the generic itself. This might
2450 -- conflict with subsequent inlinings, so that it is unsafe to try to
2451 -- inline in such a case.
2453 function Has_Single_Return
return Boolean;
2454 -- In general we cannot inline functions that return unconstrained type.
2455 -- However, we can handle such functions if all return statements return
2456 -- a local variable that is the only declaration in the body of the
2457 -- function. In that case the call can be replaced by that local
2458 -- variable as is done for other inlined calls.
2460 procedure Remove_Pragmas
;
2461 -- A pragma Unreferenced that mentions a formal parameter has no meaning
2462 -- when the body is inlined and the formals are rewritten. Remove it
2463 -- from body to inline. The analysis of the non-inlined body will handle
2464 -- the pragma properly.
2466 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean;
2467 -- If the body of the subprogram includes a call that returns an
2468 -- unconstrained type, the secondary stack is involved, and it
2469 -- is not worth inlining.
2471 ------------------------------
2472 -- Has_Excluded_Declaration --
2473 ------------------------------
2475 function Has_Excluded_Declaration
(Decls
: List_Id
) return Boolean is
2478 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean;
2479 -- Nested subprograms make a given body ineligible for inlining, but
2480 -- we make an exception for instantiations of unchecked conversion.
2481 -- The body has not been analyzed yet, so check the name, and verify
2482 -- that the visible entity with that name is the predefined unit.
2484 -----------------------------
2485 -- Is_Unchecked_Conversion --
2486 -----------------------------
2488 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean is
2489 Id
: constant Node_Id
:= Name
(D
);
2493 if Nkind
(Id
) = N_Identifier
2494 and then Chars
(Id
) = Name_Unchecked_Conversion
2496 Conv
:= Current_Entity
(Id
);
2498 elsif (Nkind
(Id
) = N_Selected_Component
2499 or else Nkind
(Id
) = N_Expanded_Name
)
2500 and then Chars
(Selector_Name
(Id
)) = Name_Unchecked_Conversion
2502 Conv
:= Current_Entity
(Selector_Name
(Id
));
2508 return Present
(Conv
)
2509 and then Is_Predefined_File_Name
2510 (Unit_File_Name
(Get_Source_Unit
(Conv
)))
2511 and then Is_Intrinsic_Subprogram
(Conv
);
2512 end Is_Unchecked_Conversion
;
2514 -- Start of processing for Has_Excluded_Declaration
2519 while Present
(D
) loop
2520 if (Nkind
(D
) = N_Function_Instantiation
2521 and then not Is_Unchecked_Conversion
(D
))
2522 or else Nkind
(D
) = N_Protected_Type_Declaration
2523 or else Nkind
(D
) = N_Package_Declaration
2524 or else Nkind
(D
) = N_Package_Instantiation
2525 or else Nkind
(D
) = N_Subprogram_Body
2526 or else Nkind
(D
) = N_Procedure_Instantiation
2527 or else Nkind
(D
) = N_Task_Type_Declaration
2530 ("cannot inline & (non-allowed declaration)?", D
, Subp
);
2538 end Has_Excluded_Declaration
;
2540 ----------------------------
2541 -- Has_Excluded_Statement --
2542 ----------------------------
2544 function Has_Excluded_Statement
(Stats
: List_Id
) return Boolean is
2550 while Present
(S
) loop
2551 Stat_Count
:= Stat_Count
+ 1;
2553 if Nkind
(S
) = N_Abort_Statement
2554 or else Nkind
(S
) = N_Asynchronous_Select
2555 or else Nkind
(S
) = N_Conditional_Entry_Call
2556 or else Nkind
(S
) = N_Delay_Relative_Statement
2557 or else Nkind
(S
) = N_Delay_Until_Statement
2558 or else Nkind
(S
) = N_Selective_Accept
2559 or else Nkind
(S
) = N_Timed_Entry_Call
2562 ("cannot inline & (non-allowed statement)?", S
, Subp
);
2565 elsif Nkind
(S
) = N_Block_Statement
then
2566 if Present
(Declarations
(S
))
2567 and then Has_Excluded_Declaration
(Declarations
(S
))
2571 elsif Present
(Handled_Statement_Sequence
(S
))
2574 (Exception_Handlers
(Handled_Statement_Sequence
(S
)))
2576 Has_Excluded_Statement
2577 (Statements
(Handled_Statement_Sequence
(S
))))
2582 elsif Nkind
(S
) = N_Case_Statement
then
2583 E
:= First
(Alternatives
(S
));
2584 while Present
(E
) loop
2585 if Has_Excluded_Statement
(Statements
(E
)) then
2592 elsif Nkind
(S
) = N_If_Statement
then
2593 if Has_Excluded_Statement
(Then_Statements
(S
)) then
2597 if Present
(Elsif_Parts
(S
)) then
2598 E
:= First
(Elsif_Parts
(S
));
2599 while Present
(E
) loop
2600 if Has_Excluded_Statement
(Then_Statements
(E
)) then
2607 if Present
(Else_Statements
(S
))
2608 and then Has_Excluded_Statement
(Else_Statements
(S
))
2613 elsif Nkind
(S
) = N_Loop_Statement
2614 and then Has_Excluded_Statement
(Statements
(S
))
2623 end Has_Excluded_Statement
;
2625 -------------------------------
2626 -- Has_Pending_Instantiation --
2627 -------------------------------
2629 function Has_Pending_Instantiation
return Boolean is
2634 while Present
(S
) loop
2635 if Is_Compilation_Unit
(S
)
2636 or else Is_Child_Unit
(S
)
2639 elsif Ekind
(S
) = E_Package
2640 and then Has_Forward_Instantiation
(S
)
2649 end Has_Pending_Instantiation
;
2651 ------------------------
2652 -- Has_Single_Return --
2653 ------------------------
2655 function Has_Single_Return
return Boolean is
2656 Return_Statement
: Node_Id
:= Empty
;
2658 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
2664 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
2666 if Nkind
(N
) = N_Simple_Return_Statement
then
2667 if Present
(Expression
(N
))
2668 and then Is_Entity_Name
(Expression
(N
))
2670 if No
(Return_Statement
) then
2671 Return_Statement
:= N
;
2674 elsif Chars
(Expression
(N
)) =
2675 Chars
(Expression
(Return_Statement
))
2684 -- Expression has wrong form
2694 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
2696 -- Start of processing for Has_Single_Return
2699 return Check_All_Returns
(N
) = OK
2700 and then Present
(Declarations
(N
))
2701 and then Present
(First
(Declarations
(N
)))
2702 and then Chars
(Expression
(Return_Statement
)) =
2703 Chars
(Defining_Identifier
(First
(Declarations
(N
))));
2704 end Has_Single_Return
;
2706 --------------------
2707 -- Remove_Pragmas --
2708 --------------------
2710 procedure Remove_Pragmas
is
2715 Decl
:= First
(Declarations
(Body_To_Analyze
));
2716 while Present
(Decl
) loop
2719 if Nkind
(Decl
) = N_Pragma
2720 and then Chars
(Decl
) = Name_Unreferenced
2729 --------------------------
2730 -- Uses_Secondary_Stack --
2731 --------------------------
2733 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean is
2734 function Check_Call
(N
: Node_Id
) return Traverse_Result
;
2735 -- Look for function calls that return an unconstrained type
2741 function Check_Call
(N
: Node_Id
) return Traverse_Result
is
2743 if Nkind
(N
) = N_Function_Call
2744 and then Is_Entity_Name
(Name
(N
))
2745 and then Is_Composite_Type
(Etype
(Entity
(Name
(N
))))
2746 and then not Is_Constrained
(Etype
(Entity
(Name
(N
))))
2749 ("cannot inline & (call returns unconstrained type)?",
2757 function Check_Calls
is new Traverse_Func
(Check_Call
);
2760 return Check_Calls
(Bod
) = Abandon
;
2761 end Uses_Secondary_Stack
;
2763 -- Start of processing for Build_Body_To_Inline
2766 if Nkind
(Decl
) = N_Subprogram_Declaration
2767 and then Present
(Body_To_Inline
(Decl
))
2769 return; -- Done already.
2771 -- Functions that return unconstrained composite types require
2772 -- secondary stack handling, and cannot currently be inlined, unless
2773 -- all return statements return a local variable that is the first
2774 -- local declaration in the body.
2776 elsif Ekind
(Subp
) = E_Function
2777 and then not Is_Scalar_Type
(Etype
(Subp
))
2778 and then not Is_Access_Type
(Etype
(Subp
))
2779 and then not Is_Constrained
(Etype
(Subp
))
2781 if not Has_Single_Return
then
2783 ("cannot inline & (unconstrained return type)?", N
, Subp
);
2787 -- Ditto for functions that return controlled types, where controlled
2788 -- actions interfere in complex ways with inlining.
2790 elsif Ekind
(Subp
) = E_Function
2791 and then Controlled_Type
(Etype
(Subp
))
2794 ("cannot inline & (controlled return type)?", N
, Subp
);
2798 if Present
(Declarations
(N
))
2799 and then Has_Excluded_Declaration
(Declarations
(N
))
2804 if Present
(Handled_Statement_Sequence
(N
)) then
2805 if Present
(Exception_Handlers
(Handled_Statement_Sequence
(N
))) then
2807 ("cannot inline& (exception handler)?",
2808 First
(Exception_Handlers
(Handled_Statement_Sequence
(N
))),
2812 Has_Excluded_Statement
2813 (Statements
(Handled_Statement_Sequence
(N
)))
2819 -- We do not inline a subprogram that is too large, unless it is
2820 -- marked Inline_Always. This pragma does not suppress the other
2821 -- checks on inlining (forbidden declarations, handlers, etc).
2823 if Stat_Count
> Max_Size
2824 and then not Is_Always_Inlined
(Subp
)
2826 Cannot_Inline
("cannot inline& (body too large)?", N
, Subp
);
2830 if Has_Pending_Instantiation
then
2832 ("cannot inline& (forward instance within enclosing body)?",
2837 -- Within an instance, the body to inline must be treated as a nested
2838 -- generic, so that the proper global references are preserved.
2841 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
2842 Original_Body
:= Copy_Generic_Node
(N
, Empty
, True);
2844 Original_Body
:= Copy_Separate_Tree
(N
);
2847 -- We need to capture references to the formals in order to substitute
2848 -- the actuals at the point of inlining, i.e. instantiation. To treat
2849 -- the formals as globals to the body to inline, we nest it within
2850 -- a dummy parameterless subprogram, declared within the real one.
2851 -- To avoid generating an internal name (which is never public, and
2852 -- which affects serial numbers of other generated names), we use
2853 -- an internal symbol that cannot conflict with user declarations.
2855 Set_Parameter_Specifications
(Specification
(Original_Body
), No_List
);
2856 Set_Defining_Unit_Name
2857 (Specification
(Original_Body
),
2858 Make_Defining_Identifier
(Sloc
(N
), Name_uParent
));
2859 Set_Corresponding_Spec
(Original_Body
, Empty
);
2861 Body_To_Analyze
:= Copy_Generic_Node
(Original_Body
, Empty
, False);
2863 -- Set return type of function, which is also global and does not need
2866 if Ekind
(Subp
) = E_Function
then
2867 Set_Result_Definition
(Specification
(Body_To_Analyze
),
2868 New_Occurrence_Of
(Etype
(Subp
), Sloc
(N
)));
2871 if No
(Declarations
(N
)) then
2872 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
2874 Append
(Body_To_Analyze
, Declarations
(N
));
2877 Expander_Mode_Save_And_Set
(False);
2880 Analyze
(Body_To_Analyze
);
2881 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
2882 Save_Global_References
(Original_Body
);
2884 Remove
(Body_To_Analyze
);
2886 Expander_Mode_Restore
;
2892 -- If secondary stk used there is no point in inlining. We have
2893 -- already issued the warning in this case, so nothing to do.
2895 if Uses_Secondary_Stack
(Body_To_Analyze
) then
2899 Set_Body_To_Inline
(Decl
, Original_Body
);
2900 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Subp
));
2901 Set_Is_Inlined
(Subp
);
2902 end Build_Body_To_Inline
;
2908 procedure Cannot_Inline
(Msg
: String; N
: Node_Id
; Subp
: Entity_Id
) is
2910 -- Do not emit warning if this is a predefined unit which is not
2911 -- the main unit. With validity checks enabled, some predefined
2912 -- subprograms may contain nested subprograms and become ineligible
2915 if Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(Subp
)))
2916 and then not In_Extended_Main_Source_Unit
(Subp
)
2920 elsif Is_Always_Inlined
(Subp
) then
2922 -- Remove last character (question mark) to make this into an error,
2923 -- because the Inline_Always pragma cannot be obeyed.
2925 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
2927 elsif Ineffective_Inline_Warnings
then
2928 Error_Msg_NE
(Msg
, N
, Subp
);
2932 -----------------------
2933 -- Check_Conformance --
2934 -----------------------
2936 procedure Check_Conformance
2937 (New_Id
: Entity_Id
;
2939 Ctype
: Conformance_Type
;
2941 Conforms
: out Boolean;
2942 Err_Loc
: Node_Id
:= Empty
;
2943 Get_Inst
: Boolean := False;
2944 Skip_Controlling_Formals
: Boolean := False)
2946 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
);
2947 -- Post error message for conformance error on given node. Two messages
2948 -- are output. The first points to the previous declaration with a
2949 -- general "no conformance" message. The second is the detailed reason,
2950 -- supplied as Msg. The parameter N provide information for a possible
2951 -- & insertion in the message, and also provides the location for
2952 -- posting the message in the absence of a specified Err_Loc location.
2954 -----------------------
2955 -- Conformance_Error --
2956 -----------------------
2958 procedure Conformance_Error
(Msg
: String; N
: Node_Id
:= New_Id
) is
2965 if No
(Err_Loc
) then
2971 Error_Msg_Sloc
:= Sloc
(Old_Id
);
2974 when Type_Conformant
=>
2976 ("not type conformant with declaration#!", Enode
);
2978 when Mode_Conformant
=>
2979 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
2981 ("not mode conformant with operation inherited#!",
2985 ("not mode conformant with declaration#!", Enode
);
2988 when Subtype_Conformant
=>
2989 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
2991 ("not subtype conformant with operation inherited#!",
2995 ("not subtype conformant with declaration#!", Enode
);
2998 when Fully_Conformant
=>
2999 if Nkind
(Parent
(Old_Id
)) = N_Full_Type_Declaration
then
3001 ("not fully conformant with operation inherited#!",
3005 ("not fully conformant with declaration#!", Enode
);
3009 Error_Msg_NE
(Msg
, Enode
, N
);
3011 end Conformance_Error
;
3015 Old_Type
: constant Entity_Id
:= Etype
(Old_Id
);
3016 New_Type
: constant Entity_Id
:= Etype
(New_Id
);
3017 Old_Formal
: Entity_Id
;
3018 New_Formal
: Entity_Id
;
3019 Access_Types_Match
: Boolean;
3020 Old_Formal_Base
: Entity_Id
;
3021 New_Formal_Base
: Entity_Id
;
3023 -- Start of processing for Check_Conformance
3028 -- We need a special case for operators, since they don't appear
3031 if Ctype
= Type_Conformant
then
3032 if Ekind
(New_Id
) = E_Operator
3033 and then Operator_Matches_Spec
(New_Id
, Old_Id
)
3039 -- If both are functions/operators, check return types conform
3041 if Old_Type
/= Standard_Void_Type
3042 and then New_Type
/= Standard_Void_Type
3044 if not Conforming_Types
(Old_Type
, New_Type
, Ctype
, Get_Inst
) then
3045 Conformance_Error
("\return type does not match!", New_Id
);
3049 -- Ada 2005 (AI-231): In case of anonymous access types check the
3050 -- null-exclusion and access-to-constant attributes match.
3052 if Ada_Version
>= Ada_05
3053 and then Ekind
(Etype
(Old_Type
)) = E_Anonymous_Access_Type
3055 (Can_Never_Be_Null
(Old_Type
)
3056 /= Can_Never_Be_Null
(New_Type
)
3057 or else Is_Access_Constant
(Etype
(Old_Type
))
3058 /= Is_Access_Constant
(Etype
(New_Type
)))
3060 Conformance_Error
("\return type does not match!", New_Id
);
3064 -- If either is a function/operator and the other isn't, error
3066 elsif Old_Type
/= Standard_Void_Type
3067 or else New_Type
/= Standard_Void_Type
3069 Conformance_Error
("\functions can only match functions!", New_Id
);
3073 -- In subtype conformant case, conventions must match (RM 6.3.1(16)).
3074 -- If this is a renaming as body, refine error message to indicate that
3075 -- the conflict is with the original declaration. If the entity is not
3076 -- frozen, the conventions don't have to match, the one of the renamed
3077 -- entity is inherited.
3079 if Ctype
>= Subtype_Conformant
then
3080 if Convention
(Old_Id
) /= Convention
(New_Id
) then
3082 if not Is_Frozen
(New_Id
) then
3085 elsif Present
(Err_Loc
)
3086 and then Nkind
(Err_Loc
) = N_Subprogram_Renaming_Declaration
3087 and then Present
(Corresponding_Spec
(Err_Loc
))
3089 Error_Msg_Name_1
:= Chars
(New_Id
);
3091 Name_Ada
+ Convention_Id
'Pos (Convention
(New_Id
));
3093 Conformance_Error
("\prior declaration for% has convention %!");
3096 Conformance_Error
("\calling conventions do not match!");
3101 elsif Is_Formal_Subprogram
(Old_Id
)
3102 or else Is_Formal_Subprogram
(New_Id
)
3104 Conformance_Error
("\formal subprograms not allowed!");
3109 -- Deal with parameters
3111 -- Note: we use the entity information, rather than going directly
3112 -- to the specification in the tree. This is not only simpler, but
3113 -- absolutely necessary for some cases of conformance tests between
3114 -- operators, where the declaration tree simply does not exist!
3116 Old_Formal
:= First_Formal
(Old_Id
);
3117 New_Formal
:= First_Formal
(New_Id
);
3119 while Present
(Old_Formal
) and then Present
(New_Formal
) loop
3120 if Is_Controlling_Formal
(Old_Formal
)
3121 and then Is_Controlling_Formal
(New_Formal
)
3122 and then Skip_Controlling_Formals
3124 goto Skip_Controlling_Formal
;
3127 if Ctype
= Fully_Conformant
then
3129 -- Names must match. Error message is more accurate if we do
3130 -- this before checking that the types of the formals match.
3132 if Chars
(Old_Formal
) /= Chars
(New_Formal
) then
3133 Conformance_Error
("\name & does not match!", New_Formal
);
3135 -- Set error posted flag on new formal as well to stop
3136 -- junk cascaded messages in some cases.
3138 Set_Error_Posted
(New_Formal
);
3143 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
3144 -- case occurs whenever a subprogram is being renamed and one of its
3145 -- parameters imposes a null exclusion. For example:
3147 -- type T is null record;
3148 -- type Acc_T is access T;
3149 -- subtype Acc_T_Sub is Acc_T;
3151 -- procedure P (Obj : not null Acc_T_Sub); -- itype
3152 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype
3155 Old_Formal_Base
:= Etype
(Old_Formal
);
3156 New_Formal_Base
:= Etype
(New_Formal
);
3159 Old_Formal_Base
:= Get_Instance_Of
(Old_Formal_Base
);
3160 New_Formal_Base
:= Get_Instance_Of
(New_Formal_Base
);
3163 Access_Types_Match
:= Ada_Version
>= Ada_05
3165 -- Ensure that this rule is only applied when New_Id is a
3166 -- renaming of Old_Id.
3168 and then Nkind
(Parent
(Parent
(New_Id
))) =
3169 N_Subprogram_Renaming_Declaration
3170 and then Nkind
(Name
(Parent
(Parent
(New_Id
)))) in N_Has_Entity
3171 and then Present
(Entity
(Name
(Parent
(Parent
(New_Id
)))))
3172 and then Entity
(Name
(Parent
(Parent
(New_Id
)))) = Old_Id
3174 -- Now handle the allowed access-type case
3176 and then Is_Access_Type
(Old_Formal_Base
)
3177 and then Is_Access_Type
(New_Formal_Base
)
3179 -- The type kinds must match. The only exception occurs with
3180 -- multiple generics of the form:
3183 -- type F is private; type A is private;
3184 -- type F_Ptr is access F; type A_Ptr is access A;
3185 -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
3186 -- package F_Pack is ... package A_Pack is
3187 -- package F_Inst is
3188 -- new F_Pack (A, A_Ptr, A_P);
3190 -- When checking for conformance between the parameters of A_P
3191 -- and F_P, the type kinds of F_Ptr and A_Ptr will not match
3192 -- because the compiler has transformed A_Ptr into a subtype of
3193 -- F_Ptr. We catch this case in the code below.
3195 and then (Ekind
(Old_Formal_Base
) = Ekind
(New_Formal_Base
)
3197 (Is_Generic_Type
(Old_Formal_Base
)
3198 and then Is_Generic_Type
(New_Formal_Base
)
3199 and then Is_Internal
(New_Formal_Base
)
3200 and then Etype
(Etype
(New_Formal_Base
)) =
3202 and then Directly_Designated_Type
(Old_Formal_Base
) =
3203 Directly_Designated_Type
(New_Formal_Base
)
3204 and then ((Is_Itype
(Old_Formal_Base
)
3205 and then Can_Never_Be_Null
(Old_Formal_Base
))
3207 (Is_Itype
(New_Formal_Base
)
3208 and then Can_Never_Be_Null
(New_Formal_Base
)));
3210 -- Types must always match. In the visible part of an instance,
3211 -- usual overloading rules for dispatching operations apply, and
3212 -- we check base types (not the actual subtypes).
3214 if In_Instance_Visible_Part
3215 and then Is_Dispatching_Operation
(New_Id
)
3217 if not Conforming_Types
3218 (T1
=> Base_Type
(Etype
(Old_Formal
)),
3219 T2
=> Base_Type
(Etype
(New_Formal
)),
3221 Get_Inst
=> Get_Inst
)
3222 and then not Access_Types_Match
3224 Conformance_Error
("\type of & does not match!", New_Formal
);
3228 elsif not Conforming_Types
3229 (T1
=> Old_Formal_Base
,
3230 T2
=> New_Formal_Base
,
3232 Get_Inst
=> Get_Inst
)
3233 and then not Access_Types_Match
3235 Conformance_Error
("\type of & does not match!", New_Formal
);
3239 -- For mode conformance, mode must match
3241 if Ctype
>= Mode_Conformant
then
3242 if Parameter_Mode
(Old_Formal
) /= Parameter_Mode
(New_Formal
) then
3243 Conformance_Error
("\mode of & does not match!", New_Formal
);
3246 -- Part of mode conformance for access types is having the same
3247 -- constant modifier.
3249 elsif Access_Types_Match
3250 and then Is_Access_Constant
(Old_Formal_Base
) /=
3251 Is_Access_Constant
(New_Formal_Base
)
3254 ("\constant modifier does not match!", New_Formal
);
3259 if Ctype
>= Subtype_Conformant
then
3261 -- Ada 2005 (AI-231): In case of anonymous access types check
3262 -- the null-exclusion and access-to-constant attributes must
3265 if Ada_Version
>= Ada_05
3266 and then Ekind
(Etype
(Old_Formal
)) = E_Anonymous_Access_Type
3267 and then Ekind
(Etype
(New_Formal
)) = E_Anonymous_Access_Type
3269 (Can_Never_Be_Null
(Old_Formal
) /=
3270 Can_Never_Be_Null
(New_Formal
)
3272 Is_Access_Constant
(Etype
(Old_Formal
)) /=
3273 Is_Access_Constant
(Etype
(New_Formal
)))
3275 -- It is allowed to omit the null-exclusion in case of stream
3276 -- attribute subprograms. We recognize stream subprograms
3277 -- through their TSS-generated suffix.
3280 TSS_Name
: constant TSS_Name_Type
:= Get_TSS_Name
(New_Id
);
3282 if TSS_Name
/= TSS_Stream_Read
3283 and then TSS_Name
/= TSS_Stream_Write
3284 and then TSS_Name
/= TSS_Stream_Input
3285 and then TSS_Name
/= TSS_Stream_Output
3288 ("\type of & does not match!", New_Formal
);
3295 -- Full conformance checks
3297 if Ctype
= Fully_Conformant
then
3299 -- We have checked already that names match
3301 if Parameter_Mode
(Old_Formal
) = E_In_Parameter
then
3303 -- Check default expressions for in parameters
3306 NewD
: constant Boolean :=
3307 Present
(Default_Value
(New_Formal
));
3308 OldD
: constant Boolean :=
3309 Present
(Default_Value
(Old_Formal
));
3311 if NewD
or OldD
then
3313 -- The old default value has been analyzed because the
3314 -- current full declaration will have frozen everything
3315 -- before. The new default value has not been analyzed,
3316 -- so analyze it now before we check for conformance.
3319 Push_Scope
(New_Id
);
3320 Analyze_Per_Use_Expression
3321 (Default_Value
(New_Formal
), Etype
(New_Formal
));
3325 if not (NewD
and OldD
)
3326 or else not Fully_Conformant_Expressions
3327 (Default_Value
(Old_Formal
),
3328 Default_Value
(New_Formal
))
3331 ("\default expression for & does not match!",
3340 -- A couple of special checks for Ada 83 mode. These checks are
3341 -- skipped if either entity is an operator in package Standard,
3342 -- or if either old or new instance is not from the source program.
3344 if Ada_Version
= Ada_83
3345 and then Sloc
(Old_Id
) > Standard_Location
3346 and then Sloc
(New_Id
) > Standard_Location
3347 and then Comes_From_Source
(Old_Id
)
3348 and then Comes_From_Source
(New_Id
)
3351 Old_Param
: constant Node_Id
:= Declaration_Node
(Old_Formal
);
3352 New_Param
: constant Node_Id
:= Declaration_Node
(New_Formal
);
3355 -- Explicit IN must be present or absent in both cases. This
3356 -- test is required only in the full conformance case.
3358 if In_Present
(Old_Param
) /= In_Present
(New_Param
)
3359 and then Ctype
= Fully_Conformant
3362 ("\(Ada 83) IN must appear in both declarations",
3367 -- Grouping (use of comma in param lists) must be the same
3368 -- This is where we catch a misconformance like:
3371 -- A : Integer; B : Integer
3373 -- which are represented identically in the tree except
3374 -- for the setting of the flags More_Ids and Prev_Ids.
3376 if More_Ids
(Old_Param
) /= More_Ids
(New_Param
)
3377 or else Prev_Ids
(Old_Param
) /= Prev_Ids
(New_Param
)
3380 ("\grouping of & does not match!", New_Formal
);
3386 -- This label is required when skipping controlling formals
3388 <<Skip_Controlling_Formal
>>
3390 Next_Formal
(Old_Formal
);
3391 Next_Formal
(New_Formal
);
3394 if Present
(Old_Formal
) then
3395 Conformance_Error
("\too few parameters!");
3398 elsif Present
(New_Formal
) then
3399 Conformance_Error
("\too many parameters!", New_Formal
);
3402 end Check_Conformance
;
3404 -----------------------
3405 -- Check_Conventions --
3406 -----------------------
3408 procedure Check_Conventions
(Typ
: Entity_Id
) is
3410 function Skip_Check
(Op
: Entity_Id
) return Boolean;
3411 pragma Inline
(Skip_Check
);
3412 -- A small optimization: skip the predefined dispatching operations,
3413 -- since they always have the same convention. Also do not consider
3414 -- abstract primitives since those are left by an erroneous overriding.
3415 -- This function returns True for any operation that is thus exempted
3416 -- exempted from checking.
3418 procedure Check_Convention
3420 Search_From
: Elmt_Id
);
3421 -- Verify that the convention of inherited dispatching operation Op is
3422 -- consistent among all subprograms it overrides. In order to minimize
3423 -- the search, Search_From is utilized to designate a specific point in
3424 -- the list rather than iterating over the whole list once more.
3426 ----------------------
3427 -- Check_Convention --
3428 ----------------------
3430 procedure Check_Convention
3432 Search_From
: Elmt_Id
)
3434 procedure Error_Msg_Operation
(Op
: Entity_Id
);
3435 -- Emit a continuation to an error message depicting the kind, name,
3436 -- convention and source location of subprogram Op.
3438 -------------------------
3439 -- Error_Msg_Operation --
3440 -------------------------
3442 procedure Error_Msg_Operation
(Op
: Entity_Id
) is
3444 Error_Msg_Name_1
:= Chars
(Op
);
3446 -- Error messages of primitive subprograms do not contain a
3447 -- convention attribute since the convention may have been first
3448 -- inherited from a parent subprogram, then changed by a pragma.
3450 if Comes_From_Source
(Op
) then
3451 Error_Msg_Sloc
:= Sloc
(Op
);
3453 ("\ primitive % defined #", Typ
);
3456 Error_Msg_Name_2
:= Get_Convention_Name
(Convention
(Op
));
3458 if Present
(Abstract_Interface_Alias
(Op
)) then
3459 Error_Msg_Sloc
:= Sloc
(Abstract_Interface_Alias
(Op
));
3460 Error_Msg_N
("\\overridden operation % with " &
3461 "convention % defined #", Typ
);
3463 else pragma Assert
(Present
(Alias
(Op
)));
3464 Error_Msg_Sloc
:= Sloc
(Alias
(Op
));
3465 Error_Msg_N
("\\inherited operation % with " &
3466 "convention % defined #", Typ
);
3469 end Error_Msg_Operation
;
3473 Second_Prim_Op
: Entity_Id
;
3474 Second_Prim_Op_Elmt
: Elmt_Id
;
3476 -- Start of processing for Check_Convention
3479 Second_Prim_Op_Elmt
:= Next_Elmt
(Search_From
);
3480 while Present
(Second_Prim_Op_Elmt
) loop
3481 Second_Prim_Op
:= Node
(Second_Prim_Op_Elmt
);
3483 if not Skip_Check
(Second_Prim_Op
)
3484 and then Chars
(Second_Prim_Op
) = Chars
(Op
)
3485 and then Type_Conformant
(Second_Prim_Op
, Op
)
3486 and then Convention
(Second_Prim_Op
) /= Convention
(Op
)
3489 ("inconsistent conventions in primitive operations", Typ
);
3491 Error_Msg_Operation
(Op
);
3492 Error_Msg_Operation
(Second_Prim_Op
);
3494 -- Avoid cascading errors
3499 Next_Elmt
(Second_Prim_Op_Elmt
);
3501 end Check_Convention
;
3507 function Skip_Check
(Op
: Entity_Id
) return Boolean is
3509 return Is_Predefined_Dispatching_Operation
(Op
)
3510 or else Is_Abstract_Subprogram
(Op
);
3515 Prim_Op
: Entity_Id
;
3516 Prim_Op_Elmt
: Elmt_Id
;
3518 -- Start of processing for Check_Conventions
3521 -- The algorithm checks every overriding dispatching operation against
3522 -- all the corresponding overridden dispatching operations, detecting
3523 -- differences in coventions.
3525 Prim_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
3526 while Present
(Prim_Op_Elmt
) loop
3527 Prim_Op
:= Node
(Prim_Op_Elmt
);
3529 -- A small optimization: skip the predefined dispatching operations
3530 -- since they always have the same convention. Also avoid processing
3531 -- of abstract primitives left from an erroneous overriding.
3533 if not Skip_Check
(Prim_Op
) then
3536 Search_From
=> Prim_Op_Elmt
);
3539 Next_Elmt
(Prim_Op_Elmt
);
3541 end Check_Conventions
;
3543 ------------------------------
3544 -- Check_Delayed_Subprogram --
3545 ------------------------------
3547 procedure Check_Delayed_Subprogram
(Designator
: Entity_Id
) is
3550 procedure Possible_Freeze
(T
: Entity_Id
);
3551 -- T is the type of either a formal parameter or of the return type.
3552 -- If T is not yet frozen and needs a delayed freeze, then the
3553 -- subprogram itself must be delayed.
3555 ---------------------
3556 -- Possible_Freeze --
3557 ---------------------
3559 procedure Possible_Freeze
(T
: Entity_Id
) is
3561 if Has_Delayed_Freeze
(T
)
3562 and then not Is_Frozen
(T
)
3564 Set_Has_Delayed_Freeze
(Designator
);
3566 elsif Is_Access_Type
(T
)
3567 and then Has_Delayed_Freeze
(Designated_Type
(T
))
3568 and then not Is_Frozen
(Designated_Type
(T
))
3570 Set_Has_Delayed_Freeze
(Designator
);
3572 end Possible_Freeze
;
3574 -- Start of processing for Check_Delayed_Subprogram
3577 -- Never need to freeze abstract subprogram
3579 if Ekind
(Designator
) /= E_Subprogram_Type
3580 and then Is_Abstract_Subprogram
(Designator
)
3584 -- Need delayed freeze if return type itself needs a delayed
3585 -- freeze and is not yet frozen.
3587 Possible_Freeze
(Etype
(Designator
));
3588 Possible_Freeze
(Base_Type
(Etype
(Designator
))); -- needed ???
3590 -- Need delayed freeze if any of the formal types themselves need
3591 -- a delayed freeze and are not yet frozen.
3593 F
:= First_Formal
(Designator
);
3594 while Present
(F
) loop
3595 Possible_Freeze
(Etype
(F
));
3596 Possible_Freeze
(Base_Type
(Etype
(F
))); -- needed ???
3601 -- Mark functions that return by reference. Note that it cannot be
3602 -- done for delayed_freeze subprograms because the underlying
3603 -- returned type may not be known yet (for private types)
3605 if not Has_Delayed_Freeze
(Designator
)
3606 and then Expander_Active
3609 Typ
: constant Entity_Id
:= Etype
(Designator
);
3610 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3613 if Is_Inherently_Limited_Type
(Typ
) then
3614 Set_Returns_By_Ref
(Designator
);
3616 elsif Present
(Utyp
) and then CW_Or_Controlled_Type
(Utyp
) then
3617 Set_Returns_By_Ref
(Designator
);
3621 end Check_Delayed_Subprogram
;
3623 ------------------------------------
3624 -- Check_Discriminant_Conformance --
3625 ------------------------------------
3627 procedure Check_Discriminant_Conformance
3632 Old_Discr
: Entity_Id
:= First_Discriminant
(Prev
);
3633 New_Discr
: Node_Id
:= First
(Discriminant_Specifications
(N
));
3634 New_Discr_Id
: Entity_Id
;
3635 New_Discr_Type
: Entity_Id
;
3637 procedure Conformance_Error
(Msg
: String; N
: Node_Id
);
3638 -- Post error message for conformance error on given node. Two messages
3639 -- are output. The first points to the previous declaration with a
3640 -- general "no conformance" message. The second is the detailed reason,
3641 -- supplied as Msg. The parameter N provide information for a possible
3642 -- & insertion in the message.
3644 -----------------------
3645 -- Conformance_Error --
3646 -----------------------
3648 procedure Conformance_Error
(Msg
: String; N
: Node_Id
) is
3650 Error_Msg_Sloc
:= Sloc
(Prev_Loc
);
3651 Error_Msg_N
("not fully conformant with declaration#!", N
);
3652 Error_Msg_NE
(Msg
, N
, N
);
3653 end Conformance_Error
;
3655 -- Start of processing for Check_Discriminant_Conformance
3658 while Present
(Old_Discr
) and then Present
(New_Discr
) loop
3660 New_Discr_Id
:= Defining_Identifier
(New_Discr
);
3662 -- The subtype mark of the discriminant on the full type has not
3663 -- been analyzed so we do it here. For an access discriminant a new
3666 if Nkind
(Discriminant_Type
(New_Discr
)) = N_Access_Definition
then
3668 Access_Definition
(N
, Discriminant_Type
(New_Discr
));
3671 Analyze
(Discriminant_Type
(New_Discr
));
3672 New_Discr_Type
:= Etype
(Discriminant_Type
(New_Discr
));
3675 if not Conforming_Types
3676 (Etype
(Old_Discr
), New_Discr_Type
, Fully_Conformant
)
3678 Conformance_Error
("type of & does not match!", New_Discr_Id
);
3681 -- Treat the new discriminant as an occurrence of the old one,
3682 -- for navigation purposes, and fill in some semantic
3683 -- information, for completeness.
3685 Generate_Reference
(Old_Discr
, New_Discr_Id
, 'r');
3686 Set_Etype
(New_Discr_Id
, Etype
(Old_Discr
));
3687 Set_Scope
(New_Discr_Id
, Scope
(Old_Discr
));
3692 if Chars
(Old_Discr
) /= Chars
(Defining_Identifier
(New_Discr
)) then
3693 Conformance_Error
("name & does not match!", New_Discr_Id
);
3697 -- Default expressions must match
3700 NewD
: constant Boolean :=
3701 Present
(Expression
(New_Discr
));
3702 OldD
: constant Boolean :=
3703 Present
(Expression
(Parent
(Old_Discr
)));
3706 if NewD
or OldD
then
3708 -- The old default value has been analyzed and expanded,
3709 -- because the current full declaration will have frozen
3710 -- everything before. The new default values have not been
3711 -- expanded, so expand now to check conformance.
3714 Analyze_Per_Use_Expression
3715 (Expression
(New_Discr
), New_Discr_Type
);
3718 if not (NewD
and OldD
)
3719 or else not Fully_Conformant_Expressions
3720 (Expression
(Parent
(Old_Discr
)),
3721 Expression
(New_Discr
))
3725 ("default expression for & does not match!",
3732 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
3734 if Ada_Version
= Ada_83
then
3736 Old_Disc
: constant Node_Id
:= Declaration_Node
(Old_Discr
);
3739 -- Grouping (use of comma in param lists) must be the same
3740 -- This is where we catch a misconformance like:
3743 -- A : Integer; B : Integer
3745 -- which are represented identically in the tree except
3746 -- for the setting of the flags More_Ids and Prev_Ids.
3748 if More_Ids
(Old_Disc
) /= More_Ids
(New_Discr
)
3749 or else Prev_Ids
(Old_Disc
) /= Prev_Ids
(New_Discr
)
3752 ("grouping of & does not match!", New_Discr_Id
);
3758 Next_Discriminant
(Old_Discr
);
3762 if Present
(Old_Discr
) then
3763 Conformance_Error
("too few discriminants!", Defining_Identifier
(N
));
3766 elsif Present
(New_Discr
) then
3768 ("too many discriminants!", Defining_Identifier
(New_Discr
));
3771 end Check_Discriminant_Conformance
;
3773 ----------------------------
3774 -- Check_Fully_Conformant --
3775 ----------------------------
3777 procedure Check_Fully_Conformant
3778 (New_Id
: Entity_Id
;
3780 Err_Loc
: Node_Id
:= Empty
)
3783 pragma Warnings
(Off
, Result
);
3786 (New_Id
, Old_Id
, Fully_Conformant
, True, Result
, Err_Loc
);
3787 end Check_Fully_Conformant
;
3789 ---------------------------
3790 -- Check_Mode_Conformant --
3791 ---------------------------
3793 procedure Check_Mode_Conformant
3794 (New_Id
: Entity_Id
;
3796 Err_Loc
: Node_Id
:= Empty
;
3797 Get_Inst
: Boolean := False)
3800 pragma Warnings
(Off
, Result
);
3803 (New_Id
, Old_Id
, Mode_Conformant
, True, Result
, Err_Loc
, Get_Inst
);
3804 end Check_Mode_Conformant
;
3806 --------------------------------
3807 -- Check_Overriding_Indicator --
3808 --------------------------------
3810 procedure Check_Overriding_Indicator
3812 Overridden_Subp
: Entity_Id
;
3813 Is_Primitive
: Boolean)
3819 -- No overriding indicator for literals
3821 if Ekind
(Subp
) = E_Enumeration_Literal
then
3824 elsif Ekind
(Subp
) = E_Entry
then
3825 Decl
:= Parent
(Subp
);
3828 Decl
:= Unit_Declaration_Node
(Subp
);
3831 if Nkind
(Decl
) = N_Subprogram_Body
3832 or else Nkind
(Decl
) = N_Subprogram_Body_Stub
3833 or else Nkind
(Decl
) = N_Subprogram_Declaration
3834 or else Nkind
(Decl
) = N_Abstract_Subprogram_Declaration
3835 or else Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
3837 Spec
:= Specification
(Decl
);
3839 elsif Nkind
(Decl
) = N_Entry_Declaration
then
3846 if Present
(Overridden_Subp
) then
3847 if Must_Not_Override
(Spec
) then
3848 Error_Msg_Sloc
:= Sloc
(Overridden_Subp
);
3850 if Ekind
(Subp
) = E_Entry
then
3852 ("entry & overrides inherited operation #", Spec
, Subp
);
3855 ("subprogram & overrides inherited operation #", Spec
, Subp
);
3859 -- If Subp is an operator, it may override a predefined operation.
3860 -- In that case overridden_subp is empty because of our implicit
3861 -- representation for predefined operators. We have to check whether the
3862 -- signature of Subp matches that of a predefined operator. Note that
3863 -- first argument provides the name of the operator, and the second
3864 -- argument the signature that may match that of a standard operation.
3866 elsif Nkind
(Subp
) = N_Defining_Operator_Symbol
3867 and then Must_Not_Override
(Spec
)
3869 if Operator_Matches_Spec
(Subp
, Subp
) then
3871 ("subprogram & overrides predefined operator ",
3875 elsif Must_Override
(Spec
) then
3876 if Ekind
(Subp
) = E_Entry
then
3877 Error_Msg_NE
("entry & is not overriding", Spec
, Subp
);
3879 elsif Nkind
(Subp
) = N_Defining_Operator_Symbol
then
3880 if not Operator_Matches_Spec
(Subp
, Subp
) then
3882 ("subprogram & is not overriding", Spec
, Subp
);
3886 Error_Msg_NE
("subprogram & is not overriding", Spec
, Subp
);
3889 -- If the operation is marked "not overriding" and it's not primitive
3890 -- then an error is issued, unless this is an operation of a task or
3891 -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
3892 -- has been specified have already been checked above.
3894 elsif Must_Not_Override
(Spec
)
3895 and then not Is_Primitive
3896 and then Ekind
(Subp
) /= E_Entry
3897 and then Ekind
(Scope
(Subp
)) /= E_Protected_Type
3900 ("overriding indicator only allowed if subprogram is primitive",
3905 end Check_Overriding_Indicator
;
3911 -- Note: this procedure needs to know far too much about how the expander
3912 -- messes with exceptions. The use of the flag Exception_Junk and the
3913 -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
3914 -- works, but is not very clean. It would be better if the expansion
3915 -- routines would leave Original_Node working nicely, and we could use
3916 -- Original_Node here to ignore all the peculiar expander messing ???
3918 procedure Check_Returns
3922 Proc
: Entity_Id
:= Empty
)
3926 procedure Check_Statement_Sequence
(L
: List_Id
);
3927 -- Internal recursive procedure to check a list of statements for proper
3928 -- termination by a return statement (or a transfer of control or a
3929 -- compound statement that is itself internally properly terminated).
3931 ------------------------------
3932 -- Check_Statement_Sequence --
3933 ------------------------------
3935 procedure Check_Statement_Sequence
(L
: List_Id
) is
3940 Raise_Exception_Call
: Boolean;
3941 -- Set True if statement sequence terminated by Raise_Exception call
3942 -- or a Reraise_Occurrence call.
3945 Raise_Exception_Call
:= False;
3947 -- Get last real statement
3949 Last_Stm
:= Last
(L
);
3951 -- Deal with digging out exception handler statement sequences that
3952 -- have been transformed by the local raise to goto optimization.
3953 -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
3954 -- optimization has occurred, we are looking at something like:
3957 -- original stmts in block
3961 -- goto L1; | omitted if No_Exception_Propagation
3966 -- goto L3; -- skip handler when exception not raised
3968 -- <<L1>> -- target label for local exception
3982 -- and what we have to do is to dig out the estmts1 and estmts2
3983 -- sequences (which were the original sequences of statements in
3984 -- the exception handlers) and check them.
3986 if Nkind
(Last_Stm
) = N_Label
3987 and then Exception_Junk
(Last_Stm
)
3993 exit when Nkind
(Stm
) /= N_Block_Statement
;
3994 exit when not Exception_Junk
(Stm
);
3997 exit when Nkind
(Stm
) /= N_Label
;
3998 exit when not Exception_Junk
(Stm
);
3999 Check_Statement_Sequence
4000 (Statements
(Handled_Statement_Sequence
(Next
(Stm
))));
4005 exit when Nkind
(Stm
) /= N_Goto_Statement
;
4006 exit when not Exception_Junk
(Stm
);
4010 -- Don't count pragmas
4012 while Nkind
(Last_Stm
) = N_Pragma
4014 -- Don't count call to SS_Release (can happen after Raise_Exception)
4017 (Nkind
(Last_Stm
) = N_Procedure_Call_Statement
4019 Nkind
(Name
(Last_Stm
)) = N_Identifier
4021 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_SS_Release
))
4023 -- Don't count exception junk
4026 ((Nkind
(Last_Stm
) = N_Goto_Statement
4027 or else Nkind
(Last_Stm
) = N_Label
4028 or else Nkind
(Last_Stm
) = N_Object_Declaration
)
4029 and then Exception_Junk
(Last_Stm
))
4030 or else Nkind
(Last_Stm
) in N_Push_xxx_Label
4031 or else Nkind
(Last_Stm
) in N_Pop_xxx_Label
4036 -- Here we have the "real" last statement
4038 Kind
:= Nkind
(Last_Stm
);
4040 -- Transfer of control, OK. Note that in the No_Return procedure
4041 -- case, we already diagnosed any explicit return statements, so
4042 -- we can treat them as OK in this context.
4044 if Is_Transfer
(Last_Stm
) then
4047 -- Check cases of explicit non-indirect procedure calls
4049 elsif Kind
= N_Procedure_Call_Statement
4050 and then Is_Entity_Name
(Name
(Last_Stm
))
4052 -- Check call to Raise_Exception procedure which is treated
4053 -- specially, as is a call to Reraise_Occurrence.
4055 -- We suppress the warning in these cases since it is likely that
4056 -- the programmer really does not expect to deal with the case
4057 -- of Null_Occurrence, and thus would find a warning about a
4058 -- missing return curious, and raising Program_Error does not
4059 -- seem such a bad behavior if this does occur.
4061 -- Note that in the Ada 2005 case for Raise_Exception, the actual
4062 -- behavior will be to raise Constraint_Error (see AI-329).
4064 if Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Raise_Exception
)
4066 Is_RTE
(Entity
(Name
(Last_Stm
)), RE_Reraise_Occurrence
)
4068 Raise_Exception_Call
:= True;
4070 -- For Raise_Exception call, test first argument, if it is
4071 -- an attribute reference for a 'Identity call, then we know
4072 -- that the call cannot possibly return.
4075 Arg
: constant Node_Id
:=
4076 Original_Node
(First_Actual
(Last_Stm
));
4078 if Nkind
(Arg
) = N_Attribute_Reference
4079 and then Attribute_Name
(Arg
) = Name_Identity
4086 -- If statement, need to look inside if there is an else and check
4087 -- each constituent statement sequence for proper termination.
4089 elsif Kind
= N_If_Statement
4090 and then Present
(Else_Statements
(Last_Stm
))
4092 Check_Statement_Sequence
(Then_Statements
(Last_Stm
));
4093 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
4095 if Present
(Elsif_Parts
(Last_Stm
)) then
4097 Elsif_Part
: Node_Id
:= First
(Elsif_Parts
(Last_Stm
));
4100 while Present
(Elsif_Part
) loop
4101 Check_Statement_Sequence
(Then_Statements
(Elsif_Part
));
4109 -- Case statement, check each case for proper termination
4111 elsif Kind
= N_Case_Statement
then
4116 Case_Alt
:= First_Non_Pragma
(Alternatives
(Last_Stm
));
4117 while Present
(Case_Alt
) loop
4118 Check_Statement_Sequence
(Statements
(Case_Alt
));
4119 Next_Non_Pragma
(Case_Alt
);
4125 -- Block statement, check its handled sequence of statements
4127 elsif Kind
= N_Block_Statement
then
4133 (Handled_Statement_Sequence
(Last_Stm
), Mode
, Err1
);
4142 -- Loop statement. If there is an iteration scheme, we can definitely
4143 -- fall out of the loop. Similarly if there is an exit statement, we
4144 -- can fall out. In either case we need a following return.
4146 elsif Kind
= N_Loop_Statement
then
4147 if Present
(Iteration_Scheme
(Last_Stm
))
4148 or else Has_Exit
(Entity
(Identifier
(Last_Stm
)))
4152 -- A loop with no exit statement or iteration scheme if either
4153 -- an inifite loop, or it has some other exit (raise/return).
4154 -- In either case, no warning is required.
4160 -- Timed entry call, check entry call and delay alternatives
4162 -- Note: in expanded code, the timed entry call has been converted
4163 -- to a set of expanded statements on which the check will work
4164 -- correctly in any case.
4166 elsif Kind
= N_Timed_Entry_Call
then
4168 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
4169 DCA
: constant Node_Id
:= Delay_Alternative
(Last_Stm
);
4172 -- If statement sequence of entry call alternative is missing,
4173 -- then we can definitely fall through, and we post the error
4174 -- message on the entry call alternative itself.
4176 if No
(Statements
(ECA
)) then
4179 -- If statement sequence of delay alternative is missing, then
4180 -- we can definitely fall through, and we post the error
4181 -- message on the delay alternative itself.
4183 -- Note: if both ECA and DCA are missing the return, then we
4184 -- post only one message, should be enough to fix the bugs.
4185 -- If not we will get a message next time on the DCA when the
4188 elsif No
(Statements
(DCA
)) then
4191 -- Else check both statement sequences
4194 Check_Statement_Sequence
(Statements
(ECA
));
4195 Check_Statement_Sequence
(Statements
(DCA
));
4200 -- Conditional entry call, check entry call and else part
4202 -- Note: in expanded code, the conditional entry call has been
4203 -- converted to a set of expanded statements on which the check
4204 -- will work correctly in any case.
4206 elsif Kind
= N_Conditional_Entry_Call
then
4208 ECA
: constant Node_Id
:= Entry_Call_Alternative
(Last_Stm
);
4211 -- If statement sequence of entry call alternative is missing,
4212 -- then we can definitely fall through, and we post the error
4213 -- message on the entry call alternative itself.
4215 if No
(Statements
(ECA
)) then
4218 -- Else check statement sequence and else part
4221 Check_Statement_Sequence
(Statements
(ECA
));
4222 Check_Statement_Sequence
(Else_Statements
(Last_Stm
));
4228 -- If we fall through, issue appropriate message
4231 if not Raise_Exception_Call
then
4233 ("?RETURN statement missing following this statement!",
4236 ("\?Program_Error may be raised at run time!",
4240 -- Note: we set Err even though we have not issued a warning
4241 -- because we still have a case of a missing return. This is
4242 -- an extremely marginal case, probably will never be noticed
4243 -- but we might as well get it right.
4247 -- Otherwise we have the case of a procedure marked No_Return
4251 ("?implied return after this statement will raise Program_Error",
4254 ("?procedure & is marked as No_Return",
4258 RE
: constant Node_Id
:=
4259 Make_Raise_Program_Error
(Sloc
(Last_Stm
),
4260 Reason
=> PE_Implicit_Return
);
4262 Insert_After
(Last_Stm
, RE
);
4266 end Check_Statement_Sequence
;
4268 -- Start of processing for Check_Returns
4272 Check_Statement_Sequence
(Statements
(HSS
));
4274 if Present
(Exception_Handlers
(HSS
)) then
4275 Handler
:= First_Non_Pragma
(Exception_Handlers
(HSS
));
4276 while Present
(Handler
) loop
4277 Check_Statement_Sequence
(Statements
(Handler
));
4278 Next_Non_Pragma
(Handler
);
4283 ----------------------------
4284 -- Check_Subprogram_Order --
4285 ----------------------------
4287 procedure Check_Subprogram_Order
(N
: Node_Id
) is
4289 function Subprogram_Name_Greater
(S1
, S2
: String) return Boolean;
4290 -- This is used to check if S1 > S2 in the sense required by this
4291 -- test, for example nameab < namec, but name2 < name10.
4293 -----------------------------
4294 -- Subprogram_Name_Greater --
4295 -----------------------------
4297 function Subprogram_Name_Greater
(S1
, S2
: String) return Boolean is
4302 -- Remove trailing numeric parts
4305 while S1
(L1
) in '0' .. '9' loop
4310 while S2
(L2
) in '0' .. '9' loop
4314 -- If non-numeric parts non-equal, that's decisive
4316 if S1
(S1
'First .. L1
) < S2
(S2
'First .. L2
) then
4319 elsif S1
(S1
'First .. L1
) > S2
(S2
'First .. L2
) then
4322 -- If non-numeric parts equal, compare suffixed numeric parts. Note
4323 -- that a missing suffix is treated as numeric zero in this test.
4327 while L1
< S1
'Last loop
4329 N1
:= N1
* 10 + Character'Pos (S1
(L1
)) - Character'Pos ('0');
4333 while L2
< S2
'Last loop
4335 N2
:= N2
* 10 + Character'Pos (S2
(L2
)) - Character'Pos ('0');
4340 end Subprogram_Name_Greater
;
4342 -- Start of processing for Check_Subprogram_Order
4345 -- Check body in alpha order if this is option
4348 and then Style_Check_Order_Subprograms
4349 and then Nkind
(N
) = N_Subprogram_Body
4350 and then Comes_From_Source
(N
)
4351 and then In_Extended_Main_Source_Unit
(N
)
4355 renames Scope_Stack
.Table
4356 (Scope_Stack
.Last
).Last_Subprogram_Name
;
4358 Body_Id
: constant Entity_Id
:=
4359 Defining_Entity
(Specification
(N
));
4362 Get_Decoded_Name_String
(Chars
(Body_Id
));
4365 if Subprogram_Name_Greater
4366 (LSN
.all, Name_Buffer
(1 .. Name_Len
))
4368 Style
.Subprogram_Not_In_Alpha_Order
(Body_Id
);
4374 LSN
:= new String'(Name_Buffer (1 .. Name_Len));
4377 end Check_Subprogram_Order;
4379 ------------------------------
4380 -- Check_Subtype_Conformant --
4381 ------------------------------
4383 procedure Check_Subtype_Conformant
4384 (New_Id : Entity_Id;
4386 Err_Loc : Node_Id := Empty)
4389 pragma Warnings (Off, Result);
4392 (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc);
4393 end Check_Subtype_Conformant;
4395 ---------------------------
4396 -- Check_Type_Conformant --
4397 ---------------------------
4399 procedure Check_Type_Conformant
4400 (New_Id : Entity_Id;
4402 Err_Loc : Node_Id := Empty)
4405 pragma Warnings (Off, Result);
4408 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
4409 end Check_Type_Conformant;
4411 ----------------------
4412 -- Conforming_Types --
4413 ----------------------
4415 function Conforming_Types
4418 Ctype : Conformance_Type;
4419 Get_Inst : Boolean := False) return Boolean
4421 Type_1 : Entity_Id := T1;
4422 Type_2 : Entity_Id := T2;
4423 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
4425 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
4426 -- If neither T1 nor T2 are generic actual types, or if they are in
4427 -- different scopes (e.g. parent and child instances), then verify that
4428 -- the base types are equal. Otherwise T1 and T2 must be on the same
4429 -- subtype chain. The whole purpose of this procedure is to prevent
4430 -- spurious ambiguities in an instantiation that may arise if two
4431 -- distinct generic types are instantiated with the same actual.
4433 function Find_Designated_Type (T : Entity_Id) return Entity_Id;
4434 -- An access parameter can designate an incomplete type. If the
4435 -- incomplete type is the limited view of a type from a limited_
4436 -- with_clause, check whether the non-limited view is available. If
4437 -- it is a (non-limited) incomplete type, get the full view.
4439 function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean;
4440 -- Returns True if and only if either T1 denotes a limited view of T2
4441 -- or T2 denotes a limited view of T1. This can arise when the limited
4442 -- with view of a type is used in a subprogram declaration and the
4443 -- subprogram body is in the scope of a regular with clause for the
4444 -- same unit. In such a case, the two type entities can be considered
4445 -- identical for purposes of conformance checking.
4447 ----------------------
4448 -- Base_Types_Match --
4449 ----------------------
4451 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
4456 elsif Base_Type (T1) = Base_Type (T2) then
4458 -- The following is too permissive. A more precise test should
4459 -- check that the generic actual is an ancestor subtype of the
4462 return not Is_Generic_Actual_Type (T1)
4463 or else not Is_Generic_Actual_Type (T2)
4464 or else Scope (T1) /= Scope (T2);
4469 end Base_Types_Match;
4471 --------------------------
4472 -- Find_Designated_Type --
4473 --------------------------
4475 function Find_Designated_Type (T : Entity_Id) return Entity_Id is
4479 Desig := Directly_Designated_Type (T);
4481 if Ekind (Desig) = E_Incomplete_Type then
4483 -- If regular incomplete type, get full view if available
4485 if Present (Full_View (Desig)) then
4486 Desig := Full_View (Desig);
4488 -- If limited view of a type, get non-limited view if available,
4489 -- and check again for a regular incomplete type.
4491 elsif Present (Non_Limited_View (Desig)) then
4492 Desig := Get_Full_View (Non_Limited_View (Desig));
4497 end Find_Designated_Type;
4499 -------------------------------
4500 -- Matches_Limited_With_View --
4501 -------------------------------
4503 function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is
4505 -- In some cases a type imported through a limited_with clause, and
4506 -- its nonlimited view are both visible, for example in an anonymous
4507 -- access-to-class-wide type in a formal. Both entities designate the
4510 if From_With_Type (T1)
4511 and then T2 = Available_View (T1)
4515 elsif From_With_Type (T2)
4516 and then T1 = Available_View (T2)
4523 end Matches_Limited_With_View;
4525 -- Start of processing for Conforming_Types
4528 -- The context is an instance association for a formal
4529 -- access-to-subprogram type; the formal parameter types require
4530 -- mapping because they may denote other formal parameters of the
4534 Type_1 := Get_Instance_Of (T1);
4535 Type_2 := Get_Instance_Of (T2);
4538 -- If one of the types is a view of the other introduced by a limited
4539 -- with clause, treat these as conforming for all purposes.
4541 if Matches_Limited_With_View (T1, T2) then
4544 elsif Base_Types_Match (Type_1, Type_2) then
4545 return Ctype <= Mode_Conformant
4546 or else Subtypes_Statically_Match (Type_1, Type_2);
4548 elsif Is_Incomplete_Or_Private_Type (Type_1)
4549 and then Present (Full_View (Type_1))
4550 and then Base_Types_Match (Full_View (Type_1), Type_2)
4552 return Ctype <= Mode_Conformant
4553 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
4555 elsif Ekind (Type_2) = E_Incomplete_Type
4556 and then Present (Full_View (Type_2))
4557 and then Base_Types_Match (Type_1, Full_View (Type_2))
4559 return Ctype <= Mode_Conformant
4560 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
4562 elsif Is_Private_Type (Type_2)
4563 and then In_Instance
4564 and then Present (Full_View (Type_2))
4565 and then Base_Types_Match (Type_1, Full_View (Type_2))
4567 return Ctype <= Mode_Conformant
4568 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
4571 -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
4572 -- treated recursively because they carry a signature.
4574 Are_Anonymous_Access_To_Subprogram_Types :=
4575 Ekind (Type_1) = Ekind (Type_2)
4577 (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
4579 Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
4581 -- Test anonymous access type case. For this case, static subtype
4582 -- matching is required for mode conformance (RM 6.3.1(15)). We check
4583 -- the base types because we may have built internal subtype entities
4584 -- to handle null-excluding types (see Process_Formals).
4586 if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
4588 Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
4589 or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
4592 Desig_1 : Entity_Id;
4593 Desig_2 : Entity_Id;
4596 -- In Ada2005, access constant indicators must match for
4597 -- subtype conformance.
4599 if Ada_Version >= Ada_05
4600 and then Ctype >= Subtype_Conformant
4602 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
4607 Desig_1 := Find_Designated_Type (Type_1);
4609 Desig_2 := Find_Designated_Type (Type_2);
4611 -- If the context is an instance association for a formal
4612 -- access-to-subprogram type; formal access parameter designated
4613 -- types require mapping because they may denote other formal
4614 -- parameters of the generic unit.
4617 Desig_1 := Get_Instance_Of (Desig_1);
4618 Desig_2 := Get_Instance_Of (Desig_2);
4621 -- It is possible for a Class_Wide_Type to be introduced for an
4622 -- incomplete type, in which case there is a separate class_ wide
4623 -- type for the full view. The types conform if their Etypes
4624 -- conform, i.e. one may be the full view of the other. This can
4625 -- only happen in the context of an access parameter, other uses
4626 -- of an incomplete Class_Wide_Type are illegal.
4628 if Is_Class_Wide_Type (Desig_1)
4629 and then Is_Class_Wide_Type (Desig_2)
4633 (Etype (Base_Type (Desig_1)),
4634 Etype (Base_Type (Desig_2)), Ctype);
4636 elsif Are_Anonymous_Access_To_Subprogram_Types then
4637 if Ada_Version < Ada_05 then
4638 return Ctype = Type_Conformant
4640 Subtypes_Statically_Match (Desig_1, Desig_2);
4642 -- We must check the conformance of the signatures themselves
4646 Conformant : Boolean;
4649 (Desig_1, Desig_2, Ctype, False, Conformant);
4655 return Base_Type (Desig_1) = Base_Type (Desig_2)
4656 and then (Ctype = Type_Conformant
4658 Subtypes_Statically_Match (Desig_1, Desig_2));
4662 -- Otherwise definitely no match
4665 if ((Ekind (Type_1) = E_Anonymous_Access_Type
4666 and then Is_Access_Type (Type_2))
4667 or else (Ekind (Type_2) = E_Anonymous_Access_Type
4668 and then Is_Access_Type (Type_1)))
4671 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
4673 May_Hide_Profile := True;
4678 end Conforming_Types;
4680 --------------------------
4681 -- Create_Extra_Formals --
4682 --------------------------
4684 procedure Create_Extra_Formals (E : Entity_Id) is
4686 First_Extra : Entity_Id := Empty;
4687 Last_Extra : Entity_Id;
4688 Formal_Type : Entity_Id;
4689 P_Formal : Entity_Id := Empty;
4691 function Add_Extra_Formal
4692 (Assoc_Entity : Entity_Id;
4695 Suffix : String) return Entity_Id;
4696 -- Add an extra formal to the current list of formals and extra formals.
4697 -- The extra formal is added to the end of the list of extra formals,
4698 -- and also returned as the result. These formals are always of mode IN.
4699 -- The new formal has the type Typ, is declared in Scope, and its name
4700 -- is given by a concatenation of the name of Assoc_Entity and Suffix.
4702 ----------------------
4703 -- Add_Extra_Formal --
4704 ----------------------
4706 function Add_Extra_Formal
4707 (Assoc_Entity : Entity_Id;
4710 Suffix : String) return Entity_Id
4712 EF : constant Entity_Id :=
4713 Make_Defining_Identifier (Sloc (Assoc_Entity),
4714 Chars => New_External_Name (Chars (Assoc_Entity),
4718 -- A little optimization. Never generate an extra formal for the
4719 -- _init operand of an initialization procedure, since it could
4722 if Chars (Formal) = Name_uInit then
4726 Set_Ekind (EF, E_In_Parameter);
4727 Set_Actual_Subtype (EF, Typ);
4728 Set_Etype (EF, Typ);
4729 Set_Scope (EF, Scope);
4730 Set_Mechanism (EF, Default_Mechanism);
4731 Set_Formal_Validity (EF);
4733 if No (First_Extra) then
4735 Set_Extra_Formals (Scope, First_Extra);
4738 if Present (Last_Extra) then
4739 Set_Extra_Formal (Last_Extra, EF);
4745 end Add_Extra_Formal;
4747 -- Start of processing for Create_Extra_Formals
4750 -- We never generate extra formals if expansion is not active
4751 -- because we don't need them unless we are generating code.
4753 if not Expander_Active then
4757 -- If this is a derived subprogram then the subtypes of the parent
4758 -- subprogram's formal parameters will be used to to determine the need
4759 -- for extra formals.
4761 if Is_Overloadable (E) and then Present (Alias (E)) then
4762 P_Formal := First_Formal (Alias (E));
4765 Last_Extra := Empty;
4766 Formal := First_Formal (E);
4767 while Present (Formal) loop
4768 Last_Extra := Formal;
4769 Next_Formal (Formal);
4772 -- If Extra_formals were already created, don't do it again. This
4773 -- situation may arise for subprogram types created as part of
4774 -- dispatching calls (see Expand_Dispatching_Call)
4776 if Present (Last_Extra) and then
4777 Present (Extra_Formal (Last_Extra))
4782 -- If the subprogram is a predefined dispatching subprogram then don't
4783 -- generate any extra constrained or accessibility level formals. In
4784 -- general we suppress these for internal subprograms (by not calling
4785 -- Freeze_Subprogram and Create_Extra_Formals at all), but internally
4786 -- generated stream attributes do get passed through because extra
4787 -- build-in-place formals are needed in some cases (limited 'Input
).
4789 if Is_Predefined_Dispatching_Operation
(E
) then
4790 goto Test_For_BIP_Extras
;
4793 Formal
:= First_Formal
(E
);
4794 while Present
(Formal
) loop
4796 -- Create extra formal for supporting the attribute 'Constrained.
4797 -- The case of a private type view without discriminants also
4798 -- requires the extra formal if the underlying type has defaulted
4801 if Ekind
(Formal
) /= E_In_Parameter
then
4802 if Present
(P_Formal
) then
4803 Formal_Type
:= Etype
(P_Formal
);
4805 Formal_Type
:= Etype
(Formal
);
4808 -- Do not produce extra formals for Unchecked_Union parameters.
4809 -- Jump directly to the end of the loop.
4811 if Is_Unchecked_Union
(Base_Type
(Formal_Type
)) then
4812 goto Skip_Extra_Formal_Generation
;
4815 if not Has_Discriminants
(Formal_Type
)
4816 and then Ekind
(Formal_Type
) in Private_Kind
4817 and then Present
(Underlying_Type
(Formal_Type
))
4819 Formal_Type
:= Underlying_Type
(Formal_Type
);
4822 if Has_Discriminants
(Formal_Type
)
4823 and then not Is_Constrained
(Formal_Type
)
4824 and then not Is_Indefinite_Subtype
(Formal_Type
)
4826 Set_Extra_Constrained
4827 (Formal
, Add_Extra_Formal
(Formal
, Standard_Boolean
, E
, "F"));
4831 -- Create extra formal for supporting accessibility checking. This
4832 -- is done for both anonymous access formals and formals of named
4833 -- access types that are marked as controlling formals. The latter
4834 -- case can occur when Expand_Dispatching_Call creates a subprogram
4835 -- type and substitutes the types of access-to-class-wide actuals
4836 -- for the anonymous access-to-specific-type of controlling formals.
4837 -- Base_Type is applied because in cases where there is a null
4838 -- exclusion the formal may have an access subtype.
4840 -- This is suppressed if we specifically suppress accessibility
4841 -- checks at the package level for either the subprogram, or the
4842 -- package in which it resides. However, we do not suppress it
4843 -- simply if the scope has accessibility checks suppressed, since
4844 -- this could cause trouble when clients are compiled with a
4845 -- different suppression setting. The explicit checks at the
4846 -- package level are safe from this point of view.
4848 if (Ekind
(Base_Type
(Etype
(Formal
))) = E_Anonymous_Access_Type
4849 or else (Is_Controlling_Formal
(Formal
)
4850 and then Is_Access_Type
(Base_Type
(Etype
(Formal
)))))
4852 (Explicit_Suppress
(E
, Accessibility_Check
)
4854 Explicit_Suppress
(Scope
(E
), Accessibility_Check
))
4857 or else Present
(Extra_Accessibility
(P_Formal
)))
4859 -- Temporary kludge: for now we avoid creating the extra formal
4860 -- for access parameters of protected operations because of
4861 -- problem with the case of internal protected calls. ???
4863 if Nkind
(Parent
(Parent
(Parent
(E
)))) /= N_Protected_Definition
4864 and then Nkind
(Parent
(Parent
(Parent
(E
)))) /= N_Protected_Body
4866 Set_Extra_Accessibility
4867 (Formal
, Add_Extra_Formal
(Formal
, Standard_Natural
, E
, "F"));
4871 -- This label is required when skipping extra formal generation for
4872 -- Unchecked_Union parameters.
4874 <<Skip_Extra_Formal_Generation
>>
4876 if Present
(P_Formal
) then
4877 Next_Formal
(P_Formal
);
4880 Next_Formal
(Formal
);
4883 <<Test_For_BIP_Extras
>>
4885 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
4886 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
4888 if Ada_Version
>= Ada_05
and then Is_Build_In_Place_Function
(E
) then
4890 Result_Subt
: constant Entity_Id
:= Etype
(E
);
4892 Discard
: Entity_Id
;
4893 pragma Warnings
(Off
, Discard
);
4896 -- In the case of functions with unconstrained result subtypes,
4897 -- add a 3-state formal indicating whether the return object is
4898 -- allocated by the caller (0), or should be allocated by the
4899 -- callee on the secondary stack (1) or in the global heap (2).
4900 -- For the moment we just use Natural for the type of this formal.
4901 -- Note that this formal isn't usually needed in the case where
4902 -- the result subtype is constrained, but it is needed when the
4903 -- function has a tagged result, because generally such functions
4904 -- can be called in a dispatching context and such calls must be
4905 -- handled like calls to a class-wide function.
4907 if not Is_Constrained
(Result_Subt
)
4908 or else Is_Tagged_Type
(Underlying_Type
(Result_Subt
))
4912 (E
, Standard_Natural
,
4913 E
, BIP_Formal_Suffix
(BIP_Alloc_Form
));
4916 -- In the case of functions whose result type has controlled
4917 -- parts, we have an extra formal of type
4918 -- System.Finalization_Implementation.Finalizable_Ptr_Ptr. That
4919 -- is, we are passing a pointer to a finalization list (which is
4920 -- itself a pointer). This extra formal is then passed along to
4921 -- Move_Final_List in case of successful completion of a return
4922 -- statement. We cannot pass an 'in out' parameter, because we
4923 -- need to update the finalization list during an abort-deferred
4924 -- region, rather than using copy-back after the function
4925 -- returns. This is true even if we are able to get away with
4926 -- having 'in out' parameters, which are normally illegal for
4927 -- functions. This formal is also needed when the function has
4928 -- a tagged result, because generally such functions can be called
4929 -- in a dispatching context and such calls must be handled like
4930 -- calls to class-wide functions.
4932 if Controlled_Type
(Result_Subt
)
4933 or else Is_Tagged_Type
(Underlying_Type
(Result_Subt
))
4937 (E
, RTE
(RE_Finalizable_Ptr_Ptr
),
4938 E
, BIP_Formal_Suffix
(BIP_Final_List
));
4941 -- If the result type contains tasks, we have two extra formals:
4942 -- the master of the tasks to be created, and the caller's
4943 -- activation chain.
4945 if Has_Task
(Result_Subt
) then
4948 (E
, RTE
(RE_Master_Id
),
4949 E
, BIP_Formal_Suffix
(BIP_Master
));
4952 (E
, RTE
(RE_Activation_Chain_Access
),
4953 E
, BIP_Formal_Suffix
(BIP_Activation_Chain
));
4956 -- All build-in-place functions get an extra formal that will be
4957 -- passed the address of the return object within the caller.
4960 Formal_Type
: constant Entity_Id
:=
4962 (E_Anonymous_Access_Type
, E
,
4963 Scope_Id
=> Scope
(E
));
4965 Set_Directly_Designated_Type
(Formal_Type
, Result_Subt
);
4966 Set_Etype
(Formal_Type
, Formal_Type
);
4967 Init_Size_Align
(Formal_Type
);
4968 Set_Depends_On_Private
4969 (Formal_Type
, Has_Private_Component
(Formal_Type
));
4970 Set_Is_Public
(Formal_Type
, Is_Public
(Scope
(Formal_Type
)));
4971 Set_Is_Access_Constant
(Formal_Type
, False);
4973 -- Ada 2005 (AI-50217): Propagate the attribute that indicates
4974 -- the designated type comes from the limited view (for
4975 -- back-end purposes).
4977 Set_From_With_Type
(Formal_Type
, From_With_Type
(Result_Subt
));
4979 Layout_Type
(Formal_Type
);
4983 (E
, Formal_Type
, E
, BIP_Formal_Suffix
(BIP_Object_Access
));
4987 end Create_Extra_Formals
;
4989 -----------------------------
4990 -- Enter_Overloaded_Entity --
4991 -----------------------------
4993 procedure Enter_Overloaded_Entity
(S
: Entity_Id
) is
4994 E
: Entity_Id
:= Current_Entity_In_Scope
(S
);
4995 C_E
: Entity_Id
:= Current_Entity
(S
);
4999 Set_Has_Homonym
(E
);
5000 Set_Has_Homonym
(S
);
5003 Set_Is_Immediately_Visible
(S
);
5004 Set_Scope
(S
, Current_Scope
);
5006 -- Chain new entity if front of homonym in current scope, so that
5007 -- homonyms are contiguous.
5012 while Homonym
(C_E
) /= E
loop
5013 C_E
:= Homonym
(C_E
);
5016 Set_Homonym
(C_E
, S
);
5020 Set_Current_Entity
(S
);
5025 Append_Entity
(S
, Current_Scope
);
5026 Set_Public_Status
(S
);
5028 if Debug_Flag_E
then
5029 Write_Str
("New overloaded entity chain: ");
5030 Write_Name
(Chars
(S
));
5033 while Present
(E
) loop
5034 Write_Str
(" "); Write_Int
(Int
(E
));
5041 -- Generate warning for hiding
5044 and then Comes_From_Source
(S
)
5045 and then In_Extended_Main_Source_Unit
(S
)
5052 -- Warn unless genuine overloading
5054 if (not Is_Overloadable
(E
) or else Subtype_Conformant
(E
, S
))
5055 and then (Is_Immediately_Visible
(E
)
5057 Is_Potentially_Use_Visible
(S
))
5059 Error_Msg_Sloc
:= Sloc
(E
);
5060 Error_Msg_N
("declaration of & hides one#?", S
);
5064 end Enter_Overloaded_Entity
;
5066 -----------------------------
5067 -- Find_Corresponding_Spec --
5068 -----------------------------
5070 function Find_Corresponding_Spec
(N
: Node_Id
) return Entity_Id
is
5071 Spec
: constant Node_Id
:= Specification
(N
);
5072 Designator
: constant Entity_Id
:= Defining_Entity
(Spec
);
5077 E
:= Current_Entity
(Designator
);
5078 while Present
(E
) loop
5080 -- We are looking for a matching spec. It must have the same scope,
5081 -- and the same name, and either be type conformant, or be the case
5082 -- of a library procedure spec and its body (which belong to one
5083 -- another regardless of whether they are type conformant or not).
5085 if Scope
(E
) = Current_Scope
then
5086 if Current_Scope
= Standard_Standard
5087 or else (Ekind
(E
) = Ekind
(Designator
)
5088 and then Type_Conformant
(E
, Designator
))
5090 -- Within an instantiation, we know that spec and body are
5091 -- subtype conformant, because they were subtype conformant
5092 -- in the generic. We choose the subtype-conformant entity
5093 -- here as well, to resolve spurious ambiguities in the
5094 -- instance that were not present in the generic (i.e. when
5095 -- two different types are given the same actual). If we are
5096 -- looking for a spec to match a body, full conformance is
5100 Set_Convention
(Designator
, Convention
(E
));
5102 if Nkind
(N
) = N_Subprogram_Body
5103 and then Present
(Homonym
(E
))
5104 and then not Fully_Conformant
(E
, Designator
)
5108 elsif not Subtype_Conformant
(E
, Designator
) then
5113 if not Has_Completion
(E
) then
5115 if Nkind
(N
) /= N_Subprogram_Body_Stub
then
5116 Set_Corresponding_Spec
(N
, E
);
5119 Set_Has_Completion
(E
);
5122 elsif Nkind
(Parent
(N
)) = N_Subunit
then
5124 -- If this is the proper body of a subunit, the completion
5125 -- flag is set when analyzing the stub.
5129 -- If E is an internal function with a controlling result
5130 -- that was created for an operation inherited by a null
5131 -- extension, it may be overridden by a body without a previous
5132 -- spec (one more reason why these should be shunned). In that
5133 -- case remove the generated body, because the current one is
5134 -- the explicit overriding.
5136 elsif Ekind
(E
) = E_Function
5137 and then Ada_Version
>= Ada_05
5138 and then not Comes_From_Source
(E
)
5139 and then Has_Controlling_Result
(E
)
5140 and then Is_Null_Extension
(Etype
(E
))
5141 and then Comes_From_Source
(Spec
)
5143 Set_Has_Completion
(E
, False);
5145 if Expander_Active
then
5147 (Unit_Declaration_Node
5148 (Corresponding_Body
(Unit_Declaration_Node
(E
))));
5151 -- If expansion is disabled, the wrapper function has not
5152 -- been generated, and this is the standard case of a late
5153 -- body overriding an inherited operation.
5159 -- If body already exists, this is an error unless the
5160 -- previous declaration is the implicit declaration of
5161 -- a derived subprogram, or this is a spurious overloading
5164 elsif No
(Alias
(E
))
5165 and then not Is_Intrinsic_Subprogram
(E
)
5166 and then not In_Instance
5168 Error_Msg_Sloc
:= Sloc
(E
);
5169 if Is_Imported
(E
) then
5171 ("body not allowed for imported subprogram & declared#",
5174 Error_Msg_NE
("duplicate body for & declared#", N
, E
);
5178 elsif Is_Child_Unit
(E
)
5180 Nkind
(Unit_Declaration_Node
(Designator
)) = N_Subprogram_Body
5182 Nkind
(Parent
(Unit_Declaration_Node
(Designator
))) =
5185 -- Child units cannot be overloaded, so a conformance mismatch
5186 -- between body and a previous spec is an error.
5189 ("body of child unit does not match previous declaration", N
);
5197 -- On exit, we know that no previous declaration of subprogram exists
5200 end Find_Corresponding_Spec
;
5202 ----------------------
5203 -- Fully_Conformant --
5204 ----------------------
5206 function Fully_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
5209 Check_Conformance
(New_Id
, Old_Id
, Fully_Conformant
, False, Result
);
5211 end Fully_Conformant
;
5213 ----------------------------------
5214 -- Fully_Conformant_Expressions --
5215 ----------------------------------
5217 function Fully_Conformant_Expressions
5218 (Given_E1
: Node_Id
;
5219 Given_E2
: Node_Id
) return Boolean
5221 E1
: constant Node_Id
:= Original_Node
(Given_E1
);
5222 E2
: constant Node_Id
:= Original_Node
(Given_E2
);
5223 -- We always test conformance on original nodes, since it is possible
5224 -- for analysis and/or expansion to make things look as though they
5225 -- conform when they do not, e.g. by converting 1+2 into 3.
5227 function FCE
(Given_E1
, Given_E2
: Node_Id
) return Boolean
5228 renames Fully_Conformant_Expressions
;
5230 function FCL
(L1
, L2
: List_Id
) return Boolean;
5231 -- Compare elements of two lists for conformance. Elements have to
5232 -- be conformant, and actuals inserted as default parameters do not
5233 -- match explicit actuals with the same value.
5235 function FCO
(Op_Node
, Call_Node
: Node_Id
) return Boolean;
5236 -- Compare an operator node with a function call
5242 function FCL
(L1
, L2
: List_Id
) return Boolean is
5246 if L1
= No_List
then
5252 if L2
= No_List
then
5258 -- Compare two lists, skipping rewrite insertions (we want to
5259 -- compare the original trees, not the expanded versions!)
5262 if Is_Rewrite_Insertion
(N1
) then
5264 elsif Is_Rewrite_Insertion
(N2
) then
5270 elsif not FCE
(N1
, N2
) then
5283 function FCO
(Op_Node
, Call_Node
: Node_Id
) return Boolean is
5284 Actuals
: constant List_Id
:= Parameter_Associations
(Call_Node
);
5289 or else Entity
(Op_Node
) /= Entity
(Name
(Call_Node
))
5294 Act
:= First
(Actuals
);
5296 if Nkind
(Op_Node
) in N_Binary_Op
then
5298 if not FCE
(Left_Opnd
(Op_Node
), Act
) then
5305 return Present
(Act
)
5306 and then FCE
(Right_Opnd
(Op_Node
), Act
)
5307 and then No
(Next
(Act
));
5311 -- Start of processing for Fully_Conformant_Expressions
5314 -- Non-conformant if paren count does not match. Note: if some idiot
5315 -- complains that we don't do this right for more than 3 levels of
5316 -- parentheses, they will be treated with the respect they deserve!
5318 if Paren_Count
(E1
) /= Paren_Count
(E2
) then
5321 -- If same entities are referenced, then they are conformant even if
5322 -- they have different forms (RM 8.3.1(19-20)).
5324 elsif Is_Entity_Name
(E1
) and then Is_Entity_Name
(E2
) then
5325 if Present
(Entity
(E1
)) then
5326 return Entity
(E1
) = Entity
(E2
)
5327 or else (Chars
(Entity
(E1
)) = Chars
(Entity
(E2
))
5328 and then Ekind
(Entity
(E1
)) = E_Discriminant
5329 and then Ekind
(Entity
(E2
)) = E_In_Parameter
);
5331 elsif Nkind
(E1
) = N_Expanded_Name
5332 and then Nkind
(E2
) = N_Expanded_Name
5333 and then Nkind
(Selector_Name
(E1
)) = N_Character_Literal
5334 and then Nkind
(Selector_Name
(E2
)) = N_Character_Literal
5336 return Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
));
5339 -- Identifiers in component associations don't always have
5340 -- entities, but their names must conform.
5342 return Nkind
(E1
) = N_Identifier
5343 and then Nkind
(E2
) = N_Identifier
5344 and then Chars
(E1
) = Chars
(E2
);
5347 elsif Nkind
(E1
) = N_Character_Literal
5348 and then Nkind
(E2
) = N_Expanded_Name
5350 return Nkind
(Selector_Name
(E2
)) = N_Character_Literal
5351 and then Chars
(E1
) = Chars
(Selector_Name
(E2
));
5353 elsif Nkind
(E2
) = N_Character_Literal
5354 and then Nkind
(E1
) = N_Expanded_Name
5356 return Nkind
(Selector_Name
(E1
)) = N_Character_Literal
5357 and then Chars
(E2
) = Chars
(Selector_Name
(E1
));
5359 elsif Nkind
(E1
) in N_Op
5360 and then Nkind
(E2
) = N_Function_Call
5362 return FCO
(E1
, E2
);
5364 elsif Nkind
(E2
) in N_Op
5365 and then Nkind
(E1
) = N_Function_Call
5367 return FCO
(E2
, E1
);
5369 -- Otherwise we must have the same syntactic entity
5371 elsif Nkind
(E1
) /= Nkind
(E2
) then
5374 -- At this point, we specialize by node type
5381 FCL
(Expressions
(E1
), Expressions
(E2
))
5382 and then FCL
(Component_Associations
(E1
),
5383 Component_Associations
(E2
));
5386 if Nkind
(Expression
(E1
)) = N_Qualified_Expression
5388 Nkind
(Expression
(E2
)) = N_Qualified_Expression
5390 return FCE
(Expression
(E1
), Expression
(E2
));
5392 -- Check that the subtype marks and any constraints
5397 Indic1
: constant Node_Id
:= Expression
(E1
);
5398 Indic2
: constant Node_Id
:= Expression
(E2
);
5403 if Nkind
(Indic1
) /= N_Subtype_Indication
then
5405 Nkind
(Indic2
) /= N_Subtype_Indication
5406 and then Entity
(Indic1
) = Entity
(Indic2
);
5408 elsif Nkind
(Indic2
) /= N_Subtype_Indication
then
5410 Nkind
(Indic1
) /= N_Subtype_Indication
5411 and then Entity
(Indic1
) = Entity
(Indic2
);
5414 if Entity
(Subtype_Mark
(Indic1
)) /=
5415 Entity
(Subtype_Mark
(Indic2
))
5420 Elt1
:= First
(Constraints
(Constraint
(Indic1
)));
5421 Elt2
:= First
(Constraints
(Constraint
(Indic2
)));
5423 while Present
(Elt1
) and then Present
(Elt2
) loop
5424 if not FCE
(Elt1
, Elt2
) then
5437 when N_Attribute_Reference
=>
5439 Attribute_Name
(E1
) = Attribute_Name
(E2
)
5440 and then FCL
(Expressions
(E1
), Expressions
(E2
));
5444 Entity
(E1
) = Entity
(E2
)
5445 and then FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
5446 and then FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
5448 when N_And_Then | N_Or_Else | N_Membership_Test
=>
5450 FCE
(Left_Opnd
(E1
), Left_Opnd
(E2
))
5452 FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
5454 when N_Character_Literal
=>
5456 Char_Literal_Value
(E1
) = Char_Literal_Value
(E2
);
5458 when N_Component_Association
=>
5460 FCL
(Choices
(E1
), Choices
(E2
))
5461 and then FCE
(Expression
(E1
), Expression
(E2
));
5463 when N_Conditional_Expression
=>
5465 FCL
(Expressions
(E1
), Expressions
(E2
));
5467 when N_Explicit_Dereference
=>
5469 FCE
(Prefix
(E1
), Prefix
(E2
));
5471 when N_Extension_Aggregate
=>
5473 FCL
(Expressions
(E1
), Expressions
(E2
))
5474 and then Null_Record_Present
(E1
) =
5475 Null_Record_Present
(E2
)
5476 and then FCL
(Component_Associations
(E1
),
5477 Component_Associations
(E2
));
5479 when N_Function_Call
=>
5481 FCE
(Name
(E1
), Name
(E2
))
5482 and then FCL
(Parameter_Associations
(E1
),
5483 Parameter_Associations
(E2
));
5485 when N_Indexed_Component
=>
5487 FCE
(Prefix
(E1
), Prefix
(E2
))
5488 and then FCL
(Expressions
(E1
), Expressions
(E2
));
5490 when N_Integer_Literal
=>
5491 return (Intval
(E1
) = Intval
(E2
));
5496 when N_Operator_Symbol
=>
5498 Chars
(E1
) = Chars
(E2
);
5500 when N_Others_Choice
=>
5503 when N_Parameter_Association
=>
5505 Chars
(Selector_Name
(E1
)) = Chars
(Selector_Name
(E2
))
5506 and then FCE
(Explicit_Actual_Parameter
(E1
),
5507 Explicit_Actual_Parameter
(E2
));
5509 when N_Qualified_Expression
=>
5511 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
5512 and then FCE
(Expression
(E1
), Expression
(E2
));
5516 FCE
(Low_Bound
(E1
), Low_Bound
(E2
))
5517 and then FCE
(High_Bound
(E1
), High_Bound
(E2
));
5519 when N_Real_Literal
=>
5520 return (Realval
(E1
) = Realval
(E2
));
5522 when N_Selected_Component
=>
5524 FCE
(Prefix
(E1
), Prefix
(E2
))
5525 and then FCE
(Selector_Name
(E1
), Selector_Name
(E2
));
5529 FCE
(Prefix
(E1
), Prefix
(E2
))
5530 and then FCE
(Discrete_Range
(E1
), Discrete_Range
(E2
));
5532 when N_String_Literal
=>
5534 S1
: constant String_Id
:= Strval
(E1
);
5535 S2
: constant String_Id
:= Strval
(E2
);
5536 L1
: constant Nat
:= String_Length
(S1
);
5537 L2
: constant Nat
:= String_Length
(S2
);
5544 for J
in 1 .. L1
loop
5545 if Get_String_Char
(S1
, J
) /=
5546 Get_String_Char
(S2
, J
)
5556 when N_Type_Conversion
=>
5558 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
5559 and then FCE
(Expression
(E1
), Expression
(E2
));
5563 Entity
(E1
) = Entity
(E2
)
5564 and then FCE
(Right_Opnd
(E1
), Right_Opnd
(E2
));
5566 when N_Unchecked_Type_Conversion
=>
5568 FCE
(Subtype_Mark
(E1
), Subtype_Mark
(E2
))
5569 and then FCE
(Expression
(E1
), Expression
(E2
));
5571 -- All other node types cannot appear in this context. Strictly
5572 -- we should raise a fatal internal error. Instead we just ignore
5573 -- the nodes. This means that if anyone makes a mistake in the
5574 -- expander and mucks an expression tree irretrievably, the
5575 -- result will be a failure to detect a (probably very obscure)
5576 -- case of non-conformance, which is better than bombing on some
5577 -- case where two expressions do in fact conform.
5584 end Fully_Conformant_Expressions
;
5586 ----------------------------------------
5587 -- Fully_Conformant_Discrete_Subtypes --
5588 ----------------------------------------
5590 function Fully_Conformant_Discrete_Subtypes
5591 (Given_S1
: Node_Id
;
5592 Given_S2
: Node_Id
) return Boolean
5594 S1
: constant Node_Id
:= Original_Node
(Given_S1
);
5595 S2
: constant Node_Id
:= Original_Node
(Given_S2
);
5597 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean;
5598 -- Special-case for a bound given by a discriminant, which in the body
5599 -- is replaced with the discriminal of the enclosing type.
5601 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean;
5602 -- Check both bounds
5604 -----------------------
5605 -- Conforming_Bounds --
5606 -----------------------
5608 function Conforming_Bounds
(B1
, B2
: Node_Id
) return Boolean is
5610 if Is_Entity_Name
(B1
)
5611 and then Is_Entity_Name
(B2
)
5612 and then Ekind
(Entity
(B1
)) = E_Discriminant
5614 return Chars
(B1
) = Chars
(B2
);
5617 return Fully_Conformant_Expressions
(B1
, B2
);
5619 end Conforming_Bounds
;
5621 -----------------------
5622 -- Conforming_Ranges --
5623 -----------------------
5625 function Conforming_Ranges
(R1
, R2
: Node_Id
) return Boolean is
5628 Conforming_Bounds
(Low_Bound
(R1
), Low_Bound
(R2
))
5630 Conforming_Bounds
(High_Bound
(R1
), High_Bound
(R2
));
5631 end Conforming_Ranges
;
5633 -- Start of processing for Fully_Conformant_Discrete_Subtypes
5636 if Nkind
(S1
) /= Nkind
(S2
) then
5639 elsif Is_Entity_Name
(S1
) then
5640 return Entity
(S1
) = Entity
(S2
);
5642 elsif Nkind
(S1
) = N_Range
then
5643 return Conforming_Ranges
(S1
, S2
);
5645 elsif Nkind
(S1
) = N_Subtype_Indication
then
5647 Entity
(Subtype_Mark
(S1
)) = Entity
(Subtype_Mark
(S2
))
5650 (Range_Expression
(Constraint
(S1
)),
5651 Range_Expression
(Constraint
(S2
)));
5655 end Fully_Conformant_Discrete_Subtypes
;
5657 --------------------
5658 -- Install_Entity --
5659 --------------------
5661 procedure Install_Entity
(E
: Entity_Id
) is
5662 Prev
: constant Entity_Id
:= Current_Entity
(E
);
5664 Set_Is_Immediately_Visible
(E
);
5665 Set_Current_Entity
(E
);
5666 Set_Homonym
(E
, Prev
);
5669 ---------------------
5670 -- Install_Formals --
5671 ---------------------
5673 procedure Install_Formals
(Id
: Entity_Id
) is
5676 F
:= First_Formal
(Id
);
5677 while Present
(F
) loop
5681 end Install_Formals
;
5683 ---------------------------------
5684 -- Is_Non_Overriding_Operation --
5685 ---------------------------------
5687 function Is_Non_Overriding_Operation
5688 (Prev_E
: Entity_Id
;
5689 New_E
: Entity_Id
) return Boolean
5693 G_Typ
: Entity_Id
:= Empty
;
5695 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
;
5696 -- If F_Type is a derived type associated with a generic actual subtype,
5697 -- then return its Generic_Parent_Type attribute, else return Empty.
5699 function Types_Correspond
5700 (P_Type
: Entity_Id
;
5701 N_Type
: Entity_Id
) return Boolean;
5702 -- Returns true if and only if the types (or designated types in the
5703 -- case of anonymous access types) are the same or N_Type is derived
5704 -- directly or indirectly from P_Type.
5706 -----------------------------
5707 -- Get_Generic_Parent_Type --
5708 -----------------------------
5710 function Get_Generic_Parent_Type
(F_Typ
: Entity_Id
) return Entity_Id
is
5715 if Is_Derived_Type
(F_Typ
)
5716 and then Nkind
(Parent
(F_Typ
)) = N_Full_Type_Declaration
5718 -- The tree must be traversed to determine the parent subtype in
5719 -- the generic unit, which unfortunately isn't always available
5720 -- via semantic attributes. ??? (Note: The use of Original_Node
5721 -- is needed for cases where a full derived type has been
5724 Indic
:= Subtype_Indication
5725 (Type_Definition
(Original_Node
(Parent
(F_Typ
))));
5727 if Nkind
(Indic
) = N_Subtype_Indication
then
5728 G_Typ
:= Entity
(Subtype_Mark
(Indic
));
5730 G_Typ
:= Entity
(Indic
);
5733 if Nkind
(Parent
(G_Typ
)) = N_Subtype_Declaration
5734 and then Present
(Generic_Parent_Type
(Parent
(G_Typ
)))
5736 return Generic_Parent_Type
(Parent
(G_Typ
));
5741 end Get_Generic_Parent_Type
;
5743 ----------------------
5744 -- Types_Correspond --
5745 ----------------------
5747 function Types_Correspond
5748 (P_Type
: Entity_Id
;
5749 N_Type
: Entity_Id
) return Boolean
5751 Prev_Type
: Entity_Id
:= Base_Type
(P_Type
);
5752 New_Type
: Entity_Id
:= Base_Type
(N_Type
);
5755 if Ekind
(Prev_Type
) = E_Anonymous_Access_Type
then
5756 Prev_Type
:= Designated_Type
(Prev_Type
);
5759 if Ekind
(New_Type
) = E_Anonymous_Access_Type
then
5760 New_Type
:= Designated_Type
(New_Type
);
5763 if Prev_Type
= New_Type
then
5766 elsif not Is_Class_Wide_Type
(New_Type
) then
5767 while Etype
(New_Type
) /= New_Type
loop
5768 New_Type
:= Etype
(New_Type
);
5769 if New_Type
= Prev_Type
then
5775 end Types_Correspond
;
5777 -- Start of processing for Is_Non_Overriding_Operation
5780 -- In the case where both operations are implicit derived subprograms
5781 -- then neither overrides the other. This can only occur in certain
5782 -- obscure cases (e.g., derivation from homographs created in a generic
5785 if Present
(Alias
(Prev_E
)) and then Present
(Alias
(New_E
)) then
5788 elsif Ekind
(Current_Scope
) = E_Package
5789 and then Is_Generic_Instance
(Current_Scope
)
5790 and then In_Private_Part
(Current_Scope
)
5791 and then Comes_From_Source
(New_E
)
5793 -- We examine the formals and result subtype of the inherited
5794 -- operation, to determine whether their type is derived from (the
5795 -- instance of) a generic type.
5797 Formal
:= First_Formal
(Prev_E
);
5799 while Present
(Formal
) loop
5800 F_Typ
:= Base_Type
(Etype
(Formal
));
5802 if Ekind
(F_Typ
) = E_Anonymous_Access_Type
then
5803 F_Typ
:= Designated_Type
(F_Typ
);
5806 G_Typ
:= Get_Generic_Parent_Type
(F_Typ
);
5808 Next_Formal
(Formal
);
5811 if No
(G_Typ
) and then Ekind
(Prev_E
) = E_Function
then
5812 G_Typ
:= Get_Generic_Parent_Type
(Base_Type
(Etype
(Prev_E
)));
5819 -- If the generic type is a private type, then the original
5820 -- operation was not overriding in the generic, because there was
5821 -- no primitive operation to override.
5823 if Nkind
(Parent
(G_Typ
)) = N_Formal_Type_Declaration
5824 and then Nkind
(Formal_Type_Definition
(Parent
(G_Typ
))) =
5825 N_Formal_Private_Type_Definition
5829 -- The generic parent type is the ancestor of a formal derived
5830 -- type declaration. We need to check whether it has a primitive
5831 -- operation that should be overridden by New_E in the generic.
5835 P_Formal
: Entity_Id
;
5836 N_Formal
: Entity_Id
;
5840 Prim_Elt
: Elmt_Id
:= First_Elmt
(Primitive_Operations
(G_Typ
));
5843 while Present
(Prim_Elt
) loop
5844 P_Prim
:= Node
(Prim_Elt
);
5846 if Chars
(P_Prim
) = Chars
(New_E
)
5847 and then Ekind
(P_Prim
) = Ekind
(New_E
)
5849 P_Formal
:= First_Formal
(P_Prim
);
5850 N_Formal
:= First_Formal
(New_E
);
5851 while Present
(P_Formal
) and then Present
(N_Formal
) loop
5852 P_Typ
:= Etype
(P_Formal
);
5853 N_Typ
:= Etype
(N_Formal
);
5855 if not Types_Correspond
(P_Typ
, N_Typ
) then
5859 Next_Entity
(P_Formal
);
5860 Next_Entity
(N_Formal
);
5863 -- Found a matching primitive operation belonging to the
5864 -- formal ancestor type, so the new subprogram is
5868 and then No
(N_Formal
)
5869 and then (Ekind
(New_E
) /= E_Function
5872 (Etype
(P_Prim
), Etype
(New_E
)))
5878 Next_Elmt
(Prim_Elt
);
5881 -- If no match found, then the new subprogram does not
5882 -- override in the generic (nor in the instance).
5890 end Is_Non_Overriding_Operation
;
5892 ------------------------------
5893 -- Make_Inequality_Operator --
5894 ------------------------------
5896 -- S is the defining identifier of an equality operator. We build a
5897 -- subprogram declaration with the right signature. This operation is
5898 -- intrinsic, because it is always expanded as the negation of the
5899 -- call to the equality function.
5901 procedure Make_Inequality_Operator
(S
: Entity_Id
) is
5902 Loc
: constant Source_Ptr
:= Sloc
(S
);
5905 Op_Name
: Entity_Id
;
5907 FF
: constant Entity_Id
:= First_Formal
(S
);
5908 NF
: constant Entity_Id
:= Next_Formal
(FF
);
5911 -- Check that equality was properly defined, ignore call if not
5918 A
: constant Entity_Id
:=
5919 Make_Defining_Identifier
(Sloc
(FF
),
5920 Chars
=> Chars
(FF
));
5922 B
: constant Entity_Id
:=
5923 Make_Defining_Identifier
(Sloc
(NF
),
5924 Chars
=> Chars
(NF
));
5927 Op_Name
:= Make_Defining_Operator_Symbol
(Loc
, Name_Op_Ne
);
5929 Formals
:= New_List
(
5930 Make_Parameter_Specification
(Loc
,
5931 Defining_Identifier
=> A
,
5933 New_Reference_To
(Etype
(First_Formal
(S
)),
5934 Sloc
(Etype
(First_Formal
(S
))))),
5936 Make_Parameter_Specification
(Loc
,
5937 Defining_Identifier
=> B
,
5939 New_Reference_To
(Etype
(Next_Formal
(First_Formal
(S
))),
5940 Sloc
(Etype
(Next_Formal
(First_Formal
(S
)))))));
5943 Make_Subprogram_Declaration
(Loc
,
5945 Make_Function_Specification
(Loc
,
5946 Defining_Unit_Name
=> Op_Name
,
5947 Parameter_Specifications
=> Formals
,
5948 Result_Definition
=>
5949 New_Reference_To
(Standard_Boolean
, Loc
)));
5951 -- Insert inequality right after equality if it is explicit or after
5952 -- the derived type when implicit. These entities are created only
5953 -- for visibility purposes, and eventually replaced in the course of
5954 -- expansion, so they do not need to be attached to the tree and seen
5955 -- by the back-end. Keeping them internal also avoids spurious
5956 -- freezing problems. The declaration is inserted in the tree for
5957 -- analysis, and removed afterwards. If the equality operator comes
5958 -- from an explicit declaration, attach the inequality immediately
5959 -- after. Else the equality is inherited from a derived type
5960 -- declaration, so insert inequality after that declaration.
5962 if No
(Alias
(S
)) then
5963 Insert_After
(Unit_Declaration_Node
(S
), Decl
);
5964 elsif Is_List_Member
(Parent
(S
)) then
5965 Insert_After
(Parent
(S
), Decl
);
5967 Insert_After
(Parent
(Etype
(First_Formal
(S
))), Decl
);
5970 Mark_Rewrite_Insertion
(Decl
);
5971 Set_Is_Intrinsic_Subprogram
(Op_Name
);
5974 Set_Has_Completion
(Op_Name
);
5975 Set_Corresponding_Equality
(Op_Name
, S
);
5976 Set_Is_Abstract_Subprogram
(Op_Name
, Is_Abstract_Subprogram
(S
));
5978 end Make_Inequality_Operator
;
5980 ----------------------
5981 -- May_Need_Actuals --
5982 ----------------------
5984 procedure May_Need_Actuals
(Fun
: Entity_Id
) is
5989 F
:= First_Formal
(Fun
);
5991 while Present
(F
) loop
5992 if No
(Default_Value
(F
)) then
6000 Set_Needs_No_Actuals
(Fun
, B
);
6001 end May_Need_Actuals
;
6003 ---------------------
6004 -- Mode_Conformant --
6005 ---------------------
6007 function Mode_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
6010 Check_Conformance
(New_Id
, Old_Id
, Mode_Conformant
, False, Result
);
6012 end Mode_Conformant
;
6014 ---------------------------
6015 -- New_Overloaded_Entity --
6016 ---------------------------
6018 procedure New_Overloaded_Entity
6020 Derived_Type
: Entity_Id
:= Empty
)
6022 Overridden_Subp
: Entity_Id
:= Empty
;
6023 -- Set if the current scope has an operation that is type-conformant
6024 -- with S, and becomes hidden by S.
6026 Is_Primitive_Subp
: Boolean;
6027 -- Set to True if the new subprogram is primitive
6030 -- Entity that S overrides
6032 Prev_Vis
: Entity_Id
:= Empty
;
6033 -- Predecessor of E in Homonym chain
6035 procedure Check_For_Primitive_Subprogram
6036 (Is_Primitive
: out Boolean;
6037 Is_Overriding
: Boolean := False);
6038 -- If the subprogram being analyzed is a primitive operation of the type
6039 -- of a formal or result, set the Has_Primitive_Operations flag on the
6040 -- type, and set Is_Primitive to True (otherwise set to False). Set the
6041 -- corresponding flag on the entity itself for later use.
6043 procedure Check_Synchronized_Overriding
6044 (Def_Id
: Entity_Id
;
6045 First_Hom
: Entity_Id
;
6046 Overridden_Subp
: out Entity_Id
);
6047 -- First determine if Def_Id is an entry or a subprogram either defined
6048 -- in the scope of a task or protected type, or is a primitive of such
6049 -- a type. Check whether Def_Id overrides a subprogram of an interface
6050 -- implemented by the synchronized type, return the overridden entity
6053 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean;
6054 -- Check that E is declared in the private part of the current package,
6055 -- or in the package body, where it may hide a previous declaration.
6056 -- We can't use In_Private_Part by itself because this flag is also
6057 -- set when freezing entities, so we must examine the place of the
6058 -- declaration in the tree, and recognize wrapper packages as well.
6060 ------------------------------------
6061 -- Check_For_Primitive_Subprogram --
6062 ------------------------------------
6064 procedure Check_For_Primitive_Subprogram
6065 (Is_Primitive
: out Boolean;
6066 Is_Overriding
: Boolean := False)
6072 function Visible_Part_Type
(T
: Entity_Id
) return Boolean;
6073 -- Returns true if T is declared in the visible part of
6074 -- the current package scope; otherwise returns false.
6075 -- Assumes that T is declared in a package.
6077 procedure Check_Private_Overriding
(T
: Entity_Id
);
6078 -- Checks that if a primitive abstract subprogram of a visible
6079 -- abstract type is declared in a private part, then it must
6080 -- override an abstract subprogram declared in the visible part.
6081 -- Also checks that if a primitive function with a controlling
6082 -- result is declared in a private part, then it must override
6083 -- a function declared in the visible part.
6085 ------------------------------
6086 -- Check_Private_Overriding --
6087 ------------------------------
6089 procedure Check_Private_Overriding
(T
: Entity_Id
) is
6091 if Ekind
(Current_Scope
) = E_Package
6092 and then In_Private_Part
(Current_Scope
)
6093 and then Visible_Part_Type
(T
)
6094 and then not In_Instance
6096 if Is_Abstract_Type
(T
)
6097 and then Is_Abstract_Subprogram
(S
)
6098 and then (not Is_Overriding
6099 or else not Is_Abstract_Subprogram
(E
))
6101 Error_Msg_N
("abstract subprograms must be visible "
6102 & "(RM 3.9.3(10))!", S
);
6104 elsif Ekind
(S
) = E_Function
6105 and then Is_Tagged_Type
(T
)
6106 and then T
= Base_Type
(Etype
(S
))
6107 and then not Is_Overriding
6110 ("private function with tagged result must"
6111 & " override visible-part function", S
);
6113 ("\move subprogram to the visible part"
6114 & " (RM 3.9.3(10))", S
);
6117 end Check_Private_Overriding
;
6119 -----------------------
6120 -- Visible_Part_Type --
6121 -----------------------
6123 function Visible_Part_Type
(T
: Entity_Id
) return Boolean is
6124 P
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(T
));
6128 -- If the entity is a private type, then it must be
6129 -- declared in a visible part.
6131 if Ekind
(T
) in Private_Kind
then
6135 -- Otherwise, we traverse the visible part looking for its
6136 -- corresponding declaration. We cannot use the declaration
6137 -- node directly because in the private part the entity of a
6138 -- private type is the one in the full view, which does not
6139 -- indicate that it is the completion of something visible.
6141 N
:= First
(Visible_Declarations
(Specification
(P
)));
6142 while Present
(N
) loop
6143 if Nkind
(N
) = N_Full_Type_Declaration
6144 and then Present
(Defining_Identifier
(N
))
6145 and then T
= Defining_Identifier
(N
)
6149 elsif (Nkind
(N
) = N_Private_Type_Declaration
6151 Nkind
(N
) = N_Private_Extension_Declaration
)
6152 and then Present
(Defining_Identifier
(N
))
6153 and then T
= Full_View
(Defining_Identifier
(N
))
6162 end Visible_Part_Type
;
6164 -- Start of processing for Check_For_Primitive_Subprogram
6167 Is_Primitive
:= False;
6169 if not Comes_From_Source
(S
) then
6172 -- If subprogram is at library level, it is not primitive operation
6174 elsif Current_Scope
= Standard_Standard
then
6177 elsif ((Ekind
(Current_Scope
) = E_Package
6178 or else Ekind
(Current_Scope
) = E_Generic_Package
)
6179 and then not In_Package_Body
(Current_Scope
))
6180 or else Is_Overriding
6182 -- For function, check return type
6184 if Ekind
(S
) = E_Function
then
6185 if Ekind
(Etype
(S
)) = E_Anonymous_Access_Type
then
6186 F_Typ
:= Designated_Type
(Etype
(S
));
6191 B_Typ
:= Base_Type
(F_Typ
);
6193 if Scope
(B_Typ
) = Current_Scope
6194 and then not Is_Class_Wide_Type
(B_Typ
)
6195 and then not Is_Generic_Type
(B_Typ
)
6197 Is_Primitive
:= True;
6198 Set_Has_Primitive_Operations
(B_Typ
);
6199 Set_Is_Primitive
(S
);
6200 Check_Private_Overriding
(B_Typ
);
6204 -- For all subprograms, check formals
6206 Formal
:= First_Formal
(S
);
6207 while Present
(Formal
) loop
6208 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
then
6209 F_Typ
:= Designated_Type
(Etype
(Formal
));
6211 F_Typ
:= Etype
(Formal
);
6214 B_Typ
:= Base_Type
(F_Typ
);
6216 if Ekind
(B_Typ
) = E_Access_Subtype
then
6217 B_Typ
:= Base_Type
(B_Typ
);
6220 if Scope
(B_Typ
) = Current_Scope
6221 and then not Is_Class_Wide_Type
(B_Typ
)
6222 and then not Is_Generic_Type
(B_Typ
)
6224 Is_Primitive
:= True;
6225 Set_Is_Primitive
(S
);
6226 Set_Has_Primitive_Operations
(B_Typ
);
6227 Check_Private_Overriding
(B_Typ
);
6230 Next_Formal
(Formal
);
6233 end Check_For_Primitive_Subprogram
;
6235 -----------------------------------
6236 -- Check_Synchronized_Overriding --
6237 -----------------------------------
6239 procedure Check_Synchronized_Overriding
6240 (Def_Id
: Entity_Id
;
6241 First_Hom
: Entity_Id
;
6242 Overridden_Subp
: out Entity_Id
)
6244 Formal_Typ
: Entity_Id
;
6245 Ifaces_List
: Elist_Id
;
6250 Overridden_Subp
:= Empty
;
6252 -- Def_Id must be an entry or a subprogram
6254 if Ekind
(Def_Id
) /= E_Entry
6255 and then Ekind
(Def_Id
) /= E_Function
6256 and then Ekind
(Def_Id
) /= E_Procedure
6261 -- Search for the concurrent declaration since it contains the list
6262 -- of all implemented interfaces. In this case, the subprogram is
6263 -- declared within the scope of a protected or a task type.
6265 if Present
(Scope
(Def_Id
))
6266 and then Is_Concurrent_Type
(Scope
(Def_Id
))
6267 and then not Is_Generic_Actual_Type
(Scope
(Def_Id
))
6269 Typ
:= Scope
(Def_Id
);
6272 -- The subprogram may be a primitive of a concurrent type
6274 elsif Present
(First_Formal
(Def_Id
)) then
6275 Formal_Typ
:= Etype
(First_Formal
(Def_Id
));
6277 if Is_Concurrent_Type
(Formal_Typ
)
6278 and then not Is_Generic_Actual_Type
(Formal_Typ
)
6283 -- This case occurs when the concurrent type is declared within
6284 -- a generic unit. As a result the corresponding record has been
6285 -- built and used as the type of the first formal, we just have
6286 -- to retrieve the corresponding concurrent type.
6288 elsif Is_Concurrent_Record_Type
(Formal_Typ
)
6289 and then Present
(Corresponding_Concurrent_Type
(Formal_Typ
))
6291 Typ
:= Corresponding_Concurrent_Type
(Formal_Typ
);
6301 -- Gather all limited, protected and task interfaces that Typ
6302 -- implements. There is no overriding to check if is an inherited
6303 -- operation in a type derivation on for a generic actual.
6305 if Nkind
(Parent
(Typ
)) /= N_Full_Type_Declaration
6306 and then Nkind
(Parent
(Def_Id
)) /= N_Subtype_Declaration
6307 and then Nkind
(Parent
(Def_Id
)) /= N_Task_Type_Declaration
6308 and then Nkind
(Parent
(Def_Id
)) /= N_Protected_Type_Declaration
6310 Collect_Abstract_Interfaces
(Typ
, Ifaces_List
);
6312 if not Is_Empty_Elmt_List
(Ifaces_List
) then
6314 Find_Overridden_Synchronized_Primitive
6315 (Def_Id
, First_Hom
, Ifaces_List
, In_Scope
);
6318 end Check_Synchronized_Overriding
;
6320 ----------------------------
6321 -- Is_Private_Declaration --
6322 ----------------------------
6324 function Is_Private_Declaration
(E
: Entity_Id
) return Boolean is
6325 Priv_Decls
: List_Id
;
6326 Decl
: constant Node_Id
:= Unit_Declaration_Node
(E
);
6329 if Is_Package_Or_Generic_Package
(Current_Scope
)
6330 and then In_Private_Part
(Current_Scope
)
6333 Private_Declarations
(
6334 Specification
(Unit_Declaration_Node
(Current_Scope
)));
6336 return In_Package_Body
(Current_Scope
)
6338 (Is_List_Member
(Decl
)
6339 and then List_Containing
(Decl
) = Priv_Decls
)
6340 or else (Nkind
(Parent
(Decl
)) = N_Package_Specification
6341 and then not Is_Compilation_Unit
(
6342 Defining_Entity
(Parent
(Decl
)))
6343 and then List_Containing
(Parent
(Parent
(Decl
)))
6348 end Is_Private_Declaration
;
6350 -- Start of processing for New_Overloaded_Entity
6353 -- We need to look for an entity that S may override. This must be a
6354 -- homonym in the current scope, so we look for the first homonym of
6355 -- S in the current scope as the starting point for the search.
6357 E
:= Current_Entity_In_Scope
(S
);
6359 -- If there is no homonym then this is definitely not overriding
6362 Enter_Overloaded_Entity
(S
);
6363 Check_Dispatching_Operation
(S
, Empty
);
6364 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
6366 -- If subprogram has an explicit declaration, check whether it
6367 -- has an overriding indicator.
6369 if Comes_From_Source
(S
) then
6370 Check_Synchronized_Overriding
(S
, Homonym
(S
), Overridden_Subp
);
6371 Check_Overriding_Indicator
6372 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
6375 -- If there is a homonym that is not overloadable, then we have an
6376 -- error, except for the special cases checked explicitly below.
6378 elsif not Is_Overloadable
(E
) then
6380 -- Check for spurious conflict produced by a subprogram that has the
6381 -- same name as that of the enclosing generic package. The conflict
6382 -- occurs within an instance, between the subprogram and the renaming
6383 -- declaration for the package. After the subprogram, the package
6384 -- renaming declaration becomes hidden.
6386 if Ekind
(E
) = E_Package
6387 and then Present
(Renamed_Object
(E
))
6388 and then Renamed_Object
(E
) = Current_Scope
6389 and then Nkind
(Parent
(Renamed_Object
(E
))) =
6390 N_Package_Specification
6391 and then Present
(Generic_Parent
(Parent
(Renamed_Object
(E
))))
6394 Set_Is_Immediately_Visible
(E
, False);
6395 Enter_Overloaded_Entity
(S
);
6396 Set_Homonym
(S
, Homonym
(E
));
6397 Check_Dispatching_Operation
(S
, Empty
);
6398 Check_Overriding_Indicator
(S
, Empty
, Is_Primitive
=> False);
6400 -- If the subprogram is implicit it is hidden by the previous
6401 -- declaration. However if it is dispatching, it must appear in the
6402 -- dispatch table anyway, because it can be dispatched to even if it
6403 -- cannot be called directly.
6405 elsif Present
(Alias
(S
))
6406 and then not Comes_From_Source
(S
)
6408 Set_Scope
(S
, Current_Scope
);
6410 if Is_Dispatching_Operation
(Alias
(S
)) then
6411 Check_Dispatching_Operation
(S
, Empty
);
6417 Error_Msg_Sloc
:= Sloc
(E
);
6419 -- Generate message,with useful additionalwarning if in generic
6421 if Is_Generic_Unit
(E
) then
6422 Error_Msg_N
("previous generic unit cannot be overloaded", S
);
6423 Error_Msg_N
("\& conflicts with declaration#", S
);
6425 Error_Msg_N
("& conflicts with declaration#", S
);
6431 -- E exists and is overloadable
6434 -- Ada 2005 (AI-251): Derivation of abstract interface primitives
6435 -- need no check against the homonym chain. They are directly added
6436 -- to the list of primitive operations of Derived_Type.
6438 if Ada_Version
>= Ada_05
6439 and then Present
(Derived_Type
)
6440 and then Is_Dispatching_Operation
(Alias
(S
))
6441 and then Present
(Find_Dispatching_Type
(Alias
(S
)))
6442 and then Is_Interface
(Find_Dispatching_Type
(Alias
(S
)))
6443 and then not Is_Predefined_Dispatching_Operation
(Alias
(S
))
6445 goto Add_New_Entity
;
6448 Check_Synchronized_Overriding
(S
, E
, Overridden_Subp
);
6450 -- Loop through E and its homonyms to determine if any of them is
6451 -- the candidate for overriding by S.
6453 while Present
(E
) loop
6455 -- Definitely not interesting if not in the current scope
6457 if Scope
(E
) /= Current_Scope
then
6460 -- Check if we have type conformance
6462 elsif Type_Conformant
(E
, S
) then
6464 -- If the old and new entities have the same profile and one
6465 -- is not the body of the other, then this is an error, unless
6466 -- one of them is implicitly declared.
6468 -- There are some cases when both can be implicit, for example
6469 -- when both a literal and a function that overrides it are
6470 -- inherited in a derivation, or when an inhertited operation
6471 -- of a tagged full type overrides the inherited operation of
6472 -- a private extension. Ada 83 had a special rule for the the
6473 -- literal case. In Ada95, the later implicit operation hides
6474 -- the former, and the literal is always the former. In the
6475 -- odd case where both are derived operations declared at the
6476 -- same point, both operations should be declared, and in that
6477 -- case we bypass the following test and proceed to the next
6478 -- part (this can only occur for certain obscure cases
6479 -- involving homographs in instances and can't occur for
6480 -- dispatching operations ???). Note that the following
6481 -- condition is less than clear. For example, it's not at all
6482 -- clear why there's a test for E_Entry here. ???
6484 if Present
(Alias
(S
))
6485 and then (No
(Alias
(E
))
6486 or else Comes_From_Source
(E
)
6487 or else Is_Dispatching_Operation
(E
))
6489 (Ekind
(E
) = E_Entry
6490 or else Ekind
(E
) /= E_Enumeration_Literal
)
6492 -- When an derived operation is overloaded it may be due to
6493 -- the fact that the full view of a private extension
6494 -- re-inherits. It has to be dealt with.
6496 if Is_Package_Or_Generic_Package
(Current_Scope
)
6497 and then In_Private_Part
(Current_Scope
)
6499 Check_Operation_From_Private_View
(S
, E
);
6502 -- In any case the implicit operation remains hidden by
6503 -- the existing declaration, which is overriding.
6505 Set_Is_Overriding_Operation
(E
);
6507 if Comes_From_Source
(E
) then
6508 Check_Overriding_Indicator
(E
, S
, Is_Primitive
=> False);
6510 -- Indicate that E overrides the operation from which
6513 if Present
(Alias
(S
)) then
6514 Set_Overridden_Operation
(E
, Alias
(S
));
6516 Set_Overridden_Operation
(E
, S
);
6522 -- Within an instance, the renaming declarations for
6523 -- actual subprograms may become ambiguous, but they do
6524 -- not hide each other.
6526 elsif Ekind
(E
) /= E_Entry
6527 and then not Comes_From_Source
(E
)
6528 and then not Is_Generic_Instance
(E
)
6529 and then (Present
(Alias
(E
))
6530 or else Is_Intrinsic_Subprogram
(E
))
6531 and then (not In_Instance
6532 or else No
(Parent
(E
))
6533 or else Nkind
(Unit_Declaration_Node
(E
)) /=
6534 N_Subprogram_Renaming_Declaration
)
6536 -- A subprogram child unit is not allowed to override
6537 -- an inherited subprogram (10.1.1(20)).
6539 if Is_Child_Unit
(S
) then
6541 ("child unit overrides inherited subprogram in parent",
6546 if Is_Non_Overriding_Operation
(E
, S
) then
6547 Enter_Overloaded_Entity
(S
);
6548 if No
(Derived_Type
)
6549 or else Is_Tagged_Type
(Derived_Type
)
6551 Check_Dispatching_Operation
(S
, Empty
);
6557 -- E is a derived operation or an internal operator which
6558 -- is being overridden. Remove E from further visibility.
6559 -- Furthermore, if E is a dispatching operation, it must be
6560 -- replaced in the list of primitive operations of its type
6561 -- (see Override_Dispatching_Operation).
6563 Overridden_Subp
:= E
;
6569 Prev
:= First_Entity
(Current_Scope
);
6571 while Present
(Prev
)
6572 and then Next_Entity
(Prev
) /= E
6577 -- It is possible for E to be in the current scope and
6578 -- yet not in the entity chain. This can only occur in a
6579 -- generic context where E is an implicit concatenation
6580 -- in the formal part, because in a generic body the
6581 -- entity chain starts with the formals.
6584 (Present
(Prev
) or else Chars
(E
) = Name_Op_Concat
);
6586 -- E must be removed both from the entity_list of the
6587 -- current scope, and from the visibility chain
6589 if Debug_Flag_E
then
6590 Write_Str
("Override implicit operation ");
6591 Write_Int
(Int
(E
));
6595 -- If E is a predefined concatenation, it stands for four
6596 -- different operations. As a result, a single explicit
6597 -- declaration does not hide it. In a possible ambiguous
6598 -- situation, Disambiguate chooses the user-defined op,
6599 -- so it is correct to retain the previous internal one.
6601 if Chars
(E
) /= Name_Op_Concat
6602 or else Ekind
(E
) /= E_Operator
6604 -- For nondispatching derived operations that are
6605 -- overridden by a subprogram declared in the private
6606 -- part of a package, we retain the derived
6607 -- subprogram but mark it as not immediately visible.
6608 -- If the derived operation was declared in the
6609 -- visible part then this ensures that it will still
6610 -- be visible outside the package with the proper
6611 -- signature (calls from outside must also be
6612 -- directed to this version rather than the
6613 -- overriding one, unlike the dispatching case).
6614 -- Calls from inside the package will still resolve
6615 -- to the overriding subprogram since the derived one
6616 -- is marked as not visible within the package.
6618 -- If the private operation is dispatching, we achieve
6619 -- the overriding by keeping the implicit operation
6620 -- but setting its alias to be the overriding one. In
6621 -- this fashion the proper body is executed in all
6622 -- cases, but the original signature is used outside
6625 -- If the overriding is not in the private part, we
6626 -- remove the implicit operation altogether.
6628 if Is_Private_Declaration
(S
) then
6630 if not Is_Dispatching_Operation
(E
) then
6631 Set_Is_Immediately_Visible
(E
, False);
6633 -- Work done in Override_Dispatching_Operation,
6634 -- so nothing else need to be done here.
6640 -- Find predecessor of E in Homonym chain
6642 if E
= Current_Entity
(E
) then
6645 Prev_Vis
:= Current_Entity
(E
);
6646 while Homonym
(Prev_Vis
) /= E
loop
6647 Prev_Vis
:= Homonym
(Prev_Vis
);
6651 if Prev_Vis
/= Empty
then
6653 -- Skip E in the visibility chain
6655 Set_Homonym
(Prev_Vis
, Homonym
(E
));
6658 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
6661 Set_Next_Entity
(Prev
, Next_Entity
(E
));
6663 if No
(Next_Entity
(Prev
)) then
6664 Set_Last_Entity
(Current_Scope
, Prev
);
6670 Enter_Overloaded_Entity
(S
);
6671 Set_Is_Overriding_Operation
(S
);
6672 Check_Overriding_Indicator
(S
, E
, Is_Primitive
=> True);
6674 -- Indicate that S overrides the operation from which
6677 if Comes_From_Source
(S
) then
6678 if Present
(Alias
(E
)) then
6679 Set_Overridden_Operation
(S
, Alias
(E
));
6681 Set_Overridden_Operation
(S
, E
);
6685 if Is_Dispatching_Operation
(E
) then
6687 -- An overriding dispatching subprogram inherits the
6688 -- convention of the overridden subprogram (by
6691 Set_Convention
(S
, Convention
(E
));
6692 Check_Dispatching_Operation
(S
, E
);
6695 Check_Dispatching_Operation
(S
, Empty
);
6698 Check_For_Primitive_Subprogram
6699 (Is_Primitive_Subp
, Is_Overriding
=> True);
6700 goto Check_Inequality
;
6703 -- Apparent redeclarations in instances can occur when two
6704 -- formal types get the same actual type. The subprograms in
6705 -- in the instance are legal, even if not callable from the
6706 -- outside. Calls from within are disambiguated elsewhere.
6707 -- For dispatching operations in the visible part, the usual
6708 -- rules apply, and operations with the same profile are not
6711 elsif (In_Instance_Visible_Part
6712 and then not Is_Dispatching_Operation
(E
))
6713 or else In_Instance_Not_Visible
6717 -- Here we have a real error (identical profile)
6720 Error_Msg_Sloc
:= Sloc
(E
);
6722 -- Avoid cascaded errors if the entity appears in
6723 -- subsequent calls.
6725 Set_Scope
(S
, Current_Scope
);
6727 -- Generate error, with extra useful warning for the case
6728 -- of a generic instance with no completion.
6730 if Is_Generic_Instance
(S
)
6731 and then not Has_Completion
(E
)
6734 ("instantiation cannot provide body for&", S
);
6735 Error_Msg_N
("\& conflicts with declaration#", S
);
6737 Error_Msg_N
("& conflicts with declaration#", S
);
6744 -- If one subprogram has an access parameter and the other
6745 -- a parameter of an access type, calls to either might be
6746 -- ambiguous. Verify that parameters match except for the
6747 -- access parameter.
6749 if May_Hide_Profile
then
6754 F1
:= First_Formal
(S
);
6755 F2
:= First_Formal
(E
);
6756 while Present
(F1
) and then Present
(F2
) loop
6757 if Is_Access_Type
(Etype
(F1
)) then
6758 if not Is_Access_Type
(Etype
(F2
))
6759 or else not Conforming_Types
6760 (Designated_Type
(Etype
(F1
)),
6761 Designated_Type
(Etype
(F2
)),
6764 May_Hide_Profile
:= False;
6768 not Conforming_Types
6769 (Etype
(F1
), Etype
(F2
), Type_Conformant
)
6771 May_Hide_Profile
:= False;
6782 Error_Msg_NE
("calls to& may be ambiguous?", S
, S
);
6793 -- On exit, we know that S is a new entity
6795 Enter_Overloaded_Entity
(S
);
6796 Check_For_Primitive_Subprogram
(Is_Primitive_Subp
);
6797 Check_Overriding_Indicator
6798 (S
, Overridden_Subp
, Is_Primitive
=> Is_Primitive_Subp
);
6800 -- If S is a derived operation for an untagged type then by
6801 -- definition it's not a dispatching operation (even if the parent
6802 -- operation was dispatching), so we don't call
6803 -- Check_Dispatching_Operation in that case.
6805 if No
(Derived_Type
)
6806 or else Is_Tagged_Type
(Derived_Type
)
6808 Check_Dispatching_Operation
(S
, Empty
);
6812 -- If this is a user-defined equality operator that is not a derived
6813 -- subprogram, create the corresponding inequality. If the operation is
6814 -- dispatching, the expansion is done elsewhere, and we do not create
6815 -- an explicit inequality operation.
6817 <<Check_Inequality
>>
6818 if Chars
(S
) = Name_Op_Eq
6819 and then Etype
(S
) = Standard_Boolean
6820 and then Present
(Parent
(S
))
6821 and then not Is_Dispatching_Operation
(S
)
6823 Make_Inequality_Operator
(S
);
6825 end New_Overloaded_Entity
;
6827 ---------------------
6828 -- Process_Formals --
6829 ---------------------
6831 procedure Process_Formals
6833 Related_Nod
: Node_Id
)
6835 Param_Spec
: Node_Id
;
6837 Formal_Type
: Entity_Id
;
6841 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean;
6842 -- Check whether the default has a class-wide type. After analysis the
6843 -- default has the type of the formal, so we must also check explicitly
6844 -- for an access attribute.
6846 ---------------------------
6847 -- Is_Class_Wide_Default --
6848 ---------------------------
6850 function Is_Class_Wide_Default
(D
: Node_Id
) return Boolean is
6852 return Is_Class_Wide_Type
(Designated_Type
(Etype
(D
)))
6853 or else (Nkind
(D
) = N_Attribute_Reference
6854 and then Attribute_Name
(D
) = Name_Access
6855 and then Is_Class_Wide_Type
(Etype
(Prefix
(D
))));
6856 end Is_Class_Wide_Default
;
6858 -- Start of processing for Process_Formals
6861 -- In order to prevent premature use of the formals in the same formal
6862 -- part, the Ekind is left undefined until all default expressions are
6863 -- analyzed. The Ekind is established in a separate loop at the end.
6865 Param_Spec
:= First
(T
);
6866 while Present
(Param_Spec
) loop
6867 Formal
:= Defining_Identifier
(Param_Spec
);
6868 Set_Never_Set_In_Source
(Formal
, True);
6869 Enter_Name
(Formal
);
6871 -- Case of ordinary parameters
6873 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
6874 Find_Type
(Parameter_Type
(Param_Spec
));
6875 Ptype
:= Parameter_Type
(Param_Spec
);
6877 if Ptype
= Error
then
6881 Formal_Type
:= Entity
(Ptype
);
6883 if Is_Incomplete_Type
(Formal_Type
)
6885 (Is_Class_Wide_Type
(Formal_Type
)
6886 and then Is_Incomplete_Type
(Root_Type
(Formal_Type
)))
6888 -- Ada 2005 (AI-326): Tagged incomplete types allowed
6890 if Is_Tagged_Type
(Formal_Type
) then
6893 -- Special handling of Value_Type for CIL case
6895 elsif Is_Value_Type
(Formal_Type
) then
6898 elsif Nkind
(Parent
(T
)) /= N_Access_Function_Definition
6899 and then Nkind
(Parent
(T
)) /= N_Access_Procedure_Definition
6901 Error_Msg_N
("invalid use of incomplete type", Param_Spec
);
6903 -- An incomplete type that is not tagged is allowed in an
6904 -- access-to-subprogram type only if it is a local declaration
6905 -- with a forthcoming completion (3.10.1 (9.2/2)).
6907 elsif Scope
(Formal_Type
) /= Scope
(Current_Scope
) then
6909 ("invalid use of limited view of type", Param_Spec
);
6912 elsif Ekind
(Formal_Type
) = E_Void
then
6913 Error_Msg_NE
("premature use of&",
6914 Parameter_Type
(Param_Spec
), Formal_Type
);
6917 -- Ada 2005 (AI-231): Create and decorate an internal subtype
6918 -- declaration corresponding to the null-excluding type of the
6919 -- formal in the enclosing scope. Finally, replace the parameter
6920 -- type of the formal with the internal subtype.
6922 if Ada_Version
>= Ada_05
6923 and then Null_Exclusion_Present
(Param_Spec
)
6925 if not Is_Access_Type
(Formal_Type
) then
6927 ("`NOT NULL` allowed only for an access type", Param_Spec
);
6930 if Can_Never_Be_Null
(Formal_Type
)
6931 and then Comes_From_Source
(Related_Nod
)
6934 ("`NOT NULL` not allowed (& already excludes null)",
6940 Create_Null_Excluding_Itype
6942 Related_Nod
=> Related_Nod
,
6943 Scope_Id
=> Scope
(Current_Scope
));
6945 -- If the designated type of the itype is an itype we
6946 -- decorate it with the Has_Delayed_Freeze attribute to
6947 -- avoid problems with the backend.
6950 -- type T is access procedure;
6951 -- procedure Op (O : not null T);
6953 if Is_Itype
(Directly_Designated_Type
(Formal_Type
)) then
6954 Set_Has_Delayed_Freeze
(Formal_Type
);
6959 -- An access formal type
6963 Access_Definition
(Related_Nod
, Parameter_Type
(Param_Spec
));
6965 -- No need to continue if we already notified errors
6967 if not Present
(Formal_Type
) then
6971 -- Ada 2005 (AI-254)
6974 AD
: constant Node_Id
:=
6975 Access_To_Subprogram_Definition
6976 (Parameter_Type
(Param_Spec
));
6978 if Present
(AD
) and then Protected_Present
(AD
) then
6980 Replace_Anonymous_Access_To_Protected_Subprogram
6986 Set_Etype
(Formal
, Formal_Type
);
6987 Default
:= Expression
(Param_Spec
);
6989 if Present
(Default
) then
6990 if Out_Present
(Param_Spec
) then
6992 ("default initialization only allowed for IN parameters",
6996 -- Do the special preanalysis of the expression (see section on
6997 -- "Handling of Default Expressions" in the spec of package Sem).
6999 Analyze_Per_Use_Expression
(Default
, Formal_Type
);
7001 -- Check that the designated type of an access parameter's default
7002 -- is not a class-wide type unless the parameter's designated type
7003 -- is also class-wide.
7005 if Ekind
(Formal_Type
) = E_Anonymous_Access_Type
7006 and then not From_With_Type
(Formal_Type
)
7007 and then Is_Class_Wide_Default
(Default
)
7008 and then not Is_Class_Wide_Type
(Designated_Type
(Formal_Type
))
7011 ("access to class-wide expression not allowed here", Default
);
7015 -- Ada 2005 (AI-231): Static checks
7017 if Ada_Version
>= Ada_05
7018 and then Is_Access_Type
(Etype
(Formal
))
7019 and then Can_Never_Be_Null
(Etype
(Formal
))
7021 Null_Exclusion_Static_Checks
(Param_Spec
);
7028 -- If this is the formal part of a function specification, analyze the
7029 -- subtype mark in the context where the formals are visible but not
7030 -- yet usable, and may hide outer homographs.
7032 if Nkind
(Related_Nod
) = N_Function_Specification
then
7033 Analyze_Return_Type
(Related_Nod
);
7036 -- Now set the kind (mode) of each formal
7038 Param_Spec
:= First
(T
);
7040 while Present
(Param_Spec
) loop
7041 Formal
:= Defining_Identifier
(Param_Spec
);
7042 Set_Formal_Mode
(Formal
);
7044 if Ekind
(Formal
) = E_In_Parameter
then
7045 Set_Default_Value
(Formal
, Expression
(Param_Spec
));
7047 if Present
(Expression
(Param_Spec
)) then
7048 Default
:= Expression
(Param_Spec
);
7050 if Is_Scalar_Type
(Etype
(Default
)) then
7052 (Parameter_Type
(Param_Spec
)) /= N_Access_Definition
7054 Formal_Type
:= Entity
(Parameter_Type
(Param_Spec
));
7057 Formal_Type
:= Access_Definition
7058 (Related_Nod
, Parameter_Type
(Param_Spec
));
7061 Apply_Scalar_Range_Check
(Default
, Formal_Type
);
7068 end Process_Formals
;
7070 ----------------------------
7071 -- Reference_Body_Formals --
7072 ----------------------------
7074 procedure Reference_Body_Formals
(Spec
: Entity_Id
; Bod
: Entity_Id
) is
7079 if Error_Posted
(Spec
) then
7083 -- Iterate over both lists. They may be of different lengths if the two
7084 -- specs are not conformant.
7086 Fs
:= First_Formal
(Spec
);
7087 Fb
:= First_Formal
(Bod
);
7088 while Present
(Fs
) and then Present
(Fb
) loop
7089 Generate_Reference
(Fs
, Fb
, 'b');
7092 Style
.Check_Identifier
(Fb
, Fs
);
7095 Set_Spec_Entity
(Fb
, Fs
);
7096 Set_Referenced
(Fs
, False);
7100 end Reference_Body_Formals
;
7102 -------------------------
7103 -- Set_Actual_Subtypes --
7104 -------------------------
7106 procedure Set_Actual_Subtypes
(N
: Node_Id
; Subp
: Entity_Id
) is
7107 Loc
: constant Source_Ptr
:= Sloc
(N
);
7111 First_Stmt
: Node_Id
:= Empty
;
7112 AS_Needed
: Boolean;
7115 -- If this is an emtpy initialization procedure, no need to create
7116 -- actual subtypes (small optimization).
7118 if Ekind
(Subp
) = E_Procedure
7119 and then Is_Null_Init_Proc
(Subp
)
7124 Formal
:= First_Formal
(Subp
);
7125 while Present
(Formal
) loop
7126 T
:= Etype
(Formal
);
7128 -- We never need an actual subtype for a constrained formal
7130 if Is_Constrained
(T
) then
7133 -- If we have unknown discriminants, then we do not need an actual
7134 -- subtype, or more accurately we cannot figure it out! Note that
7135 -- all class-wide types have unknown discriminants.
7137 elsif Has_Unknown_Discriminants
(T
) then
7140 -- At this stage we have an unconstrained type that may need an
7141 -- actual subtype. For sure the actual subtype is needed if we have
7142 -- an unconstrained array type.
7144 elsif Is_Array_Type
(T
) then
7147 -- The only other case needing an actual subtype is an unconstrained
7148 -- record type which is an IN parameter (we cannot generate actual
7149 -- subtypes for the OUT or IN OUT case, since an assignment can
7150 -- change the discriminant values. However we exclude the case of
7151 -- initialization procedures, since discriminants are handled very
7152 -- specially in this context, see the section entitled "Handling of
7153 -- Discriminants" in Einfo.
7155 -- We also exclude the case of Discrim_SO_Functions (functions used
7156 -- in front end layout mode for size/offset values), since in such
7157 -- functions only discriminants are referenced, and not only are such
7158 -- subtypes not needed, but they cannot always be generated, because
7159 -- of order of elaboration issues.
7161 elsif Is_Record_Type
(T
)
7162 and then Ekind
(Formal
) = E_In_Parameter
7163 and then Chars
(Formal
) /= Name_uInit
7164 and then not Is_Unchecked_Union
(T
)
7165 and then not Is_Discrim_SO_Function
(Subp
)
7169 -- All other cases do not need an actual subtype
7175 -- Generate actual subtypes for unconstrained arrays and
7176 -- unconstrained discriminated records.
7179 if Nkind
(N
) = N_Accept_Statement
then
7181 -- If expansion is active, The formal is replaced by a local
7182 -- variable that renames the corresponding entry of the
7183 -- parameter block, and it is this local variable that may
7184 -- require an actual subtype.
7186 if Expander_Active
then
7187 Decl
:= Build_Actual_Subtype
(T
, Renamed_Object
(Formal
));
7189 Decl
:= Build_Actual_Subtype
(T
, Formal
);
7192 if Present
(Handled_Statement_Sequence
(N
)) then
7194 First
(Statements
(Handled_Statement_Sequence
(N
)));
7195 Prepend
(Decl
, Statements
(Handled_Statement_Sequence
(N
)));
7196 Mark_Rewrite_Insertion
(Decl
);
7198 -- If the accept statement has no body, there will be no
7199 -- reference to the actuals, so no need to compute actual
7206 Decl
:= Build_Actual_Subtype
(T
, Formal
);
7207 Prepend
(Decl
, Declarations
(N
));
7208 Mark_Rewrite_Insertion
(Decl
);
7211 -- The declaration uses the bounds of an existing object, and
7212 -- therefore needs no constraint checks.
7214 Analyze
(Decl
, Suppress
=> All_Checks
);
7216 -- We need to freeze manually the generated type when it is
7217 -- inserted anywhere else than in a declarative part.
7219 if Present
(First_Stmt
) then
7220 Insert_List_Before_And_Analyze
(First_Stmt
,
7221 Freeze_Entity
(Defining_Identifier
(Decl
), Loc
));
7224 if Nkind
(N
) = N_Accept_Statement
7225 and then Expander_Active
7227 Set_Actual_Subtype
(Renamed_Object
(Formal
),
7228 Defining_Identifier
(Decl
));
7230 Set_Actual_Subtype
(Formal
, Defining_Identifier
(Decl
));
7234 Next_Formal
(Formal
);
7236 end Set_Actual_Subtypes
;
7238 ---------------------
7239 -- Set_Formal_Mode --
7240 ---------------------
7242 procedure Set_Formal_Mode
(Formal_Id
: Entity_Id
) is
7243 Spec
: constant Node_Id
:= Parent
(Formal_Id
);
7246 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
7247 -- since we ensure that corresponding actuals are always valid at the
7248 -- point of the call.
7250 if Out_Present
(Spec
) then
7251 if Ekind
(Scope
(Formal_Id
)) = E_Function
7252 or else Ekind
(Scope
(Formal_Id
)) = E_Generic_Function
7254 Error_Msg_N
("functions can only have IN parameters", Spec
);
7255 Set_Ekind
(Formal_Id
, E_In_Parameter
);
7257 elsif In_Present
(Spec
) then
7258 Set_Ekind
(Formal_Id
, E_In_Out_Parameter
);
7261 Set_Ekind
(Formal_Id
, E_Out_Parameter
);
7262 Set_Never_Set_In_Source
(Formal_Id
, True);
7263 Set_Is_True_Constant
(Formal_Id
, False);
7264 Set_Current_Value
(Formal_Id
, Empty
);
7268 Set_Ekind
(Formal_Id
, E_In_Parameter
);
7271 -- Set Is_Known_Non_Null for access parameters since the language
7272 -- guarantees that access parameters are always non-null. We also set
7273 -- Can_Never_Be_Null, since there is no way to change the value.
7275 if Nkind
(Parameter_Type
(Spec
)) = N_Access_Definition
then
7277 -- Ada 2005 (AI-231): In Ada95, access parameters are always non-
7278 -- null; In Ada 2005, only if then null_exclusion is explicit.
7280 if Ada_Version
< Ada_05
7281 or else Can_Never_Be_Null
(Etype
(Formal_Id
))
7283 Set_Is_Known_Non_Null
(Formal_Id
);
7284 Set_Can_Never_Be_Null
(Formal_Id
);
7287 -- Ada 2005 (AI-231): Null-exclusion access subtype
7289 elsif Is_Access_Type
(Etype
(Formal_Id
))
7290 and then Can_Never_Be_Null
(Etype
(Formal_Id
))
7292 Set_Is_Known_Non_Null
(Formal_Id
);
7295 Set_Mechanism
(Formal_Id
, Default_Mechanism
);
7296 Set_Formal_Validity
(Formal_Id
);
7297 end Set_Formal_Mode
;
7299 -------------------------
7300 -- Set_Formal_Validity --
7301 -------------------------
7303 procedure Set_Formal_Validity
(Formal_Id
: Entity_Id
) is
7305 -- If no validity checking, then we cannot assume anything about the
7306 -- validity of parameters, since we do not know there is any checking
7307 -- of the validity on the call side.
7309 if not Validity_Checks_On
then
7312 -- If validity checking for parameters is enabled, this means we are
7313 -- not supposed to make any assumptions about argument values.
7315 elsif Validity_Check_Parameters
then
7318 -- If we are checking in parameters, we will assume that the caller is
7319 -- also checking parameters, so we can assume the parameter is valid.
7321 elsif Ekind
(Formal_Id
) = E_In_Parameter
7322 and then Validity_Check_In_Params
7324 Set_Is_Known_Valid
(Formal_Id
, True);
7326 -- Similar treatment for IN OUT parameters
7328 elsif Ekind
(Formal_Id
) = E_In_Out_Parameter
7329 and then Validity_Check_In_Out_Params
7331 Set_Is_Known_Valid
(Formal_Id
, True);
7333 end Set_Formal_Validity
;
7335 ------------------------
7336 -- Subtype_Conformant --
7337 ------------------------
7339 function Subtype_Conformant
(New_Id
, Old_Id
: Entity_Id
) return Boolean is
7342 Check_Conformance
(New_Id
, Old_Id
, Subtype_Conformant
, False, Result
);
7344 end Subtype_Conformant
;
7346 ---------------------
7347 -- Type_Conformant --
7348 ---------------------
7350 function Type_Conformant
7351 (New_Id
: Entity_Id
;
7353 Skip_Controlling_Formals
: Boolean := False) return Boolean
7357 May_Hide_Profile
:= False;
7360 (New_Id
, Old_Id
, Type_Conformant
, False, Result
,
7361 Skip_Controlling_Formals
=> Skip_Controlling_Formals
);
7363 end Type_Conformant
;
7365 -------------------------------
7366 -- Valid_Operator_Definition --
7367 -------------------------------
7369 procedure Valid_Operator_Definition
(Designator
: Entity_Id
) is
7372 Id
: constant Name_Id
:= Chars
(Designator
);
7376 F
:= First_Formal
(Designator
);
7377 while Present
(F
) loop
7380 if Present
(Default_Value
(F
)) then
7382 ("default values not allowed for operator parameters",
7389 -- Verify that user-defined operators have proper number of arguments
7390 -- First case of operators which can only be unary
7393 or else Id
= Name_Op_Abs
7397 -- Case of operators which can be unary or binary
7399 elsif Id
= Name_Op_Add
7400 or Id
= Name_Op_Subtract
7402 N_OK
:= (N
in 1 .. 2);
7404 -- All other operators can only be binary
7412 ("incorrect number of arguments for operator", Designator
);
7416 and then Base_Type
(Etype
(Designator
)) = Standard_Boolean
7417 and then not Is_Intrinsic_Subprogram
(Designator
)
7420 ("explicit definition of inequality not allowed", Designator
);
7422 end Valid_Operator_Definition
;