1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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_Ch9; use Exp_Ch9;
36 with Exp_Disp; use Exp_Disp;
37 with Exp_Tss; use Exp_Tss;
38 with Exp_Util; use Exp_Util;
39 with Fname; use Fname;
40 with Freeze; use Freeze;
41 with Itypes; use Itypes;
42 with Lib.Xref; use Lib.Xref;
43 with Layout; use Layout;
44 with Namet; use Namet;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
49 with Output; use Output;
50 with Restrict; use Restrict;
51 with Rident; use Rident;
52 with Rtsfind; use Rtsfind;
54 with Sem_Aux; use Sem_Aux;
55 with Sem_Cat; use Sem_Cat;
56 with Sem_Ch3; use Sem_Ch3;
57 with Sem_Ch4; use Sem_Ch4;
58 with Sem_Ch5; use Sem_Ch5;
59 with Sem_Ch8; use Sem_Ch8;
60 with Sem_Ch10; use Sem_Ch10;
61 with Sem_Ch12; use Sem_Ch12;
62 with Sem_Disp; use Sem_Disp;
63 with Sem_Dist; use Sem_Dist;
64 with Sem_Elim; use Sem_Elim;
65 with Sem_Eval; use Sem_Eval;
66 with Sem_Mech; use Sem_Mech;
67 with Sem_Prag; use Sem_Prag;
68 with Sem_Res; use Sem_Res;
69 with Sem_Util; use Sem_Util;
70 with Sem_Type; use Sem_Type;
71 with Sem_Warn; use Sem_Warn;
72 with Sinput; use Sinput;
73 with Stand; use Stand;
74 with Sinfo; use Sinfo;
75 with Sinfo.CN; use Sinfo.CN;
76 with Snames; use Snames;
77 with Stringt; use Stringt;
79 with Stylesw; use Stylesw;
80 with Tbuild; use Tbuild;
81 with Uintp; use Uintp;
82 with Urealp; use Urealp;
83 with Validsw; use Validsw;
85 package body Sem_Ch6 is
87 May_Hide_Profile : Boolean := False;
88 -- This flag is used to indicate that two formals in two subprograms being
89 -- checked for conformance differ only in that one is an access parameter
90 -- while the other is of a general access type with the same designated
91 -- type. In this case, if the rest of the signatures match, a call to
92 -- either subprogram may be ambiguous, which is worth a warning. The flag
93 -- is set in Compatible_Types, and the warning emitted in
94 -- New_Overloaded_Entity.
96 -----------------------
97 -- Local Subprograms --
98 -----------------------
100 procedure Analyze_Return_Statement (N : Node_Id);
101 -- Common processing for simple and extended return statements
103 procedure Analyze_Function_Return (N : Node_Id);
104 -- Subsidiary to Analyze_Return_Statement. Called when the return statement
105 -- applies to a [generic] function.
107 procedure Analyze_Return_Type (N : Node_Id);
108 -- Subsidiary to Process_Formals: analyze subtype mark in function
109 -- specification in a context where the formals are visible and hide
112 procedure Analyze_Subprogram_Body_Helper (N : Node_Id);
113 -- Does all the real work of Analyze_Subprogram_Body. This is split out so
114 -- that we can use RETURN but not skip the debug output at the end.
116 procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
117 -- Analyze a generic subprogram body. N is the body to be analyzed, and
118 -- Gen_Id is the defining entity Id for the corresponding spec.
120 procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
121 -- If a subprogram has pragma Inline and inlining is active, use generic
122 -- machinery to build an unexpanded body for the subprogram. This body is
123 -- subsequently used for inline expansions at call sites. If subprogram can
124 -- be inlined (depending on size and nature of local declarations) this
125 -- function returns true. Otherwise subprogram body is treated normally.
126 -- If proper warnings are enabled and the subprogram contains a construct
127 -- that cannot be inlined, the offending construct is flagged accordingly.
129 procedure Check_Conformance
132 Ctype : Conformance_Type;
134 Conforms : out Boolean;
135 Err_Loc : Node_Id := Empty;
136 Get_Inst : Boolean := False;
137 Skip_Controlling_Formals : Boolean := False);
138 -- Given two entities, this procedure checks that the profiles associated
139 -- with these entities meet the conformance criterion given by the third
140 -- parameter. If they conform, Conforms is set True and control returns
141 -- to the caller. If they do not conform, Conforms is set to False, and
142 -- in addition, if Errmsg is True on the call, proper messages are output
143 -- to complain about the conformance failure. If Err_Loc is non_Empty
144 -- the error messages are placed on Err_Loc, if Err_Loc is empty, then
145 -- error messages are placed on the appropriate part of the construct
146 -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance
147 -- against a formal access-to-subprogram type so Get_Instance_Of must
150 procedure Check_Subprogram_Order (N : Node_Id);
151 -- N is the N_Subprogram_Body node for a subprogram. This routine applies
152 -- the alpha ordering rule for N if this ordering requirement applicable.
154 procedure Check_Returns
158 Proc : Entity_Id := Empty);
159 -- Called to check for missing return statements in a function body, or for
160 -- returns present in a procedure body which has No_Return set. HSS is the
161 -- handled statement sequence for the subprogram body. This procedure
162 -- checks all flow paths to make sure they either have return (Mode = 'F',
163 -- used for functions) or do not have a return (Mode = 'P', used for
164 -- No_Return procedures). The flag Err is set if there are any control
165 -- paths not explicitly terminated by a return in the function case, and is
166 -- True otherwise. Proc is the entity for the procedure case and is used
167 -- in posting the warning message.
169 procedure Enter_Overloaded_Entity (S : Entity_Id);
170 -- This procedure makes S, a new overloaded entity, into the first visible
171 -- entity with that name.
173 procedure Install_Entity (E : Entity_Id);
174 -- Make single entity visible. Used for generic formals as well
176 function Is_Non_Overriding_Operation
178 New_E : Entity_Id) return Boolean;
179 -- Enforce the rule given in 12.3(18): a private operation in an instance
180 -- overrides an inherited operation only if the corresponding operation
181 -- was overriding in the generic. This can happen for primitive operations
182 -- of types derived (in the generic unit) from formal private or formal
185 procedure Make_Inequality_Operator (S : Entity_Id);
186 -- Create the declaration for an inequality operator that is implicitly
187 -- created by a user-defined equality operator that yields a boolean.
189 procedure May_Need_Actuals (Fun : Entity_Id);
190 -- Flag functions that can be called without parameters, i.e. those that
191 -- have no parameters, or those for which defaults exist for all parameters
193 procedure Process_PPCs
196 Body_Id : Entity_Id);
197 -- Called from Analyze[_Generic]_Subprogram_Body to deal with scanning post
198 -- conditions for the body and assembling and inserting the _postconditions
199 -- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are
200 -- the entities for the body and separate spec (if there is no separate
201 -- spec, Spec_Id is Empty).
203 procedure Set_Formal_Validity (Formal_Id : Entity_Id);
204 -- Formal_Id is an formal parameter entity. This procedure deals with
205 -- setting the proper validity status for this entity, which depends on
206 -- the kind of parameter and the validity checking mode.
208 ------------------------------
209 -- Analyze_Return_Statement --
210 ------------------------------
212 procedure Analyze_Return_Statement (N : Node_Id) is
214 pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
215 N_Extended_Return_Statement));
217 Returns_Object : constant Boolean :=
218 Nkind (N) = N_Extended_Return_Statement
220 (Nkind (N) = N_Simple_Return_Statement
221 and then Present (Expression (N)));
222 -- True if we're returning something; that is, "return <expression>;"
223 -- or "return Result : T [:= ...]". False for "return;". Used for error
224 -- checking: If Returns_Object is True, N should apply to a function
225 -- body; otherwise N should apply to a procedure body, entry body,
226 -- accept statement, or extended return statement.
228 function Find_What_It_Applies_To return Entity_Id;
229 -- Find the entity representing the innermost enclosing body, accept
230 -- statement, or extended return statement. If the result is a callable
231 -- construct or extended return statement, then this will be the value
232 -- of the Return_Applies_To attribute. Otherwise, the program is
233 -- illegal. See RM-6.5(4/2).
235 -----------------------------
236 -- Find_What_It_Applies_To --
237 -----------------------------
239 function Find_What_It_Applies_To return Entity_Id is
240 Result : Entity_Id := Empty;
243 -- Loop outward through the Scope_Stack, skipping blocks and loops
245 for J in reverse 0 .. Scope_Stack.Last loop
246 Result := Scope_Stack.Table (J).Entity;
247 exit when Ekind (Result) /= E_Block and then
248 Ekind (Result) /= E_Loop;
251 pragma Assert (Present (Result));
253 end Find_What_It_Applies_To;
255 -- Local declarations
257 Scope_Id : constant Entity_Id := Find_What_It_Applies_To;
258 Kind : constant Entity_Kind := Ekind (Scope_Id);
259 Loc : constant Source_Ptr := Sloc (N);
260 Stm_Entity : constant Entity_Id :=
262 (E_Return_Statement, Current_Scope, Loc, 'R');
264 -- Start of processing for Analyze_Return_Statement
267 Set_Return_Statement_Entity (N, Stm_Entity);
269 Set_Etype (Stm_Entity, Standard_Void_Type);
270 Set_Return_Applies_To (Stm_Entity, Scope_Id);
272 -- Place Return entity on scope stack, to simplify enforcement of 6.5
273 -- (4/2): an inner return statement will apply to this extended return.
275 if Nkind (N) = N_Extended_Return_Statement then
276 Push_Scope (Stm_Entity);
279 -- Check that pragma No_Return is obeyed. Don't complain about the
280 -- implicitly-generated return that is placed at the end.
282 if No_Return (Scope_Id) and then Comes_From_Source (N) then
283 Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
286 -- Warn on any unassigned OUT parameters if in procedure
288 if Ekind (Scope_Id) = E_Procedure then
289 Warn_On_Unassigned_Out_Parameter (N, Scope_Id);
292 -- Check that functions return objects, and other things do not
294 if Kind = E_Function or else Kind = E_Generic_Function then
295 if not Returns_Object then
296 Error_Msg_N ("missing expression in return from function", N);
299 elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
300 if Returns_Object then
301 Error_Msg_N ("procedure cannot return value (use function)", N);
304 elsif Kind = E_Entry or else Kind = E_Entry_Family then
305 if Returns_Object then
306 if Is_Protected_Type (Scope (Scope_Id)) then
307 Error_Msg_N ("entry body cannot return value", N);
309 Error_Msg_N ("accept statement cannot return value", N);
313 elsif Kind = E_Return_Statement then
315 -- We are nested within another return statement, which must be an
316 -- extended_return_statement.
318 if Returns_Object then
320 ("extended_return_statement cannot return value; " &
321 "use `""RETURN;""`", N);
325 Error_Msg_N ("illegal context for return statement", N);
328 if Kind = E_Function or else Kind = E_Generic_Function then
329 Analyze_Function_Return (N);
332 if Nkind (N) = N_Extended_Return_Statement then
336 Kill_Current_Values (Last_Assignment_Only => True);
337 Check_Unreachable_Code (N);
338 end Analyze_Return_Statement;
340 ---------------------------------------------
341 -- Analyze_Abstract_Subprogram_Declaration --
342 ---------------------------------------------
344 procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
345 Designator : constant Entity_Id :=
346 Analyze_Subprogram_Specification (Specification (N));
347 Scop : constant Entity_Id := Current_Scope;
350 Generate_Definition (Designator);
351 Set_Is_Abstract_Subprogram (Designator);
352 New_Overloaded_Entity (Designator);
353 Check_Delayed_Subprogram (Designator);
355 Set_Categorization_From_Scope (Designator, Scop);
357 if Ekind (Scope (Designator)) = E_Protected_Type then
359 ("abstract subprogram not allowed in protected type", N);
361 -- Issue a warning if the abstract subprogram is neither a dispatching
362 -- operation nor an operation that overrides an inherited subprogram or
363 -- predefined operator, since this most likely indicates a mistake.
365 elsif Warn_On_Redundant_Constructs
366 and then not Is_Dispatching_Operation (Designator)
367 and then not Is_Overriding_Operation (Designator)
368 and then (not Is_Operator_Symbol_Name (Chars (Designator))
369 or else Scop /= Scope (Etype (First_Formal (Designator))))
372 ("?abstract subprogram is not dispatching or overriding", N);
375 Generate_Reference_To_Formals (Designator);
376 Check_Eliminated (Designator);
377 end Analyze_Abstract_Subprogram_Declaration;
379 ----------------------------------------
380 -- Analyze_Extended_Return_Statement --
381 ----------------------------------------
383 procedure Analyze_Extended_Return_Statement (N : Node_Id) is
385 Analyze_Return_Statement (N);
386 end Analyze_Extended_Return_Statement;
388 ----------------------------
389 -- Analyze_Function_Call --
390 ----------------------------
392 procedure Analyze_Function_Call (N : Node_Id) is
393 P : constant Node_Id := Name (N);
394 L : constant List_Id := Parameter_Associations (N);
400 -- A call of the form A.B (X) may be an Ada05 call, which is rewritten
401 -- as B (A, X). If the rewriting is successful, the call has been
402 -- analyzed and we just return.
404 if Nkind (P) = N_Selected_Component
405 and then Name (N) /= P
406 and then Is_Rewrite_Substitution (N)
407 and then Present (Etype (N))
412 -- If error analyzing name, then set Any_Type as result type and return
414 if Etype (P) = Any_Type then
415 Set_Etype (N, Any_Type);
419 -- Otherwise analyze the parameters
423 while Present (Actual) loop
425 Check_Parameterless_Call (Actual);
431 end Analyze_Function_Call;
433 -----------------------------
434 -- Analyze_Function_Return --
435 -----------------------------
437 procedure Analyze_Function_Return (N : Node_Id) is
438 Loc : constant Source_Ptr := Sloc (N);
439 Stm_Entity : constant Entity_Id := Return_Statement_Entity (N);
440 Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity);
442 R_Type : constant Entity_Id := Etype (Scope_Id);
443 -- Function result subtype
445 procedure Check_Limited_Return (Expr : Node_Id);
446 -- Check the appropriate (Ada 95 or Ada 2005) rules for returning
447 -- limited types. Used only for simple return statements.
448 -- Expr is the expression returned.
450 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
451 -- Check that the return_subtype_indication properly matches the result
452 -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
454 --------------------------
455 -- Check_Limited_Return --
456 --------------------------
458 procedure Check_Limited_Return (Expr : Node_Id) is
460 -- Ada 2005 (AI-318-02): Return-by-reference types have been
461 -- removed and replaced by anonymous access results. This is an
462 -- incompatibility with Ada 95. Not clear whether this should be
463 -- enforced yet or perhaps controllable with special switch. ???
465 if Is_Limited_Type (R_Type)
466 and then Comes_From_Source (N)
467 and then not In_Instance_Body
468 and then not OK_For_Limited_Init_In_05 (R_Type, Expr)
472 if Ada_Version >= Ada_05
473 and then not Debug_Flag_Dot_L
474 and then not GNAT_Mode
477 ("(Ada 2005) cannot copy object of a limited type " &
478 "(RM-2005 6.5(5.5/2))", Expr);
479 if Is_Inherently_Limited_Type (R_Type) then
481 ("\return by reference not permitted in Ada 2005", Expr);
484 -- Warn in Ada 95 mode, to give folks a heads up about this
487 -- In GNAT mode, this is just a warning, to allow it to be
488 -- evilly turned off. Otherwise it is a real error.
490 elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
491 if Is_Inherently_Limited_Type (R_Type) then
493 ("return by reference not permitted in Ada 2005 " &
494 "(RM-2005 6.5(5.5/2))?", Expr);
497 ("cannot copy object of a limited type in Ada 2005 " &
498 "(RM-2005 6.5(5.5/2))?", Expr);
501 -- Ada 95 mode, compatibility warnings disabled
504 return; -- skip continuation messages below
508 ("\consider switching to return of access type", Expr);
509 Explain_Limited_Type (R_Type, Expr);
511 end Check_Limited_Return;
513 -------------------------------------
514 -- Check_Return_Subtype_Indication --
515 -------------------------------------
517 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is
518 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 (must match R_Type)
523 Subtype_Ind : constant Node_Id :=
524 Object_Definition (Original_Node (Obj_Decl));
526 R_Type_Is_Anon_Access :
528 Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
530 Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
532 Ekind (R_Type) = E_Anonymous_Access_Type;
533 -- True if return type of the function is an anonymous access type
534 -- Can't we make Is_Anonymous_Access_Type in einfo ???
536 R_Stm_Type_Is_Anon_Access :
538 Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type
540 Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type
542 Ekind (R_Stm_Type) = E_Anonymous_Access_Type;
543 -- True if type of the return object is an anonymous access type
546 -- First, avoid cascaded errors
548 if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then
552 -- "return access T" case; check that the return statement also has
553 -- "access T", and that the subtypes statically match:
554 -- if this is an access to subprogram the signatures must match.
556 if R_Type_Is_Anon_Access then
557 if R_Stm_Type_Is_Anon_Access then
559 Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
561 if Base_Type (Designated_Type (R_Stm_Type)) /=
562 Base_Type (Designated_Type (R_Type))
563 or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
566 ("subtype must statically match function result subtype",
567 Subtype_Mark (Subtype_Ind));
571 -- For two anonymous access to subprogram types, the
572 -- types themselves must be type conformant.
574 if not Conforming_Types
575 (R_Stm_Type, R_Type, Fully_Conformant)
578 ("subtype must statically match function result subtype",
584 Error_Msg_N ("must use anonymous access type", Subtype_Ind);
587 -- Subtype indication case: check that the return object's type is
588 -- covered by the result type, and that the subtypes statically match
589 -- when the result subtype is constrained. Also handle record types
590 -- with unknown discriminants for which we have built the underlying
591 -- record view. Coverage is needed to allow specific-type return
592 -- objects when the result type is class-wide (see AI05-32).
594 elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type))
595 or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type))
599 Underlying_Record_View (Base_Type (R_Stm_Type))))
601 -- A null exclusion may be present on the return type, on the
602 -- function specification, on the object declaration or on the
605 if Is_Access_Type (R_Type)
607 (Can_Never_Be_Null (R_Type)
608 or else Null_Exclusion_Present (Parent (Scope_Id))) /=
609 Can_Never_Be_Null (R_Stm_Type)
612 ("subtype must statically match function result subtype",
616 if Is_Constrained (R_Type) then
617 if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
619 ("subtype must statically match function result subtype",
624 elsif Etype (Base_Type (R_Type)) = R_Stm_Type
625 and then Is_Null_Extension (Base_Type (R_Type))
631 ("wrong type for return_subtype_indication", Subtype_Ind);
633 end Check_Return_Subtype_Indication;
635 ---------------------
636 -- Local Variables --
637 ---------------------
641 -- Start of processing for Analyze_Function_Return
644 Set_Return_Present (Scope_Id);
646 if Nkind (N) = N_Simple_Return_Statement then
647 Expr := Expression (N);
648 Analyze_And_Resolve (Expr, R_Type);
649 Check_Limited_Return (Expr);
652 -- Analyze parts specific to extended_return_statement:
655 Obj_Decl : constant Node_Id :=
656 Last (Return_Object_Declarations (N));
658 HSS : constant Node_Id := Handled_Statement_Sequence (N);
661 Expr := Expression (Obj_Decl);
663 -- Note: The check for OK_For_Limited_Init will happen in
664 -- Analyze_Object_Declaration; we treat it as a normal
665 -- object declaration.
667 Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
670 Check_Return_Subtype_Indication (Obj_Decl);
672 if Present (HSS) then
675 if Present (Exception_Handlers (HSS)) then
677 -- ???Has_Nested_Block_With_Handler needs to be set.
678 -- Probably by creating an actual N_Block_Statement.
679 -- Probably in Expand.
685 -- Mark the return object as referenced, since the return is an
686 -- implicit reference of the object.
688 Set_Referenced (Defining_Identifier (Obj_Decl));
690 Check_References (Stm_Entity);
694 -- Case of Expr present
698 -- Defend against previous errors
700 and then Nkind (Expr) /= N_Empty
701 and then Present (Etype (Expr))
703 -- Apply constraint check. Note that this is done before the implicit
704 -- conversion of the expression done for anonymous access types to
705 -- ensure correct generation of the null-excluding check associated
706 -- with null-excluding expressions found in return statements.
708 Apply_Constraint_Check (Expr, R_Type);
710 -- Ada 2005 (AI-318-02): When the result type is an anonymous access
711 -- type, apply an implicit conversion of the expression to that type
712 -- to force appropriate static and run-time accessibility checks.
714 if Ada_Version >= Ada_05
715 and then Ekind (R_Type) = E_Anonymous_Access_Type
717 Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
718 Analyze_And_Resolve (Expr, R_Type);
721 -- If the result type is class-wide, then check that the return
722 -- expression's type is not declared at a deeper level than the
723 -- function (RM05-6.5(5.6/2)).
725 if Ada_Version >= Ada_05
726 and then Is_Class_Wide_Type (R_Type)
728 if Type_Access_Level (Etype (Expr)) >
729 Subprogram_Access_Level (Scope_Id)
732 ("level of return expression type is deeper than " &
733 "class-wide function!", Expr);
737 -- Check incorrect use of dynamically tagged expression
739 if Is_Tagged_Type (R_Type) then
740 Check_Dynamically_Tagged_Expression
746 -- ??? A real run-time accessibility check is needed in cases
747 -- involving dereferences of access parameters. For now we just
748 -- check the static cases.
750 if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L)
751 and then Is_Inherently_Limited_Type (Etype (Scope_Id))
752 and then Object_Access_Level (Expr) >
753 Subprogram_Access_Level (Scope_Id)
756 Make_Raise_Program_Error (Loc,
757 Reason => PE_Accessibility_Check_Failed));
761 ("cannot return a local value by reference?", N);
763 ("\& will be raised at run time?",
764 N, Standard_Program_Error);
768 and then Nkind (Parent (Scope_Id)) = N_Function_Specification
769 and then Null_Exclusion_Present (Parent (Scope_Id))
771 Apply_Compile_Time_Constraint_Error
773 Msg => "(Ada 2005) null not allowed for "
774 & "null-excluding return?",
775 Reason => CE_Null_Not_Allowed);
778 -- Apply checks suggested by AI05-0144 (dangerous order dependence)
779 -- (Disabled for now)
781 -- Check_Order_Dependence;
783 end Analyze_Function_Return;
785 -------------------------------------
786 -- Analyze_Generic_Subprogram_Body --
787 -------------------------------------
789 procedure Analyze_Generic_Subprogram_Body
793 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id);
794 Kind : constant Entity_Kind := Ekind (Gen_Id);
800 -- Copy body and disable expansion while analyzing the generic For a
801 -- stub, do not copy the stub (which would load the proper body), this
802 -- will be done when the proper body is analyzed.
804 if Nkind (N) /= N_Subprogram_Body_Stub then
805 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
810 Spec := Specification (N);
812 -- Within the body of the generic, the subprogram is callable, and
813 -- behaves like the corresponding non-generic unit.
815 Body_Id := Defining_Entity (Spec);
817 if Kind = E_Generic_Procedure
818 and then Nkind (Spec) /= N_Procedure_Specification
820 Error_Msg_N ("invalid body for generic procedure ", Body_Id);
823 elsif Kind = E_Generic_Function
824 and then Nkind (Spec) /= N_Function_Specification
826 Error_Msg_N ("invalid body for generic function ", Body_Id);
830 Set_Corresponding_Body (Gen_Decl, Body_Id);
832 if Has_Completion (Gen_Id)
833 and then Nkind (Parent (N)) /= N_Subunit
835 Error_Msg_N ("duplicate generic body", N);
838 Set_Has_Completion (Gen_Id);
841 if Nkind (N) = N_Subprogram_Body_Stub then
842 Set_Ekind (Defining_Entity (Specification (N)), Kind);
844 Set_Corresponding_Spec (N, Gen_Id);
847 if Nkind (Parent (N)) = N_Compilation_Unit then
848 Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
851 -- Make generic parameters immediately visible in the body. They are
852 -- needed to process the formals declarations. Then make the formals
853 -- visible in a separate step.
859 First_Ent : Entity_Id;
862 First_Ent := First_Entity (Gen_Id);
865 while Present (E) and then not Is_Formal (E) loop
870 Set_Use (Generic_Formal_Declarations (Gen_Decl));
872 -- Now generic formals are visible, and the specification can be
873 -- analyzed, for subsequent conformance check.
875 Body_Id := Analyze_Subprogram_Specification (Spec);
877 -- Make formal parameters visible
881 -- E is the first formal parameter, we loop through the formals
882 -- installing them so that they will be visible.
884 Set_First_Entity (Gen_Id, E);
885 while Present (E) loop
891 -- Visible generic entity is callable within its own body
893 Set_Ekind (Gen_Id, Ekind (Body_Id));
894 Set_Ekind (Body_Id, E_Subprogram_Body);
895 Set_Convention (Body_Id, Convention (Gen_Id));
896 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
897 Set_Scope (Body_Id, Scope (Gen_Id));
898 Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
900 if Nkind (N) = N_Subprogram_Body_Stub then
902 -- No body to analyze, so restore state of generic unit
904 Set_Ekind (Gen_Id, Kind);
905 Set_Ekind (Body_Id, Kind);
907 if Present (First_Ent) then
908 Set_First_Entity (Gen_Id, First_Ent);
915 -- If this is a compilation unit, it must be made visible explicitly,
916 -- because the compilation of the declaration, unlike other library
917 -- unit declarations, does not. If it is not a unit, the following
918 -- is redundant but harmless.
920 Set_Is_Immediately_Visible (Gen_Id);
921 Reference_Body_Formals (Gen_Id, Body_Id);
923 if Is_Child_Unit (Gen_Id) then
924 Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False);
927 Set_Actual_Subtypes (N, Current_Scope);
928 Process_PPCs (N, Gen_Id, Body_Id);
930 -- If the generic unit carries pre- or post-conditions, copy them
931 -- to the original generic tree, so that they are properly added
932 -- to any instantiation.
935 Orig : constant Node_Id := Original_Node (N);
939 Cond := First (Declarations (N));
940 while Present (Cond) loop
941 if Nkind (Cond) = N_Pragma
942 and then Pragma_Name (Cond) = Name_Check
944 Prepend (New_Copy_Tree (Cond), Declarations (Orig));
946 elsif Nkind (Cond) = N_Pragma
947 and then Pragma_Name (Cond) = Name_Postcondition
949 Set_Ekind (Defining_Entity (Orig), Ekind (Gen_Id));
950 Prepend (New_Copy_Tree (Cond), Declarations (Orig));
959 Analyze_Declarations (Declarations (N));
961 Analyze (Handled_Statement_Sequence (N));
963 Save_Global_References (Original_Node (N));
965 -- Prior to exiting the scope, include generic formals again (if any
966 -- are present) in the set of local entities.
968 if Present (First_Ent) then
969 Set_First_Entity (Gen_Id, First_Ent);
972 Check_References (Gen_Id);
975 Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
977 Check_Subprogram_Order (N);
979 -- Outside of its body, unit is generic again
981 Set_Ekind (Gen_Id, Kind);
982 Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
985 Style.Check_Identifier (Body_Id, Gen_Id);
989 end Analyze_Generic_Subprogram_Body;
991 -----------------------------
992 -- Analyze_Operator_Symbol --
993 -----------------------------
995 -- An operator symbol such as "+" or "and" may appear in context where the
996 -- literal denotes an entity name, such as "+"(x, y) or in context when it
997 -- is just a string, as in (conjunction = "or"). In these cases the parser
998 -- generates this node, and the semantics does the disambiguation. Other
999 -- such case are actuals in an instantiation, the generic unit in an
1000 -- instantiation, and pragma arguments.
1002 procedure Analyze_Operator_Symbol (N : Node_Id) is
1003 Par : constant Node_Id := Parent (N);
1006 if (Nkind (Par) = N_Function_Call
1007 and then N = Name (Par))
1008 or else Nkind (Par) = N_Function_Instantiation
1009 or else (Nkind (Par) = N_Indexed_Component
1010 and then N = Prefix (Par))
1011 or else (Nkind (Par) = N_Pragma_Argument_Association
1012 and then not Is_Pragma_String_Literal (Par))
1013 or else Nkind (Par) = N_Subprogram_Renaming_Declaration
1014 or else (Nkind (Par) = N_Attribute_Reference
1015 and then Attribute_Name (Par) /= Name_Value)
1017 Find_Direct_Name (N);
1020 Change_Operator_Symbol_To_String_Literal (N);
1023 end Analyze_Operator_Symbol;
1025 -----------------------------------
1026 -- Analyze_Parameter_Association --
1027 -----------------------------------
1029 procedure Analyze_Parameter_Association (N : Node_Id) is
1031 Analyze (Explicit_Actual_Parameter (N));
1032 end Analyze_Parameter_Association;
1034 ----------------------------
1035 -- Analyze_Procedure_Call --
1036 ----------------------------
1038 procedure Analyze_Procedure_Call (N : Node_Id) is
1039 Loc : constant Source_Ptr := Sloc (N);
1040 P : constant Node_Id := Name (N);
1041 Actuals : constant List_Id := Parameter_Associations (N);
1045 procedure Analyze_Call_And_Resolve;
1046 -- Do Analyze and Resolve calls for procedure call
1047 -- At end, check illegal order dependence.
1049 ------------------------------
1050 -- Analyze_Call_And_Resolve --
1051 ------------------------------
1053 procedure Analyze_Call_And_Resolve is
1055 if Nkind (N) = N_Procedure_Call_Statement then
1057 Resolve (N, Standard_Void_Type);
1059 -- Apply checks suggested by AI05-0144 (Disabled for now)
1061 -- Check_Order_Dependence;
1066 end Analyze_Call_And_Resolve;
1068 -- Start of processing for Analyze_Procedure_Call
1071 -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
1072 -- a procedure call or an entry call. The prefix may denote an access
1073 -- to subprogram type, in which case an implicit dereference applies.
1074 -- If the prefix is an indexed component (without implicit dereference)
1075 -- then the construct denotes a call to a member of an entire family.
1076 -- If the prefix is a simple name, it may still denote a call to a
1077 -- parameterless member of an entry family. Resolution of these various
1078 -- interpretations is delicate.
1082 -- If this is a call of the form Obj.Op, the call may have been
1083 -- analyzed and possibly rewritten into a block, in which case
1086 if Analyzed (N) then
1090 -- If there is an error analyzing the name (which may have been
1091 -- rewritten if the original call was in prefix notation) then error
1092 -- has been emitted already, mark node and return.
1095 or else Etype (Name (N)) = Any_Type
1097 Set_Etype (N, Any_Type);
1101 -- Otherwise analyze the parameters
1103 if Present (Actuals) then
1104 Actual := First (Actuals);
1106 while Present (Actual) loop
1108 Check_Parameterless_Call (Actual);
1113 -- Special processing for Elab_Spec and Elab_Body calls
1115 if Nkind (P) = N_Attribute_Reference
1116 and then (Attribute_Name (P) = Name_Elab_Spec
1117 or else Attribute_Name (P) = Name_Elab_Body)
1119 if Present (Actuals) then
1121 ("no parameters allowed for this call", First (Actuals));
1125 Set_Etype (N, Standard_Void_Type);
1128 elsif Is_Entity_Name (P)
1129 and then Is_Record_Type (Etype (Entity (P)))
1130 and then Remote_AST_I_Dereference (P)
1134 elsif Is_Entity_Name (P)
1135 and then Ekind (Entity (P)) /= E_Entry_Family
1137 if Is_Access_Type (Etype (P))
1138 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1139 and then No (Actuals)
1140 and then Comes_From_Source (N)
1142 Error_Msg_N ("missing explicit dereference in call", N);
1145 Analyze_Call_And_Resolve;
1147 -- If the prefix is the simple name of an entry family, this is
1148 -- a parameterless call from within the task body itself.
1150 elsif Is_Entity_Name (P)
1151 and then Nkind (P) = N_Identifier
1152 and then Ekind (Entity (P)) = E_Entry_Family
1153 and then Present (Actuals)
1154 and then No (Next (First (Actuals)))
1156 -- Can be call to parameterless entry family. What appears to be the
1157 -- sole argument is in fact the entry index. Rewrite prefix of node
1158 -- accordingly. Source representation is unchanged by this
1162 Make_Indexed_Component (Loc,
1164 Make_Selected_Component (Loc,
1165 Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
1166 Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
1167 Expressions => Actuals);
1168 Set_Name (N, New_N);
1169 Set_Etype (New_N, Standard_Void_Type);
1170 Set_Parameter_Associations (N, No_List);
1171 Analyze_Call_And_Resolve;
1173 elsif Nkind (P) = N_Explicit_Dereference then
1174 if Ekind (Etype (P)) = E_Subprogram_Type then
1175 Analyze_Call_And_Resolve;
1177 Error_Msg_N ("expect access to procedure in call", P);
1180 -- The name can be a selected component or an indexed component that
1181 -- yields an access to subprogram. Such a prefix is legal if the call
1182 -- has parameter associations.
1184 elsif Is_Access_Type (Etype (P))
1185 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1187 if Present (Actuals) then
1188 Analyze_Call_And_Resolve;
1190 Error_Msg_N ("missing explicit dereference in call ", N);
1193 -- If not an access to subprogram, then the prefix must resolve to the
1194 -- name of an entry, entry family, or protected operation.
1196 -- For the case of a simple entry call, P is a selected component where
1197 -- the prefix is the task and the selector name is the entry. A call to
1198 -- a protected procedure will have the same syntax. If the protected
1199 -- object contains overloaded operations, the entity may appear as a
1200 -- function, the context will select the operation whose type is Void.
1202 elsif Nkind (P) = N_Selected_Component
1203 and then (Ekind (Entity (Selector_Name (P))) = E_Entry
1205 Ekind (Entity (Selector_Name (P))) = E_Procedure
1207 Ekind (Entity (Selector_Name (P))) = E_Function)
1209 Analyze_Call_And_Resolve;
1211 elsif Nkind (P) = N_Selected_Component
1212 and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
1213 and then Present (Actuals)
1214 and then No (Next (First (Actuals)))
1216 -- Can be call to parameterless entry family. What appears to be the
1217 -- sole argument is in fact the entry index. Rewrite prefix of node
1218 -- accordingly. Source representation is unchanged by this
1222 Make_Indexed_Component (Loc,
1223 Prefix => New_Copy (P),
1224 Expressions => Actuals);
1225 Set_Name (N, New_N);
1226 Set_Etype (New_N, Standard_Void_Type);
1227 Set_Parameter_Associations (N, No_List);
1228 Analyze_Call_And_Resolve;
1230 -- For the case of a reference to an element of an entry family, P is
1231 -- an indexed component whose prefix is a selected component (task and
1232 -- entry family), and whose index is the entry family index.
1234 elsif Nkind (P) = N_Indexed_Component
1235 and then Nkind (Prefix (P)) = N_Selected_Component
1236 and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
1238 Analyze_Call_And_Resolve;
1240 -- If the prefix is the name of an entry family, it is a call from
1241 -- within the task body itself.
1243 elsif Nkind (P) = N_Indexed_Component
1244 and then Nkind (Prefix (P)) = N_Identifier
1245 and then Ekind (Entity (Prefix (P))) = E_Entry_Family
1248 Make_Selected_Component (Loc,
1249 Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
1250 Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
1251 Rewrite (Prefix (P), New_N);
1253 Analyze_Call_And_Resolve;
1255 -- Anything else is an error
1258 Error_Msg_N ("invalid procedure or entry call", N);
1260 end Analyze_Procedure_Call;
1262 -------------------------------------
1263 -- Analyze_Simple_Return_Statement --
1264 -------------------------------------
1266 procedure Analyze_Simple_Return_Statement (N : Node_Id) is
1268 if Present (Expression (N)) then
1269 Mark_Coextensions (N, Expression (N));
1272 Analyze_Return_Statement (N);
1273 end Analyze_Simple_Return_Statement;
1275 -------------------------
1276 -- Analyze_Return_Type --
1277 -------------------------
1279 procedure Analyze_Return_Type (N : Node_Id) is
1280 Designator : constant Entity_Id := Defining_Entity (N);
1281 Typ : Entity_Id := Empty;
1284 -- Normal case where result definition does not indicate an error
1286 if Result_Definition (N) /= Error then
1287 if Nkind (Result_Definition (N)) = N_Access_Definition then
1289 -- Ada 2005 (AI-254): Handle anonymous access to subprograms
1292 AD : constant Node_Id :=
1293 Access_To_Subprogram_Definition (Result_Definition (N));
1295 if Present (AD) and then Protected_Present (AD) then
1296 Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N);
1298 Typ := Access_Definition (N, Result_Definition (N));
1302 Set_Parent (Typ, Result_Definition (N));
1303 Set_Is_Local_Anonymous_Access (Typ);
1304 Set_Etype (Designator, Typ);
1306 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1308 Null_Exclusion_Static_Checks (N);
1310 -- Subtype_Mark case
1313 Find_Type (Result_Definition (N));
1314 Typ := Entity (Result_Definition (N));
1315 Set_Etype (Designator, Typ);
1317 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1319 Null_Exclusion_Static_Checks (N);
1321 -- If a null exclusion is imposed on the result type, then create
1322 -- a null-excluding itype (an access subtype) and use it as the
1323 -- function's Etype. Note that the null exclusion checks are done
1324 -- right before this, because they don't get applied to types that
1325 -- do not come from source.
1327 if Is_Access_Type (Typ)
1328 and then Null_Exclusion_Present (N)
1330 Set_Etype (Designator,
1331 Create_Null_Excluding_Itype
1334 Scope_Id => Scope (Current_Scope)));
1336 -- The new subtype must be elaborated before use because
1337 -- it is visible outside of the function. However its base
1338 -- type may not be frozen yet, so the reference that will
1339 -- force elaboration must be attached to the freezing of
1342 -- If the return specification appears on a proper body,
1343 -- the subtype will have been created already on the spec.
1345 if Is_Frozen (Typ) then
1346 if Nkind (Parent (N)) = N_Subprogram_Body
1347 and then Nkind (Parent (Parent (N))) = N_Subunit
1351 Build_Itype_Reference (Etype (Designator), Parent (N));
1355 Ensure_Freeze_Node (Typ);
1358 IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
1360 Set_Itype (IR, Etype (Designator));
1361 Append_Freeze_Actions (Typ, New_List (IR));
1366 Set_Etype (Designator, Typ);
1369 if Ekind (Typ) = E_Incomplete_Type
1370 and then Is_Value_Type (Typ)
1374 elsif Ekind (Typ) = E_Incomplete_Type
1375 or else (Is_Class_Wide_Type (Typ)
1377 Ekind (Root_Type (Typ)) = E_Incomplete_Type)
1380 ("invalid use of incomplete type&", Designator, Typ);
1384 -- Case where result definition does indicate an error
1387 Set_Etype (Designator, Any_Type);
1389 end Analyze_Return_Type;
1391 -----------------------------
1392 -- Analyze_Subprogram_Body --
1393 -----------------------------
1395 procedure Analyze_Subprogram_Body (N : Node_Id) is
1396 Loc : constant Source_Ptr := Sloc (N);
1397 Body_Spec : constant Node_Id := Specification (N);
1398 Body_Id : constant Entity_Id := Defining_Entity (Body_Spec);
1401 if Debug_Flag_C then
1402 Write_Str ("==> subprogram body ");
1403 Write_Name (Chars (Body_Id));
1404 Write_Str (" from ");
1405 Write_Location (Loc);
1410 Trace_Scope (N, Body_Id, " Analyze subprogram: ");
1412 -- The real work is split out into the helper, so it can do "return;"
1413 -- without skipping the debug output:
1415 Analyze_Subprogram_Body_Helper (N);
1417 if Debug_Flag_C then
1419 Write_Str ("<== subprogram body ");
1420 Write_Name (Chars (Body_Id));
1421 Write_Str (" from ");
1422 Write_Location (Loc);
1425 end Analyze_Subprogram_Body;
1427 ------------------------------------
1428 -- Analyze_Subprogram_Body_Helper --
1429 ------------------------------------
1431 -- This procedure is called for regular subprogram bodies, generic bodies,
1432 -- and for subprogram stubs of both kinds. In the case of stubs, only the
1433 -- specification matters, and is used to create a proper declaration for
1434 -- the subprogram, or to perform conformance checks.
1436 procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is
1437 Loc : constant Source_Ptr := Sloc (N);
1438 Body_Deleted : constant Boolean := False;
1439 Body_Spec : constant Node_Id := Specification (N);
1440 Body_Id : Entity_Id := Defining_Entity (Body_Spec);
1441 Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
1442 Conformant : Boolean;
1445 Prot_Typ : Entity_Id := Empty;
1446 Spec_Id : Entity_Id;
1447 Spec_Decl : Node_Id := Empty;
1449 Last_Real_Spec_Entity : Entity_Id := Empty;
1450 -- When we analyze a separate spec, the entity chain ends up containing
1451 -- the formals, as well as any itypes generated during analysis of the
1452 -- default expressions for parameters, or the arguments of associated
1453 -- precondition/postcondition pragmas (which are analyzed in the context
1454 -- of the spec since they have visibility on formals).
1456 -- These entities belong with the spec and not the body. However we do
1457 -- the analysis of the body in the context of the spec (again to obtain
1458 -- visibility to the formals), and all the entities generated during
1459 -- this analysis end up also chained to the entity chain of the spec.
1460 -- But they really belong to the body, and there is circuitry to move
1461 -- them from the spec to the body.
1463 -- However, when we do this move, we don't want to move the real spec
1464 -- entities (first para above) to the body. The Last_Real_Spec_Entity
1465 -- variable points to the last real spec entity, so we only move those
1466 -- chained beyond that point. It is initialized to Empty to deal with
1467 -- the case where there is no separate spec.
1469 procedure Check_Anonymous_Return;
1470 -- Ada 2005: if a function returns an access type that denotes a task,
1471 -- or a type that contains tasks, we must create a master entity for
1472 -- the anonymous type, which typically will be used in an allocator
1473 -- in the body of the function.
1475 procedure Check_Inline_Pragma (Spec : in out Node_Id);
1476 -- Look ahead to recognize a pragma that may appear after the body.
1477 -- If there is a previous spec, check that it appears in the same
1478 -- declarative part. If the pragma is Inline_Always, perform inlining
1479 -- unconditionally, otherwise only if Front_End_Inlining is requested.
1480 -- If the body acts as a spec, and inlining is required, we create a
1481 -- subprogram declaration for it, in order to attach the body to inline.
1482 -- If pragma does not appear after the body, check whether there is
1483 -- an inline pragma before any local declarations.
1485 procedure Check_Missing_Return;
1486 -- Checks for a function with a no return statements, and also performs
1487 -- the warning checks implemented by Check_Returns.
1489 function Disambiguate_Spec return Entity_Id;
1490 -- When a primitive is declared between the private view and the full
1491 -- view of a concurrent type which implements an interface, a special
1492 -- mechanism is used to find the corresponding spec of the primitive
1495 function Is_Private_Concurrent_Primitive
1496 (Subp_Id : Entity_Id) return Boolean;
1497 -- Determine whether subprogram Subp_Id is a primitive of a concurrent
1498 -- type that implements an interface and has a private view.
1500 procedure Set_Trivial_Subprogram (N : Node_Id);
1501 -- Sets the Is_Trivial_Subprogram flag in both spec and body of the
1502 -- subprogram whose body is being analyzed. N is the statement node
1503 -- causing the flag to be set, if the following statement is a return
1504 -- of an entity, we mark the entity as set in source to suppress any
1505 -- warning on the stylized use of function stubs with a dummy return.
1507 procedure Verify_Overriding_Indicator;
1508 -- If there was a previous spec, the entity has been entered in the
1509 -- current scope previously. If the body itself carries an overriding
1510 -- indicator, check that it is consistent with the known status of the
1513 ----------------------------
1514 -- Check_Anonymous_Return --
1515 ----------------------------
1517 procedure Check_Anonymous_Return is
1523 if Present (Spec_Id) then
1529 if Ekind (Scop) = E_Function
1530 and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type
1531 and then not Is_Thunk (Scop)
1532 and then (Has_Task (Designated_Type (Etype (Scop)))
1534 (Is_Class_Wide_Type (Designated_Type (Etype (Scop)))
1536 Is_Limited_Record (Designated_Type (Etype (Scop)))))
1537 and then Expander_Active
1539 -- Avoid cases with no tasking support
1541 and then RTE_Available (RE_Current_Master)
1542 and then not Restriction_Active (No_Task_Hierarchy)
1545 Make_Object_Declaration (Loc,
1546 Defining_Identifier =>
1547 Make_Defining_Identifier (Loc, Name_uMaster),
1548 Constant_Present => True,
1549 Object_Definition =>
1550 New_Reference_To (RTE (RE_Master_Id), Loc),
1552 Make_Explicit_Dereference (Loc,
1553 New_Reference_To (RTE (RE_Current_Master), Loc)));
1555 if Present (Declarations (N)) then
1556 Prepend (Decl, Declarations (N));
1558 Set_Declarations (N, New_List (Decl));
1561 Set_Master_Id (Etype (Scop), Defining_Identifier (Decl));
1562 Set_Has_Master_Entity (Scop);
1564 -- Now mark the containing scope as a task master
1567 while Nkind (Par) /= N_Compilation_Unit loop
1568 Par := Parent (Par);
1569 pragma Assert (Present (Par));
1571 -- If we fall off the top, we are at the outer level, and
1572 -- the environment task is our effective master, so nothing
1576 (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body)
1578 Set_Is_Task_Master (Par, True);
1583 end Check_Anonymous_Return;
1585 -------------------------
1586 -- Check_Inline_Pragma --
1587 -------------------------
1589 procedure Check_Inline_Pragma (Spec : in out Node_Id) is
1593 function Is_Inline_Pragma (N : Node_Id) return Boolean;
1594 -- True when N is a pragma Inline or Inline_Always that applies
1595 -- to this subprogram.
1597 -----------------------
1598 -- Is_Inline_Pragma --
1599 -----------------------
1601 function Is_Inline_Pragma (N : Node_Id) return Boolean is
1604 Nkind (N) = N_Pragma
1606 (Pragma_Name (N) = Name_Inline_Always
1609 and then Pragma_Name (N) = Name_Inline))
1612 (Expression (First (Pragma_Argument_Associations (N))))
1614 end Is_Inline_Pragma;
1616 -- Start of processing for Check_Inline_Pragma
1619 if not Expander_Active then
1623 if Is_List_Member (N)
1624 and then Present (Next (N))
1625 and then Is_Inline_Pragma (Next (N))
1629 elsif Nkind (N) /= N_Subprogram_Body_Stub
1630 and then Present (Declarations (N))
1631 and then Is_Inline_Pragma (First (Declarations (N)))
1633 Prag := First (Declarations (N));
1639 if Present (Prag) then
1640 if Present (Spec_Id) then
1641 if List_Containing (N) =
1642 List_Containing (Unit_Declaration_Node (Spec_Id))
1648 -- Create a subprogram declaration, to make treatment uniform
1651 Subp : constant Entity_Id :=
1652 Make_Defining_Identifier (Loc, Chars (Body_Id));
1653 Decl : constant Node_Id :=
1654 Make_Subprogram_Declaration (Loc,
1655 Specification => New_Copy_Tree (Specification (N)));
1657 Set_Defining_Unit_Name (Specification (Decl), Subp);
1659 if Present (First_Formal (Body_Id)) then
1660 Plist := Copy_Parameter_List (Body_Id);
1661 Set_Parameter_Specifications
1662 (Specification (Decl), Plist);
1665 Insert_Before (N, Decl);
1668 Set_Has_Pragma_Inline (Subp);
1670 if Pragma_Name (Prag) = Name_Inline_Always then
1671 Set_Is_Inlined (Subp);
1672 Set_Has_Pragma_Inline_Always (Subp);
1679 end Check_Inline_Pragma;
1681 --------------------------
1682 -- Check_Missing_Return --
1683 --------------------------
1685 procedure Check_Missing_Return is
1687 Missing_Ret : Boolean;
1690 if Nkind (Body_Spec) = N_Function_Specification then
1691 if Present (Spec_Id) then
1697 if Return_Present (Id) then
1698 Check_Returns (HSS, 'F', Missing_Ret);
1701 Set_Has_Missing_Return (Id);
1704 elsif (Is_Generic_Subprogram (Id)
1705 or else not Is_Machine_Code_Subprogram (Id))
1706 and then not Body_Deleted
1708 Error_Msg_N ("missing RETURN statement in function body", N);
1711 -- If procedure with No_Return, check returns
1713 elsif Nkind (Body_Spec) = N_Procedure_Specification
1714 and then Present (Spec_Id)
1715 and then No_Return (Spec_Id)
1717 Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
1719 end Check_Missing_Return;
1721 -----------------------
1722 -- Disambiguate_Spec --
1723 -----------------------
1725 function Disambiguate_Spec return Entity_Id is
1726 Priv_Spec : Entity_Id;
1729 procedure Replace_Types (To_Corresponding : Boolean);
1730 -- Depending on the flag, replace the type of formal parameters of
1731 -- Body_Id if it is a concurrent type implementing interfaces with
1732 -- the corresponding record type or the other way around.
1734 procedure Replace_Types (To_Corresponding : Boolean) is
1736 Formal_Typ : Entity_Id;
1739 Formal := First_Formal (Body_Id);
1740 while Present (Formal) loop
1741 Formal_Typ := Etype (Formal);
1743 -- From concurrent type to corresponding record
1745 if To_Corresponding then
1746 if Is_Concurrent_Type (Formal_Typ)
1747 and then Present (Corresponding_Record_Type (Formal_Typ))
1748 and then Present (Interfaces (
1749 Corresponding_Record_Type (Formal_Typ)))
1752 Corresponding_Record_Type (Formal_Typ));
1755 -- From corresponding record to concurrent type
1758 if Is_Concurrent_Record_Type (Formal_Typ)
1759 and then Present (Interfaces (Formal_Typ))
1762 Corresponding_Concurrent_Type (Formal_Typ));
1766 Next_Formal (Formal);
1770 -- Start of processing for Disambiguate_Spec
1773 -- Try to retrieve the specification of the body as is. All error
1774 -- messages are suppressed because the body may not have a spec in
1775 -- its current state.
1777 Spec_N := Find_Corresponding_Spec (N, False);
1779 -- It is possible that this is the body of a primitive declared
1780 -- between a private and a full view of a concurrent type. The
1781 -- controlling parameter of the spec carries the concurrent type,
1782 -- not the corresponding record type as transformed by Analyze_
1783 -- Subprogram_Specification. In such cases, we undo the change
1784 -- made by the analysis of the specification and try to find the
1787 -- Note that wrappers already have their corresponding specs and
1788 -- bodies set during their creation, so if the candidate spec is
1789 -- a wrapper, then we definitely need to swap all types to their
1790 -- original concurrent status.
1793 or else Is_Primitive_Wrapper (Spec_N)
1795 -- Restore all references of corresponding record types to the
1796 -- original concurrent types.
1798 Replace_Types (To_Corresponding => False);
1799 Priv_Spec := Find_Corresponding_Spec (N, False);
1801 -- The current body truly belongs to a primitive declared between
1802 -- a private and a full view. We leave the modified body as is,
1803 -- and return the true spec.
1805 if Present (Priv_Spec)
1806 and then Is_Private_Primitive (Priv_Spec)
1811 -- In case that this is some sort of error, restore the original
1812 -- state of the body.
1814 Replace_Types (To_Corresponding => True);
1818 end Disambiguate_Spec;
1820 -------------------------------------
1821 -- Is_Private_Concurrent_Primitive --
1822 -------------------------------------
1824 function Is_Private_Concurrent_Primitive
1825 (Subp_Id : Entity_Id) return Boolean
1827 Formal_Typ : Entity_Id;
1830 if Present (First_Formal (Subp_Id)) then
1831 Formal_Typ := Etype (First_Formal (Subp_Id));
1833 if Is_Concurrent_Record_Type (Formal_Typ) then
1834 Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ);
1837 -- The type of the first formal is a concurrent tagged type with
1841 Is_Concurrent_Type (Formal_Typ)
1842 and then Is_Tagged_Type (Formal_Typ)
1843 and then Has_Private_Declaration (Formal_Typ);
1847 end Is_Private_Concurrent_Primitive;
1849 ----------------------------
1850 -- Set_Trivial_Subprogram --
1851 ----------------------------
1853 procedure Set_Trivial_Subprogram (N : Node_Id) is
1854 Nxt : constant Node_Id := Next (N);
1857 Set_Is_Trivial_Subprogram (Body_Id);
1859 if Present (Spec_Id) then
1860 Set_Is_Trivial_Subprogram (Spec_Id);
1864 and then Nkind (Nxt) = N_Simple_Return_Statement
1865 and then No (Next (Nxt))
1866 and then Present (Expression (Nxt))
1867 and then Is_Entity_Name (Expression (Nxt))
1869 Set_Never_Set_In_Source (Entity (Expression (Nxt)), False);
1871 end Set_Trivial_Subprogram;
1873 ---------------------------------
1874 -- Verify_Overriding_Indicator --
1875 ---------------------------------
1877 procedure Verify_Overriding_Indicator is
1879 if Must_Override (Body_Spec) then
1880 if Nkind (Spec_Id) = N_Defining_Operator_Symbol
1881 and then Operator_Matches_Spec (Spec_Id, Spec_Id)
1885 elsif not Is_Overriding_Operation (Spec_Id) then
1887 ("subprogram& is not overriding", Body_Spec, Spec_Id);
1890 elsif Must_Not_Override (Body_Spec) then
1891 if Is_Overriding_Operation (Spec_Id) then
1893 ("subprogram& overrides inherited operation",
1894 Body_Spec, Spec_Id);
1896 elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol
1897 and then Operator_Matches_Spec (Spec_Id, Spec_Id)
1900 ("subprogram & overrides predefined operator ",
1901 Body_Spec, Spec_Id);
1903 -- If this is not a primitive operation or protected subprogram,
1904 -- then the overriding indicator is altogether illegal.
1906 elsif not Is_Primitive (Spec_Id)
1907 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
1910 ("overriding indicator only allowed " &
1911 "if subprogram is primitive",
1915 elsif Style_Check -- ??? incorrect use of Style_Check!
1916 and then Is_Overriding_Operation (Spec_Id)
1918 pragma Assert (Unit_Declaration_Node (Body_Id) = N);
1919 Style.Missing_Overriding (N, Body_Id);
1921 end Verify_Overriding_Indicator;
1923 -- Start of processing for Analyze_Subprogram_Body_Helper
1926 -- Generic subprograms are handled separately. They always have a
1927 -- generic specification. Determine whether current scope has a
1928 -- previous declaration.
1930 -- If the subprogram body is defined within an instance of the same
1931 -- name, the instance appears as a package renaming, and will be hidden
1932 -- within the subprogram.
1934 if Present (Prev_Id)
1935 and then not Is_Overloadable (Prev_Id)
1936 and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
1937 or else Comes_From_Source (Prev_Id))
1939 if Is_Generic_Subprogram (Prev_Id) then
1941 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
1942 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
1944 Analyze_Generic_Subprogram_Body (N, Spec_Id);
1946 if Nkind (N) = N_Subprogram_Body then
1947 HSS := Handled_Statement_Sequence (N);
1948 Check_Missing_Return;
1954 -- Previous entity conflicts with subprogram name. Attempting to
1955 -- enter name will post error.
1957 Enter_Name (Body_Id);
1961 -- Non-generic case, find the subprogram declaration, if one was seen,
1962 -- or enter new overloaded entity in the current scope. If the
1963 -- Current_Entity is the Body_Id itself, the unit is being analyzed as
1964 -- part of the context of one of its subunits. No need to redo the
1967 elsif Prev_Id = Body_Id
1968 and then Has_Completion (Body_Id)
1973 Body_Id := Analyze_Subprogram_Specification (Body_Spec);
1975 if Nkind (N) = N_Subprogram_Body_Stub
1976 or else No (Corresponding_Spec (N))
1978 if Is_Private_Concurrent_Primitive (Body_Id) then
1979 Spec_Id := Disambiguate_Spec;
1981 Spec_Id := Find_Corresponding_Spec (N);
1984 -- If this is a duplicate body, no point in analyzing it
1986 if Error_Posted (N) then
1990 -- A subprogram body should cause freezing of its own declaration,
1991 -- but if there was no previous explicit declaration, then the
1992 -- subprogram will get frozen too late (there may be code within
1993 -- the body that depends on the subprogram having been frozen,
1994 -- such as uses of extra formals), so we force it to be frozen
1995 -- here. Same holds if the body and spec are compilation units.
1996 -- Finally, if the return type is an anonymous access to protected
1997 -- subprogram, it must be frozen before the body because its
1998 -- expansion has generated an equivalent type that is used when
1999 -- elaborating the body.
2001 if No (Spec_Id) then
2002 Freeze_Before (N, Body_Id);
2004 elsif Nkind (Parent (N)) = N_Compilation_Unit then
2005 Freeze_Before (N, Spec_Id);
2007 elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then
2008 Freeze_Before (N, Etype (Body_Id));
2012 Spec_Id := Corresponding_Spec (N);
2016 -- Do not inline any subprogram that contains nested subprograms, since
2017 -- the backend inlining circuit seems to generate uninitialized
2018 -- references in this case. We know this happens in the case of front
2019 -- end ZCX support, but it also appears it can happen in other cases as
2020 -- well. The backend often rejects attempts to inline in the case of
2021 -- nested procedures anyway, so little if anything is lost by this.
2022 -- Note that this is test is for the benefit of the back-end. There is
2023 -- a separate test for front-end inlining that also rejects nested
2026 -- Do not do this test if errors have been detected, because in some
2027 -- error cases, this code blows up, and we don't need it anyway if
2028 -- there have been errors, since we won't get to the linker anyway.
2030 if Comes_From_Source (Body_Id)
2031 and then Serious_Errors_Detected = 0
2035 P_Ent := Scope (P_Ent);
2036 exit when No (P_Ent) or else P_Ent = Standard_Standard;
2038 if Is_Subprogram (P_Ent) then
2039 Set_Is_Inlined (P_Ent, False);
2041 if Comes_From_Source (P_Ent)
2042 and then Has_Pragma_Inline (P_Ent)
2045 ("cannot inline& (nested subprogram)?",
2052 Check_Inline_Pragma (Spec_Id);
2054 -- Deal with special case of a fully private operation in the body of
2055 -- the protected type. We must create a declaration for the subprogram,
2056 -- in order to attach the protected subprogram that will be used in
2057 -- internal calls. We exclude compiler generated bodies from the
2058 -- expander since the issue does not arise for those cases.
2061 and then Comes_From_Source (N)
2062 and then Is_Protected_Type (Current_Scope)
2064 Spec_Id := Build_Private_Protected_Declaration (N);
2067 -- If a separate spec is present, then deal with freezing issues
2069 if Present (Spec_Id) then
2070 Spec_Decl := Unit_Declaration_Node (Spec_Id);
2071 Verify_Overriding_Indicator;
2073 -- In general, the spec will be frozen when we start analyzing the
2074 -- body. However, for internally generated operations, such as
2075 -- wrapper functions for inherited operations with controlling
2076 -- results, the spec may not have been frozen by the time we
2077 -- expand the freeze actions that include the bodies. In particular,
2078 -- extra formals for accessibility or for return-in-place may need
2079 -- to be generated. Freeze nodes, if any, are inserted before the
2082 if not Is_Frozen (Spec_Id)
2083 and then Expander_Active
2085 -- Force the generation of its freezing node to ensure proper
2086 -- management of access types in the backend.
2088 -- This is definitely needed for some cases, but it is not clear
2089 -- why, to be investigated further???
2091 Set_Has_Delayed_Freeze (Spec_Id);
2092 Insert_Actions (N, Freeze_Entity (Spec_Id, Loc));
2096 -- Mark presence of postcondition procedure in current scope and mark
2097 -- the procedure itself as needing debug info. The latter is important
2098 -- when analyzing decision coverage (for example, for MC/DC coverage).
2100 if Chars (Body_Id) = Name_uPostconditions then
2101 Set_Has_Postconditions (Current_Scope);
2102 Set_Debug_Info_Needed (Body_Id);
2105 -- Place subprogram on scope stack, and make formals visible. If there
2106 -- is a spec, the visible entity remains that of the spec.
2108 if Present (Spec_Id) then
2109 Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
2111 if Is_Child_Unit (Spec_Id) then
2112 Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False);
2116 Style.Check_Identifier (Body_Id, Spec_Id);
2119 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
2120 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
2122 if Is_Abstract_Subprogram (Spec_Id) then
2123 Error_Msg_N ("an abstract subprogram cannot have a body", N);
2127 Set_Convention (Body_Id, Convention (Spec_Id));
2128 Set_Has_Completion (Spec_Id);
2130 if Is_Protected_Type (Scope (Spec_Id)) then
2131 Prot_Typ := Scope (Spec_Id);
2134 -- If this is a body generated for a renaming, do not check for
2135 -- full conformance. The check is redundant, because the spec of
2136 -- the body is a copy of the spec in the renaming declaration,
2137 -- and the test can lead to spurious errors on nested defaults.
2139 if Present (Spec_Decl)
2140 and then not Comes_From_Source (N)
2142 (Nkind (Original_Node (Spec_Decl)) =
2143 N_Subprogram_Renaming_Declaration
2144 or else (Present (Corresponding_Body (Spec_Decl))
2146 Nkind (Unit_Declaration_Node
2147 (Corresponding_Body (Spec_Decl))) =
2148 N_Subprogram_Renaming_Declaration))
2152 -- Conversely, the spec may have been generated for specless body
2153 -- with an inline pragma.
2155 elsif Comes_From_Source (N)
2156 and then not Comes_From_Source (Spec_Id)
2157 and then Has_Pragma_Inline (Spec_Id)
2164 Fully_Conformant, True, Conformant, Body_Id);
2167 -- If the body is not fully conformant, we have to decide if we
2168 -- should analyze it or not. If it has a really messed up profile
2169 -- then we probably should not analyze it, since we will get too
2170 -- many bogus messages.
2172 -- Our decision is to go ahead in the non-fully conformant case
2173 -- only if it is at least mode conformant with the spec. Note
2174 -- that the call to Check_Fully_Conformant has issued the proper
2175 -- error messages to complain about the lack of conformance.
2178 and then not Mode_Conformant (Body_Id, Spec_Id)
2184 if Spec_Id /= Body_Id then
2185 Reference_Body_Formals (Spec_Id, Body_Id);
2188 if Nkind (N) /= N_Subprogram_Body_Stub then
2189 Set_Corresponding_Spec (N, Spec_Id);
2191 -- Ada 2005 (AI-345): If the operation is a primitive operation
2192 -- of a concurrent type, the type of the first parameter has been
2193 -- replaced with the corresponding record, which is the proper
2194 -- run-time structure to use. However, within the body there may
2195 -- be uses of the formals that depend on primitive operations
2196 -- of the type (in particular calls in prefixed form) for which
2197 -- we need the original concurrent type. The operation may have
2198 -- several controlling formals, so the replacement must be done
2201 if Comes_From_Source (Spec_Id)
2202 and then Present (First_Entity (Spec_Id))
2203 and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
2204 and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
2206 Present (Interfaces (Etype (First_Entity (Spec_Id))))
2209 (Corresponding_Concurrent_Type
2210 (Etype (First_Entity (Spec_Id))))
2213 Typ : constant Entity_Id := Etype (First_Entity (Spec_Id));
2217 Form := First_Formal (Spec_Id);
2218 while Present (Form) loop
2219 if Etype (Form) = Typ then
2220 Set_Etype (Form, Corresponding_Concurrent_Type (Typ));
2228 -- Make the formals visible, and place subprogram on scope stack.
2229 -- This is also the point at which we set Last_Real_Spec_Entity
2230 -- to mark the entities which will not be moved to the body.
2232 Install_Formals (Spec_Id);
2233 Last_Real_Spec_Entity := Last_Entity (Spec_Id);
2234 Push_Scope (Spec_Id);
2236 -- Make sure that the subprogram is immediately visible. For
2237 -- child units that have no separate spec this is indispensable.
2238 -- Otherwise it is safe albeit redundant.
2240 Set_Is_Immediately_Visible (Spec_Id);
2243 Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
2244 Set_Ekind (Body_Id, E_Subprogram_Body);
2245 Set_Scope (Body_Id, Scope (Spec_Id));
2246 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
2248 -- Case of subprogram body with no previous spec
2252 and then Comes_From_Source (Body_Id)
2253 and then not Suppress_Style_Checks (Body_Id)
2254 and then not In_Instance
2256 Style.Body_With_No_Spec (N);
2259 New_Overloaded_Entity (Body_Id);
2261 if Nkind (N) /= N_Subprogram_Body_Stub then
2262 Set_Acts_As_Spec (N);
2263 Generate_Definition (Body_Id);
2265 (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
2266 Generate_Reference_To_Formals (Body_Id);
2267 Install_Formals (Body_Id);
2268 Push_Scope (Body_Id);
2272 -- If the return type is an anonymous access type whose designated type
2273 -- is the limited view of a class-wide type and the non-limited view is
2274 -- available, update the return type accordingly.
2276 if Ada_Version >= Ada_05
2277 and then Comes_From_Source (N)
2284 Rtyp := Etype (Current_Scope);
2286 if Ekind (Rtyp) = E_Anonymous_Access_Type then
2287 Etyp := Directly_Designated_Type (Rtyp);
2289 if Is_Class_Wide_Type (Etyp)
2290 and then From_With_Type (Etyp)
2292 Set_Directly_Designated_Type
2293 (Etype (Current_Scope), Available_View (Etyp));
2299 -- If this is the proper body of a stub, we must verify that the stub
2300 -- conforms to the body, and to the previous spec if one was present.
2301 -- we know already that the body conforms to that spec. This test is
2302 -- only required for subprograms that come from source.
2304 if Nkind (Parent (N)) = N_Subunit
2305 and then Comes_From_Source (N)
2306 and then not Error_Posted (Body_Id)
2307 and then Nkind (Corresponding_Stub (Parent (N))) =
2308 N_Subprogram_Body_Stub
2311 Old_Id : constant Entity_Id :=
2313 (Specification (Corresponding_Stub (Parent (N))));
2315 Conformant : Boolean := False;
2318 if No (Spec_Id) then
2319 Check_Fully_Conformant (Body_Id, Old_Id);
2323 (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
2325 if not Conformant then
2327 -- The stub was taken to be a new declaration. Indicate
2328 -- that it lacks a body.
2330 Set_Has_Completion (Old_Id, False);
2336 Set_Has_Completion (Body_Id);
2337 Check_Eliminated (Body_Id);
2339 if Nkind (N) = N_Subprogram_Body_Stub then
2342 elsif Present (Spec_Id)
2343 and then Expander_Active
2345 (Has_Pragma_Inline_Always (Spec_Id)
2346 or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
2348 Build_Body_To_Inline (N, Spec_Id);
2351 -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
2352 -- if its specification we have to install the private withed units.
2353 -- This holds for child units as well.
2355 if Is_Compilation_Unit (Body_Id)
2356 or else Nkind (Parent (N)) = N_Compilation_Unit
2358 Install_Private_With_Clauses (Body_Id);
2361 Check_Anonymous_Return;
2363 -- Set the Protected_Formal field of each extra formal of the protected
2364 -- subprogram to reference the corresponding extra formal of the
2365 -- subprogram that implements it. For regular formals this occurs when
2366 -- the protected subprogram's declaration is expanded, but the extra
2367 -- formals don't get created until the subprogram is frozen. We need to
2368 -- do this before analyzing the protected subprogram's body so that any
2369 -- references to the original subprogram's extra formals will be changed
2370 -- refer to the implementing subprogram's formals (see Expand_Formal).
2372 if Present (Spec_Id)
2373 and then Is_Protected_Type (Scope (Spec_Id))
2374 and then Present (Protected_Body_Subprogram (Spec_Id))
2377 Impl_Subp : constant Entity_Id :=
2378 Protected_Body_Subprogram (Spec_Id);
2379 Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id);
2380 Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp);
2382 while Present (Prot_Ext_Formal) loop
2383 pragma Assert (Present (Impl_Ext_Formal));
2384 Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
2385 Next_Formal_With_Extras (Prot_Ext_Formal);
2386 Next_Formal_With_Extras (Impl_Ext_Formal);
2391 -- Now we can go on to analyze the body
2393 HSS := Handled_Statement_Sequence (N);
2394 Set_Actual_Subtypes (N, Current_Scope);
2396 -- Deal with preconditions and postconditions
2398 Process_PPCs (N, Spec_Id, Body_Id);
2400 -- Add a declaration for the Protection object, renaming declarations
2401 -- for discriminals and privals and finally a declaration for the entry
2402 -- family index (if applicable). This form of early expansion is done
2403 -- when the Expander is active because Install_Private_Data_Declarations
2404 -- references entities which were created during regular expansion.
2407 and then Comes_From_Source (N)
2408 and then Present (Prot_Typ)
2409 and then Present (Spec_Id)
2410 and then not Is_Eliminated (Spec_Id)
2412 Install_Private_Data_Declarations
2413 (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N));
2416 -- Analyze the declarations (this call will analyze the precondition
2417 -- Check pragmas we prepended to the list, as well as the declaration
2418 -- of the _Postconditions procedure).
2420 Analyze_Declarations (Declarations (N));
2422 -- Check completion, and analyze the statements
2425 Inspect_Deferred_Constant_Completion (Declarations (N));
2428 -- Deal with end of scope processing for the body
2430 Process_End_Label (HSS, 't', Current_Scope);
2432 Check_Subprogram_Order (N);
2433 Set_Analyzed (Body_Id);
2435 -- If we have a separate spec, then the analysis of the declarations
2436 -- caused the entities in the body to be chained to the spec id, but
2437 -- we want them chained to the body id. Only the formal parameters
2438 -- end up chained to the spec id in this case.
2440 if Present (Spec_Id) then
2442 -- We must conform to the categorization of our spec
2444 Validate_Categorization_Dependency (N, Spec_Id);
2446 -- And if this is a child unit, the parent units must conform
2448 if Is_Child_Unit (Spec_Id) then
2449 Validate_Categorization_Dependency
2450 (Unit_Declaration_Node (Spec_Id), Spec_Id);
2453 -- Here is where we move entities from the spec to the body
2455 -- Case where there are entities that stay with the spec
2457 if Present (Last_Real_Spec_Entity) then
2459 -- No body entities (happens when the only real spec entities
2460 -- come from precondition and postcondition pragmas)
2462 if No (Last_Entity (Body_Id)) then
2464 (Body_Id, Next_Entity (Last_Real_Spec_Entity));
2466 -- Body entities present (formals), so chain stuff past them
2470 (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity));
2473 Set_Next_Entity (Last_Real_Spec_Entity, Empty);
2474 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
2475 Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity);
2477 -- Case where there are no spec entities, in this case there can
2478 -- be no body entities either, so just move everything.
2481 pragma Assert (No (Last_Entity (Body_Id)));
2482 Set_First_Entity (Body_Id, First_Entity (Spec_Id));
2483 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
2484 Set_First_Entity (Spec_Id, Empty);
2485 Set_Last_Entity (Spec_Id, Empty);
2489 Check_Missing_Return;
2491 -- Now we are going to check for variables that are never modified in
2492 -- the body of the procedure. But first we deal with a special case
2493 -- where we want to modify this check. If the body of the subprogram
2494 -- starts with a raise statement or its equivalent, or if the body
2495 -- consists entirely of a null statement, then it is pretty obvious
2496 -- that it is OK to not reference the parameters. For example, this
2497 -- might be the following common idiom for a stubbed function:
2498 -- statement of the procedure raises an exception. In particular this
2499 -- deals with the common idiom of a stubbed function, which might
2500 -- appear as something like
2502 -- function F (A : Integer) return Some_Type;
2505 -- raise Program_Error;
2509 -- Here the purpose of X is simply to satisfy the annoying requirement
2510 -- in Ada that there be at least one return, and we certainly do not
2511 -- want to go posting warnings on X that it is not initialized! On
2512 -- the other hand, if X is entirely unreferenced that should still
2515 -- What we do is to detect these cases, and if we find them, flag the
2516 -- subprogram as being Is_Trivial_Subprogram and then use that flag to
2517 -- suppress unwanted warnings. For the case of the function stub above
2518 -- we have a special test to set X as apparently assigned to suppress
2525 -- Skip initial labels (for one thing this occurs when we are in
2526 -- front end ZCX mode, but in any case it is irrelevant), and also
2527 -- initial Push_xxx_Error_Label nodes, which are also irrelevant.
2529 Stm := First (Statements (HSS));
2530 while Nkind (Stm) = N_Label
2531 or else Nkind (Stm) in N_Push_xxx_Label
2536 -- Do the test on the original statement before expansion
2539 Ostm : constant Node_Id := Original_Node (Stm);
2542 -- If explicit raise statement, turn on flag
2544 if Nkind (Ostm) = N_Raise_Statement then
2545 Set_Trivial_Subprogram (Stm);
2547 -- If null statement, and no following statements, turn on flag
2549 elsif Nkind (Stm) = N_Null_Statement
2550 and then Comes_From_Source (Stm)
2551 and then No (Next (Stm))
2553 Set_Trivial_Subprogram (Stm);
2555 -- Check for explicit call cases which likely raise an exception
2557 elsif Nkind (Ostm) = N_Procedure_Call_Statement then
2558 if Is_Entity_Name (Name (Ostm)) then
2560 Ent : constant Entity_Id := Entity (Name (Ostm));
2563 -- If the procedure is marked No_Return, then likely it
2564 -- raises an exception, but in any case it is not coming
2565 -- back here, so turn on the flag.
2567 if Ekind (Ent) = E_Procedure
2568 and then No_Return (Ent)
2570 Set_Trivial_Subprogram (Stm);
2578 -- Check for variables that are never modified
2584 -- If there is a separate spec, then transfer Never_Set_In_Source
2585 -- flags from out parameters to the corresponding entities in the
2586 -- body. The reason we do that is we want to post error flags on
2587 -- the body entities, not the spec entities.
2589 if Present (Spec_Id) then
2590 E1 := First_Entity (Spec_Id);
2591 while Present (E1) loop
2592 if Ekind (E1) = E_Out_Parameter then
2593 E2 := First_Entity (Body_Id);
2594 while Present (E2) loop
2595 exit when Chars (E1) = Chars (E2);
2599 if Present (E2) then
2600 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
2608 -- Check references in body unless it was deleted. Note that the
2609 -- check of Body_Deleted here is not just for efficiency, it is
2610 -- necessary to avoid junk warnings on formal parameters.
2612 if not Body_Deleted then
2613 Check_References (Body_Id);
2616 end Analyze_Subprogram_Body_Helper;
2618 ------------------------------------
2619 -- Analyze_Subprogram_Declaration --
2620 ------------------------------------
2622 procedure Analyze_Subprogram_Declaration (N : Node_Id) is
2623 Loc : constant Source_Ptr := Sloc (N);
2624 Designator : Entity_Id;
2626 Scop : constant Entity_Id := Current_Scope;
2627 Null_Body : Node_Id := Empty;
2629 -- Start of processing for Analyze_Subprogram_Declaration
2632 -- For a null procedure, capture the profile before analysis, for
2633 -- expansion at the freeze point and at each point of call.
2634 -- The body will only be used if the procedure has preconditions.
2635 -- In that case the body is analyzed at the freeze point.
2637 if Nkind (Specification (N)) = N_Procedure_Specification
2638 and then Null_Present (Specification (N))
2639 and then Expander_Active
2642 Make_Subprogram_Body (Loc,
2644 New_Copy_Tree (Specification (N)),
2647 Handled_Statement_Sequence =>
2648 Make_Handled_Sequence_Of_Statements (Loc,
2649 Statements => New_List (Make_Null_Statement (Loc))));
2651 -- Create new entities for body and formals
2653 Set_Defining_Unit_Name (Specification (Null_Body),
2654 Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))));
2655 Set_Corresponding_Body (N, Defining_Entity (Null_Body));
2657 Form := First (Parameter_Specifications (Specification (Null_Body)));
2658 while Present (Form) loop
2659 Set_Defining_Identifier (Form,
2660 Make_Defining_Identifier (Loc,
2661 Chars (Defining_Identifier (Form))));
2665 if Is_Protected_Type (Current_Scope) then
2666 Error_Msg_N ("protected operation cannot be a null procedure", N);
2670 Designator := Analyze_Subprogram_Specification (Specification (N));
2671 Generate_Definition (Designator);
2673 if Debug_Flag_C then
2674 Write_Str ("==> subprogram spec ");
2675 Write_Name (Chars (Designator));
2676 Write_Str (" from ");
2677 Write_Location (Sloc (N));
2682 if Nkind (Specification (N)) = N_Procedure_Specification
2683 and then Null_Present (Specification (N))
2685 Set_Has_Completion (Designator);
2687 if Present (Null_Body) then
2688 Set_Corresponding_Body (N, Defining_Entity (Null_Body));
2689 Set_Body_To_Inline (N, Null_Body);
2690 Set_Is_Inlined (Designator);
2694 Validate_RCI_Subprogram_Declaration (N);
2695 New_Overloaded_Entity (Designator);
2696 Check_Delayed_Subprogram (Designator);
2698 -- If the type of the first formal of the current subprogram is a
2699 -- nongeneric tagged private type, mark the subprogram as being a
2700 -- private primitive. Ditto if this is a function with controlling
2701 -- result, and the return type is currently private. In both cases,
2702 -- the type of the controlling argument or result must be in the
2703 -- current scope for the operation to be primitive.
2705 if Has_Controlling_Result (Designator)
2706 and then Is_Private_Type (Etype (Designator))
2707 and then Scope (Etype (Designator)) = Current_Scope
2708 and then not Is_Generic_Actual_Type (Etype (Designator))
2710 Set_Is_Private_Primitive (Designator);
2712 elsif Present (First_Formal (Designator)) then
2714 Formal_Typ : constant Entity_Id :=
2715 Etype (First_Formal (Designator));
2717 Set_Is_Private_Primitive (Designator,
2718 Is_Tagged_Type (Formal_Typ)
2719 and then Scope (Formal_Typ) = Current_Scope
2720 and then Is_Private_Type (Formal_Typ)
2721 and then not Is_Generic_Actual_Type (Formal_Typ));
2725 -- Ada 2005 (AI-251): Abstract interface primitives must be abstract
2728 if Ada_Version >= Ada_05
2729 and then Comes_From_Source (N)
2730 and then Is_Dispatching_Operation (Designator)
2737 if Has_Controlling_Result (Designator) then
2738 Etyp := Etype (Designator);
2741 E := First_Entity (Designator);
2743 and then Is_Formal (E)
2744 and then not Is_Controlling_Formal (E)
2752 if Is_Access_Type (Etyp) then
2753 Etyp := Directly_Designated_Type (Etyp);
2756 if Is_Interface (Etyp)
2757 and then not Is_Abstract_Subprogram (Designator)
2758 and then not (Ekind (Designator) = E_Procedure
2759 and then Null_Present (Specification (N)))
2761 Error_Msg_Name_1 := Chars (Defining_Entity (N));
2763 ("(Ada 2005) interface subprogram % must be abstract or null",
2769 -- What is the following code for, it used to be
2771 -- ??? Set_Suppress_Elaboration_Checks
2772 -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
2774 -- The following seems equivalent, but a bit dubious
2776 if Elaboration_Checks_Suppressed (Designator) then
2777 Set_Kill_Elaboration_Checks (Designator);
2780 if Scop /= Standard_Standard
2781 and then not Is_Child_Unit (Designator)
2783 Set_Categorization_From_Scope (Designator, Scop);
2785 -- For a compilation unit, check for library-unit pragmas
2787 Push_Scope (Designator);
2788 Set_Categorization_From_Pragmas (N);
2789 Validate_Categorization_Dependency (N, Designator);
2793 -- For a compilation unit, set body required. This flag will only be
2794 -- reset if a valid Import or Interface pragma is processed later on.
2796 if Nkind (Parent (N)) = N_Compilation_Unit then
2797 Set_Body_Required (Parent (N), True);
2799 if Ada_Version >= Ada_05
2800 and then Nkind (Specification (N)) = N_Procedure_Specification
2801 and then Null_Present (Specification (N))
2804 ("null procedure cannot be declared at library level", N);
2808 Generate_Reference_To_Formals (Designator);
2809 Check_Eliminated (Designator);
2811 if Debug_Flag_C then
2813 Write_Str ("<== subprogram spec ");
2814 Write_Name (Chars (Designator));
2815 Write_Str (" from ");
2816 Write_Location (Sloc (N));
2819 end Analyze_Subprogram_Declaration;
2821 --------------------------------------
2822 -- Analyze_Subprogram_Specification --
2823 --------------------------------------
2825 -- Reminder: N here really is a subprogram specification (not a subprogram
2826 -- declaration). This procedure is called to analyze the specification in
2827 -- both subprogram bodies and subprogram declarations (specs).
2829 function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
2830 Designator : constant Entity_Id := Defining_Entity (N);
2831 Formals : constant List_Id := Parameter_Specifications (N);
2833 -- Start of processing for Analyze_Subprogram_Specification
2836 Generate_Definition (Designator);
2838 if Nkind (N) = N_Function_Specification then
2839 Set_Ekind (Designator, E_Function);
2840 Set_Mechanism (Designator, Default_Mechanism);
2843 Set_Ekind (Designator, E_Procedure);
2844 Set_Etype (Designator, Standard_Void_Type);
2847 -- Introduce new scope for analysis of the formals and the return type
2849 Set_Scope (Designator, Current_Scope);
2851 if Present (Formals) then
2852 Push_Scope (Designator);
2853 Process_Formals (Formals, N);
2855 -- Ada 2005 (AI-345): If this is an overriding operation of an
2856 -- inherited interface operation, and the controlling type is
2857 -- a synchronized type, replace the type with its corresponding
2858 -- record, to match the proper signature of an overriding operation.
2859 -- Same processing for an access parameter whose designated type is
2860 -- derived from a synchronized interface.
2862 if Ada_Version >= Ada_05 then
2865 Formal_Typ : Entity_Id;
2866 Rec_Typ : Entity_Id;
2867 Desig_Typ : Entity_Id;
2870 Formal := First_Formal (Designator);
2871 while Present (Formal) loop
2872 Formal_Typ := Etype (Formal);
2874 if Is_Concurrent_Type (Formal_Typ)
2875 and then Present (Corresponding_Record_Type (Formal_Typ))
2877 Rec_Typ := Corresponding_Record_Type (Formal_Typ);
2879 if Present (Interfaces (Rec_Typ)) then
2880 Set_Etype (Formal, Rec_Typ);
2883 elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then
2884 Desig_Typ := Designated_Type (Formal_Typ);
2886 if Is_Concurrent_Type (Desig_Typ)
2887 and then Present (Corresponding_Record_Type (Desig_Typ))
2889 Rec_Typ := Corresponding_Record_Type (Desig_Typ);
2891 if Present (Interfaces (Rec_Typ)) then
2892 Set_Directly_Designated_Type (Formal_Typ, Rec_Typ);
2897 Next_Formal (Formal);
2904 -- The subprogram scope is pushed and popped around the processing of
2905 -- the return type for consistency with call above to Process_Formals
2906 -- (which itself can call Analyze_Return_Type), and to ensure that any
2907 -- itype created for the return type will be associated with the proper
2910 elsif Nkind (N) = N_Function_Specification then
2911 Push_Scope (Designator);
2913 Analyze_Return_Type (N);
2918 if Nkind (N) = N_Function_Specification then
2919 if Nkind (Designator) = N_Defining_Operator_Symbol then
2920 Valid_Operator_Definition (Designator);
2923 May_Need_Actuals (Designator);
2925 -- Ada 2005 (AI-251): If the return type is abstract, verify that
2926 -- the subprogram is abstract also. This does not apply to renaming
2927 -- declarations, where abstractness is inherited.
2928 -- In case of primitives associated with abstract interface types
2929 -- the check is applied later (see Analyze_Subprogram_Declaration).
2931 if Is_Abstract_Type (Etype (Designator))
2932 and then not Is_Interface (Etype (Designator))
2933 and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
2934 and then Nkind (Parent (N)) /=
2935 N_Abstract_Subprogram_Declaration
2937 (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration
2940 ("function that returns abstract type must be abstract", N);
2945 end Analyze_Subprogram_Specification;
2947 --------------------------
2948 -- Build_Body_To_Inline --
2949 --------------------------
2951 procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
2952 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
2953 Original_Body : Node_Id;
2954 Body_To_Analyze : Node_Id;
2955 Max_Size : constant := 10;
2956 Stat_Count : Integer := 0;
2958 function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
2959 -- Check for declarations that make inlining not worthwhile
2961 function Has_Excluded_Statement (Stats : List_Id) return Boolean;
2962 -- Check for statements that make inlining not worthwhile: any tasking
2963 -- statement, nested at any level. Keep track of total number of
2964 -- elementary statements, as a measure of acceptable size.
2966 function Has_Pending_Instantiation return Boolean;
2967 -- If some enclosing body contains instantiations that appear before the
2968 -- corresponding generic body, the enclosing body has a freeze node so
2969 -- that it can be elaborated after the generic itself. This might
2970 -- conflict with subsequent inlinings, so that it is unsafe to try to
2971 -- inline in such a case.
2973 function Has_Single_Return return Boolean;
2974 -- In general we cannot inline functions that return unconstrained type.
2975 -- However, we can handle such functions if all return statements return
2976 -- a local variable that is the only declaration in the body of the
2977 -- function. In that case the call can be replaced by that local
2978 -- variable as is done for other inlined calls.
2980 procedure Remove_Pragmas;
2981 -- A pragma Unreferenced or pragma Unmodified that mentions a formal
2982 -- parameter has no meaning when the body is inlined and the formals
2983 -- are rewritten. Remove it from body to inline. The analysis of the
2984 -- non-inlined body will handle the pragma properly.
2986 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
2987 -- If the body of the subprogram includes a call that returns an
2988 -- unconstrained type, the secondary stack is involved, and it
2989 -- is not worth inlining.
2991 ------------------------------
2992 -- Has_Excluded_Declaration --
2993 ------------------------------
2995 function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
2998 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
2999 -- Nested subprograms make a given body ineligible for inlining, but
3000 -- we make an exception for instantiations of unchecked conversion.
3001 -- The body has not been analyzed yet, so check the name, and verify
3002 -- that the visible entity with that name is the predefined unit.
3004 -----------------------------
3005 -- Is_Unchecked_Conversion --
3006 -----------------------------
3008 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
3009 Id : constant Node_Id := Name (D);
3013 if Nkind (Id) = N_Identifier
3014 and then Chars (Id) = Name_Unchecked_Conversion
3016 Conv := Current_Entity (Id);
3018 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
3019 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
3021 Conv := Current_Entity (Selector_Name (Id));
3026 return Present (Conv)
3027 and then Is_Predefined_File_Name
3028 (Unit_File_Name (Get_Source_Unit (Conv)))
3029 and then Is_Intrinsic_Subprogram (Conv);
3030 end Is_Unchecked_Conversion;
3032 -- Start of processing for Has_Excluded_Declaration
3036 while Present (D) loop
3037 if (Nkind (D) = N_Function_Instantiation
3038 and then not Is_Unchecked_Conversion (D))
3039 or else Nkind_In (D, N_Protected_Type_Declaration,
3040 N_Package_Declaration,
3041 N_Package_Instantiation,
3043 N_Procedure_Instantiation,
3044 N_Task_Type_Declaration)
3047 ("cannot inline & (non-allowed declaration)?", D, Subp);
3055 end Has_Excluded_Declaration;
3057 ----------------------------
3058 -- Has_Excluded_Statement --
3059 ----------------------------
3061 function Has_Excluded_Statement (Stats : List_Id) return Boolean is
3067 while Present (S) loop
3068 Stat_Count := Stat_Count + 1;
3070 if Nkind_In (S, N_Abort_Statement,
3071 N_Asynchronous_Select,
3072 N_Conditional_Entry_Call,
3073 N_Delay_Relative_Statement,
3074 N_Delay_Until_Statement,
3079 ("cannot inline & (non-allowed statement)?", S, Subp);
3082 elsif Nkind (S) = N_Block_Statement then
3083 if Present (Declarations (S))
3084 and then Has_Excluded_Declaration (Declarations (S))
3088 elsif Present (Handled_Statement_Sequence (S))
3091 (Exception_Handlers (Handled_Statement_Sequence (S)))
3093 Has_Excluded_Statement
3094 (Statements (Handled_Statement_Sequence (S))))
3099 elsif Nkind (S) = N_Case_Statement then
3100 E := First (Alternatives (S));
3101 while Present (E) loop
3102 if Has_Excluded_Statement (Statements (E)) then
3109 elsif Nkind (S) = N_If_Statement then
3110 if Has_Excluded_Statement (Then_Statements (S)) then
3114 if Present (Elsif_Parts (S)) then
3115 E := First (Elsif_Parts (S));
3116 while Present (E) loop
3117 if Has_Excluded_Statement (Then_Statements (E)) then
3124 if Present (Else_Statements (S))
3125 and then Has_Excluded_Statement (Else_Statements (S))
3130 elsif Nkind (S) = N_Loop_Statement
3131 and then Has_Excluded_Statement (Statements (S))
3135 elsif Nkind (S) = N_Extended_Return_Statement then
3136 if Has_Excluded_Statement
3137 (Statements (Handled_Statement_Sequence (S)))
3139 (Exception_Handlers (Handled_Statement_Sequence (S)))
3149 end Has_Excluded_Statement;
3151 -------------------------------
3152 -- Has_Pending_Instantiation --
3153 -------------------------------
3155 function Has_Pending_Instantiation return Boolean is
3160 while Present (S) loop
3161 if Is_Compilation_Unit (S)
3162 or else Is_Child_Unit (S)
3166 elsif Ekind (S) = E_Package
3167 and then Has_Forward_Instantiation (S)
3176 end Has_Pending_Instantiation;
3178 ------------------------
3179 -- Has_Single_Return --
3180 ------------------------
3182 function Has_Single_Return return Boolean is
3183 Return_Statement : Node_Id := Empty;
3185 function Check_Return (N : Node_Id) return Traverse_Result;
3191 function Check_Return (N : Node_Id) return Traverse_Result is
3193 if Nkind (N) = N_Simple_Return_Statement then
3194 if Present (Expression (N))
3195 and then Is_Entity_Name (Expression (N))
3197 if No (Return_Statement) then
3198 Return_Statement := N;
3201 elsif Chars (Expression (N)) =
3202 Chars (Expression (Return_Statement))
3210 -- A return statement within an extended return is a noop
3213 elsif No (Expression (N))
3214 and then Nkind (Parent (Parent (N))) =
3215 N_Extended_Return_Statement
3220 -- Expression has wrong form
3225 -- We can only inline a build-in-place function if
3226 -- it has a single extended return.
3228 elsif Nkind (N) = N_Extended_Return_Statement then
3229 if No (Return_Statement) then
3230 Return_Statement := N;
3242 function Check_All_Returns is new Traverse_Func (Check_Return);
3244 -- Start of processing for Has_Single_Return
3247 if Check_All_Returns (N) /= OK then
3250 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
3254 return Present (Declarations (N))
3255 and then Present (First (Declarations (N)))
3256 and then Chars (Expression (Return_Statement)) =
3257 Chars (Defining_Identifier (First (Declarations (N))));
3259 end Has_Single_Return;
3261 --------------------
3262 -- Remove_Pragmas --
3263 --------------------
3265 procedure Remove_Pragmas is
3270 Decl := First (Declarations (Body_To_Analyze));
3271 while Present (Decl) loop
3274 if Nkind (Decl) = N_Pragma
3275 and then (Pragma_Name (Decl) = Name_Unreferenced
3277 Pragma_Name (Decl) = Name_Unmodified)
3286 --------------------------
3287 -- Uses_Secondary_Stack --
3288 --------------------------
3290 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
3291 function Check_Call (N : Node_Id) return Traverse_Result;
3292 -- Look for function calls that return an unconstrained type
3298 function Check_Call (N : Node_Id) return Traverse_Result is
3300 if Nkind (N) = N_Function_Call
3301 and then Is_Entity_Name (Name (N))
3302 and then Is_Composite_Type (Etype (Entity (Name (N))))
3303 and then not Is_Constrained (Etype (Entity (Name (N))))
3306 ("cannot inline & (call returns unconstrained type)?",
3314 function Check_Calls is new Traverse_Func (Check_Call);
3317 return Check_Calls (Bod) = Abandon;
3318 end Uses_Secondary_Stack;
3320 -- Start of processing for Build_Body_To_Inline
3323 -- Return immediately if done already
3325 if Nkind (Decl) = N_Subprogram_Declaration
3326 and then Present (Body_To_Inline (Decl))
3330 -- Functions that return unconstrained composite types require
3331 -- secondary stack handling, and cannot currently be inlined, unless
3332 -- all return statements return a local variable that is the first
3333 -- local declaration in the body.
3335 elsif Ekind (Subp) = E_Function
3336 and then not Is_Scalar_Type (Etype (Subp))
3337 and then not Is_Access_Type (Etype (Subp))
3338 and then not Is_Constrained (Etype (Subp))
3340 if not Has_Single_Return then
3342 ("cannot inline & (unconstrained return type)?", N, Subp);
3346 -- Ditto for functions that return controlled types, where controlled
3347 -- actions interfere in complex ways with inlining.
3349 elsif Ekind (Subp) = E_Function
3350 and then Needs_Finalization (Etype (Subp))
3353 ("cannot inline & (controlled return type)?", N, Subp);
3357 if Present (Declarations (N))
3358 and then Has_Excluded_Declaration (Declarations (N))
3363 if Present (Handled_Statement_Sequence (N)) then
3364 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
3366 ("cannot inline& (exception handler)?",
3367 First (Exception_Handlers (Handled_Statement_Sequence (N))),
3371 Has_Excluded_Statement
3372 (Statements (Handled_Statement_Sequence (N)))
3378 -- We do not inline a subprogram that is too large, unless it is
3379 -- marked Inline_Always. This pragma does not suppress the other
3380 -- checks on inlining (forbidden declarations, handlers, etc).
3382 if Stat_Count > Max_Size
3383 and then not Has_Pragma_Inline_Always (Subp)
3385 Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
3389 if Has_Pending_Instantiation then
3391 ("cannot inline& (forward instance within enclosing body)?",
3396 -- Within an instance, the body to inline must be treated as a nested
3397 -- generic, so that the proper global references are preserved.
3399 -- Note that we do not do this at the library level, because it is not
3400 -- needed, and furthermore this causes trouble if front end inlining
3401 -- is activated (-gnatN).
3403 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
3404 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
3405 Original_Body := Copy_Generic_Node (N, Empty, True);
3407 Original_Body := Copy_Separate_Tree (N);
3410 -- We need to capture references to the formals in order to substitute
3411 -- the actuals at the point of inlining, i.e. instantiation. To treat
3412 -- the formals as globals to the body to inline, we nest it within
3413 -- a dummy parameterless subprogram, declared within the real one.
3414 -- To avoid generating an internal name (which is never public, and
3415 -- which affects serial numbers of other generated names), we use
3416 -- an internal symbol that cannot conflict with user declarations.
3418 Set_Parameter_Specifications (Specification (Original_Body), No_List);
3419 Set_Defining_Unit_Name
3420 (Specification (Original_Body),
3421 Make_Defining_Identifier (Sloc (N), Name_uParent));
3422 Set_Corresponding_Spec (Original_Body, Empty);
3424 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
3426 -- Set return type of function, which is also global and does not need
3429 if Ekind (Subp) = E_Function then
3430 Set_Result_Definition (Specification (Body_To_Analyze),
3431 New_Occurrence_Of (Etype (Subp), Sloc (N)));
3434 if No (Declarations (N)) then
3435 Set_Declarations (N, New_List (Body_To_Analyze));
3437 Append (Body_To_Analyze, Declarations (N));
3440 Expander_Mode_Save_And_Set (False);
3443 Analyze (Body_To_Analyze);
3444 Push_Scope (Defining_Entity (Body_To_Analyze));
3445 Save_Global_References (Original_Body);
3447 Remove (Body_To_Analyze);
3449 Expander_Mode_Restore;
3451 -- Restore environment if previously saved
3453 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
3457 -- If secondary stk used there is no point in inlining. We have
3458 -- already issued the warning in this case, so nothing to do.
3460 if Uses_Secondary_Stack (Body_To_Analyze) then
3464 Set_Body_To_Inline (Decl, Original_Body);
3465 Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
3466 Set_Is_Inlined (Subp);
3467 end Build_Body_To_Inline;
3473 procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is
3475 -- Do not emit warning if this is a predefined unit which is not
3476 -- the main unit. With validity checks enabled, some predefined
3477 -- subprograms may contain nested subprograms and become ineligible
3480 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
3481 and then not In_Extended_Main_Source_Unit (Subp)
3485 elsif Has_Pragma_Inline_Always (Subp) then
3487 -- Remove last character (question mark) to make this into an error,
3488 -- because the Inline_Always pragma cannot be obeyed.
3490 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
3492 elsif Ineffective_Inline_Warnings then
3493 Error_Msg_NE (Msg, N, Subp);
3497 -----------------------
3498 -- Check_Conformance --
3499 -----------------------
3501 procedure Check_Conformance
3502 (New_Id : Entity_Id;
3504 Ctype : Conformance_Type;
3506 Conforms : out Boolean;
3507 Err_Loc : Node_Id := Empty;
3508 Get_Inst : Boolean := False;
3509 Skip_Controlling_Formals : Boolean := False)
3511 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
3512 -- Sets Conforms to False. If Errmsg is False, then that's all it does.
3513 -- If Errmsg is True, then processing continues to post an error message
3514 -- for conformance error on given node. Two messages are output. The
3515 -- first message points to the previous declaration with a general "no
3516 -- conformance" message. The second is the detailed reason, supplied as
3517 -- Msg. The parameter N provide information for a possible & insertion
3518 -- in the message, and also provides the location for posting the
3519 -- message in the absence of a specified Err_Loc location.
3521 -----------------------
3522 -- Conformance_Error --
3523 -----------------------
3525 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
3532 if No (Err_Loc) then
3538 Error_Msg_Sloc := Sloc (Old_Id);
3541 when Type_Conformant =>
3542 Error_Msg_N -- CODEFIX
3543 ("not type conformant with declaration#!", Enode);
3545 when Mode_Conformant =>
3546 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3548 ("not mode conformant with operation inherited#!",
3552 ("not mode conformant with declaration#!", Enode);
3555 when Subtype_Conformant =>
3556 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3558 ("not subtype conformant with operation inherited#!",
3562 ("not subtype conformant with declaration#!", Enode);
3565 when Fully_Conformant =>
3566 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3567 Error_Msg_N -- CODEFIX
3568 ("not fully conformant with operation inherited#!",
3571 Error_Msg_N -- CODEFIX
3572 ("not fully conformant with declaration#!", Enode);
3576 Error_Msg_NE (Msg, Enode, N);
3578 end Conformance_Error;
3582 Old_Type : constant Entity_Id := Etype (Old_Id);
3583 New_Type : constant Entity_Id := Etype (New_Id);
3584 Old_Formal : Entity_Id;
3585 New_Formal : Entity_Id;
3586 Access_Types_Match : Boolean;
3587 Old_Formal_Base : Entity_Id;
3588 New_Formal_Base : Entity_Id;
3590 -- Start of processing for Check_Conformance
3595 -- We need a special case for operators, since they don't appear
3598 if Ctype = Type_Conformant then
3599 if Ekind (New_Id) = E_Operator
3600 and then Operator_Matches_Spec (New_Id, Old_Id)
3606 -- If both are functions/operators, check return types conform
3608 if Old_Type /= Standard_Void_Type
3609 and then New_Type /= Standard_Void_Type
3612 -- If we are checking interface conformance we omit controlling
3613 -- arguments and result, because we are only checking the conformance
3614 -- of the remaining parameters.
3616 if Has_Controlling_Result (Old_Id)
3617 and then Has_Controlling_Result (New_Id)
3618 and then Skip_Controlling_Formals
3622 elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
3623 Conformance_Error ("\return type does not match!", New_Id);
3627 -- Ada 2005 (AI-231): In case of anonymous access types check the
3628 -- null-exclusion and access-to-constant attributes match.
3630 if Ada_Version >= Ada_05
3631 and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
3633 (Can_Never_Be_Null (Old_Type)
3634 /= Can_Never_Be_Null (New_Type)
3635 or else Is_Access_Constant (Etype (Old_Type))
3636 /= Is_Access_Constant (Etype (New_Type)))
3638 Conformance_Error ("\return type does not match!", New_Id);
3642 -- If either is a function/operator and the other isn't, error
3644 elsif Old_Type /= Standard_Void_Type
3645 or else New_Type /= Standard_Void_Type
3647 Conformance_Error ("\functions can only match functions!", New_Id);
3651 -- In subtype conformant case, conventions must match (RM 6.3.1(16)).
3652 -- If this is a renaming as body, refine error message to indicate that
3653 -- the conflict is with the original declaration. If the entity is not
3654 -- frozen, the conventions don't have to match, the one of the renamed
3655 -- entity is inherited.
3657 if Ctype >= Subtype_Conformant then
3658 if Convention (Old_Id) /= Convention (New_Id) then
3660 if not Is_Frozen (New_Id) then
3663 elsif Present (Err_Loc)
3664 and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
3665 and then Present (Corresponding_Spec (Err_Loc))
3667 Error_Msg_Name_1 := Chars (New_Id);
3669 Name_Ada + Convention_Id'Pos (Convention (New_Id));
3671 Conformance_Error ("\prior declaration for% has convention %!");
3674 Conformance_Error ("\calling conventions do not match!");
3679 elsif Is_Formal_Subprogram (Old_Id)
3680 or else Is_Formal_Subprogram (New_Id)
3682 Conformance_Error ("\formal subprograms not allowed!");
3687 -- Deal with parameters
3689 -- Note: we use the entity information, rather than going directly
3690 -- to the specification in the tree. This is not only simpler, but
3691 -- absolutely necessary for some cases of conformance tests between
3692 -- operators, where the declaration tree simply does not exist!
3694 Old_Formal := First_Formal (Old_Id);
3695 New_Formal := First_Formal (New_Id);
3696 while Present (Old_Formal) and then Present (New_Formal) loop
3697 if Is_Controlling_Formal (Old_Formal)
3698 and then Is_Controlling_Formal (New_Formal)
3699 and then Skip_Controlling_Formals
3701 -- The controlling formals will have different types when
3702 -- comparing an interface operation with its match, but both
3703 -- or neither must be access parameters.
3705 if Is_Access_Type (Etype (Old_Formal))
3707 Is_Access_Type (Etype (New_Formal))
3709 goto Skip_Controlling_Formal;
3712 ("\access parameter does not match!", New_Formal);
3716 if Ctype = Fully_Conformant then
3718 -- Names must match. Error message is more accurate if we do
3719 -- this before checking that the types of the formals match.
3721 if Chars (Old_Formal) /= Chars (New_Formal) then
3722 Conformance_Error ("\name & does not match!", New_Formal);
3724 -- Set error posted flag on new formal as well to stop
3725 -- junk cascaded messages in some cases.
3727 Set_Error_Posted (New_Formal);
3732 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
3733 -- case occurs whenever a subprogram is being renamed and one of its
3734 -- parameters imposes a null exclusion. For example:
3736 -- type T is null record;
3737 -- type Acc_T is access T;
3738 -- subtype Acc_T_Sub is Acc_T;
3740 -- procedure P (Obj : not null Acc_T_Sub); -- itype
3741 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype
3744 Old_Formal_Base := Etype (Old_Formal);
3745 New_Formal_Base := Etype (New_Formal);
3748 Old_Formal_Base := Get_Instance_Of (Old_Formal_Base);
3749 New_Formal_Base := Get_Instance_Of (New_Formal_Base);
3752 Access_Types_Match := Ada_Version >= Ada_05
3754 -- Ensure that this rule is only applied when New_Id is a
3755 -- renaming of Old_Id.
3757 and then Nkind (Parent (Parent (New_Id))) =
3758 N_Subprogram_Renaming_Declaration
3759 and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity
3760 and then Present (Entity (Name (Parent (Parent (New_Id)))))
3761 and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
3763 -- Now handle the allowed access-type case
3765 and then Is_Access_Type (Old_Formal_Base)
3766 and then Is_Access_Type (New_Formal_Base)
3768 -- The type kinds must match. The only exception occurs with
3769 -- multiple generics of the form:
3772 -- type F is private; type A is private;
3773 -- type F_Ptr is access F; type A_Ptr is access A;
3774 -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
3775 -- package F_Pack is ... package A_Pack is
3776 -- package F_Inst is
3777 -- new F_Pack (A, A_Ptr, A_P);
3779 -- When checking for conformance between the parameters of A_P
3780 -- and F_P, the type kinds of F_Ptr and A_Ptr will not match
3781 -- because the compiler has transformed A_Ptr into a subtype of
3782 -- F_Ptr. We catch this case in the code below.
3784 and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base)
3786 (Is_Generic_Type (Old_Formal_Base)
3787 and then Is_Generic_Type (New_Formal_Base)
3788 and then Is_Internal (New_Formal_Base)
3789 and then Etype (Etype (New_Formal_Base)) =
3791 and then Directly_Designated_Type (Old_Formal_Base) =
3792 Directly_Designated_Type (New_Formal_Base)
3793 and then ((Is_Itype (Old_Formal_Base)
3794 and then Can_Never_Be_Null (Old_Formal_Base))
3796 (Is_Itype (New_Formal_Base)
3797 and then Can_Never_Be_Null (New_Formal_Base)));
3799 -- Types must always match. In the visible part of an instance,
3800 -- usual overloading rules for dispatching operations apply, and
3801 -- we check base types (not the actual subtypes).
3803 if In_Instance_Visible_Part
3804 and then Is_Dispatching_Operation (New_Id)
3806 if not Conforming_Types
3807 (T1 => Base_Type (Etype (Old_Formal)),
3808 T2 => Base_Type (Etype (New_Formal)),
3810 Get_Inst => Get_Inst)
3811 and then not Access_Types_Match
3813 Conformance_Error ("\type of & does not match!", New_Formal);
3817 elsif not Conforming_Types
3818 (T1 => Old_Formal_Base,
3819 T2 => New_Formal_Base,
3821 Get_Inst => Get_Inst)
3822 and then not Access_Types_Match
3824 -- Don't give error message if old type is Any_Type. This test
3825 -- avoids some cascaded errors, e.g. in case of a bad spec.
3827 if Errmsg and then Old_Formal_Base = Any_Type then
3830 Conformance_Error ("\type of & does not match!", New_Formal);
3836 -- For mode conformance, mode must match
3838 if Ctype >= Mode_Conformant then
3839 if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then
3840 Conformance_Error ("\mode of & does not match!", New_Formal);
3843 -- Part of mode conformance for access types is having the same
3844 -- constant modifier.
3846 elsif Access_Types_Match
3847 and then Is_Access_Constant (Old_Formal_Base) /=
3848 Is_Access_Constant (New_Formal_Base)
3851 ("\constant modifier does not match!", New_Formal);
3856 if Ctype >= Subtype_Conformant then
3858 -- Ada 2005 (AI-231): In case of anonymous access types check
3859 -- the null-exclusion and access-to-constant attributes must
3862 if Ada_Version >= Ada_05
3863 and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
3864 and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type
3866 (Can_Never_Be_Null (Old_Formal) /=
3867 Can_Never_Be_Null (New_Formal)
3869 Is_Access_Constant (Etype (Old_Formal)) /=
3870 Is_Access_Constant (Etype (New_Formal)))
3872 -- It is allowed to omit the null-exclusion in case of stream
3873 -- attribute subprograms. We recognize stream subprograms
3874 -- through their TSS-generated suffix.
3877 TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id);
3879 if TSS_Name /= TSS_Stream_Read
3880 and then TSS_Name /= TSS_Stream_Write
3881 and then TSS_Name /= TSS_Stream_Input
3882 and then TSS_Name /= TSS_Stream_Output
3885 ("\type of & does not match!", New_Formal);
3892 -- Full conformance checks
3894 if Ctype = Fully_Conformant then
3896 -- We have checked already that names match
3898 if Parameter_Mode (Old_Formal) = E_In_Parameter then
3900 -- Check default expressions for in parameters
3903 NewD : constant Boolean :=
3904 Present (Default_Value (New_Formal));
3905 OldD : constant Boolean :=
3906 Present (Default_Value (Old_Formal));
3908 if NewD or OldD then
3910 -- The old default value has been analyzed because the
3911 -- current full declaration will have frozen everything
3912 -- before. The new default value has not been analyzed,
3913 -- so analyze it now before we check for conformance.
3916 Push_Scope (New_Id);
3917 Preanalyze_Spec_Expression
3918 (Default_Value (New_Formal), Etype (New_Formal));
3922 if not (NewD and OldD)
3923 or else not Fully_Conformant_Expressions
3924 (Default_Value (Old_Formal),
3925 Default_Value (New_Formal))
3928 ("\default expression for & does not match!",
3937 -- A couple of special checks for Ada 83 mode. These checks are
3938 -- skipped if either entity is an operator in package Standard,
3939 -- or if either old or new instance is not from the source program.
3941 if Ada_Version = Ada_83
3942 and then Sloc (Old_Id) > Standard_Location
3943 and then Sloc (New_Id) > Standard_Location
3944 and then Comes_From_Source (Old_Id)
3945 and then Comes_From_Source (New_Id)
3948 Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
3949 New_Param : constant Node_Id := Declaration_Node (New_Formal);
3952 -- Explicit IN must be present or absent in both cases. This
3953 -- test is required only in the full conformance case.
3955 if In_Present (Old_Param) /= In_Present (New_Param)
3956 and then Ctype = Fully_Conformant
3959 ("\(Ada 83) IN must appear in both declarations",
3964 -- Grouping (use of comma in param lists) must be the same
3965 -- This is where we catch a misconformance like:
3968 -- A : Integer; B : Integer
3970 -- which are represented identically in the tree except
3971 -- for the setting of the flags More_Ids and Prev_Ids.
3973 if More_Ids (Old_Param) /= More_Ids (New_Param)
3974 or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
3977 ("\grouping of & does not match!", New_Formal);
3983 -- This label is required when skipping controlling formals
3985 <<Skip_Controlling_Formal>>
3987 Next_Formal (Old_Formal);
3988 Next_Formal (New_Formal);
3991 if Present (Old_Formal) then
3992 Conformance_Error ("\too few parameters!");
3995 elsif Present (New_Formal) then
3996 Conformance_Error ("\too many parameters!", New_Formal);
3999 end Check_Conformance;
4001 -----------------------
4002 -- Check_Conventions --
4003 -----------------------
4005 procedure Check_Conventions (Typ : Entity_Id) is
4006 Ifaces_List : Elist_Id;
4008 procedure Check_Convention (Op : Entity_Id);
4009 -- Verify that the convention of inherited dispatching operation Op is
4010 -- consistent among all subprograms it overrides. In order to minimize
4011 -- the search, Search_From is utilized to designate a specific point in
4012 -- the list rather than iterating over the whole list once more.
4014 ----------------------
4015 -- Check_Convention --
4016 ----------------------
4018 procedure Check_Convention (Op : Entity_Id) is
4019 Iface_Elmt : Elmt_Id;
4020 Iface_Prim_Elmt : Elmt_Id;
4021 Iface_Prim : Entity_Id;
4024 Iface_Elmt := First_Elmt (Ifaces_List);
4025 while Present (Iface_Elmt) loop
4027 First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
4028 while Present (Iface_Prim_Elmt) loop
4029 Iface_Prim := Node (Iface_Prim_Elmt);
4031 if Is_Interface_Conformant (Typ, Iface_Prim, Op)
4032 and then Convention (Iface_Prim) /= Convention (Op)
4035 ("inconsistent conventions in primitive operations", Typ);
4037 Error_Msg_Name_1 := Chars (Op);
4038 Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
4039 Error_Msg_Sloc := Sloc (Op);
4041 if Comes_From_Source (Op) then
4042 if not Is_Overriding_Operation (Op) then
4043 Error_Msg_N ("\\primitive % defined #", Typ);
4046 ("\\overriding operation % with " &
4047 "convention % defined #", Typ);
4050 else pragma Assert (Present (Alias (Op)));
4051 Error_Msg_Sloc := Sloc (Alias (Op));
4053 ("\\inherited operation % with " &
4054 "convention % defined #", Typ);
4057 Error_Msg_Name_1 := Chars (Op);
4059 Get_Convention_Name (Convention (Iface_Prim));
4060 Error_Msg_Sloc := Sloc (Iface_Prim);
4062 ("\\overridden operation % with " &
4063 "convention % defined #", Typ);
4065 -- Avoid cascading errors
4070 Next_Elmt (Iface_Prim_Elmt);
4073 Next_Elmt (Iface_Elmt);
4075 end Check_Convention;
4079 Prim_Op : Entity_Id;
4080 Prim_Op_Elmt : Elmt_Id;
4082 -- Start of processing for Check_Conventions
4085 if not Has_Interfaces (Typ) then
4089 Collect_Interfaces (Typ, Ifaces_List);
4091 -- The algorithm checks every overriding dispatching operation against
4092 -- all the corresponding overridden dispatching operations, detecting
4093 -- differences in conventions.
4095 Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ));
4096 while Present (Prim_Op_Elmt) loop
4097 Prim_Op := Node (Prim_Op_Elmt);
4099 -- A small optimization: skip the predefined dispatching operations
4100 -- since they always have the same convention.
4102 if not Is_Predefined_Dispatching_Operation (Prim_Op) then
4103 Check_Convention (Prim_Op);
4106 Next_Elmt (Prim_Op_Elmt);
4108 end Check_Conventions;
4110 ------------------------------
4111 -- Check_Delayed_Subprogram --
4112 ------------------------------
4114 procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
4117 procedure Possible_Freeze (T : Entity_Id);
4118 -- T is the type of either a formal parameter or of the return type.
4119 -- If T is not yet frozen and needs a delayed freeze, then the
4120 -- subprogram itself must be delayed. If T is the limited view of an
4121 -- incomplete type the subprogram must be frozen as well, because
4122 -- T may depend on local types that have not been frozen yet.
4124 ---------------------
4125 -- Possible_Freeze --
4126 ---------------------
4128 procedure Possible_Freeze (T : Entity_Id) is
4130 if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
4131 Set_Has_Delayed_Freeze (Designator);
4133 elsif Is_Access_Type (T)
4134 and then Has_Delayed_Freeze (Designated_Type (T))
4135 and then not Is_Frozen (Designated_Type (T))
4137 Set_Has_Delayed_Freeze (Designator);
4139 elsif Ekind (T) = E_Incomplete_Type and then From_With_Type (T) then
4140 Set_Has_Delayed_Freeze (Designator);
4143 end Possible_Freeze;
4145 -- Start of processing for Check_Delayed_Subprogram
4148 -- Never need to freeze abstract subprogram
4150 if Ekind (Designator) /= E_Subprogram_Type
4151 and then Is_Abstract_Subprogram (Designator)
4155 -- Need delayed freeze if return type itself needs a delayed
4156 -- freeze and is not yet frozen.
4158 Possible_Freeze (Etype (Designator));
4159 Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
4161 -- Need delayed freeze if any of the formal types themselves need
4162 -- a delayed freeze and are not yet frozen.
4164 F := First_Formal (Designator);
4165 while Present (F) loop
4166 Possible_Freeze (Etype (F));
4167 Possible_Freeze (Base_Type (Etype (F))); -- needed ???
4172 -- Mark functions that return by reference. Note that it cannot be
4173 -- done for delayed_freeze subprograms because the underlying
4174 -- returned type may not be known yet (for private types)
4176 if not Has_Delayed_Freeze (Designator)
4177 and then Expander_Active
4180 Typ : constant Entity_Id := Etype (Designator);
4181 Utyp : constant Entity_Id := Underlying_Type (Typ);
4184 if Is_Inherently_Limited_Type (Typ) then
4185 Set_Returns_By_Ref (Designator);
4187 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
4188 Set_Returns_By_Ref (Designator);
4192 end Check_Delayed_Subprogram;
4194 ------------------------------------
4195 -- Check_Discriminant_Conformance --
4196 ------------------------------------
4198 procedure Check_Discriminant_Conformance
4203 Old_Discr : Entity_Id := First_Discriminant (Prev);
4204 New_Discr : Node_Id := First (Discriminant_Specifications (N));
4205 New_Discr_Id : Entity_Id;
4206 New_Discr_Type : Entity_Id;
4208 procedure Conformance_Error (Msg : String; N : Node_Id);
4209 -- Post error message for conformance error on given node. Two messages
4210 -- are output. The first points to the previous declaration with a
4211 -- general "no conformance" message. The second is the detailed reason,
4212 -- supplied as Msg. The parameter N provide information for a possible
4213 -- & insertion in the message.
4215 -----------------------
4216 -- Conformance_Error --
4217 -----------------------
4219 procedure Conformance_Error (Msg : String; N : Node_Id) is
4221 Error_Msg_Sloc := Sloc (Prev_Loc);
4222 Error_Msg_N -- CODEFIX
4223 ("not fully conformant with declaration#!", N);
4224 Error_Msg_NE (Msg, N, N);
4225 end Conformance_Error;
4227 -- Start of processing for Check_Discriminant_Conformance
4230 while Present (Old_Discr) and then Present (New_Discr) loop
4232 New_Discr_Id := Defining_Identifier (New_Discr);
4234 -- The subtype mark of the discriminant on the full type has not
4235 -- been analyzed so we do it here. For an access discriminant a new
4238 if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
4240 Access_Definition (N, Discriminant_Type (New_Discr));
4243 Analyze (Discriminant_Type (New_Discr));
4244 New_Discr_Type := Etype (Discriminant_Type (New_Discr));
4246 -- Ada 2005: if the discriminant definition carries a null
4247 -- exclusion, create an itype to check properly for consistency
4248 -- with partial declaration.
4250 if Is_Access_Type (New_Discr_Type)
4251 and then Null_Exclusion_Present (New_Discr)
4254 Create_Null_Excluding_Itype
4255 (T => New_Discr_Type,
4256 Related_Nod => New_Discr,
4257 Scope_Id => Current_Scope);
4261 if not Conforming_Types
4262 (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
4264 Conformance_Error ("type of & does not match!", New_Discr_Id);
4267 -- Treat the new discriminant as an occurrence of the old one,
4268 -- for navigation purposes, and fill in some semantic
4269 -- information, for completeness.
4271 Generate_Reference (Old_Discr, New_Discr_Id, 'r');
4272 Set_Etype (New_Discr_Id, Etype (Old_Discr));
4273 Set_Scope (New_Discr_Id, Scope (Old_Discr));
4278 if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
4279 Conformance_Error ("name & does not match!", New_Discr_Id);
4283 -- Default expressions must match
4286 NewD : constant Boolean :=
4287 Present (Expression (New_Discr));
4288 OldD : constant Boolean :=
4289 Present (Expression (Parent (Old_Discr)));
4292 if NewD or OldD then
4294 -- The old default value has been analyzed and expanded,
4295 -- because the current full declaration will have frozen
4296 -- everything before. The new default values have not been
4297 -- expanded, so expand now to check conformance.
4300 Preanalyze_Spec_Expression
4301 (Expression (New_Discr), New_Discr_Type);
4304 if not (NewD and OldD)
4305 or else not Fully_Conformant_Expressions
4306 (Expression (Parent (Old_Discr)),
4307 Expression (New_Discr))
4311 ("default expression for & does not match!",
4318 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
4320 if Ada_Version = Ada_83 then
4322 Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
4325 -- Grouping (use of comma in param lists) must be the same
4326 -- This is where we catch a misconformance like:
4329 -- A : Integer; B : Integer
4331 -- which are represented identically in the tree except
4332 -- for the setting of the flags More_Ids and Prev_Ids.
4334 if More_Ids (Old_Disc) /= More_Ids (New_Discr)
4335 or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
4338 ("grouping of & does not match!", New_Discr_Id);
4344 Next_Discriminant (Old_Discr);
4348 if Present (Old_Discr) then
4349 Conformance_Error ("too few discriminants!", Defining_Identifier (N));
4352 elsif Present (New_Discr) then
4354 ("too many discriminants!", Defining_Identifier (New_Discr));
4357 end Check_Discriminant_Conformance;
4359 ----------------------------
4360 -- Check_Fully_Conformant --
4361 ----------------------------
4363 procedure Check_Fully_Conformant
4364 (New_Id : Entity_Id;
4366 Err_Loc : Node_Id := Empty)
4369 pragma Warnings (Off, Result);
4372 (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
4373 end Check_Fully_Conformant;
4375 ---------------------------
4376 -- Check_Mode_Conformant --
4377 ---------------------------
4379 procedure Check_Mode_Conformant
4380 (New_Id : Entity_Id;
4382 Err_Loc : Node_Id := Empty;
4383 Get_Inst : Boolean := False)
4386 pragma Warnings (Off, Result);
4389 (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
4390 end Check_Mode_Conformant;
4392 --------------------------------
4393 -- Check_Overriding_Indicator --
4394 --------------------------------
4396 procedure Check_Overriding_Indicator
4398 Overridden_Subp : Entity_Id;
4399 Is_Primitive : Boolean)
4405 -- No overriding indicator for literals
4407 if Ekind (Subp) = E_Enumeration_Literal then
4410 elsif Ekind (Subp) = E_Entry then
4411 Decl := Parent (Subp);
4413 -- No point in analyzing a malformed operator
4415 elsif Nkind (Subp) = N_Defining_Operator_Symbol
4416 and then Error_Posted (Subp)
4421 Decl := Unit_Declaration_Node (Subp);
4424 if Nkind_In (Decl, N_Subprogram_Body,
4425 N_Subprogram_Body_Stub,
4426 N_Subprogram_Declaration,
4427 N_Abstract_Subprogram_Declaration,
4428 N_Subprogram_Renaming_Declaration)
4430 Spec := Specification (Decl);
4432 elsif Nkind (Decl) = N_Entry_Declaration then
4439 -- The overriding operation is type conformant with the overridden one,
4440 -- but the names of the formals are not required to match. If the names
4441 -- appear permuted in the overriding operation, this is a possible
4442 -- source of confusion that is worth diagnosing. Controlling formals
4443 -- often carry names that reflect the type, and it is not worthwhile
4444 -- requiring that their names match.
4446 if Present (Overridden_Subp)
4447 and then Nkind (Subp) /= N_Defining_Operator_Symbol
4454 Form1 := First_Formal (Subp);
4455 Form2 := First_Formal (Overridden_Subp);
4457 -- If the overriding operation is a synchronized operation, skip
4458 -- the first parameter of the overridden operation, which is
4459 -- implicit in the new one. If the operation is declared in the
4460 -- body it is not primitive and all formals must match.
4462 if Is_Concurrent_Type (Scope (Subp))
4463 and then Is_Tagged_Type (Scope (Subp))
4464 and then not Has_Completion (Scope (Subp))
4466 Form2 := Next_Formal (Form2);
4469 if Present (Form1) then
4470 Form1 := Next_Formal (Form1);
4471 Form2 := Next_Formal (Form2);
4474 while Present (Form1) loop
4475 if not Is_Controlling_Formal (Form1)
4476 and then Present (Next_Formal (Form2))
4477 and then Chars (Form1) = Chars (Next_Formal (Form2))
4479 Error_Msg_Node_2 := Alias (Overridden_Subp);
4480 Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
4482 ("& does not match corresponding formal of&#",
4487 Next_Formal (Form1);
4488 Next_Formal (Form2);
4493 -- If there is an overridden subprogram, then check that there is not
4494 -- a "not overriding" indicator, and mark the subprogram as overriding.
4495 -- This is not done if the overridden subprogram is marked as hidden,
4496 -- which can occur for the case of inherited controlled operations
4497 -- (see Derive_Subprogram), unless the inherited subprogram's parent
4498 -- subprogram is not itself hidden. (Note: This condition could probably
4499 -- be simplified, leaving out the testing for the specific controlled
4500 -- cases, but it seems safer and clearer this way, and echoes similar
4501 -- special-case tests of this kind in other places.)
4503 if Present (Overridden_Subp)
4504 and then (not Is_Hidden (Overridden_Subp)
4506 ((Chars (Overridden_Subp) = Name_Initialize
4507 or else Chars (Overridden_Subp) = Name_Adjust
4508 or else Chars (Overridden_Subp) = Name_Finalize)
4509 and then Present (Alias (Overridden_Subp))
4510 and then not Is_Hidden (Alias (Overridden_Subp))))
4512 if Must_Not_Override (Spec) then
4513 Error_Msg_Sloc := Sloc (Overridden_Subp);
4515 if Ekind (Subp) = E_Entry then
4517 ("entry & overrides inherited operation #", Spec, Subp);
4520 ("subprogram & overrides inherited operation #", Spec, Subp);
4523 elsif Is_Subprogram (Subp) then
4524 Set_Is_Overriding_Operation (Subp);
4527 -- If primitive flag is set or this is a protected operation, then
4528 -- the operation is overriding at the point of its declaration, so
4529 -- warn if necessary. Otherwise it may have been declared before the
4530 -- operation it overrides and no check is required.
4533 and then not Must_Override (Spec)
4534 and then (Is_Primitive
4535 or else Ekind (Scope (Subp)) = E_Protected_Type)
4537 Style.Missing_Overriding (Decl, Subp);
4540 -- If Subp is an operator, it may override a predefined operation, if
4541 -- it is defined in the same scope as the type to which it applies.
4542 -- In that case overridden_subp is empty because of our implicit
4543 -- representation for predefined operators. We have to check whether the
4544 -- signature of Subp matches that of a predefined operator. Note that
4545 -- first argument provides the name of the operator, and the second
4546 -- argument the signature that may match that of a standard operation.
4547 -- If the indicator is overriding, then the operator must match a
4548 -- predefined signature, because we know already that there is no
4549 -- explicit overridden operation.
4551 elsif Nkind (Subp) = N_Defining_Operator_Symbol then
4553 Typ : constant Entity_Id :=
4554 Base_Type (Etype (First_Formal (Subp)));
4556 Can_Override : constant Boolean :=
4557 Operator_Matches_Spec (Subp, Subp)
4558 and then Scope (Subp) = Scope (Typ)
4559 and then not Is_Class_Wide_Type (Typ);
4562 if Must_Not_Override (Spec) then
4564 -- If this is not a primitive or a protected subprogram, then
4565 -- "not overriding" is illegal.
4568 and then Ekind (Scope (Subp)) /= E_Protected_Type
4571 ("overriding indicator only allowed "
4572 & "if subprogram is primitive", Subp);
4574 elsif Can_Override then
4576 ("subprogram & overrides predefined operator ",
4580 elsif Must_Override (Spec) then
4581 if Is_Overriding_Operation (Subp) then
4584 elsif not Can_Override then
4585 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
4588 elsif not Error_Posted (Subp)
4589 and then Style_Check
4590 and then Can_Override
4592 not Is_Predefined_File_Name
4593 (Unit_File_Name (Get_Source_Unit (Subp)))
4595 Set_Is_Overriding_Operation (Subp);
4597 -- If style checks are enabled, indicate that the indicator is
4598 -- missing. However, at the point of declaration, the type of
4599 -- which this is a primitive operation may be private, in which
4600 -- case the indicator would be premature.
4602 if Has_Private_Declaration (Etype (Subp))
4603 or else Has_Private_Declaration (Etype (First_Formal (Subp)))
4607 Style.Missing_Overriding (Decl, Subp);
4612 elsif Must_Override (Spec) then
4613 if Ekind (Subp) = E_Entry then
4614 Error_Msg_NE ("entry & is not overriding", Spec, Subp);
4616 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
4619 -- If the operation is marked "not overriding" and it's not primitive
4620 -- then an error is issued, unless this is an operation of a task or
4621 -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
4622 -- has been specified have already been checked above.
4624 elsif Must_Not_Override (Spec)
4625 and then not Is_Primitive
4626 and then Ekind (Subp) /= E_Entry
4627 and then Ekind (Scope (Subp)) /= E_Protected_Type
4630 ("overriding indicator only allowed if subprogram is primitive",
4634 end Check_Overriding_Indicator;
4640 -- Note: this procedure needs to know far too much about how the expander
4641 -- messes with exceptions. The use of the flag Exception_Junk and the
4642 -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
4643 -- works, but is not very clean. It would be better if the expansion
4644 -- routines would leave Original_Node working nicely, and we could use
4645 -- Original_Node here to ignore all the peculiar expander messing ???
4647 procedure Check_Returns
4651 Proc : Entity_Id := Empty)
4655 procedure Check_Statement_Sequence (L : List_Id);
4656 -- Internal recursive procedure to check a list of statements for proper
4657 -- termination by a return statement (or a transfer of control or a
4658 -- compound statement that is itself internally properly terminated).
4660 ------------------------------
4661 -- Check_Statement_Sequence --
4662 ------------------------------
4664 procedure Check_Statement_Sequence (L : List_Id) is
4669 Raise_Exception_Call : Boolean;
4670 -- Set True if statement sequence terminated by Raise_Exception call
4671 -- or a Reraise_Occurrence call.
4674 Raise_Exception_Call := False;
4676 -- Get last real statement
4678 Last_Stm := Last (L);
4680 -- Deal with digging out exception handler statement sequences that
4681 -- have been transformed by the local raise to goto optimization.
4682 -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
4683 -- optimization has occurred, we are looking at something like:
4686 -- original stmts in block
4690 -- goto L1; | omitted if No_Exception_Propagation
4695 -- goto L3; -- skip handler when exception not raised
4697 -- <<L1>> -- target label for local exception
4711 -- and what we have to do is to dig out the estmts1 and estmts2
4712 -- sequences (which were the original sequences of statements in
4713 -- the exception handlers) and check them.
4715 if Nkind (Last_Stm) = N_Label
4716 and then Exception_Junk (Last_Stm)
4722 exit when Nkind (Stm) /= N_Block_Statement;
4723 exit when not Exception_Junk (Stm);
4726 exit when Nkind (Stm) /= N_Label;
4727 exit when not Exception_Junk (Stm);
4728 Check_Statement_Sequence
4729 (Statements (Handled_Statement_Sequence (Next (Stm))));
4734 exit when Nkind (Stm) /= N_Goto_Statement;
4735 exit when not Exception_Junk (Stm);
4739 -- Don't count pragmas
4741 while Nkind (Last_Stm) = N_Pragma
4743 -- Don't count call to SS_Release (can happen after Raise_Exception)
4746 (Nkind (Last_Stm) = N_Procedure_Call_Statement
4748 Nkind (Name (Last_Stm)) = N_Identifier
4750 Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
4752 -- Don't count exception junk
4755 (Nkind_In (Last_Stm, N_Goto_Statement,
4757 N_Object_Declaration)
4758 and then Exception_Junk (Last_Stm))
4759 or else Nkind (Last_Stm) in N_Push_xxx_Label
4760 or else Nkind (Last_Stm) in N_Pop_xxx_Label
4765 -- Here we have the "real" last statement
4767 Kind := Nkind (Last_Stm);
4769 -- Transfer of control, OK. Note that in the No_Return procedure
4770 -- case, we already diagnosed any explicit return statements, so
4771 -- we can treat them as OK in this context.
4773 if Is_Transfer (Last_Stm) then
4776 -- Check cases of explicit non-indirect procedure calls
4778 elsif Kind = N_Procedure_Call_Statement
4779 and then Is_Entity_Name (Name (Last_Stm))
4781 -- Check call to Raise_Exception procedure which is treated
4782 -- specially, as is a call to Reraise_Occurrence.
4784 -- We suppress the warning in these cases since it is likely that
4785 -- the programmer really does not expect to deal with the case
4786 -- of Null_Occurrence, and thus would find a warning about a
4787 -- missing return curious, and raising Program_Error does not
4788 -- seem such a bad behavior if this does occur.
4790 -- Note that in the Ada 2005 case for Raise_Exception, the actual
4791 -- behavior will be to raise Constraint_Error (see AI-329).
4793 if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
4795 Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
4797 Raise_Exception_Call := True;
4799 -- For Raise_Exception call, test first argument, if it is
4800 -- an attribute reference for a 'Identity call, then we know
4801 -- that the call cannot possibly return.
4804 Arg : constant Node_Id :=
4805 Original_Node (First_Actual (Last_Stm));
4807 if Nkind (Arg) = N_Attribute_Reference
4808 and then Attribute_Name (Arg) = Name_Identity
4815 -- If statement, need to look inside if there is an else and check
4816 -- each constituent statement sequence for proper termination.
4818 elsif Kind = N_If_Statement
4819 and then Present (Else_Statements (Last_Stm))
4821 Check_Statement_Sequence (Then_Statements (Last_Stm));
4822 Check_Statement_Sequence (Else_Statements (Last_Stm));
4824 if Present (Elsif_Parts (Last_Stm)) then
4826 Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
4829 while Present (Elsif_Part) loop
4830 Check_Statement_Sequence (Then_Statements (Elsif_Part));
4838 -- Case statement, check each case for proper termination
4840 elsif Kind = N_Case_Statement then
4844 Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
4845 while Present (Case_Alt) loop
4846 Check_Statement_Sequence (Statements (Case_Alt));
4847 Next_Non_Pragma (Case_Alt);
4853 -- Block statement, check its handled sequence of statements
4855 elsif Kind = N_Block_Statement then
4861 (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
4870 -- Loop statement. If there is an iteration scheme, we can definitely
4871 -- fall out of the loop. Similarly if there is an exit statement, we
4872 -- can fall out. In either case we need a following return.
4874 elsif Kind = N_Loop_Statement then
4875 if Present (Iteration_Scheme (Last_Stm))
4876 or else Has_Exit (Entity (Identifier (Last_Stm)))
4880 -- A loop with no exit statement or iteration scheme is either
4881 -- an infinite loop, or it has some other exit (raise/return).
4882 -- In either case, no warning is required.
4888 -- Timed entry call, check entry call and delay alternatives
4890 -- Note: in expanded code, the timed entry call has been converted
4891 -- to a set of expanded statements on which the check will work
4892 -- correctly in any case.
4894 elsif Kind = N_Timed_Entry_Call then
4896 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
4897 DCA : constant Node_Id := Delay_Alternative (Last_Stm);
4900 -- If statement sequence of entry call alternative is missing,
4901 -- then we can definitely fall through, and we post the error
4902 -- message on the entry call alternative itself.
4904 if No (Statements (ECA)) then
4907 -- If statement sequence of delay alternative is missing, then
4908 -- we can definitely fall through, and we post the error
4909 -- message on the delay alternative itself.
4911 -- Note: if both ECA and DCA are missing the return, then we
4912 -- post only one message, should be enough to fix the bugs.
4913 -- If not we will get a message next time on the DCA when the
4916 elsif No (Statements (DCA)) then
4919 -- Else check both statement sequences
4922 Check_Statement_Sequence (Statements (ECA));
4923 Check_Statement_Sequence (Statements (DCA));
4928 -- Conditional entry call, check entry call and else part
4930 -- Note: in expanded code, the conditional entry call has been
4931 -- converted to a set of expanded statements on which the check
4932 -- will work correctly in any case.
4934 elsif Kind = N_Conditional_Entry_Call then
4936 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
4939 -- If statement sequence of entry call alternative is missing,
4940 -- then we can definitely fall through, and we post the error
4941 -- message on the entry call alternative itself.
4943 if No (Statements (ECA)) then
4946 -- Else check statement sequence and else part
4949 Check_Statement_Sequence (Statements (ECA));
4950 Check_Statement_Sequence (Else_Statements (Last_Stm));
4956 -- If we fall through, issue appropriate message
4959 if not Raise_Exception_Call then
4961 ("?RETURN statement missing following this statement!",
4964 ("\?Program_Error may be raised at run time!",
4968 -- Note: we set Err even though we have not issued a warning
4969 -- because we still have a case of a missing return. This is
4970 -- an extremely marginal case, probably will never be noticed
4971 -- but we might as well get it right.
4975 -- Otherwise we have the case of a procedure marked No_Return
4978 if not Raise_Exception_Call then
4980 ("?implied return after this statement " &
4981 "will raise Program_Error",
4984 ("\?procedure & is marked as No_Return!",
4989 RE : constant Node_Id :=
4990 Make_Raise_Program_Error (Sloc (Last_Stm),
4991 Reason => PE_Implicit_Return);
4993 Insert_After (Last_Stm, RE);
4997 end Check_Statement_Sequence;
4999 -- Start of processing for Check_Returns
5003 Check_Statement_Sequence (Statements (HSS));
5005 if Present (Exception_Handlers (HSS)) then
5006 Handler := First_Non_Pragma (Exception_Handlers (HSS));
5007 while Present (Handler) loop
5008 Check_Statement_Sequence (Statements (Handler));
5009 Next_Non_Pragma (Handler);
5014 ----------------------------
5015 -- Check_Subprogram_Order --
5016 ----------------------------
5018 procedure Check_Subprogram_Order (N : Node_Id) is
5020 function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
5021 -- This is used to check if S1 > S2 in the sense required by this
5022 -- test, for example nameab < namec, but name2 < name10.
5024 -----------------------------
5025 -- Subprogram_Name_Greater --
5026 -----------------------------
5028 function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
5033 -- Remove trailing numeric parts
5036 while S1 (L1) in '0' .. '9' loop
5041 while S2 (L2) in '0' .. '9' loop
5045 -- If non-numeric parts non-equal, that's decisive
5047 if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
5050 elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
5053 -- If non-numeric parts equal, compare suffixed numeric parts. Note
5054 -- that a missing suffix is treated as numeric zero in this test.
5058 while L1 < S1'Last loop
5060 N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
5064 while L2 < S2'Last loop
5066 N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
5071 end Subprogram_Name_Greater;
5073 -- Start of processing for Check_Subprogram_Order
5076 -- Check body in alpha order if this is option
5079 and then Style_Check_Order_Subprograms
5080 and then Nkind (N) = N_Subprogram_Body
5081 and then Comes_From_Source (N)
5082 and then In_Extended_Main_Source_Unit (N)
5086 renames Scope_Stack.Table
5087 (Scope_Stack.Last).Last_Subprogram_Name;
5089 Body_Id : constant Entity_Id :=
5090 Defining_Entity (Specification (N));
5093 Get_Decoded_Name_String (Chars (Body_Id));
5096 if Subprogram_Name_Greater
5097 (LSN.all, Name_Buffer (1 .. Name_Len))
5099 Style.Subprogram_Not_In_Alpha_Order (Body_Id);
5105 LSN := new String'(Name_Buffer (1 .. Name_Len));
5108 end Check_Subprogram_Order;
5110 ------------------------------
5111 -- Check_Subtype_Conformant --
5112 ------------------------------
5114 procedure Check_Subtype_Conformant
5115 (New_Id : Entity_Id;
5117 Err_Loc : Node_Id := Empty;
5118 Skip_Controlling_Formals : Boolean := False)
5121 pragma Warnings (Off, Result);
5124 (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
5125 Skip_Controlling_Formals => Skip_Controlling_Formals);
5126 end Check_Subtype_Conformant;
5128 ---------------------------
5129 -- Check_Type_Conformant --
5130 ---------------------------
5132 procedure Check_Type_Conformant
5133 (New_Id : Entity_Id;
5135 Err_Loc : Node_Id := Empty)
5138 pragma Warnings (Off, Result);
5141 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
5142 end Check_Type_Conformant;
5144 ----------------------
5145 -- Conforming_Types --
5146 ----------------------
5148 function Conforming_Types
5151 Ctype : Conformance_Type;
5152 Get_Inst : Boolean := False) return Boolean
5154 Type_1 : Entity_Id := T1;
5155 Type_2 : Entity_Id := T2;
5156 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
5158 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
5159 -- If neither T1 nor T2 are generic actual types, or if they are in
5160 -- different scopes (e.g. parent and child instances), then verify that
5161 -- the base types are equal. Otherwise T1 and T2 must be on the same
5162 -- subtype chain. The whole purpose of this procedure is to prevent
5163 -- spurious ambiguities in an instantiation that may arise if two
5164 -- distinct generic types are instantiated with the same actual.
5166 function Find_Designated_Type (T : Entity_Id) return Entity_Id;
5167 -- An access parameter can designate an incomplete type. If the
5168 -- incomplete type is the limited view of a type from a limited_
5169 -- with_clause, check whether the non-limited view is available. If
5170 -- it is a (non-limited) incomplete type, get the full view.
5172 function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean;
5173 -- Returns True if and only if either T1 denotes a limited view of T2
5174 -- or T2 denotes a limited view of T1. This can arise when the limited
5175 -- with view of a type is used in a subprogram declaration and the
5176 -- subprogram body is in the scope of a regular with clause for the
5177 -- same unit. In such a case, the two type entities can be considered
5178 -- identical for purposes of conformance checking.
5180 ----------------------
5181 -- Base_Types_Match --
5182 ----------------------
5184 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
5189 elsif Base_Type (T1) = Base_Type (T2) then
5191 -- The following is too permissive. A more precise test should
5192 -- check that the generic actual is an ancestor subtype of the
5195 return not Is_Generic_Actual_Type (T1)
5196 or else not Is_Generic_Actual_Type (T2)
5197 or else Scope (T1) /= Scope (T2);
5202 end Base_Types_Match;
5204 --------------------------
5205 -- Find_Designated_Type --
5206 --------------------------
5208 function Find_Designated_Type (T : Entity_Id) return Entity_Id is
5212 Desig := Directly_Designated_Type (T);
5214 if Ekind (Desig) = E_Incomplete_Type then
5216 -- If regular incomplete type, get full view if available
5218 if Present (Full_View (Desig)) then
5219 Desig := Full_View (Desig);
5221 -- If limited view of a type, get non-limited view if available,
5222 -- and check again for a regular incomplete type.
5224 elsif Present (Non_Limited_View (Desig)) then
5225 Desig := Get_Full_View (Non_Limited_View (Desig));
5230 end Find_Designated_Type;
5232 -------------------------------
5233 -- Matches_Limited_With_View --
5234 -------------------------------
5236 function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is
5238 -- In some cases a type imported through a limited_with clause, and
5239 -- its nonlimited view are both visible, for example in an anonymous
5240 -- access-to-class-wide type in a formal. Both entities designate the
5243 if From_With_Type (T1)
5244 and then T2 = Available_View (T1)
5248 elsif From_With_Type (T2)
5249 and then T1 = Available_View (T2)
5256 end Matches_Limited_With_View;
5258 -- Start of processing for Conforming_Types
5261 -- The context is an instance association for a formal
5262 -- access-to-subprogram type; the formal parameter types require
5263 -- mapping because they may denote other formal parameters of the
5267 Type_1 := Get_Instance_Of (T1);
5268 Type_2 := Get_Instance_Of (T2);
5271 -- If one of the types is a view of the other introduced by a limited
5272 -- with clause, treat these as conforming for all purposes.
5274 if Matches_Limited_With_View (T1, T2) then
5277 elsif Base_Types_Match (Type_1, Type_2) then
5278 return Ctype <= Mode_Conformant
5279 or else Subtypes_Statically_Match (Type_1, Type_2);
5281 elsif Is_Incomplete_Or_Private_Type (Type_1)
5282 and then Present (Full_View (Type_1))
5283 and then Base_Types_Match (Full_View (Type_1), Type_2)
5285 return Ctype <= Mode_Conformant
5286 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
5288 elsif Ekind (Type_2) = E_Incomplete_Type
5289 and then Present (Full_View (Type_2))
5290 and then Base_Types_Match (Type_1, Full_View (Type_2))
5292 return Ctype <= Mode_Conformant
5293 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
5295 elsif Is_Private_Type (Type_2)
5296 and then In_Instance
5297 and then Present (Full_View (Type_2))
5298 and then Base_Types_Match (Type_1, Full_View (Type_2))
5300 return Ctype <= Mode_Conformant
5301 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
5304 -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
5305 -- treated recursively because they carry a signature.
5307 Are_Anonymous_Access_To_Subprogram_Types :=
5308 Ekind (Type_1) = Ekind (Type_2)
5310 (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
5312 Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
5314 -- Test anonymous access type case. For this case, static subtype
5315 -- matching is required for mode conformance (RM 6.3.1(15)). We check
5316 -- the base types because we may have built internal subtype entities
5317 -- to handle null-excluding types (see Process_Formals).
5319 if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
5321 Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
5322 or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
5325 Desig_1 : Entity_Id;
5326 Desig_2 : Entity_Id;
5329 -- In Ada2005, access constant indicators must match for
5330 -- subtype conformance.
5332 if Ada_Version >= Ada_05
5333 and then Ctype >= Subtype_Conformant
5335 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
5340 Desig_1 := Find_Designated_Type (Type_1);
5342 Desig_2 := Find_Designated_Type (Type_2);
5344 -- If the context is an instance association for a formal
5345 -- access-to-subprogram type; formal access parameter designated
5346 -- types require mapping because they may denote other formal
5347 -- parameters of the generic unit.
5350 Desig_1 := Get_Instance_Of (Desig_1);
5351 Desig_2 := Get_Instance_Of (Desig_2);
5354 -- It is possible for a Class_Wide_Type to be introduced for an
5355 -- incomplete type, in which case there is a separate class_ wide
5356 -- type for the full view. The types conform if their Etypes
5357 -- conform, i.e. one may be the full view of the other. This can
5358 -- only happen in the context of an access parameter, other uses
5359 -- of an incomplete Class_Wide_Type are illegal.
5361 if Is_Class_Wide_Type (Desig_1)
5362 and then Is_Class_Wide_Type (Desig_2)
5366 (Etype (Base_Type (Desig_1)),
5367 Etype (Base_Type (Desig_2)), Ctype);
5369 elsif Are_Anonymous_Access_To_Subprogram_Types then
5370 if Ada_Version < Ada_05 then
5371 return Ctype = Type_Conformant
5373 Subtypes_Statically_Match (Desig_1, Desig_2);
5375 -- We must check the conformance of the signatures themselves
5379 Conformant : Boolean;
5382 (Desig_1, Desig_2, Ctype, False, Conformant);
5388 return Base_Type (Desig_1) = Base_Type (Desig_2)
5389 and then (Ctype = Type_Conformant
5391 Subtypes_Statically_Match (Desig_1, Desig_2));
5395 -- Otherwise definitely no match
5398 if ((Ekind (Type_1) = E_Anonymous_Access_Type
5399 and then Is_Access_Type (Type_2))
5400 or else (Ekind (Type_2) = E_Anonymous_Access_Type
5401 and then Is_Access_Type (Type_1)))
5404 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
5406 May_Hide_Profile := True;
5411 end Conforming_Types;
5413 --------------------------
5414 -- Create_Extra_Formals --
5415 --------------------------
5417 procedure Create_Extra_Formals (E : Entity_Id) is
5419 First_Extra : Entity_Id := Empty;
5420 Last_Extra : Entity_Id;
5421 Formal_Type : Entity_Id;
5422 P_Formal : Entity_Id := Empty;
5424 function Add_Extra_Formal
5425 (Assoc_Entity : Entity_Id;
5428 Suffix : String) return Entity_Id;
5429 -- Add an extra formal to the current list of formals and extra formals.
5430 -- The extra formal is added to the end of the list of extra formals,
5431 -- and also returned as the result. These formals are always of mode IN.
5432 -- The new formal has the type Typ, is declared in Scope, and its name
5433 -- is given by a concatenation of the name of Assoc_Entity and Suffix.
5434 -- The following suffixes are currently used. They should not be changed
5435 -- without coordinating with CodePeer, which makes use of these to
5436 -- provide better messages.
5438 -- C denotes the Constrained bit.
5439 -- A denotes the accessibility level.
5440 -- BIP_xxx denotes an extra formal for a build-in-place function. See
5441 -- the full list in exp_ch6.BIP_Formal_Kind.
5443 ----------------------
5444 -- Add_Extra_Formal --
5445 ----------------------
5447 function Add_Extra_Formal
5448 (Assoc_Entity : Entity_Id;
5451 Suffix : String) return Entity_Id
5453 EF : constant Entity_Id :=
5454 Make_Defining_Identifier (Sloc (Assoc_Entity),
5455 Chars => New_External_Name (Chars (Assoc_Entity),
5459 -- A little optimization. Never generate an extra formal for the
5460 -- _init operand of an initialization procedure, since it could
5463 if Chars (Formal) = Name_uInit then
5467 Set_Ekind (EF, E_In_Parameter);
5468 Set_Actual_Subtype (EF, Typ);
5469 Set_Etype (EF, Typ);
5470 Set_Scope (EF, Scope);
5471 Set_Mechanism (EF, Default_Mechanism);
5472 Set_Formal_Validity (EF);
5474 if No (First_Extra) then
5476 Set_Extra_Formals (Scope, First_Extra);
5479 if Present (Last_Extra) then
5480 Set_Extra_Formal (Last_Extra, EF);
5486 end Add_Extra_Formal;
5488 -- Start of processing for Create_Extra_Formals
5491 -- We never generate extra formals if expansion is not active
5492 -- because we don't need them unless we are generating code.
5494 if not Expander_Active then
5498 -- If this is a derived subprogram then the subtypes of the parent
5499 -- subprogram's formal parameters will be used to determine the need
5500 -- for extra formals.
5502 if Is_Overloadable (E) and then Present (Alias (E)) then
5503 P_Formal := First_Formal (Alias (E));
5506 Last_Extra := Empty;
5507 Formal := First_Formal (E);
5508 while Present (Formal) loop
5509 Last_Extra := Formal;
5510 Next_Formal (Formal);
5513 -- If Extra_formals were already created, don't do it again. This
5514 -- situation may arise for subprogram types created as part of
5515 -- dispatching calls (see Expand_Dispatching_Call)
5517 if Present (Last_Extra) and then
5518 Present (Extra_Formal (Last_Extra))
5523 -- If the subprogram is a predefined dispatching subprogram then don't
5524 -- generate any extra constrained or accessibility level formals. In
5525 -- general we suppress these for internal subprograms (by not calling
5526 -- Freeze_Subprogram and Create_Extra_Formals at all), but internally
5527 -- generated stream attributes do get passed through because extra
5528 -- build-in-place formals are needed in some cases (limited 'Input).
5530 if Is_Predefined_Internal_Operation (E) then
5531 goto Test_For_BIP_Extras;
5534 Formal := First_Formal (E);
5535 while Present (Formal) loop
5537 -- Create extra formal for supporting the attribute 'Constrained.
5538 -- The case of a private type view without discriminants also
5539 -- requires the extra formal if the underlying type has defaulted
5542 if Ekind (Formal) /= E_In_Parameter then
5543 if Present (P_Formal) then
5544 Formal_Type := Etype (P_Formal);
5546 Formal_Type := Etype (Formal);
5549 -- Do not produce extra formals for Unchecked_Union parameters.
5550 -- Jump directly to the end of the loop.
5552 if Is_Unchecked_Union (Base_Type (Formal_Type)) then
5553 goto Skip_Extra_Formal_Generation;
5556 if not Has_Discriminants (Formal_Type)
5557 and then Ekind (Formal_Type) in Private_Kind
5558 and then Present (Underlying_Type (Formal_Type))
5560 Formal_Type := Underlying_Type (Formal_Type);
5563 if Has_Discriminants (Formal_Type)
5564 and then not Is_Constrained (Formal_Type)
5565 and then not Is_Indefinite_Subtype (Formal_Type)
5567 Set_Extra_Constrained
5568 (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "C"));
5572 -- Create extra formal for supporting accessibility checking. This
5573 -- is done for both anonymous access formals and formals of named
5574 -- access types that are marked as controlling formals. The latter
5575 -- case can occur when Expand_Dispatching_Call creates a subprogram
5576 -- type and substitutes the types of access-to-class-wide actuals
5577 -- for the anonymous access-to-specific-type of controlling formals.
5578 -- Base_Type is applied because in cases where there is a null
5579 -- exclusion the formal may have an access subtype.
5581 -- This is suppressed if we specifically suppress accessibility
5582 -- checks at the package level for either the subprogram, or the
5583 -- package in which it resides. However, we do not suppress it
5584 -- simply if the scope has accessibility checks suppressed, since
5585 -- this could cause trouble when clients are compiled with a
5586 -- different suppression setting. The explicit checks at the
5587 -- package level are safe from this point of view.
5589 if (Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
5590 or else (Is_Controlling_Formal (Formal)
5591 and then Is_Access_Type (Base_Type (Etype (Formal)))))
5593 (Explicit_Suppress (E, Accessibility_Check)
5595 Explicit_Suppress (Scope (E), Accessibility_Check))
5598 or else Present (Extra_Accessibility (P_Formal)))
5600 Set_Extra_Accessibility
5601 (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "A"));
5604 -- This label is required when skipping extra formal generation for
5605 -- Unchecked_Union parameters.
5607 <<Skip_Extra_Formal_Generation>>
5609 if Present (P_Formal) then
5610 Next_Formal (P_Formal);
5613 Next_Formal (Formal);
5616 <<Test_For_BIP_Extras>>
5618 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
5619 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
5621 if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function (E) then
5623 Result_Subt : constant Entity_Id := Etype (E);
5625 Discard : Entity_Id;
5626 pragma Warnings (Off, Discard);
5629 -- In the case of functions with unconstrained result subtypes,
5630 -- add a 3-state formal indicating whether the return object is
5631 -- allocated by the caller (0), or should be allocated by the
5632 -- callee on the secondary stack (1) or in the global heap (2).
5633 -- For the moment we just use Natural for the type of this formal.
5634 -- Note that this formal isn't usually needed in the case where
5635 -- the result subtype is constrained, but it is needed when the
5636 -- function has a tagged result, because generally such functions
5637 -- can be called in a dispatching context and such calls must be
5638 -- handled like calls to a class-wide function.
5640 if not Is_Constrained (Underlying_Type (Result_Subt))
5641 or else Is_Tagged_Type (Underlying_Type (Result_Subt))
5645 (E, Standard_Natural,
5646 E, BIP_Formal_Suffix (BIP_Alloc_Form));
5649 -- In the case of functions whose result type has controlled
5650 -- parts, we have an extra formal of type
5651 -- System.Finalization_Implementation.Finalizable_Ptr_Ptr. That
5652 -- is, we are passing a pointer to a finalization list (which is
5653 -- itself a pointer). This extra formal is then passed along to
5654 -- Move_Final_List in case of successful completion of a return
5655 -- statement. We cannot pass an 'in out' parameter, because we
5656 -- need to update the finalization list during an abort-deferred
5657 -- region, rather than using copy-back after the function
5658 -- returns. This is true even if we are able to get away with
5659 -- having 'in out' parameters, which are normally illegal for
5660 -- functions. This formal is also needed when the function has
5663 if Needs_BIP_Final_List (E) then
5666 (E, RTE (RE_Finalizable_Ptr_Ptr),
5667 E, BIP_Formal_Suffix (BIP_Final_List));
5670 -- If the result type contains tasks, we have two extra formals:
5671 -- the master of the tasks to be created, and the caller's
5672 -- activation chain.
5674 if Has_Task (Result_Subt) then
5677 (E, RTE (RE_Master_Id),
5678 E, BIP_Formal_Suffix (BIP_Master));
5681 (E, RTE (RE_Activation_Chain_Access),
5682 E, BIP_Formal_Suffix (BIP_Activation_Chain));
5685 -- All build-in-place functions get an extra formal that will be
5686 -- passed the address of the return object within the caller.
5689 Formal_Type : constant Entity_Id :=
5691 (E_Anonymous_Access_Type, E,
5692 Scope_Id => Scope (E));
5694 Set_Directly_Designated_Type (Formal_Type, Result_Subt);
5695 Set_Etype (Formal_Type, Formal_Type);
5696 Set_Depends_On_Private
5697 (Formal_Type, Has_Private_Component (Formal_Type));
5698 Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
5699 Set_Is_Access_Constant (Formal_Type, False);
5701 -- Ada 2005 (AI-50217): Propagate the attribute that indicates
5702 -- the designated type comes from the limited view (for
5703 -- back-end purposes).
5705 Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt));
5707 Layout_Type (Formal_Type);
5711 (E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access));
5715 end Create_Extra_Formals;
5717 -----------------------------
5718 -- Enter_Overloaded_Entity --
5719 -----------------------------
5721 procedure Enter_Overloaded_Entity (S : Entity_Id) is
5722 E : Entity_Id := Current_Entity_In_Scope (S);
5723 C_E : Entity_Id := Current_Entity (S);
5727 Set_Has_Homonym (E);
5728 Set_Has_Homonym (S);
5731 Set_Is_Immediately_Visible (S);
5732 Set_Scope (S, Current_Scope);
5734 -- Chain new entity if front of homonym in current scope, so that
5735 -- homonyms are contiguous.
5740 while Homonym (C_E) /= E loop
5741 C_E := Homonym (C_E);
5744 Set_Homonym (C_E, S);
5748 Set_Current_Entity (S);
5753 Append_Entity (S, Current_Scope);
5754 Set_Public_Status (S);
5756 if Debug_Flag_E then
5757 Write_Str ("New overloaded entity chain: ");
5758 Write_Name (Chars (S));
5761 while Present (E) loop
5762 Write_Str (" "); Write_Int (Int (E));
5769 -- Generate warning for hiding
5772 and then Comes_From_Source (S)
5773 and then In_Extended_Main_Source_Unit (S)
5780 -- Warn unless genuine overloading
5782 if (not Is_Overloadable (E) or else Subtype_Conformant (E, S))
5783 and then (Is_Immediately_Visible (E)
5785 Is_Potentially_Use_Visible (S))
5787 Error_Msg_Sloc := Sloc (E);
5788 Error_Msg_N ("declaration of & hides one#?", S);
5792 end Enter_Overloaded_Entity;
5794 -----------------------------
5795 -- Find_Corresponding_Spec --
5796 -----------------------------
5798 function Find_Corresponding_Spec
5800 Post_Error : Boolean := True) return Entity_Id
5802 Spec : constant Node_Id := Specification (N);
5803 Designator : constant Entity_Id := Defining_Entity (Spec);
5808 E := Current_Entity (Designator);
5809 while Present (E) loop
5811 -- We are looking for a matching spec. It must have the same scope,
5812 -- and the same name, and either be type conformant, or be the case
5813 -- of a library procedure spec and its body (which belong to one
5814 -- another regardless of whether they are type conformant or not).
5816 if Scope (E) = Current_Scope then
5817 if Current_Scope = Standard_Standard
5818 or else (Ekind (E) = Ekind (Designator)
5819 and then Type_Conformant (E, Designator))
5821 -- Within an instantiation, we know that spec and body are
5822 -- subtype conformant, because they were subtype conformant
5823 -- in the generic. We choose the subtype-conformant entity
5824 -- here as well, to resolve spurious ambiguities in the
5825 -- instance that were not present in the generic (i.e. when
5826 -- two different types are given the same actual). If we are
5827 -- looking for a spec to match a body, full conformance is
5831 Set_Convention (Designator, Convention (E));
5833 if Nkind (N) = N_Subprogram_Body
5834 and then Present (Homonym (E))
5835 and then not Fully_Conformant (E, Designator)
5839 elsif not Subtype_Conformant (E, Designator) then
5844 if not Has_Completion (E) then
5845 if Nkind (N) /= N_Subprogram_Body_Stub then
5846 Set_Corresponding_Spec (N, E);
5849 Set_Has_Completion (E);
5852 elsif Nkind (Parent (N)) = N_Subunit then
5854 -- If this is the proper body of a subunit, the completion
5855 -- flag is set when analyzing the stub.
5859 -- If E is an internal function with a controlling result
5860 -- that was created for an operation inherited by a null
5861 -- extension, it may be overridden by a body without a previous
5862 -- spec (one more reason why these should be shunned). In that
5863 -- case remove the generated body, because the current one is
5864 -- the explicit overriding.
5866 elsif Ekind (E) = E_Function
5867 and then Ada_Version >= Ada_05
5868 and then not Comes_From_Source (E)
5869 and then Has_Controlling_Result (E)
5870 and then Is_Null_Extension (Etype (E))
5871 and then Comes_From_Source (Spec)
5873 Set_Has_Completion (E, False);
5875 if Expander_Active then
5877 (Unit_Declaration_Node
5878 (Corresponding_Body (Unit_Declaration_Node (E))));
5881 -- If expansion is disabled, the wrapper function has not
5882 -- been generated, and this is the standard case of a late
5883 -- body overriding an inherited operation.
5889 -- If the body already exists, then this is an error unless
5890 -- the previous declaration is the implicit declaration of a
5891 -- derived subprogram, or this is a spurious overloading in an
5894 elsif No (Alias (E))
5895 and then not Is_Intrinsic_Subprogram (E)
5896 and then not In_Instance
5899 Error_Msg_Sloc := Sloc (E);
5901 if Is_Imported (E) then
5903 ("body not allowed for imported subprogram & declared#",
5906 Error_Msg_NE ("duplicate body for & declared#", N, E);
5910 -- Child units cannot be overloaded, so a conformance mismatch
5911 -- between body and a previous spec is an error.
5913 elsif Is_Child_Unit (E)
5915 Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
5917 Nkind (Parent (Unit_Declaration_Node (Designator))) =
5922 ("body of child unit does not match previous declaration", N);
5930 -- On exit, we know that no previous declaration of subprogram exists
5933 end Find_Corresponding_Spec;
5935 ----------------------
5936 -- Fully_Conformant --
5937 ----------------------
5939 function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
5942 Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
5944 end Fully_Conformant;
5946 ----------------------------------
5947 -- Fully_Conformant_Expressions --
5948 ----------------------------------
5950 function Fully_Conformant_Expressions
5951 (Given_E1 : Node_Id;
5952 Given_E2 : Node_Id) return Boolean
5954 E1 : constant Node_Id := Original_Node (Given_E1);
5955 E2 : constant Node_Id := Original_Node (Given_E2);
5956 -- We always test conformance on original nodes, since it is possible
5957 -- for analysis and/or expansion to make things look as though they
5958 -- conform when they do not, e.g. by converting 1+2 into 3.
5960 function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
5961 renames Fully_Conformant_Expressions;
5963 function FCL (L1, L2 : List_Id) return Boolean;
5964 -- Compare elements of two lists for conformance. Elements have to
5965 -- be conformant, and actuals inserted as default parameters do not
5966 -- match explicit actuals with the same value.
5968 function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
5969 -- Compare an operator node with a function call
5975 function FCL (L1, L2 : List_Id) return Boolean is
5979 if L1 = No_List then
5985 if L2 = No_List then
5991 -- Compare two lists, skipping rewrite insertions (we want to
5992 -- compare the original trees, not the expanded versions!)
5995 if Is_Rewrite_Insertion (N1) then
5997 elsif Is_Rewrite_Insertion (N2) then
6003 elsif not FCE (N1, N2) then
6016 function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
6017 Actuals : constant List_Id := Parameter_Associations (Call_Node);
6022 or else Entity (Op_Node) /= Entity (Name (Call_Node))
6027 Act := First (Actuals);
6029 if Nkind (Op_Node) in N_Binary_Op then
6030 if not FCE (Left_Opnd (Op_Node), Act) then
6037 return Present (Act)
6038 and then FCE (Right_Opnd (Op_Node), Act)
6039 and then No (Next (Act));
6043 -- Start of processing for Fully_Conformant_Expressions
6046 -- Non-conformant if paren count does not match. Note: if some idiot
6047 -- complains that we don't do this right for more than 3 levels of
6048 -- parentheses, they will be treated with the respect they deserve!
6050 if Paren_Count (E1) /= Paren_Count (E2) then
6053 -- If same entities are referenced, then they are conformant even if
6054 -- they have different forms (RM 8.3.1(19-20)).
6056 elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
6057 if Present (Entity (E1)) then
6058 return Entity (E1) = Entity (E2)
6059 or else (Chars (Entity (E1)) = Chars (Entity (E2))
6060 and then Ekind (Entity (E1)) = E_Discriminant
6061 and then Ekind (Entity (E2)) = E_In_Parameter);
6063 elsif Nkind (E1) = N_Expanded_Name
6064 and then Nkind (E2) = N_Expanded_Name
6065 and then Nkind (Selector_Name (E1)) = N_Character_Literal
6066 and then Nkind (Selector_Name (E2)) = N_Character_Literal
6068 return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
6071 -- Identifiers in component associations don't always have
6072 -- entities, but their names must conform.
6074 return Nkind (E1) = N_Identifier
6075 and then Nkind (E2) = N_Identifier
6076 and then Chars (E1) = Chars (E2);
6079 elsif Nkind (E1) = N_Character_Literal
6080 and then Nkind (E2) = N_Expanded_Name
6082 return Nkind (Selector_Name (E2)) = N_Character_Literal
6083 and then Chars (E1) = Chars (Selector_Name (E2));
6085 elsif Nkind (E2) = N_Character_Literal
6086 and then Nkind (E1) = N_Expanded_Name
6088 return Nkind (Selector_Name (E1)) = N_Character_Literal
6089 and then Chars (E2) = Chars (Selector_Name (E1));
6091 elsif Nkind (E1) in N_Op
6092 and then Nkind (E2) = N_Function_Call
6094 return FCO (E1, E2);
6096 elsif Nkind (E2) in N_Op
6097 and then Nkind (E1) = N_Function_Call
6099 return FCO (E2, E1);
6101 -- Otherwise we must have the same syntactic entity
6103 elsif Nkind (E1) /= Nkind (E2) then
6106 -- At this point, we specialize by node type
6113 FCL (Expressions (E1), Expressions (E2))
6115 FCL (Component_Associations (E1),
6116 Component_Associations (E2));
6119 if Nkind (Expression (E1)) = N_Qualified_Expression
6121 Nkind (Expression (E2)) = N_Qualified_Expression
6123 return FCE (Expression (E1), Expression (E2));
6125 -- Check that the subtype marks and any constraints
6130 Indic1 : constant Node_Id := Expression (E1);
6131 Indic2 : constant Node_Id := Expression (E2);
6136 if Nkind (Indic1) /= N_Subtype_Indication then
6138 Nkind (Indic2) /= N_Subtype_Indication
6139 and then Entity (Indic1) = Entity (Indic2);
6141 elsif Nkind (Indic2) /= N_Subtype_Indication then
6143 Nkind (Indic1) /= N_Subtype_Indication
6144 and then Entity (Indic1) = Entity (Indic2);
6147 if Entity (Subtype_Mark (Indic1)) /=
6148 Entity (Subtype_Mark (Indic2))
6153 Elt1 := First (Constraints (Constraint (Indic1)));
6154 Elt2 := First (Constraints (Constraint (Indic2)));
6155 while Present (Elt1) and then Present (Elt2) loop
6156 if not FCE (Elt1, Elt2) then
6169 when N_Attribute_Reference =>
6171 Attribute_Name (E1) = Attribute_Name (E2)
6172 and then FCL (Expressions (E1), Expressions (E2));
6176 Entity (E1) = Entity (E2)
6177 and then FCE (Left_Opnd (E1), Left_Opnd (E2))
6178 and then FCE (Right_Opnd (E1), Right_Opnd (E2));
6180 when N_Short_Circuit | N_Membership_Test =>
6182 FCE (Left_Opnd (E1), Left_Opnd (E2))
6184 FCE (Right_Opnd (E1), Right_Opnd (E2));
6186 when N_Case_Expression =>
6192 if not FCE (Expression (E1), Expression (E2)) then
6196 Alt1 := First (Alternatives (E1));
6197 Alt2 := First (Alternatives (E2));
6199 if Present (Alt1) /= Present (Alt2) then
6201 elsif No (Alt1) then
6205 if not FCE (Expression (Alt1), Expression (Alt2))
6206 or else not FCL (Discrete_Choices (Alt1),
6207 Discrete_Choices (Alt2))
6218 when N_Character_Literal =>
6220 Char_Literal_Value (E1) = Char_Literal_Value (E2);
6222 when N_Component_Association =>
6224 FCL (Choices (E1), Choices (E2))
6226 FCE (Expression (E1), Expression (E2));
6228 when N_Conditional_Expression =>
6230 FCL (Expressions (E1), Expressions (E2));
6232 when N_Explicit_Dereference =>
6234 FCE (Prefix (E1), Prefix (E2));
6236 when N_Extension_Aggregate =>
6238 FCL (Expressions (E1), Expressions (E2))
6239 and then Null_Record_Present (E1) =
6240 Null_Record_Present (E2)
6241 and then FCL (Component_Associations (E1),
6242 Component_Associations (E2));
6244 when N_Function_Call =>
6246 FCE (Name (E1), Name (E2))
6248 FCL (Parameter_Associations (E1),
6249 Parameter_Associations (E2));
6251 when N_Indexed_Component =>
6253 FCE (Prefix (E1), Prefix (E2))
6255 FCL (Expressions (E1), Expressions (E2));
6257 when N_Integer_Literal =>
6258 return (Intval (E1) = Intval (E2));
6263 when N_Operator_Symbol =>
6265 Chars (E1) = Chars (E2);
6267 when N_Others_Choice =>
6270 when N_Parameter_Association =>
6272 Chars (Selector_Name (E1)) = Chars (Selector_Name (E2))
6273 and then FCE (Explicit_Actual_Parameter (E1),
6274 Explicit_Actual_Parameter (E2));
6276 when N_Qualified_Expression =>
6278 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6280 FCE (Expression (E1), Expression (E2));
6284 FCE (Low_Bound (E1), Low_Bound (E2))
6286 FCE (High_Bound (E1), High_Bound (E2));
6288 when N_Real_Literal =>
6289 return (Realval (E1) = Realval (E2));
6291 when N_Selected_Component =>
6293 FCE (Prefix (E1), Prefix (E2))
6295 FCE (Selector_Name (E1), Selector_Name (E2));
6299 FCE (Prefix (E1), Prefix (E2))
6301 FCE (Discrete_Range (E1), Discrete_Range (E2));
6303 when N_String_Literal =>
6305 S1 : constant String_Id := Strval (E1);
6306 S2 : constant String_Id := Strval (E2);
6307 L1 : constant Nat := String_Length (S1);
6308 L2 : constant Nat := String_Length (S2);
6315 for J in 1 .. L1 loop
6316 if Get_String_Char (S1, J) /=
6317 Get_String_Char (S2, J)
6327 when N_Type_Conversion =>
6329 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6331 FCE (Expression (E1), Expression (E2));
6335 Entity (E1) = Entity (E2)
6337 FCE (Right_Opnd (E1), Right_Opnd (E2));
6339 when N_Unchecked_Type_Conversion =>
6341 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6343 FCE (Expression (E1), Expression (E2));
6345 -- All other node types cannot appear in this context. Strictly
6346 -- we should raise a fatal internal error. Instead we just ignore
6347 -- the nodes. This means that if anyone makes a mistake in the
6348 -- expander and mucks an expression tree irretrievably, the
6349 -- result will be a failure to detect a (probably very obscure)
6350 -- case of non-conformance, which is better than bombing on some
6351 -- case where two expressions do in fact conform.
6358 end Fully_Conformant_Expressions;
6360 ----------------------------------------
6361 -- Fully_Conformant_Discrete_Subtypes --
6362 ----------------------------------------
6364 function Fully_Conformant_Discrete_Subtypes
6365 (Given_S1 : Node_Id;
6366 Given_S2 : Node_Id) return Boolean
6368 S1 : constant Node_Id := Original_Node (Given_S1);
6369 S2 : constant Node_Id := Original_Node (Given_S2);
6371 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean;
6372 -- Special-case for a bound given by a discriminant, which in the body
6373 -- is replaced with the discriminal of the enclosing type.
6375 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean;
6376 -- Check both bounds
6378 -----------------------
6379 -- Conforming_Bounds --
6380 -----------------------
6382 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is
6384 if Is_Entity_Name (B1)
6385 and then Is_Entity_Name (B2)
6386 and then Ekind (Entity (B1)) = E_Discriminant
6388 return Chars (B1) = Chars (B2);
6391 return Fully_Conformant_Expressions (B1, B2);
6393 end Conforming_Bounds;
6395 -----------------------
6396 -- Conforming_Ranges --
6397 -----------------------
6399 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is
6402 Conforming_Bounds (Low_Bound (R1), Low_Bound (R2))
6404 Conforming_Bounds (High_Bound (R1), High_Bound (R2));
6405 end Conforming_Ranges;
6407 -- Start of processing for Fully_Conformant_Discrete_Subtypes
6410 if Nkind (S1) /= Nkind (S2) then
6413 elsif Is_Entity_Name (S1) then
6414 return Entity (S1) = Entity (S2);
6416 elsif Nkind (S1) = N_Range then
6417 return Conforming_Ranges (S1, S2);
6419 elsif Nkind (S1) = N_Subtype_Indication then
6421 Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2))
6424 (Range_Expression (Constraint (S1)),
6425 Range_Expression (Constraint (S2)));
6429 end Fully_Conformant_Discrete_Subtypes;
6431 --------------------
6432 -- Install_Entity --
6433 --------------------
6435 procedure Install_Entity (E : Entity_Id) is
6436 Prev : constant Entity_Id := Current_Entity (E);
6438 Set_Is_Immediately_Visible (E);
6439 Set_Current_Entity (E);
6440 Set_Homonym (E, Prev);
6443 ---------------------
6444 -- Install_Formals --
6445 ---------------------
6447 procedure Install_Formals (Id : Entity_Id) is
6450 F := First_Formal (Id);
6451 while Present (F) loop
6455 end Install_Formals;
6457 -----------------------------
6458 -- Is_Interface_Conformant --
6459 -----------------------------
6461 function Is_Interface_Conformant
6462 (Tagged_Type : Entity_Id;
6463 Iface_Prim : Entity_Id;
6464 Prim : Entity_Id) return Boolean
6466 Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim);
6467 Typ : constant Entity_Id := Find_Dispatching_Type (Prim);
6470 pragma Assert (Is_Subprogram (Iface_Prim)
6471 and then Is_Subprogram (Prim)
6472 and then Is_Dispatching_Operation (Iface_Prim)
6473 and then Is_Dispatching_Operation (Prim));
6475 pragma Assert (Is_Interface (Iface)
6476 or else (Present (Alias (Iface_Prim))
6479 (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
6481 if Prim = Iface_Prim
6482 or else not Is_Subprogram (Prim)
6483 or else Ekind (Prim) /= Ekind (Iface_Prim)
6484 or else not Is_Dispatching_Operation (Prim)
6485 or else Scope (Prim) /= Scope (Tagged_Type)
6487 or else Base_Type (Typ) /= Tagged_Type
6488 or else not Primitive_Names_Match (Iface_Prim, Prim)
6492 -- Case of a procedure, or a function that does not have a controlling
6493 -- result (I or access I).
6495 elsif Ekind (Iface_Prim) = E_Procedure
6496 or else Etype (Prim) = Etype (Iface_Prim)
6497 or else not Has_Controlling_Result (Prim)
6499 return Type_Conformant
6500 (Iface_Prim, Prim, Skip_Controlling_Formals => True);
6502 -- Case of a function returning an interface, or an access to one.
6503 -- Check that the return types correspond.
6505 elsif Implements_Interface (Typ, Iface) then
6506 if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type)
6508 (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type)
6513 Type_Conformant (Prim, Iface_Prim,
6514 Skip_Controlling_Formals => True);
6520 end Is_Interface_Conformant;
6522 ---------------------------------
6523 -- Is_Non_Overriding_Operation --
6524 ---------------------------------
6526 function Is_Non_Overriding_Operation
6527 (Prev_E : Entity_Id;
6528 New_E : Entity_Id) return Boolean
6532 G_Typ : Entity_Id := Empty;
6534 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
6535 -- If F_Type is a derived type associated with a generic actual subtype,
6536 -- then return its Generic_Parent_Type attribute, else return Empty.
6538 function Types_Correspond
6539 (P_Type : Entity_Id;
6540 N_Type : Entity_Id) return Boolean;
6541 -- Returns true if and only if the types (or designated types in the
6542 -- case of anonymous access types) are the same or N_Type is derived
6543 -- directly or indirectly from P_Type.
6545 -----------------------------
6546 -- Get_Generic_Parent_Type --
6547 -----------------------------
6549 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
6554 if Is_Derived_Type (F_Typ)
6555 and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
6557 -- The tree must be traversed to determine the parent subtype in
6558 -- the generic unit, which unfortunately isn't always available
6559 -- via semantic attributes. ??? (Note: The use of Original_Node
6560 -- is needed for cases where a full derived type has been
6563 Indic := Subtype_Indication
6564 (Type_Definition (Original_Node (Parent (F_Typ))));
6566 if Nkind (Indic) = N_Subtype_Indication then
6567 G_Typ := Entity (Subtype_Mark (Indic));
6569 G_Typ := Entity (Indic);
6572 if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
6573 and then Present (Generic_Parent_Type (Parent (G_Typ)))
6575 return Generic_Parent_Type (Parent (G_Typ));
6580 end Get_Generic_Parent_Type;
6582 ----------------------
6583 -- Types_Correspond --
6584 ----------------------
6586 function Types_Correspond
6587 (P_Type : Entity_Id;
6588 N_Type : Entity_Id) return Boolean
6590 Prev_Type : Entity_Id := Base_Type (P_Type);
6591 New_Type : Entity_Id := Base_Type (N_Type);
6594 if Ekind (Prev_Type) = E_Anonymous_Access_Type then
6595 Prev_Type := Designated_Type (Prev_Type);
6598 if Ekind (New_Type) = E_Anonymous_Access_Type then
6599 New_Type := Designated_Type (New_Type);
6602 if Prev_Type = New_Type then
6605 elsif not Is_Class_Wide_Type (New_Type) then
6606 while Etype (New_Type) /= New_Type loop
6607 New_Type := Etype (New_Type);
6608 if New_Type = Prev_Type then
6614 end Types_Correspond;
6616 -- Start of processing for Is_Non_Overriding_Operation
6619 -- In the case where both operations are implicit derived subprograms
6620 -- then neither overrides the other. This can only occur in certain
6621 -- obscure cases (e.g., derivation from homographs created in a generic
6624 if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
6627 elsif Ekind (Current_Scope) = E_Package
6628 and then Is_Generic_Instance (Current_Scope)
6629 and then In_Private_Part (Current_Scope)
6630 and then Comes_From_Source (New_E)
6632 -- We examine the formals and result subtype of the inherited
6633 -- operation, to determine whether their type is derived from (the
6634 -- instance of) a generic type.
6636 Formal := First_Formal (Prev_E);
6637 while Present (Formal) loop
6638 F_Typ := Base_Type (Etype (Formal));
6640 if Ekind (F_Typ) = E_Anonymous_Access_Type then
6641 F_Typ := Designated_Type (F_Typ);
6644 G_Typ := Get_Generic_Parent_Type (F_Typ);
6646 Next_Formal (Formal);
6649 if No (G_Typ) and then Ekind (Prev_E) = E_Function then
6650 G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
6657 -- If the generic type is a private type, then the original operation
6658 -- was not overriding in the generic, because there was no primitive
6659 -- operation to override.
6661 if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
6662 and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
6663 N_Formal_Private_Type_Definition
6667 -- The generic parent type is the ancestor of a formal derived
6668 -- type declaration. We need to check whether it has a primitive
6669 -- operation that should be overridden by New_E in the generic.
6673 P_Formal : Entity_Id;
6674 N_Formal : Entity_Id;
6678 Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
6681 while Present (Prim_Elt) loop
6682 P_Prim := Node (Prim_Elt);
6684 if Chars (P_Prim) = Chars (New_E)
6685 and then Ekind (P_Prim) = Ekind (New_E)
6687 P_Formal := First_Formal (P_Prim);
6688 N_Formal := First_Formal (New_E);
6689 while Present (P_Formal) and then Present (N_Formal) loop
6690 P_Typ := Etype (P_Formal);
6691 N_Typ := Etype (N_Formal);
6693 if not Types_Correspond (P_Typ, N_Typ) then
6697 Next_Entity (P_Formal);
6698 Next_Entity (N_Formal);
6701 -- Found a matching primitive operation belonging to the
6702 -- formal ancestor type, so the new subprogram is
6706 and then No (N_Formal)
6707 and then (Ekind (New_E) /= E_Function
6710 (Etype (P_Prim), Etype (New_E)))
6716 Next_Elmt (Prim_Elt);
6719 -- If no match found, then the new subprogram does not
6720 -- override in the generic (nor in the instance).
6728 end Is_Non_Overriding_Operation;
6730 ------------------------------
6731 -- Make_Inequality_Operator --
6732 ------------------------------
6734 -- S is the defining identifier of an equality operator. We build a
6735 -- subprogram declaration with the right signature. This operation is
6736 -- intrinsic, because it is always expanded as the negation of the
6737 -- call to the equality function.
6739 procedure Make_Inequality_Operator (S : Entity_Id) is
6740 Loc : constant Source_Ptr := Sloc (S);
6743 Op_Name : Entity_Id;
6745 FF : constant Entity_Id := First_Formal (S);
6746 NF : constant Entity_Id := Next_Formal (FF);
6749 -- Check that equality was properly defined, ignore call if not
6756 A : constant Entity_Id :=
6757 Make_Defining_Identifier (Sloc (FF),
6758 Chars => Chars (FF));
6760 B : constant Entity_Id :=
6761 Make_Defining_Identifier (Sloc (NF),
6762 Chars => Chars (NF));
6765 Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
6767 Formals := New_List (
6768 Make_Parameter_Specification (Loc,
6769 Defining_Identifier => A,
6771 New_Reference_To (Etype (First_Formal (S)),
6772 Sloc (Etype (First_Formal (S))))),
6774 Make_Parameter_Specification (Loc,
6775 Defining_Identifier => B,
6777 New_Reference_To (Etype (Next_Formal (First_Formal (S))),
6778 Sloc (Etype (Next_Formal (First_Formal (S)))))));
6781 Make_Subprogram_Declaration (Loc,
6783 Make_Function_Specification (Loc,
6784 Defining_Unit_Name => Op_Name,
6785 Parameter_Specifications => Formals,
6786 Result_Definition =>
6787 New_Reference_To (Standard_Boolean, Loc)));
6789 -- Insert inequality right after equality if it is explicit or after
6790 -- the derived type when implicit. These entities are created only
6791 -- for visibility purposes, and eventually replaced in the course of
6792 -- expansion, so they do not need to be attached to the tree and seen
6793 -- by the back-end. Keeping them internal also avoids spurious
6794 -- freezing problems. The declaration is inserted in the tree for
6795 -- analysis, and removed afterwards. If the equality operator comes
6796 -- from an explicit declaration, attach the inequality immediately
6797 -- after. Else the equality is inherited from a derived type
6798 -- declaration, so insert inequality after that declaration.
6800 if No (Alias (S)) then
6801 Insert_After (Unit_Declaration_Node (S), Decl);
6802 elsif Is_List_Member (Parent (S)) then
6803 Insert_After (Parent (S), Decl);
6805 Insert_After (Parent (Etype (First_Formal (S))), Decl);
6808 Mark_Rewrite_Insertion (Decl);
6809 Set_Is_Intrinsic_Subprogram (Op_Name);
6812 Set_Has_Completion (Op_Name);
6813 Set_Corresponding_Equality (Op_Name, S);
6814 Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S));
6816 end Make_Inequality_Operator;
6818 ----------------------
6819 -- May_Need_Actuals --
6820 ----------------------
6822 procedure May_Need_Actuals (Fun : Entity_Id) is
6827 F := First_Formal (Fun);
6829 while Present (F) loop
6830 if No (Default_Value (F)) then
6838 Set_Needs_No_Actuals (Fun, B);
6839 end May_Need_Actuals;
6841 ---------------------
6842 -- Mode_Conformant --
6843 ---------------------
6845 function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
6848 Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
6850 end Mode_Conformant;
6852 ---------------------------
6853 -- New_Overloaded_Entity --
6854 ---------------------------
6856 procedure New_Overloaded_Entity
6858 Derived_Type : Entity_Id := Empty)
6860 Overridden_Subp : Entity_Id := Empty;
6861 -- Set if the current scope has an operation that is type-conformant
6862 -- with S, and becomes hidden by S.
6864 Is_Primitive_Subp : Boolean;
6865 -- Set to True if the new subprogram is primitive
6868 -- Entity that S overrides
6870 Prev_Vis : Entity_Id := Empty;
6871 -- Predecessor of E in Homonym chain
6873 procedure Check_For_Primitive_Subprogram
6874 (Is_Primitive : out Boolean;
6875 Is_Overriding : Boolean := False);
6876 -- If the subprogram being analyzed is a primitive operation of the type
6877 -- of a formal or result, set the Has_Primitive_Operations flag on the
6878 -- type, and set Is_Primitive to True (otherwise set to False). Set the
6879 -- corresponding flag on the entity itself for later use.
6881 procedure Check_Synchronized_Overriding
6882 (Def_Id : Entity_Id;
6883 Overridden_Subp : out Entity_Id);
6884 -- First determine if Def_Id is an entry or a subprogram either defined
6885 -- in the scope of a task or protected type, or is a primitive of such
6886 -- a type. Check whether Def_Id overrides a subprogram of an interface
6887 -- implemented by the synchronized type, return the overridden entity
6890 function Is_Private_Declaration (E : Entity_Id) return Boolean;
6891 -- Check that E is declared in the private part of the current package,
6892 -- or in the package body, where it may hide a previous declaration.
6893 -- We can't use In_Private_Part by itself because this flag is also
6894 -- set when freezing entities, so we must examine the place of the
6895 -- declaration in the tree, and recognize wrapper packages as well.
6897 function Is_Overriding_Alias
6899 New_E : Entity_Id) return Boolean;
6900 -- Check whether new subprogram and old subprogram are both inherited
6901 -- from subprograms that have distinct dispatch table entries. This can
6902 -- occur with derivations from instances with accidental homonyms.
6903 -- The function is conservative given that the converse is only true
6904 -- within instances that contain accidental overloadings.
6906 ------------------------------------
6907 -- Check_For_Primitive_Subprogram --
6908 ------------------------------------
6910 procedure Check_For_Primitive_Subprogram
6911 (Is_Primitive : out Boolean;
6912 Is_Overriding : Boolean := False)
6918 function Visible_Part_Type (T : Entity_Id) return Boolean;
6919 -- Returns true if T is declared in the visible part of the current
6920 -- package scope; otherwise returns false. Assumes that T is declared
6923 procedure Check_Private_Overriding (T : Entity_Id);
6924 -- Checks that if a primitive abstract subprogram of a visible
6925 -- abstract type is declared in a private part, then it must override
6926 -- an abstract subprogram declared in the visible part. Also checks
6927 -- that if a primitive function with a controlling result is declared
6928 -- in a private part, then it must override a function declared in
6929 -- the visible part.
6931 ------------------------------
6932 -- Check_Private_Overriding --
6933 ------------------------------
6935 procedure Check_Private_Overriding (T : Entity_Id) is
6937 if Is_Package_Or_Generic_Package (Current_Scope)
6938 and then In_Private_Part (Current_Scope)
6939 and then Visible_Part_Type (T)
6940 and then not In_Instance
6942 if Is_Abstract_Type (T)
6943 and then Is_Abstract_Subprogram (S)
6944 and then (not Is_Overriding
6945 or else not Is_Abstract_Subprogram (E))
6948 ("abstract subprograms must be visible "
6949 & "(RM 3.9.3(10))!", S);
6951 elsif Ekind (S) = E_Function
6952 and then Is_Tagged_Type (T)
6953 and then T = Base_Type (Etype (S))
6954 and then not Is_Overriding
6957 ("private function with tagged result must"
6958 & " override visible-part function", S);
6960 ("\move subprogram to the visible part"
6961 & " (RM 3.9.3(10))", S);
6964 end Check_Private_Overriding;
6966 -----------------------
6967 -- Visible_Part_Type --
6968 -----------------------
6970 function Visible_Part_Type (T : Entity_Id) return Boolean is
6971 P : constant Node_Id := Unit_Declaration_Node (Scope (T));
6975 -- If the entity is a private type, then it must be declared in a
6978 if Ekind (T) in Private_Kind then
6982 -- Otherwise, we traverse the visible part looking for its
6983 -- corresponding declaration. We cannot use the declaration
6984 -- node directly because in the private part the entity of a
6985 -- private type is the one in the full view, which does not
6986 -- indicate that it is the completion of something visible.
6988 N := First (Visible_Declarations (Specification (P)));
6989 while Present (N) loop
6990 if Nkind (N) = N_Full_Type_Declaration
6991 and then Present (Defining_Identifier (N))
6992 and then T = Defining_Identifier (N)
6996 elsif Nkind_In (N, N_Private_Type_Declaration,
6997 N_Private_Extension_Declaration)
6998 and then Present (Defining_Identifier (N))
6999 and then T = Full_View (Defining_Identifier (N))
7008 end Visible_Part_Type;
7010 -- Start of processing for Check_For_Primitive_Subprogram
7013 Is_Primitive := False;
7015 if not Comes_From_Source (S) then
7018 -- If subprogram is at library level, it is not primitive operation
7020 elsif Current_Scope = Standard_Standard then
7023 elsif (Is_Package_Or_Generic_Package (Current_Scope)
7024 and then not In_Package_Body (Current_Scope))
7025 or else Is_Overriding
7027 -- For function, check return type
7029 if Ekind (S) = E_Function then
7030 if Ekind (Etype (S)) = E_Anonymous_Access_Type then
7031 F_Typ := Designated_Type (Etype (S));
7036 B_Typ := Base_Type (F_Typ);
7038 if Scope (B_Typ) = Current_Scope
7039 and then not Is_Class_Wide_Type (B_Typ)
7040 and then not Is_Generic_Type (B_Typ)
7042 Is_Primitive := True;
7043 Set_Has_Primitive_Operations (B_Typ);
7044 Set_Is_Primitive (S);
7045 Check_Private_Overriding (B_Typ);
7049 -- For all subprograms, check formals
7051 Formal := First_Formal (S);
7052 while Present (Formal) loop
7053 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
7054 F_Typ := Designated_Type (Etype (Formal));
7056 F_Typ := Etype (Formal);
7059 B_Typ := Base_Type (F_Typ);
7061 if Ekind (B_Typ) = E_Access_Subtype then
7062 B_Typ := Base_Type (B_Typ);
7065 if Scope (B_Typ) = Current_Scope
7066 and then not Is_Class_Wide_Type (B_Typ)
7067 and then not Is_Generic_Type (B_Typ)
7069 Is_Primitive := True;
7070 Set_Is_Primitive (S);
7071 Set_Has_Primitive_Operations (B_Typ);
7072 Check_Private_Overriding (B_Typ);
7075 Next_Formal (Formal);
7078 end Check_For_Primitive_Subprogram;
7080 -----------------------------------
7081 -- Check_Synchronized_Overriding --
7082 -----------------------------------
7084 procedure Check_Synchronized_Overriding
7085 (Def_Id : Entity_Id;
7086 Overridden_Subp : out Entity_Id)
7088 Ifaces_List : Elist_Id;
7092 function Matches_Prefixed_View_Profile
7093 (Prim_Params : List_Id;
7094 Iface_Params : List_Id) return Boolean;
7095 -- Determine whether a subprogram's parameter profile Prim_Params
7096 -- matches that of a potentially overridden interface subprogram
7097 -- Iface_Params. Also determine if the type of first parameter of
7098 -- Iface_Params is an implemented interface.
7100 -----------------------------------
7101 -- Matches_Prefixed_View_Profile --
7102 -----------------------------------
7104 function Matches_Prefixed_View_Profile
7105 (Prim_Params : List_Id;
7106 Iface_Params : List_Id) return Boolean
7108 Iface_Id : Entity_Id;
7109 Iface_Param : Node_Id;
7110 Iface_Typ : Entity_Id;
7111 Prim_Id : Entity_Id;
7112 Prim_Param : Node_Id;
7113 Prim_Typ : Entity_Id;
7115 function Is_Implemented
7116 (Ifaces_List : Elist_Id;
7117 Iface : Entity_Id) return Boolean;
7118 -- Determine if Iface is implemented by the current task or
7121 --------------------
7122 -- Is_Implemented --
7123 --------------------
7125 function Is_Implemented
7126 (Ifaces_List : Elist_Id;
7127 Iface : Entity_Id) return Boolean
7129 Iface_Elmt : Elmt_Id;
7132 Iface_Elmt := First_Elmt (Ifaces_List);
7133 while Present (Iface_Elmt) loop
7134 if Node (Iface_Elmt) = Iface then
7138 Next_Elmt (Iface_Elmt);
7144 -- Start of processing for Matches_Prefixed_View_Profile
7147 Iface_Param := First (Iface_Params);
7148 Iface_Typ := Etype (Defining_Identifier (Iface_Param));
7150 if Is_Access_Type (Iface_Typ) then
7151 Iface_Typ := Designated_Type (Iface_Typ);
7154 Prim_Param := First (Prim_Params);
7156 -- The first parameter of the potentially overridden subprogram
7157 -- must be an interface implemented by Prim.
7159 if not Is_Interface (Iface_Typ)
7160 or else not Is_Implemented (Ifaces_List, Iface_Typ)
7165 -- The checks on the object parameters are done, move onto the
7166 -- rest of the parameters.
7168 if not In_Scope then
7169 Prim_Param := Next (Prim_Param);
7172 Iface_Param := Next (Iface_Param);
7173 while Present (Iface_Param) and then Present (Prim_Param) loop
7174 Iface_Id := Defining_Identifier (Iface_Param);
7175 Iface_Typ := Find_Parameter_Type (Iface_Param);
7177 Prim_Id := Defining_Identifier (Prim_Param);
7178 Prim_Typ := Find_Parameter_Type (Prim_Param);
7180 if Ekind (Iface_Typ) = E_Anonymous_Access_Type
7181 and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
7182 and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
7184 Iface_Typ := Designated_Type (Iface_Typ);
7185 Prim_Typ := Designated_Type (Prim_Typ);
7188 -- Case of multiple interface types inside a parameter profile
7190 -- (Obj_Param : in out Iface; ...; Param : Iface)
7192 -- If the interface type is implemented, then the matching type
7193 -- in the primitive should be the implementing record type.
7195 if Ekind (Iface_Typ) = E_Record_Type
7196 and then Is_Interface (Iface_Typ)
7197 and then Is_Implemented (Ifaces_List, Iface_Typ)
7199 if Prim_Typ /= Typ then
7203 -- The two parameters must be both mode and subtype conformant
7205 elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
7207 Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
7216 -- One of the two lists contains more parameters than the other
7218 if Present (Iface_Param) or else Present (Prim_Param) then
7223 end Matches_Prefixed_View_Profile;
7225 -- Start of processing for Check_Synchronized_Overriding
7228 Overridden_Subp := Empty;
7230 -- Def_Id must be an entry or a subprogram. We should skip predefined
7231 -- primitives internally generated by the frontend; however at this
7232 -- stage predefined primitives are still not fully decorated. As a
7233 -- minor optimization we skip here internally generated subprograms.
7235 if (Ekind (Def_Id) /= E_Entry
7236 and then Ekind (Def_Id) /= E_Function
7237 and then Ekind (Def_Id) /= E_Procedure)
7238 or else not Comes_From_Source (Def_Id)
7243 -- Search for the concurrent declaration since it contains the list
7244 -- of all implemented interfaces. In this case, the subprogram is
7245 -- declared within the scope of a protected or a task type.
7247 if Present (Scope (Def_Id))
7248 and then Is_Concurrent_Type (Scope (Def_Id))
7249 and then not Is_Generic_Actual_Type (Scope (Def_Id))
7251 Typ := Scope (Def_Id);
7254 -- The enclosing scope is not a synchronized type and the subprogram
7257 elsif No (First_Formal (Def_Id)) then
7260 -- The subprogram has formals and hence it may be a primitive of a
7264 Typ := Etype (First_Formal (Def_Id));
7266 if Is_Access_Type (Typ) then
7267 Typ := Directly_Designated_Type (Typ);
7270 if Is_Concurrent_Type (Typ)
7271 and then not Is_Generic_Actual_Type (Typ)
7275 -- This case occurs when the concurrent type is declared within
7276 -- a generic unit. As a result the corresponding record has been
7277 -- built and used as the type of the first formal, we just have
7278 -- to retrieve the corresponding concurrent type.
7280 elsif Is_Concurrent_Record_Type (Typ)
7281 and then Present (Corresponding_Concurrent_Type (Typ))
7283 Typ := Corresponding_Concurrent_Type (Typ);
7291 -- There is no overriding to check if is an inherited operation in a
7292 -- type derivation on for a generic actual.
7294 Collect_Interfaces (Typ, Ifaces_List);
7296 if Is_Empty_Elmt_List (Ifaces_List) then
7300 -- Determine whether entry or subprogram Def_Id overrides a primitive
7301 -- operation that belongs to one of the interfaces in Ifaces_List.
7304 Candidate : Entity_Id := Empty;
7305 Hom : Entity_Id := Empty;
7306 Iface_Typ : Entity_Id;
7307 Subp : Entity_Id := Empty;
7310 -- Traverse the homonym chain, looking at a potentially
7311 -- overridden subprogram that belongs to an implemented
7314 Hom := Current_Entity_In_Scope (Def_Id);
7315 while Present (Hom) loop
7319 or else not Is_Overloadable (Subp)
7320 or else not Is_Primitive (Subp)
7321 or else not Is_Dispatching_Operation (Subp)
7322 or else not Present (Find_Dispatching_Type (Subp))
7323 or else not Is_Interface (Find_Dispatching_Type (Subp))
7327 -- Entries and procedures can override abstract or null
7328 -- interface procedures
7330 elsif (Ekind (Def_Id) = E_Procedure
7331 or else Ekind (Def_Id) = E_Entry)
7332 and then Ekind (Subp) = E_Procedure
7333 and then Matches_Prefixed_View_Profile
7334 (Parameter_Specifications (Parent (Def_Id)),
7335 Parameter_Specifications (Parent (Subp)))
7339 -- For an overridden subprogram Subp, check whether the mode
7340 -- of its first parameter is correct depending on the kind
7341 -- of synchronized type.
7344 Formal : constant Node_Id := First_Formal (Candidate);
7347 -- In order for an entry or a protected procedure to
7348 -- override, the first parameter of the overridden
7349 -- routine must be of mode "out", "in out" or
7350 -- access-to-variable.
7352 if (Ekind (Candidate) = E_Entry
7353 or else Ekind (Candidate) = E_Procedure)
7354 and then Is_Protected_Type (Typ)
7355 and then Ekind (Formal) /= E_In_Out_Parameter
7356 and then Ekind (Formal) /= E_Out_Parameter
7357 and then Nkind (Parameter_Type (Parent (Formal)))
7358 /= N_Access_Definition
7362 -- All other cases are OK since a task entry or routine
7363 -- does not have a restriction on the mode of the first
7364 -- parameter of the overridden interface routine.
7367 Overridden_Subp := Candidate;
7372 -- Functions can override abstract interface functions
7374 elsif Ekind (Def_Id) = E_Function
7375 and then Ekind (Subp) = E_Function
7376 and then Matches_Prefixed_View_Profile
7377 (Parameter_Specifications (Parent (Def_Id)),
7378 Parameter_Specifications (Parent (Subp)))
7379 and then Etype (Result_Definition (Parent (Def_Id))) =
7380 Etype (Result_Definition (Parent (Subp)))
7382 Overridden_Subp := Subp;
7386 Hom := Homonym (Hom);
7389 -- After examining all candidates for overriding, we are
7390 -- left with the best match which is a mode incompatible
7391 -- interface routine. Do not emit an error if the Expander
7392 -- is active since this error will be detected later on
7393 -- after all concurrent types are expanded and all wrappers
7394 -- are built. This check is meant for spec-only
7397 if Present (Candidate)
7398 and then not Expander_Active
7401 Find_Parameter_Type (Parent (First_Formal (Candidate)));
7403 -- Def_Id is primitive of a protected type, declared
7404 -- inside the type, and the candidate is primitive of a
7405 -- limited or synchronized interface.
7408 and then Is_Protected_Type (Typ)
7410 (Is_Limited_Interface (Iface_Typ)
7411 or else Is_Protected_Interface (Iface_Typ)
7412 or else Is_Synchronized_Interface (Iface_Typ)
7413 or else Is_Task_Interface (Iface_Typ))
7415 -- Must reword this message, comma before to in -gnatj
7419 ("first formal of & must be of mode `OUT`, `IN OUT`"
7420 & " or access-to-variable", Typ, Candidate);
7422 ("\to be overridden by protected procedure or entry "
7423 & "(RM 9.4(11.9/2))", Typ);
7427 Overridden_Subp := Candidate;
7430 end Check_Synchronized_Overriding;
7432 ----------------------------
7433 -- Is_Private_Declaration --
7434 ----------------------------
7436 function Is_Private_Declaration (E : Entity_Id) return Boolean is
7437 Priv_Decls : List_Id;
7438 Decl : constant Node_Id := Unit_Declaration_Node (E);
7441 if Is_Package_Or_Generic_Package (Current_Scope)
7442 and then In_Private_Part (Current_Scope)
7445 Private_Declarations (
7446 Specification (Unit_Declaration_Node (Current_Scope)));
7448 return In_Package_Body (Current_Scope)
7450 (Is_List_Member (Decl)
7451 and then List_Containing (Decl) = Priv_Decls)
7452 or else (Nkind (Parent (Decl)) = N_Package_Specification
7455 (Defining_Entity (Parent (Decl)))
7456 and then List_Containing (Parent (Parent (Decl)))
7461 end Is_Private_Declaration;
7463 --------------------------
7464 -- Is_Overriding_Alias --
7465 --------------------------
7467 function Is_Overriding_Alias
7469 New_E : Entity_Id) return Boolean
7471 AO : constant Entity_Id := Alias (Old_E);
7472 AN : constant Entity_Id := Alias (New_E);
7475 return Scope (AO) /= Scope (AN)
7476 or else No (DTC_Entity (AO))
7477 or else No (DTC_Entity (AN))
7478 or else DT_Position (AO) = DT_Position (AN);
7479 end Is_Overriding_Alias;
7481 -- Start of processing for New_Overloaded_Entity
7484 -- We need to look for an entity that S may override. This must be a
7485 -- homonym in the current scope, so we look for the first homonym of
7486 -- S in the current scope as the starting point for the search.
7488 E := Current_Entity_In_Scope (S);
7490 -- If there is no homonym then this is definitely not overriding
7493 Enter_Overloaded_Entity (S);
7494 Check_Dispatching_Operation (S, Empty);
7495 Check_For_Primitive_Subprogram (Is_Primitive_Subp);
7497 -- If subprogram has an explicit declaration, check whether it
7498 -- has an overriding indicator.
7500 if Comes_From_Source (S) then
7501 Check_Synchronized_Overriding (S, Overridden_Subp);
7502 Check_Overriding_Indicator
7503 (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
7506 -- If there is a homonym that is not overloadable, then we have an
7507 -- error, except for the special cases checked explicitly below.
7509 elsif not Is_Overloadable (E) then
7511 -- Check for spurious conflict produced by a subprogram that has the
7512 -- same name as that of the enclosing generic package. The conflict
7513 -- occurs within an instance, between the subprogram and the renaming
7514 -- declaration for the package. After the subprogram, the package
7515 -- renaming declaration becomes hidden.
7517 if Ekind (E) = E_Package
7518 and then Present (Renamed_Object (E))
7519 and then Renamed_Object (E) = Current_Scope
7520 and then Nkind (Parent (Renamed_Object (E))) =
7521 N_Package_Specification
7522 and then Present (Generic_Parent (Parent (Renamed_Object (E))))
7525 Set_Is_Immediately_Visible (E, False);
7526 Enter_Overloaded_Entity (S);
7527 Set_Homonym (S, Homonym (E));
7528 Check_Dispatching_Operation (S, Empty);
7529 Check_Overriding_Indicator (S, Empty, Is_Primitive => False);
7531 -- If the subprogram is implicit it is hidden by the previous
7532 -- declaration. However if it is dispatching, it must appear in the
7533 -- dispatch table anyway, because it can be dispatched to even if it
7534 -- cannot be called directly.
7536 elsif Present (Alias (S))
7537 and then not Comes_From_Source (S)
7539 Set_Scope (S, Current_Scope);
7541 if Is_Dispatching_Operation (Alias (S)) then
7542 Check_Dispatching_Operation (S, Empty);
7548 Error_Msg_Sloc := Sloc (E);
7550 -- Generate message, with useful additional warning if in generic
7552 if Is_Generic_Unit (E) then
7553 Error_Msg_N ("previous generic unit cannot be overloaded", S);
7554 Error_Msg_N ("\& conflicts with declaration#", S);
7556 Error_Msg_N ("& conflicts with declaration#", S);
7562 -- E exists and is overloadable
7565 -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
7566 -- They are directly added to the list of primitive operations of
7567 -- Derived_Type, unless this is a rederivation in the private part
7568 -- of an operation that was already derived in the visible part of
7569 -- the current package.
7571 if Ada_Version >= Ada_05
7572 and then Present (Derived_Type)
7573 and then Is_Dispatching_Operation (Alias (S))
7574 and then Present (Find_Dispatching_Type (Alias (S)))
7575 and then Is_Interface (Find_Dispatching_Type (Alias (S)))
7577 if Type_Conformant (E, S)
7578 and then Is_Package_Or_Generic_Package (Current_Scope)
7579 and then In_Private_Part (Current_Scope)
7580 and then Parent (E) /= Parent (S)
7581 and then Alias (E) = Alias (S)
7583 Check_Operation_From_Private_View (S, E);
7585 goto Add_New_Entity;
7589 Check_Synchronized_Overriding (S, Overridden_Subp);
7591 -- Loop through E and its homonyms to determine if any of them is
7592 -- the candidate for overriding by S.
7594 while Present (E) loop
7596 -- Definitely not interesting if not in the current scope
7598 if Scope (E) /= Current_Scope then
7601 -- Check if we have type conformance
7603 elsif Type_Conformant (E, S) then
7605 -- If the old and new entities have the same profile and one
7606 -- is not the body of the other, then this is an error, unless
7607 -- one of them is implicitly declared.
7609 -- There are some cases when both can be implicit, for example
7610 -- when both a literal and a function that overrides it are
7611 -- inherited in a derivation, or when an inherited operation
7612 -- of a tagged full type overrides the inherited operation of
7613 -- a private extension. Ada 83 had a special rule for the
7614 -- literal case. In Ada95, the later implicit operation hides
7615 -- the former, and the literal is always the former. In the
7616 -- odd case where both are derived operations declared at the
7617 -- same point, both operations should be declared, and in that
7618 -- case we bypass the following test and proceed to the next
7619 -- part. This can only occur for certain obscure cases in
7620 -- instances, when an operation on a type derived from a formal
7621 -- private type does not override a homograph inherited from
7622 -- the actual. In subsequent derivations of such a type, the
7623 -- DT positions of these operations remain distinct, if they
7626 if Present (Alias (S))
7627 and then (No (Alias (E))
7628 or else Comes_From_Source (E)
7629 or else Is_Abstract_Subprogram (S)
7631 (Is_Dispatching_Operation (E)
7632 and then Is_Overriding_Alias (E, S)))
7633 and then Ekind (E) /= E_Enumeration_Literal
7635 -- When an derived operation is overloaded it may be due to
7636 -- the fact that the full view of a private extension
7637 -- re-inherits. It has to be dealt with.
7639 if Is_Package_Or_Generic_Package (Current_Scope)
7640 and then In_Private_Part (Current_Scope)
7642 Check_Operation_From_Private_View (S, E);
7645 -- In any case the implicit operation remains hidden by
7646 -- the existing declaration, which is overriding.
7648 Set_Is_Overriding_Operation (E);
7650 if Comes_From_Source (E) then
7651 Check_Overriding_Indicator (E, S, Is_Primitive => False);
7653 -- Indicate that E overrides the operation from which
7656 if Present (Alias (S)) then
7657 Set_Overridden_Operation (E, Alias (S));
7659 Set_Overridden_Operation (E, S);
7665 -- Within an instance, the renaming declarations for actual
7666 -- subprograms may become ambiguous, but they do not hide each
7669 elsif Ekind (E) /= E_Entry
7670 and then not Comes_From_Source (E)
7671 and then not Is_Generic_Instance (E)
7672 and then (Present (Alias (E))
7673 or else Is_Intrinsic_Subprogram (E))
7674 and then (not In_Instance
7675 or else No (Parent (E))
7676 or else Nkind (Unit_Declaration_Node (E)) /=
7677 N_Subprogram_Renaming_Declaration)
7679 -- A subprogram child unit is not allowed to override an
7680 -- inherited subprogram (10.1.1(20)).
7682 if Is_Child_Unit (S) then
7684 ("child unit overrides inherited subprogram in parent",
7689 if Is_Non_Overriding_Operation (E, S) then
7690 Enter_Overloaded_Entity (S);
7692 if No (Derived_Type)
7693 or else Is_Tagged_Type (Derived_Type)
7695 Check_Dispatching_Operation (S, Empty);
7701 -- E is a derived operation or an internal operator which
7702 -- is being overridden. Remove E from further visibility.
7703 -- Furthermore, if E is a dispatching operation, it must be
7704 -- replaced in the list of primitive operations of its type
7705 -- (see Override_Dispatching_Operation).
7707 Overridden_Subp := E;
7713 Prev := First_Entity (Current_Scope);
7714 while Present (Prev)
7715 and then Next_Entity (Prev) /= E
7720 -- It is possible for E to be in the current scope and
7721 -- yet not in the entity chain. This can only occur in a
7722 -- generic context where E is an implicit concatenation
7723 -- in the formal part, because in a generic body the
7724 -- entity chain starts with the formals.
7727 (Present (Prev) or else Chars (E) = Name_Op_Concat);
7729 -- E must be removed both from the entity_list of the
7730 -- current scope, and from the visibility chain
7732 if Debug_Flag_E then
7733 Write_Str ("Override implicit operation ");
7734 Write_Int (Int (E));
7738 -- If E is a predefined concatenation, it stands for four
7739 -- different operations. As a result, a single explicit
7740 -- declaration does not hide it. In a possible ambiguous
7741 -- situation, Disambiguate chooses the user-defined op,
7742 -- so it is correct to retain the previous internal one.
7744 if Chars (E) /= Name_Op_Concat
7745 or else Ekind (E) /= E_Operator
7747 -- For nondispatching derived operations that are
7748 -- overridden by a subprogram declared in the private
7749 -- part of a package, we retain the derived subprogram
7750 -- but mark it as not immediately visible. If the
7751 -- derived operation was declared in the visible part
7752 -- then this ensures that it will still be visible
7753 -- outside the package with the proper signature
7754 -- (calls from outside must also be directed to this
7755 -- version rather than the overriding one, unlike the
7756 -- dispatching case). Calls from inside the package
7757 -- will still resolve to the overriding subprogram
7758 -- since the derived one is marked as not visible
7759 -- within the package.
7761 -- If the private operation is dispatching, we achieve
7762 -- the overriding by keeping the implicit operation
7763 -- but setting its alias to be the overriding one. In
7764 -- this fashion the proper body is executed in all
7765 -- cases, but the original signature is used outside
7768 -- If the overriding is not in the private part, we
7769 -- remove the implicit operation altogether.
7771 if Is_Private_Declaration (S) then
7772 if not Is_Dispatching_Operation (E) then
7773 Set_Is_Immediately_Visible (E, False);
7775 -- Work done in Override_Dispatching_Operation,
7776 -- so nothing else need to be done here.
7782 -- Find predecessor of E in Homonym chain
7784 if E = Current_Entity (E) then
7787 Prev_Vis := Current_Entity (E);
7788 while Homonym (Prev_Vis) /= E loop
7789 Prev_Vis := Homonym (Prev_Vis);
7793 if Prev_Vis /= Empty then
7795 -- Skip E in the visibility chain
7797 Set_Homonym (Prev_Vis, Homonym (E));
7800 Set_Name_Entity_Id (Chars (E), Homonym (E));
7803 Set_Next_Entity (Prev, Next_Entity (E));
7805 if No (Next_Entity (Prev)) then
7806 Set_Last_Entity (Current_Scope, Prev);
7812 Enter_Overloaded_Entity (S);
7813 Set_Is_Overriding_Operation (S);
7814 Check_Overriding_Indicator (S, E, Is_Primitive => True);
7816 -- If S is a user-defined subprogram or a null procedure
7817 -- expanded to override an inherited null procedure, then
7818 -- indicate that E overrides the operation from which S
7819 -- is inherited. It seems odd that Overridden_Operation
7820 -- isn't set in all cases where Is_Overriding_Operation
7821 -- is true, but doing so causes infinite loops in the
7822 -- compiler for implicit overriding subprograms. ???
7824 if Comes_From_Source (S)
7826 (Present (Parent (S))
7828 Nkind (Parent (S)) = N_Procedure_Specification
7830 Null_Present (Parent (S)))
7832 if Present (Alias (E)) then
7833 Set_Overridden_Operation (S, Alias (E));
7835 Set_Overridden_Operation (S, E);
7839 if Is_Dispatching_Operation (E) then
7841 -- An overriding dispatching subprogram inherits the
7842 -- convention of the overridden subprogram (by
7845 Set_Convention (S, Convention (E));
7846 Check_Dispatching_Operation (S, E);
7849 Check_Dispatching_Operation (S, Empty);
7852 Check_For_Primitive_Subprogram
7853 (Is_Primitive_Subp, Is_Overriding => True);
7854 goto Check_Inequality;
7857 -- Apparent redeclarations in instances can occur when two
7858 -- formal types get the same actual type. The subprograms in
7859 -- in the instance are legal, even if not callable from the
7860 -- outside. Calls from within are disambiguated elsewhere.
7861 -- For dispatching operations in the visible part, the usual
7862 -- rules apply, and operations with the same profile are not
7865 elsif (In_Instance_Visible_Part
7866 and then not Is_Dispatching_Operation (E))
7867 or else In_Instance_Not_Visible
7871 -- Here we have a real error (identical profile)
7874 Error_Msg_Sloc := Sloc (E);
7876 -- Avoid cascaded errors if the entity appears in
7877 -- subsequent calls.
7879 Set_Scope (S, Current_Scope);
7881 -- Generate error, with extra useful warning for the case
7882 -- of a generic instance with no completion.
7884 if Is_Generic_Instance (S)
7885 and then not Has_Completion (E)
7888 ("instantiation cannot provide body for&", S);
7889 Error_Msg_N ("\& conflicts with declaration#", S);
7891 Error_Msg_N ("& conflicts with declaration#", S);
7898 -- If one subprogram has an access parameter and the other
7899 -- a parameter of an access type, calls to either might be
7900 -- ambiguous. Verify that parameters match except for the
7901 -- access parameter.
7903 if May_Hide_Profile then
7909 F1 := First_Formal (S);
7910 F2 := First_Formal (E);
7911 while Present (F1) and then Present (F2) loop
7912 if Is_Access_Type (Etype (F1)) then
7913 if not Is_Access_Type (Etype (F2))
7914 or else not Conforming_Types
7915 (Designated_Type (Etype (F1)),
7916 Designated_Type (Etype (F2)),
7919 May_Hide_Profile := False;
7923 not Conforming_Types
7924 (Etype (F1), Etype (F2), Type_Conformant)
7926 May_Hide_Profile := False;
7937 Error_Msg_NE ("calls to& may be ambiguous?", S, S);
7948 -- On exit, we know that S is a new entity
7950 Enter_Overloaded_Entity (S);
7951 Check_For_Primitive_Subprogram (Is_Primitive_Subp);
7952 Check_Overriding_Indicator
7953 (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
7955 -- If S is a derived operation for an untagged type then by
7956 -- definition it's not a dispatching operation (even if the parent
7957 -- operation was dispatching), so we don't call
7958 -- Check_Dispatching_Operation in that case.
7960 if No (Derived_Type)
7961 or else Is_Tagged_Type (Derived_Type)
7963 Check_Dispatching_Operation (S, Empty);
7967 -- If this is a user-defined equality operator that is not a derived
7968 -- subprogram, create the corresponding inequality. If the operation is
7969 -- dispatching, the expansion is done elsewhere, and we do not create
7970 -- an explicit inequality operation.
7972 <<Check_Inequality>>
7973 if Chars (S) = Name_Op_Eq
7974 and then Etype (S) = Standard_Boolean
7975 and then Present (Parent (S))
7976 and then not Is_Dispatching_Operation (S)
7978 Make_Inequality_Operator (S);
7980 end New_Overloaded_Entity;
7982 ---------------------
7983 -- Process_Formals --
7984 ---------------------
7986 procedure Process_Formals
7988 Related_Nod : Node_Id)
7990 Param_Spec : Node_Id;
7992 Formal_Type : Entity_Id;
7996 Num_Out_Params : Nat := 0;
7997 First_Out_Param : Entity_Id := Empty;
7998 -- Used for setting Is_Only_Out_Parameter
8000 function Designates_From_With_Type (Typ : Entity_Id) return Boolean;
8001 -- Determine whether an access type designates a type coming from a
8004 function Is_Class_Wide_Default (D : Node_Id) return Boolean;
8005 -- Check whether the default has a class-wide type. After analysis the
8006 -- default has the type of the formal, so we must also check explicitly
8007 -- for an access attribute.
8009 -------------------------------
8010 -- Designates_From_With_Type --
8011 -------------------------------
8013 function Designates_From_With_Type (Typ : Entity_Id) return Boolean is
8014 Desig : Entity_Id := Typ;
8017 if Is_Access_Type (Desig) then
8018 Desig := Directly_Designated_Type (Desig);
8021 if Is_Class_Wide_Type (Desig) then
8022 Desig := Root_Type (Desig);
8026 Ekind (Desig) = E_Incomplete_Type
8027 and then From_With_Type (Desig);
8028 end Designates_From_With_Type;
8030 ---------------------------
8031 -- Is_Class_Wide_Default --
8032 ---------------------------
8034 function Is_Class_Wide_Default (D : Node_Id) return Boolean is
8036 return Is_Class_Wide_Type (Designated_Type (Etype (D)))
8037 or else (Nkind (D) = N_Attribute_Reference
8038 and then Attribute_Name (D) = Name_Access
8039 and then Is_Class_Wide_Type (Etype (Prefix (D))));
8040 end Is_Class_Wide_Default;
8042 -- Start of processing for Process_Formals
8045 -- In order to prevent premature use of the formals in the same formal
8046 -- part, the Ekind is left undefined until all default expressions are
8047 -- analyzed. The Ekind is established in a separate loop at the end.
8049 Param_Spec := First (T);
8050 while Present (Param_Spec) loop
8051 Formal := Defining_Identifier (Param_Spec);
8052 Set_Never_Set_In_Source (Formal, True);
8053 Enter_Name (Formal);
8055 -- Case of ordinary parameters
8057 if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
8058 Find_Type (Parameter_Type (Param_Spec));
8059 Ptype := Parameter_Type (Param_Spec);
8061 if Ptype = Error then
8065 Formal_Type := Entity (Ptype);
8067 if Is_Incomplete_Type (Formal_Type)
8069 (Is_Class_Wide_Type (Formal_Type)
8070 and then Is_Incomplete_Type (Root_Type (Formal_Type)))
8072 -- Ada 2005 (AI-326): Tagged incomplete types allowed in
8073 -- primitive operations, as long as their completion is
8074 -- in the same declarative part. If in the private part
8075 -- this means that the type cannot be a Taft-amendment type.
8076 -- Check is done on package exit. For access to subprograms,
8077 -- the use is legal for Taft-amendment types.
8079 if Is_Tagged_Type (Formal_Type) then
8080 if Ekind (Scope (Current_Scope)) = E_Package
8081 and then In_Private_Part (Scope (Current_Scope))
8082 and then not From_With_Type (Formal_Type)
8083 and then not Is_Class_Wide_Type (Formal_Type)
8086 (Parent (T), N_Access_Function_Definition,
8087 N_Access_Procedure_Definition)
8091 Private_Dependents (Base_Type (Formal_Type)));
8095 -- Special handling of Value_Type for CIL case
8097 elsif Is_Value_Type (Formal_Type) then
8100 elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
8101 N_Access_Procedure_Definition)
8104 ("invalid use of incomplete type&",
8105 Param_Spec, Formal_Type);
8107 -- Further checks on the legality of incomplete types
8108 -- in formal parts must be delayed until the freeze point
8109 -- of the enclosing subprogram or access to subprogram.
8112 elsif Ekind (Formal_Type) = E_Void then
8113 Error_Msg_NE ("premature use of&",
8114 Parameter_Type (Param_Spec), Formal_Type);
8117 -- Ada 2005 (AI-231): Create and decorate an internal subtype
8118 -- declaration corresponding to the null-excluding type of the
8119 -- formal in the enclosing scope. Finally, replace the parameter
8120 -- type of the formal with the internal subtype.
8122 if Ada_Version >= Ada_05
8123 and then Null_Exclusion_Present (Param_Spec)
8125 if not Is_Access_Type (Formal_Type) then
8127 ("`NOT NULL` allowed only for an access type", Param_Spec);
8130 if Can_Never_Be_Null (Formal_Type)
8131 and then Comes_From_Source (Related_Nod)
8134 ("`NOT NULL` not allowed (& already excludes null)",
8140 Create_Null_Excluding_Itype
8142 Related_Nod => Related_Nod,
8143 Scope_Id => Scope (Current_Scope));
8145 -- If the designated type of the itype is an itype we
8146 -- decorate it with the Has_Delayed_Freeze attribute to
8147 -- avoid problems with the backend.
8150 -- type T is access procedure;
8151 -- procedure Op (O : not null T);
8153 if Is_Itype (Directly_Designated_Type (Formal_Type)) then
8154 Set_Has_Delayed_Freeze (Formal_Type);
8159 -- An access formal type
8163 Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
8165 -- No need to continue if we already notified errors
8167 if not Present (Formal_Type) then
8171 -- Ada 2005 (AI-254)
8174 AD : constant Node_Id :=
8175 Access_To_Subprogram_Definition
8176 (Parameter_Type (Param_Spec));
8178 if Present (AD) and then Protected_Present (AD) then
8180 Replace_Anonymous_Access_To_Protected_Subprogram
8186 Set_Etype (Formal, Formal_Type);
8187 Default := Expression (Param_Spec);
8189 if Present (Default) then
8190 if Out_Present (Param_Spec) then
8192 ("default initialization only allowed for IN parameters",
8196 -- Do the special preanalysis of the expression (see section on
8197 -- "Handling of Default Expressions" in the spec of package Sem).
8199 Preanalyze_Spec_Expression (Default, Formal_Type);
8201 -- An access to constant cannot be the default for
8202 -- an access parameter that is an access to variable.
8204 if Ekind (Formal_Type) = E_Anonymous_Access_Type
8205 and then not Is_Access_Constant (Formal_Type)
8206 and then Is_Access_Type (Etype (Default))
8207 and then Is_Access_Constant (Etype (Default))
8210 ("formal that is access to variable cannot be initialized " &
8211 "with an access-to-constant expression", Default);
8214 -- Check that the designated type of an access parameter's default
8215 -- is not a class-wide type unless the parameter's designated type
8216 -- is also class-wide.
8218 if Ekind (Formal_Type) = E_Anonymous_Access_Type
8219 and then not Designates_From_With_Type (Formal_Type)
8220 and then Is_Class_Wide_Default (Default)
8221 and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
8224 ("access to class-wide expression not allowed here", Default);
8227 -- Check incorrect use of dynamically tagged expressions
8229 if Is_Tagged_Type (Formal_Type) then
8230 Check_Dynamically_Tagged_Expression
8233 Related_Nod => Default);
8237 -- Ada 2005 (AI-231): Static checks
8239 if Ada_Version >= Ada_05
8240 and then Is_Access_Type (Etype (Formal))
8241 and then Can_Never_Be_Null (Etype (Formal))
8243 Null_Exclusion_Static_Checks (Param_Spec);
8250 -- If this is the formal part of a function specification, analyze the
8251 -- subtype mark in the context where the formals are visible but not
8252 -- yet usable, and may hide outer homographs.
8254 if Nkind (Related_Nod) = N_Function_Specification then
8255 Analyze_Return_Type (Related_Nod);
8258 -- Now set the kind (mode) of each formal
8260 Param_Spec := First (T);
8262 while Present (Param_Spec) loop
8263 Formal := Defining_Identifier (Param_Spec);
8264 Set_Formal_Mode (Formal);
8266 if Ekind (Formal) = E_In_Parameter then
8267 Set_Default_Value (Formal, Expression (Param_Spec));
8269 if Present (Expression (Param_Spec)) then
8270 Default := Expression (Param_Spec);
8272 if Is_Scalar_Type (Etype (Default)) then
8274 (Parameter_Type (Param_Spec)) /= N_Access_Definition
8276 Formal_Type := Entity (Parameter_Type (Param_Spec));
8279 Formal_Type := Access_Definition
8280 (Related_Nod, Parameter_Type (Param_Spec));
8283 Apply_Scalar_Range_Check (Default, Formal_Type);
8287 elsif Ekind (Formal) = E_Out_Parameter then
8288 Num_Out_Params := Num_Out_Params + 1;
8290 if Num_Out_Params = 1 then
8291 First_Out_Param := Formal;
8294 elsif Ekind (Formal) = E_In_Out_Parameter then
8295 Num_Out_Params := Num_Out_Params + 1;
8301 if Present (First_Out_Param) and then Num_Out_Params = 1 then
8302 Set_Is_Only_Out_Parameter (First_Out_Param);
8304 end Process_Formals;
8310 procedure Process_PPCs
8312 Spec_Id : Entity_Id;
8313 Body_Id : Entity_Id)
8315 Loc : constant Source_Ptr := Sloc (N);
8317 Plist : List_Id := No_List;
8321 function Grab_PPC (Nam : Name_Id) return Node_Id;
8322 -- Prag contains an analyzed precondition or postcondition pragma.
8323 -- This function copies the pragma, changes it to the corresponding
8324 -- Check pragma and returns the Check pragma as the result. The
8325 -- argument Nam is either Name_Precondition or Name_Postcondition.
8331 function Grab_PPC (Nam : Name_Id) return Node_Id is
8332 CP : constant Node_Id := New_Copy_Tree (Prag);
8335 -- Set Analyzed to false, since we want to reanalyze the check
8336 -- procedure. Note that it is only at the outer level that we
8337 -- do this fiddling, for the spec cases, the already preanalyzed
8338 -- parameters are not affected.
8340 -- For a postcondition pragma within a generic, preserve the pragma
8341 -- for later expansion.
8343 Set_Analyzed (CP, False);
8345 if Nam = Name_Postcondition
8346 and then not Expander_Active
8351 -- Change pragma into corresponding pragma Check
8353 Prepend_To (Pragma_Argument_Associations (CP),
8354 Make_Pragma_Argument_Association (Sloc (Prag),
8356 Make_Identifier (Loc,
8358 Set_Pragma_Identifier (CP,
8359 Make_Identifier (Sloc (Prag),
8360 Chars => Name_Check));
8365 -- Start of processing for Process_PPCs
8368 -- Nothing to do if we are not generating code
8370 if Operating_Mode /= Generate_Code then
8374 -- Grab preconditions from spec
8376 if Present (Spec_Id) then
8378 -- Loop through PPC pragmas from spec. Note that preconditions from
8379 -- the body will be analyzed and converted when we scan the body
8380 -- declarations below.
8382 Prag := Spec_PPC_List (Spec_Id);
8383 while Present (Prag) loop
8384 if Pragma_Name (Prag) = Name_Precondition
8385 and then Pragma_Enabled (Prag)
8387 -- Add pragma Check at the start of the declarations of N.
8388 -- Note that this processing reverses the order of the list,
8389 -- which is what we want since new entries were chained to
8390 -- the head of the list.
8392 Prepend (Grab_PPC (Name_Precondition), Declarations (N));
8395 Prag := Next_Pragma (Prag);
8399 -- Build postconditions procedure if needed and prepend the following
8400 -- declaration to the start of the declarations for the subprogram.
8402 -- procedure _postconditions [(_Result : resulttype)] is
8404 -- pragma Check (Postcondition, condition [,message]);
8405 -- pragma Check (Postcondition, condition [,message]);
8409 -- First we deal with the postconditions in the body
8411 if Is_Non_Empty_List (Declarations (N)) then
8413 -- Loop through declarations
8415 Prag := First (Declarations (N));
8416 while Present (Prag) loop
8417 if Nkind (Prag) = N_Pragma then
8419 -- If pragma, capture if enabled postcondition, else ignore
8421 if Pragma_Name (Prag) = Name_Postcondition
8422 and then Check_Enabled (Name_Postcondition)
8424 if Plist = No_List then
8425 Plist := Empty_List;
8430 -- If expansion is disabled, as in a generic unit,
8431 -- save pragma for later expansion.
8433 if not Expander_Active then
8434 Prepend (Grab_PPC (Name_Postcondition), Declarations (N));
8436 Append (Grab_PPC (Name_Postcondition), Plist);
8442 -- Not a pragma, if comes from source, then end scan
8444 elsif Comes_From_Source (Prag) then
8447 -- Skip stuff not coming from source
8455 -- Now deal with any postconditions from the spec
8457 if Present (Spec_Id) then
8459 -- Loop through PPC pragmas from spec
8461 Prag := Spec_PPC_List (Spec_Id);
8462 while Present (Prag) loop
8463 if Pragma_Name (Prag) = Name_Postcondition
8464 and then Pragma_Enabled (Prag)
8466 if Plist = No_List then
8467 Plist := Empty_List;
8470 if not Expander_Active then
8471 Prepend (Grab_PPC (Name_Postcondition), Declarations (N));
8473 Append (Grab_PPC (Name_Postcondition), Plist);
8477 Prag := Next_Pragma (Prag);
8481 -- If we had any postconditions and expansion is enabled, build
8482 -- the _Postconditions procedure.
8485 and then Expander_Active
8487 Subp := Defining_Entity (N);
8489 if Etype (Subp) /= Standard_Void_Type then
8491 Make_Parameter_Specification (Loc,
8492 Defining_Identifier =>
8493 Make_Defining_Identifier (Loc,
8494 Chars => Name_uResult),
8495 Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
8501 Post_Proc : constant Entity_Id :=
8502 Make_Defining_Identifier (Loc,
8503 Chars => Name_uPostconditions);
8504 -- The entity for the _Postconditions procedure
8506 Prepend_To (Declarations (N),
8507 Make_Subprogram_Body (Loc,
8509 Make_Procedure_Specification (Loc,
8510 Defining_Unit_Name => Post_Proc,
8511 Parameter_Specifications => Parms),
8513 Declarations => Empty_List,
8515 Handled_Statement_Sequence =>
8516 Make_Handled_Sequence_Of_Statements (Loc,
8517 Statements => Plist)));
8519 -- If this is a procedure, set the Postcondition_Proc attribute on
8520 -- the proper defining entity for the subprogram.
8522 if Etype (Subp) = Standard_Void_Type then
8523 if Present (Spec_Id) then
8524 Set_Postcondition_Proc (Spec_Id, Post_Proc);
8526 Set_Postcondition_Proc (Body_Id, Post_Proc);
8531 if Present (Spec_Id) then
8532 Set_Has_Postconditions (Spec_Id);
8534 Set_Has_Postconditions (Body_Id);
8539 ----------------------------
8540 -- Reference_Body_Formals --
8541 ----------------------------
8543 procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is
8548 if Error_Posted (Spec) then
8552 -- Iterate over both lists. They may be of different lengths if the two
8553 -- specs are not conformant.
8555 Fs := First_Formal (Spec);
8556 Fb := First_Formal (Bod);
8557 while Present (Fs) and then Present (Fb) loop
8558 Generate_Reference (Fs, Fb, 'b');
8561 Style.Check_Identifier (Fb, Fs);
8564 Set_Spec_Entity (Fb, Fs);
8565 Set_Referenced (Fs, False);
8569 end Reference_Body_Formals;
8571 -------------------------
8572 -- Set_Actual_Subtypes --
8573 -------------------------
8575 procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
8576 Loc : constant Source_Ptr := Sloc (N);
8580 First_Stmt : Node_Id := Empty;
8581 AS_Needed : Boolean;
8584 -- If this is an empty initialization procedure, no need to create
8585 -- actual subtypes (small optimization).
8587 if Ekind (Subp) = E_Procedure
8588 and then Is_Null_Init_Proc (Subp)
8593 Formal := First_Formal (Subp);
8594 while Present (Formal) loop
8595 T := Etype (Formal);
8597 -- We never need an actual subtype for a constrained formal
8599 if Is_Constrained (T) then
8602 -- If we have unknown discriminants, then we do not need an actual
8603 -- subtype, or more accurately we cannot figure it out! Note that
8604 -- all class-wide types have unknown discriminants.
8606 elsif Has_Unknown_Discriminants (T) then
8609 -- At this stage we have an unconstrained type that may need an
8610 -- actual subtype. For sure the actual subtype is needed if we have
8611 -- an unconstrained array type.
8613 elsif Is_Array_Type (T) then
8616 -- The only other case needing an actual subtype is an unconstrained
8617 -- record type which is an IN parameter (we cannot generate actual
8618 -- subtypes for the OUT or IN OUT case, since an assignment can
8619 -- change the discriminant values. However we exclude the case of
8620 -- initialization procedures, since discriminants are handled very
8621 -- specially in this context, see the section entitled "Handling of
8622 -- Discriminants" in Einfo.
8624 -- We also exclude the case of Discrim_SO_Functions (functions used
8625 -- in front end layout mode for size/offset values), since in such
8626 -- functions only discriminants are referenced, and not only are such
8627 -- subtypes not needed, but they cannot always be generated, because
8628 -- of order of elaboration issues.
8630 elsif Is_Record_Type (T)
8631 and then Ekind (Formal) = E_In_Parameter
8632 and then Chars (Formal) /= Name_uInit
8633 and then not Is_Unchecked_Union (T)
8634 and then not Is_Discrim_SO_Function (Subp)
8638 -- All other cases do not need an actual subtype
8644 -- Generate actual subtypes for unconstrained arrays and
8645 -- unconstrained discriminated records.
8648 if Nkind (N) = N_Accept_Statement then
8650 -- If expansion is active, The formal is replaced by a local
8651 -- variable that renames the corresponding entry of the
8652 -- parameter block, and it is this local variable that may
8653 -- require an actual subtype.
8655 if Expander_Active then
8656 Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
8658 Decl := Build_Actual_Subtype (T, Formal);
8661 if Present (Handled_Statement_Sequence (N)) then
8663 First (Statements (Handled_Statement_Sequence (N)));
8664 Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
8665 Mark_Rewrite_Insertion (Decl);
8667 -- If the accept statement has no body, there will be no
8668 -- reference to the actuals, so no need to compute actual
8675 Decl := Build_Actual_Subtype (T, Formal);
8676 Prepend (Decl, Declarations (N));
8677 Mark_Rewrite_Insertion (Decl);
8680 -- The declaration uses the bounds of an existing object, and
8681 -- therefore needs no constraint checks.
8683 Analyze (Decl, Suppress => All_Checks);
8685 -- We need to freeze manually the generated type when it is
8686 -- inserted anywhere else than in a declarative part.
8688 if Present (First_Stmt) then
8689 Insert_List_Before_And_Analyze (First_Stmt,
8690 Freeze_Entity (Defining_Identifier (Decl), Loc));
8693 if Nkind (N) = N_Accept_Statement
8694 and then Expander_Active
8696 Set_Actual_Subtype (Renamed_Object (Formal),
8697 Defining_Identifier (Decl));
8699 Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
8703 Next_Formal (Formal);
8705 end Set_Actual_Subtypes;
8707 ---------------------
8708 -- Set_Formal_Mode --
8709 ---------------------
8711 procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
8712 Spec : constant Node_Id := Parent (Formal_Id);
8715 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
8716 -- since we ensure that corresponding actuals are always valid at the
8717 -- point of the call.
8719 if Out_Present (Spec) then
8720 if Ekind (Scope (Formal_Id)) = E_Function
8721 or else Ekind (Scope (Formal_Id)) = E_Generic_Function
8723 Error_Msg_N ("functions can only have IN parameters", Spec);
8724 Set_Ekind (Formal_Id, E_In_Parameter);
8726 elsif In_Present (Spec) then
8727 Set_Ekind (Formal_Id, E_In_Out_Parameter);
8730 Set_Ekind (Formal_Id, E_Out_Parameter);
8731 Set_Never_Set_In_Source (Formal_Id, True);
8732 Set_Is_True_Constant (Formal_Id, False);
8733 Set_Current_Value (Formal_Id, Empty);
8737 Set_Ekind (Formal_Id, E_In_Parameter);
8740 -- Set Is_Known_Non_Null for access parameters since the language
8741 -- guarantees that access parameters are always non-null. We also set
8742 -- Can_Never_Be_Null, since there is no way to change the value.
8744 if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
8746 -- Ada 2005 (AI-231): In Ada95, access parameters are always non-
8747 -- null; In Ada 2005, only if then null_exclusion is explicit.
8749 if Ada_Version < Ada_05
8750 or else Can_Never_Be_Null (Etype (Formal_Id))
8752 Set_Is_Known_Non_Null (Formal_Id);
8753 Set_Can_Never_Be_Null (Formal_Id);
8756 -- Ada 2005 (AI-231): Null-exclusion access subtype
8758 elsif Is_Access_Type (Etype (Formal_Id))
8759 and then Can_Never_Be_Null (Etype (Formal_Id))
8761 Set_Is_Known_Non_Null (Formal_Id);
8764 Set_Mechanism (Formal_Id, Default_Mechanism);
8765 Set_Formal_Validity (Formal_Id);
8766 end Set_Formal_Mode;
8768 -------------------------
8769 -- Set_Formal_Validity --
8770 -------------------------
8772 procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
8774 -- If no validity checking, then we cannot assume anything about the
8775 -- validity of parameters, since we do not know there is any checking
8776 -- of the validity on the call side.
8778 if not Validity_Checks_On then
8781 -- If validity checking for parameters is enabled, this means we are
8782 -- not supposed to make any assumptions about argument values.
8784 elsif Validity_Check_Parameters then
8787 -- If we are checking in parameters, we will assume that the caller is
8788 -- also checking parameters, so we can assume the parameter is valid.
8790 elsif Ekind (Formal_Id) = E_In_Parameter
8791 and then Validity_Check_In_Params
8793 Set_Is_Known_Valid (Formal_Id, True);
8795 -- Similar treatment for IN OUT parameters
8797 elsif Ekind (Formal_Id) = E_In_Out_Parameter
8798 and then Validity_Check_In_Out_Params
8800 Set_Is_Known_Valid (Formal_Id, True);
8802 end Set_Formal_Validity;
8804 ------------------------
8805 -- Subtype_Conformant --
8806 ------------------------
8808 function Subtype_Conformant
8809 (New_Id : Entity_Id;
8811 Skip_Controlling_Formals : Boolean := False) return Boolean
8815 Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result,
8816 Skip_Controlling_Formals => Skip_Controlling_Formals);
8818 end Subtype_Conformant;
8820 ---------------------
8821 -- Type_Conformant --
8822 ---------------------
8824 function Type_Conformant
8825 (New_Id : Entity_Id;
8827 Skip_Controlling_Formals : Boolean := False) return Boolean
8831 May_Hide_Profile := False;
8834 (New_Id, Old_Id, Type_Conformant, False, Result,
8835 Skip_Controlling_Formals => Skip_Controlling_Formals);
8837 end Type_Conformant;
8839 -------------------------------
8840 -- Valid_Operator_Definition --
8841 -------------------------------
8843 procedure Valid_Operator_Definition (Designator : Entity_Id) is
8846 Id : constant Name_Id := Chars (Designator);
8850 F := First_Formal (Designator);
8851 while Present (F) loop
8854 if Present (Default_Value (F)) then
8856 ("default values not allowed for operator parameters",
8863 -- Verify that user-defined operators have proper number of arguments
8864 -- First case of operators which can only be unary
8867 or else Id = Name_Op_Abs
8871 -- Case of operators which can be unary or binary
8873 elsif Id = Name_Op_Add
8874 or Id = Name_Op_Subtract
8876 N_OK := (N in 1 .. 2);
8878 -- All other operators can only be binary
8886 ("incorrect number of arguments for operator", Designator);
8890 and then Base_Type (Etype (Designator)) = Standard_Boolean
8891 and then not Is_Intrinsic_Subprogram (Designator)
8894 ("explicit definition of inequality not allowed", Designator);
8896 end Valid_Operator_Definition;
OSDN Git Service
