1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Expander; use Expander;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch7; use Exp_Ch7;
36 with Exp_Tss; use Exp_Tss;
37 with Exp_Util; use Exp_Util;
38 with Fname; use Fname;
39 with Freeze; use Freeze;
40 with Itypes; use Itypes;
41 with Lib.Xref; use Lib.Xref;
42 with Layout; use Layout;
43 with Namet; use Namet;
45 with Nlists; use Nlists;
46 with Nmake; use Nmake;
48 with Output; use Output;
49 with Rtsfind; use Rtsfind;
51 with Sem_Cat; use Sem_Cat;
52 with Sem_Ch3; use Sem_Ch3;
53 with Sem_Ch4; use Sem_Ch4;
54 with Sem_Ch5; use Sem_Ch5;
55 with Sem_Ch8; use Sem_Ch8;
56 with Sem_Ch10; use Sem_Ch10;
57 with Sem_Ch12; use Sem_Ch12;
58 with Sem_Disp; use Sem_Disp;
59 with Sem_Dist; use Sem_Dist;
60 with Sem_Elim; use Sem_Elim;
61 with Sem_Eval; use Sem_Eval;
62 with Sem_Mech; use Sem_Mech;
63 with Sem_Prag; use Sem_Prag;
64 with Sem_Res; use Sem_Res;
65 with Sem_Util; use Sem_Util;
66 with Sem_Type; use Sem_Type;
67 with Sem_Warn; use Sem_Warn;
68 with Sinput; use Sinput;
69 with Stand; use Stand;
70 with Sinfo; use Sinfo;
71 with Sinfo.CN; use Sinfo.CN;
72 with Snames; use Snames;
73 with Stringt; use Stringt;
75 with Stylesw; use Stylesw;
76 with Tbuild; use Tbuild;
77 with Uintp; use Uintp;
78 with Urealp; use Urealp;
79 with Validsw; use Validsw;
81 package body Sem_Ch6 is
83 Enable_New_Return_Processing : constant Boolean := True;
84 -- ??? This flag is temporary. False causes the compiler to use the old
85 -- version of Analyze_Return_Statement; True, the new version, which does
86 -- not yet work. You probably want this to match the corresponding thing
89 May_Hide_Profile : Boolean := False;
90 -- This flag is used to indicate that two formals in two subprograms being
91 -- checked for conformance differ only in that one is an access parameter
92 -- while the other is of a general access type with the same designated
93 -- type. In this case, if the rest of the signatures match, a call to
94 -- either subprogram may be ambiguous, which is worth a warning. The flag
95 -- is set in Compatible_Types, and the warning emitted in
96 -- New_Overloaded_Entity.
98 -----------------------
99 -- Local Subprograms --
100 -----------------------
102 procedure Analyze_A_Return_Statement (N : Node_Id);
103 -- Common processing for simple_ and extended_return_statements
105 procedure Analyze_Function_Return (N : Node_Id);
106 -- Subsidiary to Analyze_A_Return_Statement.
107 -- Called when the return statement applies to a [generic] function.
109 procedure Analyze_Return_Type (N : Node_Id);
110 -- Subsidiary to Process_Formals: analyze subtype mark in function
111 -- specification, in a context where the formals are visible and hide
114 procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
115 -- Analyze a generic subprogram body. N is the body to be analyzed, and
116 -- Gen_Id is the defining entity Id for the corresponding spec.
118 procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
119 -- If a subprogram has pragma Inline and inlining is active, use generic
120 -- machinery to build an unexpanded body for the subprogram. This body is
121 -- subsequenty used for inline expansions at call sites. If subprogram can
122 -- be inlined (depending on size and nature of local declarations) this
123 -- function returns true. Otherwise subprogram body is treated normally.
124 -- If proper warnings are enabled and the subprogram contains a construct
125 -- that cannot be inlined, the offending construct is flagged accordingly.
127 procedure Check_Conformance
130 Ctype : Conformance_Type;
132 Conforms : out Boolean;
133 Err_Loc : Node_Id := Empty;
134 Get_Inst : Boolean := False;
135 Skip_Controlling_Formals : Boolean := False);
136 -- Given two entities, this procedure checks that the profiles associated
137 -- with these entities meet the conformance criterion given by the third
138 -- parameter. If they conform, Conforms is set True and control returns
139 -- to the caller. If they do not conform, Conforms is set to False, and
140 -- in addition, if Errmsg is True on the call, proper messages are output
141 -- to complain about the conformance failure. If Err_Loc is non_Empty
142 -- the error messages are placed on Err_Loc, if Err_Loc is empty, then
143 -- error messages are placed on the appropriate part of the construct
144 -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance
145 -- against a formal access-to-subprogram type so Get_Instance_Of must
148 procedure Check_Overriding_Indicator
150 Overridden_Subp : Entity_Id := Empty);
151 -- Verify the consistency of an overriding_indicator given for subprogram
152 -- declaration, body, renaming, or instantiation. Overridden_Subp is set
153 -- if the scope into which we are introducing the subprogram contains a
154 -- type-conformant subprogram that becomes hidden by the new subprogram.
156 procedure Check_Subprogram_Order (N : Node_Id);
157 -- N is the N_Subprogram_Body node for a subprogram. This routine applies
158 -- the alpha ordering rule for N if this ordering requirement applicable.
160 procedure Check_Returns
164 Proc : Entity_Id := Empty);
165 -- Called to check for missing return statements in a function body, or for
166 -- returns present in a procedure body which has No_Return set. L is the
167 -- handled statement sequence for the subprogram body. This procedure
168 -- checks all flow paths to make sure they either have return (Mode = 'F',
169 -- used for functions) or do not have a return (Mode = 'P', used for
170 -- No_Return procedures). The flag Err is set if there are any control
171 -- paths not explicitly terminated by a return in the function case, and is
172 -- True otherwise. Proc is the entity for the procedure case and is used
173 -- in posting the warning message.
175 procedure Enter_Overloaded_Entity (S : Entity_Id);
176 -- This procedure makes S, a new overloaded entity, into the first visible
177 -- entity with that name.
179 procedure Install_Entity (E : Entity_Id);
180 -- Make single entity visible. Used for generic formals as well
182 procedure Install_Formals (Id : Entity_Id);
183 -- On entry to a subprogram body, make the formals visible. Note that
184 -- simply placing the subprogram on the scope stack is not sufficient:
185 -- the formals must become the current entities for their names.
187 function Is_Non_Overriding_Operation
189 New_E : Entity_Id) return Boolean;
190 -- Enforce the rule given in 12.3(18): a private operation in an instance
191 -- overrides an inherited operation only if the corresponding operation
192 -- was overriding in the generic. This can happen for primitive operations
193 -- of types derived (in the generic unit) from formal private or formal
196 procedure Make_Inequality_Operator (S : Entity_Id);
197 -- Create the declaration for an inequality operator that is implicitly
198 -- created by a user-defined equality operator that yields a boolean.
200 procedure May_Need_Actuals (Fun : Entity_Id);
201 -- Flag functions that can be called without parameters, i.e. those that
202 -- have no parameters, or those for which defaults exist for all parameters
204 procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id);
205 -- If there is a separate spec for a subprogram or generic subprogram, the
206 -- formals of the body are treated as references to the corresponding
207 -- formals of the spec. This reference does not count as an actual use of
208 -- the formal, in order to diagnose formals that are unused in the body.
210 procedure Set_Formal_Validity (Formal_Id : Entity_Id);
211 -- Formal_Id is an formal parameter entity. This procedure deals with
212 -- setting the proper validity status for this entity, which depends
213 -- on the kind of parameter and the validity checking mode.
215 --------------------------------
216 -- Analyze_A_Return_Statement --
217 --------------------------------
219 procedure Analyze_A_Return_Statement (N : Node_Id) is
220 -- ???This should be called Analyze_Return_Statement, and
221 -- Analyze_Return_Statement should be called
222 -- Analyze_Simple_Return_Statement!
224 pragma Assert (Nkind (N) = N_Return_Statement
225 or else Nkind (N) = N_Extended_Return_Statement);
227 Returns_Object : constant Boolean :=
228 Nkind (N) = N_Extended_Return_Statement
230 (Nkind (N) = N_Return_Statement and then Present (Expression (N)));
232 -- True if we're returning something; that is, "return <expression>;"
233 -- or "return Result : T [:= ...]". False for "return;".
234 -- Used for error checking: If Returns_Object is True, N should apply
235 -- to a function body; otherwise N should apply to a procedure body,
236 -- entry body, accept statement, or extended return statement.
238 function Find_What_It_Applies_To return Entity_Id;
239 -- Find the entity representing the innermost enclosing body, accept
240 -- statement, or extended return statement. If the result is a
241 -- callable construct or extended return statement, then this will be
242 -- the value of the Return_Applies_To attribute. Otherwise, the program
243 -- is illegal. See RM-6.5(4/2). I am disinclined to call this
244 -- Find_The_Construct_To_Which_This_Return_Statement_Applies. ;-)
246 -----------------------------
247 -- Find_What_It_Applies_To --
248 -----------------------------
250 function Find_What_It_Applies_To return Entity_Id is
251 Result : Entity_Id := Empty;
254 -- Loop outward through the Scope_Stack, skipping blocks and loops
256 for J in reverse 0 .. Scope_Stack.Last loop
257 Result := Scope_Stack.Table (J).Entity;
258 exit when Ekind (Result) /= E_Block and then
259 Ekind (Result) /= E_Loop;
262 pragma Assert (Present (Result));
265 end Find_What_It_Applies_To;
267 Scope_Id : constant Entity_Id := Find_What_It_Applies_To;
268 Kind : constant Entity_Kind := Ekind (Scope_Id);
270 Loc : constant Source_Ptr := Sloc (N);
271 Stm_Entity : constant Entity_Id :=
273 (E_Return_Statement, Current_Scope, Loc, 'R');
275 -- Start of processing for Analyze_A_Return_Statement
279 Set_Return_Statement_Entity (N, Stm_Entity);
281 Set_Etype (Stm_Entity, Standard_Void_Type);
282 Set_Return_Applies_To (Stm_Entity, Scope_Id);
284 -- Place the Return entity on scope stack, to simplify enforcement
285 -- of 6.5 (4/2): an inner return statement will apply to this extended
288 if Nkind (N) = N_Extended_Return_Statement then
289 New_Scope (Stm_Entity);
292 -- Check that pragma No_Return is obeyed:
294 if No_Return (Scope_Id) then
295 Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
298 -- Check that functions return objects, and other things do not:
300 if Kind = E_Function or else Kind = E_Generic_Function then
301 if not Returns_Object then
302 Error_Msg_N ("missing expression in return from function", N);
305 elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
306 if Returns_Object then
307 Error_Msg_N ("procedure cannot return value (use function)", N);
310 elsif Kind = E_Entry or else Kind = E_Entry_Family then
311 if Returns_Object then
312 if Is_Protected_Type (Scope (Scope_Id)) then
313 Error_Msg_N ("entry body cannot return value", N);
315 Error_Msg_N ("accept statement cannot return value", N);
319 elsif Kind = E_Return_Statement then
321 -- We are nested within another return statement, which must be an
322 -- extended_return_statement.
324 if Returns_Object then
326 ("extended_return_statement cannot return value; " &
327 "use `""RETURN;""`", N);
331 Error_Msg_N ("illegal context for return statement", N);
334 if Kind = E_Function or else Kind = E_Generic_Function then
335 Analyze_Function_Return (N);
338 if Nkind (N) = N_Extended_Return_Statement then
342 Check_Unreachable_Code (N);
343 end Analyze_A_Return_Statement;
345 ---------------------------------------------
346 -- Analyze_Abstract_Subprogram_Declaration --
347 ---------------------------------------------
349 procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
350 Designator : constant Entity_Id :=
351 Analyze_Subprogram_Specification (Specification (N));
352 Scop : constant Entity_Id := Current_Scope;
355 Generate_Definition (Designator);
356 Set_Is_Abstract_Subprogram (Designator);
357 New_Overloaded_Entity (Designator);
358 Check_Delayed_Subprogram (Designator);
360 Set_Categorization_From_Scope (Designator, Scop);
362 if Ekind (Scope (Designator)) = E_Protected_Type then
364 ("abstract subprogram not allowed in protected type", N);
367 Generate_Reference_To_Formals (Designator);
368 end Analyze_Abstract_Subprogram_Declaration;
370 ----------------------------------------
371 -- Analyze_Extended_Return_Statement --
372 ----------------------------------------
374 procedure Analyze_Extended_Return_Statement (N : Node_Id) is
376 Analyze_A_Return_Statement (N);
377 end Analyze_Extended_Return_Statement;
379 ----------------------------
380 -- Analyze_Function_Call --
381 ----------------------------
383 procedure Analyze_Function_Call (N : Node_Id) is
384 P : constant Node_Id := Name (N);
385 L : constant List_Id := Parameter_Associations (N);
391 -- A call of the form A.B (X) may be an Ada05 call, which is rewritten
392 -- as B (A, X). If the rewriting is successful, the call has been
393 -- analyzed and we just return.
395 if Nkind (P) = N_Selected_Component
396 and then Name (N) /= P
397 and then Is_Rewrite_Substitution (N)
398 and then Present (Etype (N))
403 -- If error analyzing name, then set Any_Type as result type and return
405 if Etype (P) = Any_Type then
406 Set_Etype (N, Any_Type);
410 -- Otherwise analyze the parameters
414 while Present (Actual) loop
416 Check_Parameterless_Call (Actual);
422 end Analyze_Function_Call;
424 -----------------------------
425 -- Analyze_Function_Return --
426 -----------------------------
428 procedure Analyze_Function_Return (N : Node_Id) is
429 Loc : constant Source_Ptr := Sloc (N);
430 Stm_Entity : constant Entity_Id := Return_Statement_Entity (N);
431 Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity);
433 R_Type : constant Entity_Id := Etype (Scope_Id);
434 -- Function result subtype
436 procedure Check_Limited_Return (Expr : Node_Id);
437 -- Check the appropriate (Ada 95 or Ada 2005) rules for returning
438 -- limited types. Used only for simple return statements.
439 -- Expr is the expression returned.
441 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
442 -- Check that the return_subtype_indication properly matches the result
443 -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
445 --------------------------
446 -- Check_Limited_Return --
447 --------------------------
449 procedure Check_Limited_Return (Expr : Node_Id) is
451 -- Ada 2005 (AI-318-02): Return-by-reference types have been
452 -- removed and replaced by anonymous access results. This is an
453 -- incompatibility with Ada 95. Not clear whether this should be
454 -- enforced yet or perhaps controllable with special switch. ???
456 if Is_Limited_Type (R_Type)
457 and then Comes_From_Source (N)
458 and then not In_Instance_Body
459 and then not OK_For_Limited_Init_In_05 (Expr)
463 if Ada_Version >= Ada_05
464 and then not Debug_Flag_Dot_L
465 and then not GNAT_Mode
468 ("(Ada 2005) cannot copy object of a limited type " &
469 "('R'M'-2005 6.5(5.5/2))", Expr);
470 if Is_Inherently_Limited_Type (R_Type) then
472 ("\return by reference not permitted in Ada 2005", Expr);
475 -- Warn in Ada 95 mode, to give folks a heads up about this
478 -- In GNAT mode, this is just a warning, to allow it to be
479 -- evilly turned off. Otherwise it is a real error.
481 elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
482 if Is_Inherently_Limited_Type (R_Type) then
484 ("return by reference not permitted in Ada 2005 " &
485 "('R'M'-2005 6.5(5.5/2))?", Expr);
488 ("cannot copy object of a limited type in Ada 2005 " &
489 "('R'M'-2005 6.5(5.5/2))?", Expr);
492 -- Ada 95 mode, compatibility warnings disabled
495 return; -- skip continuation messages below
499 ("\consider switching to return of access type", Expr);
500 Explain_Limited_Type (R_Type, Expr);
502 end Check_Limited_Return;
504 -------------------------------------
505 -- Check_Return_Subtype_Indication --
506 -------------------------------------
508 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is
509 Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl);
510 R_Stm_Type : constant Entity_Id := Etype (Return_Obj);
511 -- Subtype given in the extended return statement;
512 -- this must match R_Type.
514 Subtype_Ind : constant Node_Id :=
515 Object_Definition (Original_Node (Obj_Decl));
517 R_Type_Is_Anon_Access :
519 Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
521 Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
523 Ekind (R_Type) = E_Anonymous_Access_Type;
524 -- True if return type of the function is an anonymous access type
525 -- Can't we make Is_Anonymous_Access_Type in einfo ???
527 R_Stm_Type_Is_Anon_Access :
529 Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
531 Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
533 Ekind (R_Type) = E_Anonymous_Access_Type;
534 -- True if type of the return object is an anonymous access type
537 -- First, avoid cascade errors:
539 if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then
543 -- "return access T" case; check that the return statement also has
544 -- "access T", and that the subtypes statically match:
546 if R_Type_Is_Anon_Access then
547 if R_Stm_Type_Is_Anon_Access then
548 if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
550 ("subtypes must statically match", Subtype_Ind);
553 Error_Msg_N ("must use anonymous access type", Subtype_Ind);
556 -- Subtype_indication case; check that the types are the same, and
557 -- statically match if appropriate:
559 elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) then
560 if Is_Constrained (R_Type) then
561 if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
563 ("subtypes must statically match", Subtype_Ind);
569 ("wrong type for return_subtype_indication", Subtype_Ind);
571 end Check_Return_Subtype_Indication;
573 ---------------------
574 -- Local Variables --
575 ---------------------
579 -- Start of processing for Analyze_Function_Return
582 Set_Return_Present (Scope_Id);
584 if Nkind (N) = N_Return_Statement then
585 Expr := Expression (N);
586 Analyze_And_Resolve (Expr, R_Type);
587 Check_Limited_Return (Expr);
590 -- Analyze parts specific to extended_return_statement:
593 Obj_Decl : constant Node_Id :=
594 Last (Return_Object_Declarations (N));
596 HSS : constant Node_Id := Handled_Statement_Sequence (N);
599 Expr := Expression (Obj_Decl);
601 -- Note: The check for OK_For_Limited_Init will happen in
602 -- Analyze_Object_Declaration; we treat it as a normal
603 -- object declaration.
607 Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
608 Check_Return_Subtype_Indication (Obj_Decl);
610 if Present (HSS) then
613 if Present (Exception_Handlers (HSS)) then
615 -- ???Has_Nested_Block_With_Handler needs to be set.
616 -- Probably by creating an actual N_Block_Statement.
617 -- Probably in Expand.
623 Check_References (Stm_Entity);
628 and then Present (Etype (Expr)) -- Could be False in case of errors.
630 -- Ada 2005 (AI-318-02): When the result type is an anonymous
631 -- access type, apply an implicit conversion of the expression
632 -- to that type to force appropriate static and run-time
633 -- accessibility checks.
635 if Ada_Version >= Ada_05
636 and then Ekind (R_Type) = E_Anonymous_Access_Type
638 Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
639 Analyze_And_Resolve (Expr, R_Type);
642 if (Is_Class_Wide_Type (Etype (Expr))
643 or else Is_Dynamically_Tagged (Expr))
644 and then not Is_Class_Wide_Type (R_Type)
647 ("dynamically tagged expression not allowed!", Expr);
650 Apply_Constraint_Check (Expr, R_Type);
652 -- ??? A real run-time accessibility check is needed in cases
653 -- involving dereferences of access parameters. For now we just
654 -- check the static cases.
656 if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L)
657 and then Is_Inherently_Limited_Type (Etype (Scope_Id))
658 and then Object_Access_Level (Expr) >
659 Subprogram_Access_Level (Scope_Id)
662 Make_Raise_Program_Error (Loc,
663 Reason => PE_Accessibility_Check_Failed));
667 ("cannot return a local value by reference?", N);
669 ("\& will be raised at run time?",
670 N, Standard_Program_Error);
673 end Analyze_Function_Return;
675 -------------------------------------
676 -- Analyze_Generic_Subprogram_Body --
677 -------------------------------------
679 procedure Analyze_Generic_Subprogram_Body
683 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id);
684 Kind : constant Entity_Kind := Ekind (Gen_Id);
690 -- Copy body and disable expansion while analyzing the generic For a
691 -- stub, do not copy the stub (which would load the proper body), this
692 -- will be done when the proper body is analyzed.
694 if Nkind (N) /= N_Subprogram_Body_Stub then
695 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
700 Spec := Specification (N);
702 -- Within the body of the generic, the subprogram is callable, and
703 -- behaves like the corresponding non-generic unit.
705 Body_Id := Defining_Entity (Spec);
707 if Kind = E_Generic_Procedure
708 and then Nkind (Spec) /= N_Procedure_Specification
710 Error_Msg_N ("invalid body for generic procedure ", Body_Id);
713 elsif Kind = E_Generic_Function
714 and then Nkind (Spec) /= N_Function_Specification
716 Error_Msg_N ("invalid body for generic function ", Body_Id);
720 Set_Corresponding_Body (Gen_Decl, Body_Id);
722 if Has_Completion (Gen_Id)
723 and then Nkind (Parent (N)) /= N_Subunit
725 Error_Msg_N ("duplicate generic body", N);
728 Set_Has_Completion (Gen_Id);
731 if Nkind (N) = N_Subprogram_Body_Stub then
732 Set_Ekind (Defining_Entity (Specification (N)), Kind);
734 Set_Corresponding_Spec (N, Gen_Id);
737 if Nkind (Parent (N)) = N_Compilation_Unit then
738 Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
741 -- Make generic parameters immediately visible in the body. They are
742 -- needed to process the formals declarations. Then make the formals
743 -- visible in a separate step.
749 First_Ent : Entity_Id;
752 First_Ent := First_Entity (Gen_Id);
755 while Present (E) and then not Is_Formal (E) loop
760 Set_Use (Generic_Formal_Declarations (Gen_Decl));
762 -- Now generic formals are visible, and the specification can be
763 -- analyzed, for subsequent conformance check.
765 Body_Id := Analyze_Subprogram_Specification (Spec);
767 -- Make formal parameters visible
771 -- E is the first formal parameter, we loop through the formals
772 -- installing them so that they will be visible.
774 Set_First_Entity (Gen_Id, E);
775 while Present (E) loop
781 -- Visible generic entity is callable within its own body
783 Set_Ekind (Gen_Id, Ekind (Body_Id));
784 Set_Ekind (Body_Id, E_Subprogram_Body);
785 Set_Convention (Body_Id, Convention (Gen_Id));
786 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
787 Set_Scope (Body_Id, Scope (Gen_Id));
788 Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
790 if Nkind (N) = N_Subprogram_Body_Stub then
792 -- No body to analyze, so restore state of generic unit
794 Set_Ekind (Gen_Id, Kind);
795 Set_Ekind (Body_Id, Kind);
797 if Present (First_Ent) then
798 Set_First_Entity (Gen_Id, First_Ent);
805 -- If this is a compilation unit, it must be made visible explicitly,
806 -- because the compilation of the declaration, unlike other library
807 -- unit declarations, does not. If it is not a unit, the following
808 -- is redundant but harmless.
810 Set_Is_Immediately_Visible (Gen_Id);
811 Reference_Body_Formals (Gen_Id, Body_Id);
813 if Is_Child_Unit (Gen_Id) then
814 Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False);
817 Set_Actual_Subtypes (N, Current_Scope);
818 Analyze_Declarations (Declarations (N));
820 Analyze (Handled_Statement_Sequence (N));
822 Save_Global_References (Original_Node (N));
824 -- Prior to exiting the scope, include generic formals again (if any
825 -- are present) in the set of local entities.
827 if Present (First_Ent) then
828 Set_First_Entity (Gen_Id, First_Ent);
831 Check_References (Gen_Id);
834 Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
836 Check_Subprogram_Order (N);
838 -- Outside of its body, unit is generic again
840 Set_Ekind (Gen_Id, Kind);
841 Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
842 Style.Check_Identifier (Body_Id, Gen_Id);
844 end Analyze_Generic_Subprogram_Body;
846 -----------------------------
847 -- Analyze_Operator_Symbol --
848 -----------------------------
850 -- An operator symbol such as "+" or "and" may appear in context where the
851 -- literal denotes an entity name, such as "+"(x, y) or in context when it
852 -- is just a string, as in (conjunction = "or"). In these cases the parser
853 -- generates this node, and the semantics does the disambiguation. Other
854 -- such case are actuals in an instantiation, the generic unit in an
855 -- instantiation, and pragma arguments.
857 procedure Analyze_Operator_Symbol (N : Node_Id) is
858 Par : constant Node_Id := Parent (N);
861 if (Nkind (Par) = N_Function_Call and then N = Name (Par))
862 or else Nkind (Par) = N_Function_Instantiation
863 or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
864 or else (Nkind (Par) = N_Pragma_Argument_Association
865 and then not Is_Pragma_String_Literal (Par))
866 or else Nkind (Par) = N_Subprogram_Renaming_Declaration
867 or else (Nkind (Par) = N_Attribute_Reference
868 and then Attribute_Name (Par) /= Name_Value)
870 Find_Direct_Name (N);
873 Change_Operator_Symbol_To_String_Literal (N);
876 end Analyze_Operator_Symbol;
878 -----------------------------------
879 -- Analyze_Parameter_Association --
880 -----------------------------------
882 procedure Analyze_Parameter_Association (N : Node_Id) is
884 Analyze (Explicit_Actual_Parameter (N));
885 end Analyze_Parameter_Association;
887 ----------------------------
888 -- Analyze_Procedure_Call --
889 ----------------------------
891 procedure Analyze_Procedure_Call (N : Node_Id) is
892 Loc : constant Source_Ptr := Sloc (N);
893 P : constant Node_Id := Name (N);
894 Actuals : constant List_Id := Parameter_Associations (N);
898 procedure Analyze_Call_And_Resolve;
899 -- Do Analyze and Resolve calls for procedure call
901 ------------------------------
902 -- Analyze_Call_And_Resolve --
903 ------------------------------
905 procedure Analyze_Call_And_Resolve is
907 if Nkind (N) = N_Procedure_Call_Statement then
909 Resolve (N, Standard_Void_Type);
913 end Analyze_Call_And_Resolve;
915 -- Start of processing for Analyze_Procedure_Call
918 -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
919 -- a procedure call or an entry call. The prefix may denote an access
920 -- to subprogram type, in which case an implicit dereference applies.
921 -- If the prefix is an indexed component (without implicit defererence)
922 -- then the construct denotes a call to a member of an entire family.
923 -- If the prefix is a simple name, it may still denote a call to a
924 -- parameterless member of an entry family. Resolution of these various
925 -- interpretations is delicate.
929 -- If this is a call of the form Obj.Op, the call may have been
930 -- analyzed and possibly rewritten into a block, in which case
937 -- If error analyzing prefix, then set Any_Type as result and return
939 if Etype (P) = Any_Type then
940 Set_Etype (N, Any_Type);
944 -- Otherwise analyze the parameters
946 if Present (Actuals) then
947 Actual := First (Actuals);
949 while Present (Actual) loop
951 Check_Parameterless_Call (Actual);
956 -- Special processing for Elab_Spec and Elab_Body calls
958 if Nkind (P) = N_Attribute_Reference
959 and then (Attribute_Name (P) = Name_Elab_Spec
960 or else Attribute_Name (P) = Name_Elab_Body)
962 if Present (Actuals) then
964 ("no parameters allowed for this call", First (Actuals));
968 Set_Etype (N, Standard_Void_Type);
971 elsif Is_Entity_Name (P)
972 and then Is_Record_Type (Etype (Entity (P)))
973 and then Remote_AST_I_Dereference (P)
977 elsif Is_Entity_Name (P)
978 and then Ekind (Entity (P)) /= E_Entry_Family
980 if Is_Access_Type (Etype (P))
981 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
982 and then No (Actuals)
983 and then Comes_From_Source (N)
985 Error_Msg_N ("missing explicit dereference in call", N);
988 Analyze_Call_And_Resolve;
990 -- If the prefix is the simple name of an entry family, this is
991 -- a parameterless call from within the task body itself.
993 elsif Is_Entity_Name (P)
994 and then Nkind (P) = N_Identifier
995 and then Ekind (Entity (P)) = E_Entry_Family
996 and then Present (Actuals)
997 and then No (Next (First (Actuals)))
999 -- Can be call to parameterless entry family. What appears to be the
1000 -- sole argument is in fact the entry index. Rewrite prefix of node
1001 -- accordingly. Source representation is unchanged by this
1005 Make_Indexed_Component (Loc,
1007 Make_Selected_Component (Loc,
1008 Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
1009 Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
1010 Expressions => Actuals);
1011 Set_Name (N, New_N);
1012 Set_Etype (New_N, Standard_Void_Type);
1013 Set_Parameter_Associations (N, No_List);
1014 Analyze_Call_And_Resolve;
1016 elsif Nkind (P) = N_Explicit_Dereference then
1017 if Ekind (Etype (P)) = E_Subprogram_Type then
1018 Analyze_Call_And_Resolve;
1020 Error_Msg_N ("expect access to procedure in call", P);
1023 -- The name can be a selected component or an indexed component that
1024 -- yields an access to subprogram. Such a prefix is legal if the call
1025 -- has parameter associations.
1027 elsif Is_Access_Type (Etype (P))
1028 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1030 if Present (Actuals) then
1031 Analyze_Call_And_Resolve;
1033 Error_Msg_N ("missing explicit dereference in call ", N);
1036 -- If not an access to subprogram, then the prefix must resolve to the
1037 -- name of an entry, entry family, or protected operation.
1039 -- For the case of a simple entry call, P is a selected component where
1040 -- the prefix is the task and the selector name is the entry. A call to
1041 -- a protected procedure will have the same syntax. If the protected
1042 -- object contains overloaded operations, the entity may appear as a
1043 -- function, the context will select the operation whose type is Void.
1045 elsif Nkind (P) = N_Selected_Component
1046 and then (Ekind (Entity (Selector_Name (P))) = E_Entry
1048 Ekind (Entity (Selector_Name (P))) = E_Procedure
1050 Ekind (Entity (Selector_Name (P))) = E_Function)
1052 Analyze_Call_And_Resolve;
1054 elsif Nkind (P) = N_Selected_Component
1055 and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
1056 and then Present (Actuals)
1057 and then No (Next (First (Actuals)))
1059 -- Can be call to parameterless entry family. What appears to be the
1060 -- sole argument is in fact the entry index. Rewrite prefix of node
1061 -- accordingly. Source representation is unchanged by this
1065 Make_Indexed_Component (Loc,
1066 Prefix => New_Copy (P),
1067 Expressions => Actuals);
1068 Set_Name (N, New_N);
1069 Set_Etype (New_N, Standard_Void_Type);
1070 Set_Parameter_Associations (N, No_List);
1071 Analyze_Call_And_Resolve;
1073 -- For the case of a reference to an element of an entry family, P is
1074 -- an indexed component whose prefix is a selected component (task and
1075 -- entry family), and whose index is the entry family index.
1077 elsif Nkind (P) = N_Indexed_Component
1078 and then Nkind (Prefix (P)) = N_Selected_Component
1079 and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
1081 Analyze_Call_And_Resolve;
1083 -- If the prefix is the name of an entry family, it is a call from
1084 -- within the task body itself.
1086 elsif Nkind (P) = N_Indexed_Component
1087 and then Nkind (Prefix (P)) = N_Identifier
1088 and then Ekind (Entity (Prefix (P))) = E_Entry_Family
1091 Make_Selected_Component (Loc,
1092 Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
1093 Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
1094 Rewrite (Prefix (P), New_N);
1096 Analyze_Call_And_Resolve;
1098 -- Anything else is an error
1101 Error_Msg_N ("invalid procedure or entry call", N);
1103 end Analyze_Procedure_Call;
1105 ------------------------------
1106 -- Analyze_Return_Statement --
1107 ------------------------------
1109 procedure Analyze_Return_Statement (N : Node_Id) is
1110 Loc : constant Source_Ptr := Sloc (N);
1112 Scope_Id : Entity_Id;
1116 Stm_Entity : constant Entity_Id :=
1118 (E_Return_Statement, Current_Scope, Loc, 'R');
1121 if Enable_New_Return_Processing then -- ???Temporary hack.
1122 Analyze_A_Return_Statement (N);
1126 -- Find subprogram or accept statement enclosing the return statement
1129 for J in reverse 0 .. Scope_Stack.Last loop
1130 Scope_Id := Scope_Stack.Table (J).Entity;
1131 exit when Ekind (Scope_Id) /= E_Block and then
1132 Ekind (Scope_Id) /= E_Loop;
1135 pragma Assert (Present (Scope_Id));
1137 Set_Return_Statement_Entity (N, Stm_Entity);
1138 Set_Return_Applies_To (Stm_Entity, Scope_Id);
1140 Kind := Ekind (Scope_Id);
1141 Expr := Expression (N);
1143 if Kind /= E_Function
1144 and then Kind /= E_Generic_Function
1145 and then Kind /= E_Procedure
1146 and then Kind /= E_Generic_Procedure
1147 and then Kind /= E_Entry
1148 and then Kind /= E_Entry_Family
1150 Error_Msg_N ("illegal context for return statement", N);
1152 elsif Present (Expr) then
1153 if Kind = E_Function or else Kind = E_Generic_Function then
1154 Set_Return_Present (Scope_Id);
1155 R_Type := Etype (Scope_Id);
1156 Analyze_And_Resolve (Expr, R_Type);
1158 -- Ada 2005 (AI-318-02): When the result type is an anonymous
1159 -- access type, apply an implicit conversion of the expression
1160 -- to that type to force appropriate static and run-time
1161 -- accessibility checks.
1163 if Ada_Version >= Ada_05
1164 and then Ekind (R_Type) = E_Anonymous_Access_Type
1166 Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
1167 Analyze_And_Resolve (Expr, R_Type);
1170 if (Is_Class_Wide_Type (Etype (Expr))
1171 or else Is_Dynamically_Tagged (Expr))
1172 and then not Is_Class_Wide_Type (R_Type)
1175 ("dynamically tagged expression not allowed!", Expr);
1178 Apply_Constraint_Check (Expr, R_Type);
1180 -- Ada 2005 (AI-318-02): Return-by-reference types have been
1181 -- removed and replaced by anonymous access results. This is
1182 -- an incompatibility with Ada 95. Not clear whether this
1183 -- should be enforced yet or perhaps controllable with a
1184 -- special switch. ???
1186 -- if Ada_Version >= Ada_05
1187 -- and then Is_Limited_Type (R_Type)
1188 -- and then Nkind (Expr) /= N_Aggregate
1189 -- and then Nkind (Expr) /= N_Extension_Aggregate
1190 -- and then Nkind (Expr) /= N_Function_Call
1193 -- ("(Ada 2005) illegal operand for limited return", N);
1196 -- ??? A real run-time accessibility check is needed in cases
1197 -- involving dereferences of access parameters. For now we just
1198 -- check the static cases.
1200 if Is_Inherently_Limited_Type (Etype (Scope_Id))
1201 and then Object_Access_Level (Expr)
1202 > Subprogram_Access_Level (Scope_Id)
1205 Make_Raise_Program_Error (Loc,
1206 Reason => PE_Accessibility_Check_Failed));
1210 ("cannot return a local value by reference?", N);
1212 ("\& will be raised at run time?",
1213 N, Standard_Program_Error);
1216 elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
1217 Error_Msg_N ("procedure cannot return value (use function)", N);
1220 Error_Msg_N ("accept statement cannot return value", N);
1223 -- No expression present
1226 if Kind = E_Function or Kind = E_Generic_Function then
1227 Error_Msg_N ("missing expression in return from function", N);
1230 if (Ekind (Scope_Id) = E_Procedure
1231 or else Ekind (Scope_Id) = E_Generic_Procedure)
1232 and then No_Return (Scope_Id)
1235 ("RETURN statement not allowed (No_Return)", N);
1239 Check_Unreachable_Code (N);
1240 end Analyze_Return_Statement;
1242 -------------------------
1243 -- Analyze_Return_Type --
1244 -------------------------
1246 procedure Analyze_Return_Type (N : Node_Id) is
1247 Designator : constant Entity_Id := Defining_Entity (N);
1248 Typ : Entity_Id := Empty;
1251 -- Normal case where result definition does not indicate an error
1253 if Result_Definition (N) /= Error then
1254 if Nkind (Result_Definition (N)) = N_Access_Definition then
1255 Typ := Access_Definition (N, Result_Definition (N));
1256 Set_Parent (Typ, Result_Definition (N));
1257 Set_Is_Local_Anonymous_Access (Typ);
1258 Set_Etype (Designator, Typ);
1260 -- Subtype_Mark case
1263 Find_Type (Result_Definition (N));
1264 Typ := Entity (Result_Definition (N));
1265 Set_Etype (Designator, Typ);
1267 if Ekind (Typ) = E_Incomplete_Type
1268 or else (Is_Class_Wide_Type (Typ)
1270 Ekind (Root_Type (Typ)) = E_Incomplete_Type)
1273 ("invalid use of incomplete type", Result_Definition (N));
1277 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1279 Null_Exclusion_Static_Checks (N);
1281 -- Case where result definition does indicate an error
1284 Set_Etype (Designator, Any_Type);
1286 end Analyze_Return_Type;
1288 -----------------------------
1289 -- Analyze_Subprogram_Body --
1290 -----------------------------
1292 -- This procedure is called for regular subprogram bodies, generic bodies,
1293 -- and for subprogram stubs of both kinds. In the case of stubs, only the
1294 -- specification matters, and is used to create a proper declaration for
1295 -- the subprogram, or to perform conformance checks.
1297 procedure Analyze_Subprogram_Body (N : Node_Id) is
1298 Loc : constant Source_Ptr := Sloc (N);
1299 Body_Spec : constant Node_Id := Specification (N);
1300 Body_Id : Entity_Id := Defining_Entity (Body_Spec);
1301 Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
1302 Body_Deleted : constant Boolean := False;
1305 Spec_Id : Entity_Id;
1306 Spec_Decl : Node_Id := Empty;
1307 Last_Formal : Entity_Id := Empty;
1308 Conformant : Boolean;
1309 Missing_Ret : Boolean;
1312 procedure Check_Anonymous_Return;
1313 -- (Ada 2005): if a function returns an access type that denotes a task,
1314 -- or a type that contains tasks, we must create a master entity for
1315 -- the anonymous type, which typically will be used in an allocator
1316 -- in the body of the function.
1318 procedure Check_Inline_Pragma (Spec : in out Node_Id);
1319 -- Look ahead to recognize a pragma that may appear after the body.
1320 -- If there is a previous spec, check that it appears in the same
1321 -- declarative part. If the pragma is Inline_Always, perform inlining
1322 -- unconditionally, otherwise only if Front_End_Inlining is requested.
1323 -- If the body acts as a spec, and inlining is required, we create a
1324 -- subprogram declaration for it, in order to attach the body to inline.
1326 procedure Copy_Parameter_List (Plist : List_Id);
1327 -- Utility to create a parameter profile for a new subprogram spec,
1328 -- when the subprogram has a body that acts as spec. This is done for
1329 -- some cases of inlining, and for private protected ops.
1331 procedure Verify_Overriding_Indicator;
1332 -- If there was a previous spec, the entity has been entered in the
1333 -- current scope previously. If the body itself carries an overriding
1334 -- indicator, check that it is consistent with the known status of the
1337 ----------------------------
1338 -- Check_Anonymous_Return --
1339 ----------------------------
1341 procedure Check_Anonymous_Return is
1346 if Present (Spec_Id) then
1352 if Ekind (Scop) = E_Function
1353 and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type
1354 and then Has_Task (Designated_Type (Etype (Scop)))
1355 and then Expander_Active
1358 Make_Object_Declaration (Loc,
1359 Defining_Identifier =>
1360 Make_Defining_Identifier (Loc, Name_uMaster),
1361 Constant_Present => True,
1362 Object_Definition =>
1363 New_Reference_To (RTE (RE_Master_Id), Loc),
1365 Make_Explicit_Dereference (Loc,
1366 New_Reference_To (RTE (RE_Current_Master), Loc)));
1368 if Present (Declarations (N)) then
1369 Prepend (Decl, Declarations (N));
1371 Set_Declarations (N, New_List (Decl));
1374 Set_Master_Id (Etype (Scop), Defining_Identifier (Decl));
1375 Set_Has_Master_Entity (Scop);
1377 end Check_Anonymous_Return;
1379 -------------------------
1380 -- Check_Inline_Pragma --
1381 -------------------------
1383 procedure Check_Inline_Pragma (Spec : in out Node_Id) is
1388 if not Expander_Active then
1392 if Is_List_Member (N)
1393 and then Present (Next (N))
1394 and then Nkind (Next (N)) = N_Pragma
1398 if Nkind (Prag) = N_Pragma
1400 (Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always
1403 and then Get_Pragma_Id (Chars (Prag)) = Pragma_Inline))
1406 (Expression (First (Pragma_Argument_Associations (Prag))))
1417 if Present (Prag) then
1418 if Present (Spec_Id) then
1419 if List_Containing (N) =
1420 List_Containing (Unit_Declaration_Node (Spec_Id))
1426 -- Create a subprogram declaration, to make treatment uniform
1429 Subp : constant Entity_Id :=
1430 Make_Defining_Identifier (Loc, Chars (Body_Id));
1431 Decl : constant Node_Id :=
1432 Make_Subprogram_Declaration (Loc,
1433 Specification => New_Copy_Tree (Specification (N)));
1435 Set_Defining_Unit_Name (Specification (Decl), Subp);
1437 if Present (First_Formal (Body_Id)) then
1439 Copy_Parameter_List (Plist);
1440 Set_Parameter_Specifications
1441 (Specification (Decl), Plist);
1444 Insert_Before (N, Decl);
1447 Set_Has_Pragma_Inline (Subp);
1449 if Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always then
1450 Set_Is_Inlined (Subp);
1451 Set_Next_Rep_Item (Prag, First_Rep_Item (Subp));
1452 Set_First_Rep_Item (Subp, Prag);
1459 end Check_Inline_Pragma;
1461 -------------------------
1462 -- Copy_Parameter_List --
1463 -------------------------
1465 procedure Copy_Parameter_List (Plist : List_Id) is
1469 Formal := First_Formal (Body_Id);
1471 while Present (Formal) loop
1473 (Make_Parameter_Specification (Loc,
1474 Defining_Identifier =>
1475 Make_Defining_Identifier (Sloc (Formal),
1476 Chars => Chars (Formal)),
1477 In_Present => In_Present (Parent (Formal)),
1478 Out_Present => Out_Present (Parent (Formal)),
1480 New_Reference_To (Etype (Formal), Loc),
1482 New_Copy_Tree (Expression (Parent (Formal)))),
1485 Next_Formal (Formal);
1487 end Copy_Parameter_List;
1489 ---------------------------------
1490 -- Verify_Overriding_Indicator --
1491 ---------------------------------
1493 procedure Verify_Overriding_Indicator is
1495 if Must_Override (Body_Spec)
1496 and then not Is_Overriding_Operation (Spec_Id)
1499 ("subprogram& is not overriding", Body_Spec, Spec_Id);
1501 elsif Must_Not_Override (Body_Spec)
1502 and then Is_Overriding_Operation (Spec_Id)
1505 ("subprogram& overrides inherited operation",
1506 Body_Spec, Spec_Id);
1508 end Verify_Overriding_Indicator;
1510 -- Start of processing for Analyze_Subprogram_Body
1513 if Debug_Flag_C then
1514 Write_Str ("==== Compiling subprogram body ");
1515 Write_Name (Chars (Body_Id));
1516 Write_Str (" from ");
1517 Write_Location (Loc);
1521 Trace_Scope (N, Body_Id, " Analyze subprogram");
1523 -- Generic subprograms are handled separately. They always have a
1524 -- generic specification. Determine whether current scope has a
1525 -- previous declaration.
1527 -- If the subprogram body is defined within an instance of the same
1528 -- name, the instance appears as a package renaming, and will be hidden
1529 -- within the subprogram.
1531 if Present (Prev_Id)
1532 and then not Is_Overloadable (Prev_Id)
1533 and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
1534 or else Comes_From_Source (Prev_Id))
1536 if Is_Generic_Subprogram (Prev_Id) then
1538 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
1539 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
1541 Analyze_Generic_Subprogram_Body (N, Spec_Id);
1545 -- Previous entity conflicts with subprogram name. Attempting to
1546 -- enter name will post error.
1548 Enter_Name (Body_Id);
1552 -- Non-generic case, find the subprogram declaration, if one was seen,
1553 -- or enter new overloaded entity in the current scope. If the
1554 -- Current_Entity is the Body_Id itself, the unit is being analyzed as
1555 -- part of the context of one of its subunits. No need to redo the
1558 elsif Prev_Id = Body_Id
1559 and then Has_Completion (Body_Id)
1564 Body_Id := Analyze_Subprogram_Specification (Body_Spec);
1566 if Nkind (N) = N_Subprogram_Body_Stub
1567 or else No (Corresponding_Spec (N))
1569 Spec_Id := Find_Corresponding_Spec (N);
1571 -- If this is a duplicate body, no point in analyzing it
1573 if Error_Posted (N) then
1577 -- A subprogram body should cause freezing of its own declaration,
1578 -- but if there was no previous explicit declaration, then the
1579 -- subprogram will get frozen too late (there may be code within
1580 -- the body that depends on the subprogram having been frozen,
1581 -- such as uses of extra formals), so we force it to be frozen
1582 -- here. Same holds if the body and the spec are compilation
1585 if No (Spec_Id) then
1586 Freeze_Before (N, Body_Id);
1588 elsif Nkind (Parent (N)) = N_Compilation_Unit then
1589 Freeze_Before (N, Spec_Id);
1592 Spec_Id := Corresponding_Spec (N);
1596 -- Do not inline any subprogram that contains nested subprograms, since
1597 -- the backend inlining circuit seems to generate uninitialized
1598 -- references in this case. We know this happens in the case of front
1599 -- end ZCX support, but it also appears it can happen in other cases as
1600 -- well. The backend often rejects attempts to inline in the case of
1601 -- nested procedures anyway, so little if anything is lost by this.
1602 -- Note that this is test is for the benefit of the back-end. There is
1603 -- a separate test for front-end inlining that also rejects nested
1606 -- Do not do this test if errors have been detected, because in some
1607 -- error cases, this code blows up, and we don't need it anyway if
1608 -- there have been errors, since we won't get to the linker anyway.
1610 if Comes_From_Source (Body_Id)
1611 and then Serious_Errors_Detected = 0
1615 P_Ent := Scope (P_Ent);
1616 exit when No (P_Ent) or else P_Ent = Standard_Standard;
1618 if Is_Subprogram (P_Ent) then
1619 Set_Is_Inlined (P_Ent, False);
1621 if Comes_From_Source (P_Ent)
1622 and then Has_Pragma_Inline (P_Ent)
1625 ("cannot inline& (nested subprogram)?",
1632 Check_Inline_Pragma (Spec_Id);
1634 -- Case of fully private operation in the body of the protected type.
1635 -- We must create a declaration for the subprogram, in order to attach
1636 -- the protected subprogram that will be used in internal calls.
1639 and then Comes_From_Source (N)
1640 and then Is_Protected_Type (Current_Scope)
1649 Formal := First_Formal (Body_Id);
1651 -- The protected operation always has at least one formal, namely
1652 -- the object itself, but it is only placed in the parameter list
1653 -- if expansion is enabled.
1656 or else Expander_Active
1664 Copy_Parameter_List (Plist);
1666 if Nkind (Body_Spec) = N_Procedure_Specification then
1668 Make_Procedure_Specification (Loc,
1669 Defining_Unit_Name =>
1670 Make_Defining_Identifier (Sloc (Body_Id),
1671 Chars => Chars (Body_Id)),
1672 Parameter_Specifications => Plist);
1675 Make_Function_Specification (Loc,
1676 Defining_Unit_Name =>
1677 Make_Defining_Identifier (Sloc (Body_Id),
1678 Chars => Chars (Body_Id)),
1679 Parameter_Specifications => Plist,
1680 Result_Definition =>
1681 New_Occurrence_Of (Etype (Body_Id), Loc));
1685 Make_Subprogram_Declaration (Loc,
1686 Specification => New_Spec);
1687 Insert_Before (N, Decl);
1688 Spec_Id := Defining_Unit_Name (New_Spec);
1690 -- Indicate that the entity comes from source, to ensure that
1691 -- cross-reference information is properly generated. The body
1692 -- itself is rewritten during expansion, and the body entity will
1693 -- not appear in calls to the operation.
1695 Set_Comes_From_Source (Spec_Id, True);
1697 Set_Has_Completion (Spec_Id);
1698 Set_Convention (Spec_Id, Convention_Protected);
1701 elsif Present (Spec_Id) then
1702 Spec_Decl := Unit_Declaration_Node (Spec_Id);
1703 Verify_Overriding_Indicator;
1706 -- Place subprogram on scope stack, and make formals visible. If there
1707 -- is a spec, the visible entity remains that of the spec.
1709 if Present (Spec_Id) then
1710 Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
1712 if Is_Child_Unit (Spec_Id) then
1713 Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False);
1717 Style.Check_Identifier (Body_Id, Spec_Id);
1720 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
1721 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
1723 if Is_Abstract_Subprogram (Spec_Id) then
1724 Error_Msg_N ("an abstract subprogram cannot have a body", N);
1727 Set_Convention (Body_Id, Convention (Spec_Id));
1728 Set_Has_Completion (Spec_Id);
1730 if Is_Protected_Type (Scope (Spec_Id)) then
1731 Set_Privals_Chain (Spec_Id, New_Elmt_List);
1734 -- If this is a body generated for a renaming, do not check for
1735 -- full conformance. The check is redundant, because the spec of
1736 -- the body is a copy of the spec in the renaming declaration,
1737 -- and the test can lead to spurious errors on nested defaults.
1739 if Present (Spec_Decl)
1740 and then not Comes_From_Source (N)
1742 (Nkind (Original_Node (Spec_Decl)) =
1743 N_Subprogram_Renaming_Declaration
1744 or else (Present (Corresponding_Body (Spec_Decl))
1746 Nkind (Unit_Declaration_Node
1747 (Corresponding_Body (Spec_Decl))) =
1748 N_Subprogram_Renaming_Declaration))
1754 Fully_Conformant, True, Conformant, Body_Id);
1757 -- If the body is not fully conformant, we have to decide if we
1758 -- should analyze it or not. If it has a really messed up profile
1759 -- then we probably should not analyze it, since we will get too
1760 -- many bogus messages.
1762 -- Our decision is to go ahead in the non-fully conformant case
1763 -- only if it is at least mode conformant with the spec. Note
1764 -- that the call to Check_Fully_Conformant has issued the proper
1765 -- error messages to complain about the lack of conformance.
1768 and then not Mode_Conformant (Body_Id, Spec_Id)
1774 if Spec_Id /= Body_Id then
1775 Reference_Body_Formals (Spec_Id, Body_Id);
1778 if Nkind (N) /= N_Subprogram_Body_Stub then
1779 Set_Corresponding_Spec (N, Spec_Id);
1781 -- Ada 2005 (AI-345): Restore the correct Etype: here we undo the
1782 -- work done by Analyze_Subprogram_Specification to allow the
1783 -- overriding of task, protected and interface primitives.
1785 if Comes_From_Source (Spec_Id)
1786 and then Present (First_Entity (Spec_Id))
1787 and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
1788 and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
1789 and then Present (Abstract_Interfaces
1790 (Etype (First_Entity (Spec_Id))))
1791 and then Present (Corresponding_Concurrent_Type
1792 (Etype (First_Entity (Spec_Id))))
1794 Set_Etype (First_Entity (Spec_Id),
1795 Corresponding_Concurrent_Type
1796 (Etype (First_Entity (Spec_Id))));
1799 -- Now make the formals visible, and place subprogram
1802 Install_Formals (Spec_Id);
1803 Last_Formal := Last_Entity (Spec_Id);
1804 New_Scope (Spec_Id);
1806 -- Make sure that the subprogram is immediately visible. For
1807 -- child units that have no separate spec this is indispensable.
1808 -- Otherwise it is safe albeit redundant.
1810 Set_Is_Immediately_Visible (Spec_Id);
1813 Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
1814 Set_Ekind (Body_Id, E_Subprogram_Body);
1815 Set_Scope (Body_Id, Scope (Spec_Id));
1816 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
1818 -- Case of subprogram body with no previous spec
1822 and then Comes_From_Source (Body_Id)
1823 and then not Suppress_Style_Checks (Body_Id)
1824 and then not In_Instance
1826 Style.Body_With_No_Spec (N);
1829 New_Overloaded_Entity (Body_Id);
1831 if Nkind (N) /= N_Subprogram_Body_Stub then
1832 Set_Acts_As_Spec (N);
1833 Generate_Definition (Body_Id);
1835 (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
1836 Generate_Reference_To_Formals (Body_Id);
1837 Install_Formals (Body_Id);
1838 New_Scope (Body_Id);
1842 -- Ada 2005 (AI-251): Check wrong placement of abstract interface
1845 if Ada_Version >= Ada_05
1846 and then Comes_From_Source (N)
1853 -- Check the type of the formals
1855 E := First_Entity (Body_Id);
1856 while Present (E) loop
1859 if Is_Access_Type (Etyp) then
1860 Etyp := Directly_Designated_Type (Etyp);
1863 if not Is_Class_Wide_Type (Etyp)
1864 and then Is_Interface (Etyp)
1866 Error_Msg_Name_1 := Chars (Defining_Entity (N));
1868 ("(Ada 2005) abstract interface primitives must be" &
1869 " defined in package specs", N);
1876 -- In case of functions, check the type of the result
1878 if Ekind (Body_Id) = E_Function then
1879 Etyp := Etype (Body_Id);
1881 if Is_Access_Type (Etyp) then
1882 Etyp := Directly_Designated_Type (Etyp);
1885 if not Is_Class_Wide_Type (Etyp)
1886 and then Is_Interface (Etyp)
1888 Error_Msg_Name_1 := Chars (Defining_Entity (N));
1890 ("(Ada 2005) abstract interface primitives must be" &
1891 " defined in package specs", N);
1897 -- If this is the proper body of a stub, we must verify that the stub
1898 -- conforms to the body, and to the previous spec if one was present.
1899 -- we know already that the body conforms to that spec. This test is
1900 -- only required for subprograms that come from source.
1902 if Nkind (Parent (N)) = N_Subunit
1903 and then Comes_From_Source (N)
1904 and then not Error_Posted (Body_Id)
1905 and then Nkind (Corresponding_Stub (Parent (N))) =
1906 N_Subprogram_Body_Stub
1909 Old_Id : constant Entity_Id :=
1911 (Specification (Corresponding_Stub (Parent (N))));
1913 Conformant : Boolean := False;
1916 if No (Spec_Id) then
1917 Check_Fully_Conformant (Body_Id, Old_Id);
1921 (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
1923 if not Conformant then
1925 -- The stub was taken to be a new declaration. Indicate
1926 -- that it lacks a body.
1928 Set_Has_Completion (Old_Id, False);
1934 Set_Has_Completion (Body_Id);
1935 Check_Eliminated (Body_Id);
1937 if Nkind (N) = N_Subprogram_Body_Stub then
1940 elsif Present (Spec_Id)
1941 and then Expander_Active
1943 (Is_Always_Inlined (Spec_Id)
1944 or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
1946 Build_Body_To_Inline (N, Spec_Id);
1949 -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
1950 -- if its specification we have to install the private withed units.
1952 if Is_Compilation_Unit (Body_Id)
1953 and then Scope (Body_Id) = Standard_Standard
1955 Install_Private_With_Clauses (Body_Id);
1958 Check_Anonymous_Return;
1960 -- Now we can go on to analyze the body
1962 HSS := Handled_Statement_Sequence (N);
1963 Set_Actual_Subtypes (N, Current_Scope);
1964 Analyze_Declarations (Declarations (N));
1967 Process_End_Label (HSS, 't', Current_Scope);
1969 Check_Subprogram_Order (N);
1970 Set_Analyzed (Body_Id);
1972 -- If we have a separate spec, then the analysis of the declarations
1973 -- caused the entities in the body to be chained to the spec id, but
1974 -- we want them chained to the body id. Only the formal parameters
1975 -- end up chained to the spec id in this case.
1977 if Present (Spec_Id) then
1979 -- We must conform to the categorization of our spec
1981 Validate_Categorization_Dependency (N, Spec_Id);
1983 -- And if this is a child unit, the parent units must conform
1985 if Is_Child_Unit (Spec_Id) then
1986 Validate_Categorization_Dependency
1987 (Unit_Declaration_Node (Spec_Id), Spec_Id);
1990 if Present (Last_Formal) then
1992 (Last_Entity (Body_Id), Next_Entity (Last_Formal));
1993 Set_Next_Entity (Last_Formal, Empty);
1994 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
1995 Set_Last_Entity (Spec_Id, Last_Formal);
1998 Set_First_Entity (Body_Id, First_Entity (Spec_Id));
1999 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
2000 Set_First_Entity (Spec_Id, Empty);
2001 Set_Last_Entity (Spec_Id, Empty);
2005 -- If function, check return statements
2007 if Nkind (Body_Spec) = N_Function_Specification then
2012 if Present (Spec_Id) then
2018 if Return_Present (Id) then
2019 Check_Returns (HSS, 'F', Missing_Ret);
2022 Set_Has_Missing_Return (Id);
2025 elsif not Is_Machine_Code_Subprogram (Id)
2026 and then not Body_Deleted
2028 Error_Msg_N ("missing RETURN statement in function body", N);
2032 -- If procedure with No_Return, check returns
2034 elsif Nkind (Body_Spec) = N_Procedure_Specification
2035 and then Present (Spec_Id)
2036 and then No_Return (Spec_Id)
2038 Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
2041 -- Now we are going to check for variables that are never modified in
2042 -- the body of the procedure. We omit these checks if the first
2043 -- statement of the procedure raises an exception. In particular this
2044 -- deals with the common idiom of a stubbed function, which might
2045 -- appear as something like
2047 -- function F (A : Integer) return Some_Type;
2050 -- raise Program_Error;
2054 -- Here the purpose of X is simply to satisfy the (annoying)
2055 -- requirement in Ada that there be at least one return, and we
2056 -- certainly do not want to go posting warnings on X that it is not
2060 Stm : Node_Id := First (Statements (HSS));
2063 -- Skip an initial label (for one thing this occurs when we are in
2064 -- front end ZCX mode, but in any case it is irrelevant).
2066 if Nkind (Stm) = N_Label then
2070 -- Do the test on the original statement before expansion
2073 Ostm : constant Node_Id := Original_Node (Stm);
2076 -- If explicit raise statement, return with no checks
2078 if Nkind (Ostm) = N_Raise_Statement then
2081 -- Check for explicit call cases which likely raise an exception
2083 elsif Nkind (Ostm) = N_Procedure_Call_Statement then
2084 if Is_Entity_Name (Name (Ostm)) then
2086 Ent : constant Entity_Id := Entity (Name (Ostm));
2089 -- If the procedure is marked No_Return, then likely it
2090 -- raises an exception, but in any case it is not coming
2091 -- back here, so no need to check beyond the call.
2093 if Ekind (Ent) = E_Procedure
2094 and then No_Return (Ent)
2098 -- If the procedure name is Raise_Exception, then also
2099 -- assume that it raises an exception. The main target
2100 -- here is Ada.Exceptions.Raise_Exception, but this name
2101 -- is pretty evocative in any context! Note that the
2102 -- procedure in Ada.Exceptions is not marked No_Return
2103 -- because of the annoying case of the null exception Id.
2105 elsif Chars (Ent) = Name_Raise_Exception then
2114 -- Check for variables that are never modified
2120 -- If there is a separate spec, then transfer Never_Set_In_Source
2121 -- flags from out parameters to the corresponding entities in the
2122 -- body. The reason we do that is we want to post error flags on
2123 -- the body entities, not the spec entities.
2125 if Present (Spec_Id) then
2126 E1 := First_Entity (Spec_Id);
2127 while Present (E1) loop
2128 if Ekind (E1) = E_Out_Parameter then
2129 E2 := First_Entity (Body_Id);
2130 while Present (E2) loop
2131 exit when Chars (E1) = Chars (E2);
2135 if Present (E2) then
2136 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
2144 -- Check references in body unless it was deleted. Note that the
2145 -- check of Body_Deleted here is not just for efficiency, it is
2146 -- necessary to avoid junk warnings on formal parameters.
2148 if not Body_Deleted then
2149 Check_References (Body_Id);
2152 end Analyze_Subprogram_Body;
2154 ------------------------------------
2155 -- Analyze_Subprogram_Declaration --
2156 ------------------------------------
2158 procedure Analyze_Subprogram_Declaration (N : Node_Id) is
2159 Designator : constant Entity_Id :=
2160 Analyze_Subprogram_Specification (Specification (N));
2161 Scop : constant Entity_Id := Current_Scope;
2163 -- Start of processing for Analyze_Subprogram_Declaration
2166 Generate_Definition (Designator);
2168 -- Check for RCI unit subprogram declarations against in-lined
2169 -- subprograms and subprograms having access parameter or limited
2170 -- parameter without Read and Write (RM E.2.3(12-13)).
2172 Validate_RCI_Subprogram_Declaration (N);
2176 Defining_Entity (N),
2177 " Analyze subprogram spec. ");
2179 if Debug_Flag_C then
2180 Write_Str ("==== Compiling subprogram spec ");
2181 Write_Name (Chars (Designator));
2182 Write_Str (" from ");
2183 Write_Location (Sloc (N));
2187 New_Overloaded_Entity (Designator);
2188 Check_Delayed_Subprogram (Designator);
2190 -- Ada 2005 (AI-251): Abstract interface primitives must be abstract
2193 if Ada_Version >= Ada_05
2194 and then Comes_From_Source (N)
2195 and then Is_Dispatching_Operation (Designator)
2202 if Has_Controlling_Result (Designator) then
2203 Etyp := Etype (Designator);
2206 E := First_Entity (Designator);
2208 and then Is_Formal (E)
2209 and then not Is_Controlling_Formal (E)
2217 if Is_Access_Type (Etyp) then
2218 Etyp := Directly_Designated_Type (Etyp);
2221 if Is_Interface (Etyp)
2222 and then not Is_Abstract_Subprogram (Designator)
2223 and then not (Ekind (Designator) = E_Procedure
2224 and then Null_Present (Specification (N)))
2226 Error_Msg_Name_1 := Chars (Defining_Entity (N));
2228 ("(Ada 2005) interface subprogram % must be abstract or null",
2234 -- What is the following code for, it used to be
2236 -- ??? Set_Suppress_Elaboration_Checks
2237 -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
2239 -- The following seems equivalent, but a bit dubious
2241 if Elaboration_Checks_Suppressed (Designator) then
2242 Set_Kill_Elaboration_Checks (Designator);
2245 if Scop /= Standard_Standard
2246 and then not Is_Child_Unit (Designator)
2248 Set_Categorization_From_Scope (Designator, Scop);
2250 -- For a compilation unit, check for library-unit pragmas
2252 New_Scope (Designator);
2253 Set_Categorization_From_Pragmas (N);
2254 Validate_Categorization_Dependency (N, Designator);
2258 -- For a compilation unit, set body required. This flag will only be
2259 -- reset if a valid Import or Interface pragma is processed later on.
2261 if Nkind (Parent (N)) = N_Compilation_Unit then
2262 Set_Body_Required (Parent (N), True);
2264 if Ada_Version >= Ada_05
2265 and then Nkind (Specification (N)) = N_Procedure_Specification
2266 and then Null_Present (Specification (N))
2269 ("null procedure cannot be declared at library level", N);
2273 Generate_Reference_To_Formals (Designator);
2274 Check_Eliminated (Designator);
2276 -- Ada 2005: if procedure is declared with "is null" qualifier,
2277 -- it requires no body.
2279 if Nkind (Specification (N)) = N_Procedure_Specification
2280 and then Null_Present (Specification (N))
2282 Set_Has_Completion (Designator);
2283 Set_Is_Inlined (Designator);
2285 if Is_Protected_Type (Current_Scope) then
2287 ("protected operation cannot be a null procedure", N);
2290 end Analyze_Subprogram_Declaration;
2292 --------------------------------------
2293 -- Analyze_Subprogram_Specification --
2294 --------------------------------------
2296 -- Reminder: N here really is a subprogram specification (not a subprogram
2297 -- declaration). This procedure is called to analyze the specification in
2298 -- both subprogram bodies and subprogram declarations (specs).
2300 function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
2301 Designator : constant Entity_Id := Defining_Entity (N);
2302 Formals : constant List_Id := Parameter_Specifications (N);
2304 -- Start of processing for Analyze_Subprogram_Specification
2307 Generate_Definition (Designator);
2309 if Nkind (N) = N_Function_Specification then
2310 Set_Ekind (Designator, E_Function);
2311 Set_Mechanism (Designator, Default_Mechanism);
2314 Set_Ekind (Designator, E_Procedure);
2315 Set_Etype (Designator, Standard_Void_Type);
2318 -- Introduce new scope for analysis of the formals and of the
2321 Set_Scope (Designator, Current_Scope);
2323 if Present (Formals) then
2324 New_Scope (Designator);
2325 Process_Formals (Formals, N);
2327 -- Ada 2005 (AI-345): Allow overriding primitives of protected
2328 -- interfaces by means of normal subprograms. For this purpose
2329 -- temporarily use the corresponding record type as the etype
2330 -- of the first formal.
2332 if Ada_Version >= Ada_05
2333 and then Comes_From_Source (Designator)
2334 and then Present (First_Entity (Designator))
2335 and then (Ekind (Etype (First_Entity (Designator)))
2338 Ekind (Etype (First_Entity (Designator)))
2340 and then Present (Corresponding_Record_Type
2341 (Etype (First_Entity (Designator))))
2342 and then Present (Abstract_Interfaces
2343 (Corresponding_Record_Type
2344 (Etype (First_Entity (Designator)))))
2346 Set_Etype (First_Entity (Designator),
2347 Corresponding_Record_Type (Etype (First_Entity (Designator))));
2352 elsif Nkind (N) = N_Function_Specification then
2353 Analyze_Return_Type (N);
2356 if Nkind (N) = N_Function_Specification then
2357 if Nkind (Designator) = N_Defining_Operator_Symbol then
2358 Valid_Operator_Definition (Designator);
2361 May_Need_Actuals (Designator);
2363 -- Ada 2005 (AI-251): In case of primitives associated with abstract
2364 -- interface types the following error message will be reported later
2365 -- (see Analyze_Subprogram_Declaration).
2367 if Is_Abstract_Type (Etype (Designator))
2368 and then not Is_Interface (Etype (Designator))
2369 and then Nkind (Parent (N))
2370 /= N_Abstract_Subprogram_Declaration
2371 and then (Nkind (Parent (N)))
2372 /= N_Formal_Abstract_Subprogram_Declaration
2373 and then (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
2374 or else not Is_Entity_Name (Name (Parent (N)))
2375 or else not Is_Abstract_Subprogram
2376 (Entity (Name (Parent (N)))))
2379 ("function that returns abstract type must be abstract", N);
2384 end Analyze_Subprogram_Specification;
2386 --------------------------
2387 -- Build_Body_To_Inline --
2388 --------------------------
2390 procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
2391 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
2392 Original_Body : Node_Id;
2393 Body_To_Analyze : Node_Id;
2394 Max_Size : constant := 10;
2395 Stat_Count : Integer := 0;
2397 function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
2398 -- Check for declarations that make inlining not worthwhile
2400 function Has_Excluded_Statement (Stats : List_Id) return Boolean;
2401 -- Check for statements that make inlining not worthwhile: any tasking
2402 -- statement, nested at any level. Keep track of total number of
2403 -- elementary statements, as a measure of acceptable size.
2405 function Has_Pending_Instantiation return Boolean;
2406 -- If some enclosing body contains instantiations that appear before the
2407 -- corresponding generic body, the enclosing body has a freeze node so
2408 -- that it can be elaborated after the generic itself. This might
2409 -- conflict with subsequent inlinings, so that it is unsafe to try to
2410 -- inline in such a case.
2412 function Has_Single_Return return Boolean;
2413 -- In general we cannot inline functions that return unconstrained type.
2414 -- However, we can handle such functions if all return statements return
2415 -- a local variable that is the only declaration in the body of the
2416 -- function. In that case the call can be replaced by that local
2417 -- variable as is done for other inlined calls.
2419 procedure Remove_Pragmas;
2420 -- A pragma Unreferenced that mentions a formal parameter has no meaning
2421 -- when the body is inlined and the formals are rewritten. Remove it
2422 -- from body to inline. The analysis of the non-inlined body will handle
2423 -- the pragma properly.
2425 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
2426 -- If the body of the subprogram includes a call that returns an
2427 -- unconstrained type, the secondary stack is involved, and it
2428 -- is not worth inlining.
2430 ------------------------------
2431 -- Has_Excluded_Declaration --
2432 ------------------------------
2434 function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
2437 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
2438 -- Nested subprograms make a given body ineligible for inlining, but
2439 -- we make an exception for instantiations of unchecked conversion.
2440 -- The body has not been analyzed yet, so check the name, and verify
2441 -- that the visible entity with that name is the predefined unit.
2443 -----------------------------
2444 -- Is_Unchecked_Conversion --
2445 -----------------------------
2447 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
2448 Id : constant Node_Id := Name (D);
2452 if Nkind (Id) = N_Identifier
2453 and then Chars (Id) = Name_Unchecked_Conversion
2455 Conv := Current_Entity (Id);
2457 elsif (Nkind (Id) = N_Selected_Component
2458 or else Nkind (Id) = N_Expanded_Name)
2459 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
2461 Conv := Current_Entity (Selector_Name (Id));
2467 return Present (Conv)
2468 and then Is_Predefined_File_Name
2469 (Unit_File_Name (Get_Source_Unit (Conv)))
2470 and then Is_Intrinsic_Subprogram (Conv);
2471 end Is_Unchecked_Conversion;
2473 -- Start of processing for Has_Excluded_Declaration
2478 while Present (D) loop
2479 if (Nkind (D) = N_Function_Instantiation
2480 and then not Is_Unchecked_Conversion (D))
2481 or else Nkind (D) = N_Protected_Type_Declaration
2482 or else Nkind (D) = N_Package_Declaration
2483 or else Nkind (D) = N_Package_Instantiation
2484 or else Nkind (D) = N_Subprogram_Body
2485 or else Nkind (D) = N_Procedure_Instantiation
2486 or else Nkind (D) = N_Task_Type_Declaration
2489 ("cannot inline & (non-allowed declaration)?", D, Subp);
2497 end Has_Excluded_Declaration;
2499 ----------------------------
2500 -- Has_Excluded_Statement --
2501 ----------------------------
2503 function Has_Excluded_Statement (Stats : List_Id) return Boolean is
2509 while Present (S) loop
2510 Stat_Count := Stat_Count + 1;
2512 if Nkind (S) = N_Abort_Statement
2513 or else Nkind (S) = N_Asynchronous_Select
2514 or else Nkind (S) = N_Conditional_Entry_Call
2515 or else Nkind (S) = N_Delay_Relative_Statement
2516 or else Nkind (S) = N_Delay_Until_Statement
2517 or else Nkind (S) = N_Selective_Accept
2518 or else Nkind (S) = N_Timed_Entry_Call
2521 ("cannot inline & (non-allowed statement)?", S, Subp);
2524 elsif Nkind (S) = N_Block_Statement then
2525 if Present (Declarations (S))
2526 and then Has_Excluded_Declaration (Declarations (S))
2530 elsif Present (Handled_Statement_Sequence (S))
2533 (Exception_Handlers (Handled_Statement_Sequence (S)))
2535 Has_Excluded_Statement
2536 (Statements (Handled_Statement_Sequence (S))))
2541 elsif Nkind (S) = N_Case_Statement then
2542 E := First (Alternatives (S));
2543 while Present (E) loop
2544 if Has_Excluded_Statement (Statements (E)) then
2551 elsif Nkind (S) = N_If_Statement then
2552 if Has_Excluded_Statement (Then_Statements (S)) then
2556 if Present (Elsif_Parts (S)) then
2557 E := First (Elsif_Parts (S));
2558 while Present (E) loop
2559 if Has_Excluded_Statement (Then_Statements (E)) then
2566 if Present (Else_Statements (S))
2567 and then Has_Excluded_Statement (Else_Statements (S))
2572 elsif Nkind (S) = N_Loop_Statement
2573 and then Has_Excluded_Statement (Statements (S))
2582 end Has_Excluded_Statement;
2584 -------------------------------
2585 -- Has_Pending_Instantiation --
2586 -------------------------------
2588 function Has_Pending_Instantiation return Boolean is
2593 while Present (S) loop
2594 if Is_Compilation_Unit (S)
2595 or else Is_Child_Unit (S)
2598 elsif Ekind (S) = E_Package
2599 and then Has_Forward_Instantiation (S)
2608 end Has_Pending_Instantiation;
2610 ------------------------
2611 -- Has_Single_Return --
2612 ------------------------
2614 function Has_Single_Return return Boolean is
2615 Return_Statement : Node_Id := Empty;
2617 function Check_Return (N : Node_Id) return Traverse_Result;
2623 function Check_Return (N : Node_Id) return Traverse_Result is
2625 if Nkind (N) = N_Return_Statement then
2626 if Present (Expression (N))
2627 and then Is_Entity_Name (Expression (N))
2629 if No (Return_Statement) then
2630 Return_Statement := N;
2633 elsif Chars (Expression (N)) =
2634 Chars (Expression (Return_Statement))
2643 -- Expression has wrong form
2653 function Check_All_Returns is new Traverse_Func (Check_Return);
2655 -- Start of processing for Has_Single_Return
2658 return Check_All_Returns (N) = OK
2659 and then Present (Declarations (N))
2660 and then Chars (Expression (Return_Statement)) =
2661 Chars (Defining_Identifier (First (Declarations (N))));
2662 end Has_Single_Return;
2664 --------------------
2665 -- Remove_Pragmas --
2666 --------------------
2668 procedure Remove_Pragmas is
2673 Decl := First (Declarations (Body_To_Analyze));
2674 while Present (Decl) loop
2677 if Nkind (Decl) = N_Pragma
2678 and then Chars (Decl) = Name_Unreferenced
2687 --------------------------
2688 -- Uses_Secondary_Stack --
2689 --------------------------
2691 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
2692 function Check_Call (N : Node_Id) return Traverse_Result;
2693 -- Look for function calls that return an unconstrained type
2699 function Check_Call (N : Node_Id) return Traverse_Result is
2701 if Nkind (N) = N_Function_Call
2702 and then Is_Entity_Name (Name (N))
2703 and then Is_Composite_Type (Etype (Entity (Name (N))))
2704 and then not Is_Constrained (Etype (Entity (Name (N))))
2707 ("cannot inline & (call returns unconstrained type)?",
2715 function Check_Calls is new Traverse_Func (Check_Call);
2718 return Check_Calls (Bod) = Abandon;
2719 end Uses_Secondary_Stack;
2721 -- Start of processing for Build_Body_To_Inline
2724 if Nkind (Decl) = N_Subprogram_Declaration
2725 and then Present (Body_To_Inline (Decl))
2727 return; -- Done already.
2729 -- Functions that return unconstrained composite types require
2730 -- secondary stack handling, and cannot currently be inlined, unless
2731 -- all return statements return a local variable that is the first
2732 -- local declaration in the body.
2734 elsif Ekind (Subp) = E_Function
2735 and then not Is_Scalar_Type (Etype (Subp))
2736 and then not Is_Access_Type (Etype (Subp))
2737 and then not Is_Constrained (Etype (Subp))
2739 if not Has_Single_Return then
2741 ("cannot inline & (unconstrained return type)?", N, Subp);
2745 -- Ditto for functions that return controlled types, where controlled
2746 -- actions interfere in complex ways with inlining.
2748 elsif Ekind (Subp) = E_Function
2749 and then Controlled_Type (Etype (Subp))
2752 ("cannot inline & (controlled return type)?", N, Subp);
2756 if Present (Declarations (N))
2757 and then Has_Excluded_Declaration (Declarations (N))
2762 if Present (Handled_Statement_Sequence (N)) then
2763 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
2765 ("cannot inline& (exception handler)?",
2766 First (Exception_Handlers (Handled_Statement_Sequence (N))),
2770 Has_Excluded_Statement
2771 (Statements (Handled_Statement_Sequence (N)))
2777 -- We do not inline a subprogram that is too large, unless it is
2778 -- marked Inline_Always. This pragma does not suppress the other
2779 -- checks on inlining (forbidden declarations, handlers, etc).
2781 if Stat_Count > Max_Size
2782 and then not Is_Always_Inlined (Subp)
2784 Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
2788 if Has_Pending_Instantiation then
2790 ("cannot inline& (forward instance within enclosing body)?",
2795 -- Within an instance, the body to inline must be treated as a nested
2796 -- generic, so that the proper global references are preserved.
2799 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
2800 Original_Body := Copy_Generic_Node (N, Empty, True);
2802 Original_Body := Copy_Separate_Tree (N);
2805 -- We need to capture references to the formals in order to substitute
2806 -- the actuals at the point of inlining, i.e. instantiation. To treat
2807 -- the formals as globals to the body to inline, we nest it within
2808 -- a dummy parameterless subprogram, declared within the real one.
2809 -- To avoid generating an internal name (which is never public, and
2810 -- which affects serial numbers of other generated names), we use
2811 -- an internal symbol that cannot conflict with user declarations.
2813 Set_Parameter_Specifications (Specification (Original_Body), No_List);
2814 Set_Defining_Unit_Name
2815 (Specification (Original_Body),
2816 Make_Defining_Identifier (Sloc (N), Name_uParent));
2817 Set_Corresponding_Spec (Original_Body, Empty);
2819 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
2821 -- Set return type of function, which is also global and does not need
2824 if Ekind (Subp) = E_Function then
2825 Set_Result_Definition (Specification (Body_To_Analyze),
2826 New_Occurrence_Of (Etype (Subp), Sloc (N)));
2829 if No (Declarations (N)) then
2830 Set_Declarations (N, New_List (Body_To_Analyze));
2832 Append (Body_To_Analyze, Declarations (N));
2835 Expander_Mode_Save_And_Set (False);
2838 Analyze (Body_To_Analyze);
2839 New_Scope (Defining_Entity (Body_To_Analyze));
2840 Save_Global_References (Original_Body);
2842 Remove (Body_To_Analyze);
2844 Expander_Mode_Restore;
2850 -- If secondary stk used there is no point in inlining. We have
2851 -- already issued the warning in this case, so nothing to do.
2853 if Uses_Secondary_Stack (Body_To_Analyze) then
2857 Set_Body_To_Inline (Decl, Original_Body);
2858 Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
2859 Set_Is_Inlined (Subp);
2860 end Build_Body_To_Inline;
2866 procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is
2868 -- Do not emit warning if this is a predefined unit which is not
2869 -- the main unit. With validity checks enabled, some predefined
2870 -- subprograms may contain nested subprograms and become ineligible
2873 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
2874 and then not In_Extended_Main_Source_Unit (Subp)
2878 elsif Is_Always_Inlined (Subp) then
2880 -- Remove last character (question mark) to make this into an error,
2881 -- because the Inline_Always pragma cannot be obeyed.
2883 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2885 elsif Ineffective_Inline_Warnings then
2886 Error_Msg_NE (Msg, N, Subp);
2890 -----------------------
2891 -- Check_Conformance --
2892 -----------------------
2894 procedure Check_Conformance
2895 (New_Id : Entity_Id;
2897 Ctype : Conformance_Type;
2899 Conforms : out Boolean;
2900 Err_Loc : Node_Id := Empty;
2901 Get_Inst : Boolean := False;
2902 Skip_Controlling_Formals : Boolean := False)
2904 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
2905 -- Post error message for conformance error on given node. Two messages
2906 -- are output. The first points to the previous declaration with a
2907 -- general "no conformance" message. The second is the detailed reason,
2908 -- supplied as Msg. The parameter N provide information for a possible
2909 -- & insertion in the message, and also provides the location for
2910 -- posting the message in the absence of a specified Err_Loc location.
2912 -----------------------
2913 -- Conformance_Error --
2914 -----------------------
2916 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
2923 if No (Err_Loc) then
2929 Error_Msg_Sloc := Sloc (Old_Id);
2932 when Type_Conformant =>
2934 ("not type conformant with declaration#!", Enode);
2936 when Mode_Conformant =>
2938 ("not mode conformant with declaration#!", Enode);
2940 when Subtype_Conformant =>
2942 ("not subtype conformant with declaration#!", Enode);
2944 when Fully_Conformant =>
2946 ("not fully conformant with declaration#!", Enode);
2949 Error_Msg_NE (Msg, Enode, N);
2951 end Conformance_Error;
2955 Old_Type : constant Entity_Id := Etype (Old_Id);
2956 New_Type : constant Entity_Id := Etype (New_Id);
2957 Old_Formal : Entity_Id;
2958 New_Formal : Entity_Id;
2959 Access_Types_Match : Boolean;
2960 Old_Formal_Base : Entity_Id;
2961 New_Formal_Base : Entity_Id;
2963 -- Start of processing for Check_Conformance
2968 -- We need a special case for operators, since they don't appear
2971 if Ctype = Type_Conformant then
2972 if Ekind (New_Id) = E_Operator
2973 and then Operator_Matches_Spec (New_Id, Old_Id)
2979 -- If both are functions/operators, check return types conform
2981 if Old_Type /= Standard_Void_Type
2982 and then New_Type /= Standard_Void_Type
2984 if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
2985 Conformance_Error ("return type does not match!", New_Id);
2989 -- Ada 2005 (AI-231): In case of anonymous access types check the
2990 -- null-exclusion and access-to-constant attributes must match.
2992 if Ada_Version >= Ada_05
2993 and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
2995 (Can_Never_Be_Null (Old_Type)
2996 /= Can_Never_Be_Null (New_Type)
2997 or else Is_Access_Constant (Etype (Old_Type))
2998 /= Is_Access_Constant (Etype (New_Type)))
3000 Conformance_Error ("return type does not match!", New_Id);
3004 -- If either is a function/operator and the other isn't, error
3006 elsif Old_Type /= Standard_Void_Type
3007 or else New_Type /= Standard_Void_Type
3009 Conformance_Error ("functions can only match functions!", New_Id);
3013 -- In subtype conformant case, conventions must match (RM 6.3.1(16))
3014 -- If this is a renaming as body, refine error message to indicate that
3015 -- the conflict is with the original declaration. If the entity is not
3016 -- frozen, the conventions don't have to match, the one of the renamed
3017 -- entity is inherited.
3019 if Ctype >= Subtype_Conformant then
3020 if Convention (Old_Id) /= Convention (New_Id) then
3022 if not Is_Frozen (New_Id) then
3025 elsif Present (Err_Loc)
3026 and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
3027 and then Present (Corresponding_Spec (Err_Loc))
3029 Error_Msg_Name_1 := Chars (New_Id);
3031 Name_Ada + Convention_Id'Pos (Convention (New_Id));
3033 Conformance_Error ("prior declaration for% has convention %!");
3036 Conformance_Error ("calling conventions do not match!");
3041 elsif Is_Formal_Subprogram (Old_Id)
3042 or else Is_Formal_Subprogram (New_Id)
3044 Conformance_Error ("formal subprograms not allowed!");
3049 -- Deal with parameters
3051 -- Note: we use the entity information, rather than going directly
3052 -- to the specification in the tree. This is not only simpler, but
3053 -- absolutely necessary for some cases of conformance tests between
3054 -- operators, where the declaration tree simply does not exist!
3056 Old_Formal := First_Formal (Old_Id);
3057 New_Formal := First_Formal (New_Id);
3059 while Present (Old_Formal) and then Present (New_Formal) loop
3060 if Is_Controlling_Formal (Old_Formal)
3061 and then Is_Controlling_Formal (New_Formal)
3062 and then Skip_Controlling_Formals
3064 goto Skip_Controlling_Formal;
3067 if Ctype = Fully_Conformant then
3069 -- Names must match. Error message is more accurate if we do
3070 -- this before checking that the types of the formals match.
3072 if Chars (Old_Formal) /= Chars (New_Formal) then
3073 Conformance_Error ("name & does not match!", New_Formal);
3075 -- Set error posted flag on new formal as well to stop
3076 -- junk cascaded messages in some cases.
3078 Set_Error_Posted (New_Formal);
3083 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
3084 -- case occurs whenever a subprogram is being renamed and one of its
3085 -- parameters imposes a null exclusion. For example:
3087 -- type T is null record;
3088 -- type Acc_T is access T;
3089 -- subtype Acc_T_Sub is Acc_T;
3091 -- procedure P (Obj : not null Acc_T_Sub); -- itype
3092 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype
3095 Old_Formal_Base := Etype (Old_Formal);
3096 New_Formal_Base := Etype (New_Formal);
3099 Old_Formal_Base := Get_Instance_Of (Old_Formal_Base);
3100 New_Formal_Base := Get_Instance_Of (New_Formal_Base);
3103 Access_Types_Match := Ada_Version >= Ada_05
3105 -- Ensure that this rule is only applied when New_Id is a
3106 -- renaming of Old_Id
3108 and then Nkind (Parent (Parent (New_Id)))
3109 = N_Subprogram_Renaming_Declaration
3110 and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity
3111 and then Present (Entity (Name (Parent (Parent (New_Id)))))
3112 and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
3114 -- Now handle the allowed access-type case
3116 and then Is_Access_Type (Old_Formal_Base)
3117 and then Is_Access_Type (New_Formal_Base)
3118 and then Directly_Designated_Type (Old_Formal_Base) =
3119 Directly_Designated_Type (New_Formal_Base)
3120 and then ((Is_Itype (Old_Formal_Base)
3121 and then Can_Never_Be_Null (Old_Formal_Base))
3123 (Is_Itype (New_Formal_Base)
3124 and then Can_Never_Be_Null (New_Formal_Base)));
3126 -- Types must always match. In the visible part of an instance,
3127 -- usual overloading rules for dispatching operations apply, and
3128 -- we check base types (not the actual subtypes).
3130 if In_Instance_Visible_Part
3131 and then Is_Dispatching_Operation (New_Id)
3133 if not Conforming_Types
3134 (T1 => Base_Type (Etype (Old_Formal)),
3135 T2 => Base_Type (Etype (New_Formal)),
3137 Get_Inst => Get_Inst)
3138 and then not Access_Types_Match
3140 Conformance_Error ("type of & does not match!", New_Formal);
3144 elsif not Conforming_Types
3145 (T1 => Etype (Old_Formal),
3146 T2 => Etype (New_Formal),
3148 Get_Inst => Get_Inst)
3149 and then not Access_Types_Match
3151 Conformance_Error ("type of & does not match!", New_Formal);
3155 -- For mode conformance, mode must match
3157 if Ctype >= Mode_Conformant
3158 and then Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal)
3160 Conformance_Error ("mode of & does not match!", New_Formal);
3164 -- Full conformance checks
3166 if Ctype = Fully_Conformant then
3168 -- We have checked already that names match
3170 if Parameter_Mode (Old_Formal) = E_In_Parameter then
3172 -- Ada 2005 (AI-231): In case of anonymous access types check
3173 -- the null-exclusion and access-to-constant attributes must
3176 if Ada_Version >= Ada_05
3177 and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
3179 (Can_Never_Be_Null (Old_Formal)
3180 /= Can_Never_Be_Null (New_Formal)
3181 or else Is_Access_Constant (Etype (Old_Formal))
3182 /= Is_Access_Constant (Etype (New_Formal)))
3184 -- It is allowed to omit the null-exclusion in case of
3185 -- stream attribute subprograms
3188 TSS_Name : TSS_Name_Type;
3191 Get_Name_String (Chars (New_Id));
3195 (Name_Len - TSS_Name'Length + 1 .. Name_Len));
3197 if TSS_Name /= TSS_Stream_Read
3198 and then TSS_Name /= TSS_Stream_Write
3199 and then TSS_Name /= TSS_Stream_Input
3200 and then TSS_Name /= TSS_Stream_Output
3203 ("type of & does not match!", New_Formal);
3209 -- Check default expressions for in parameters
3212 NewD : constant Boolean :=
3213 Present (Default_Value (New_Formal));
3214 OldD : constant Boolean :=
3215 Present (Default_Value (Old_Formal));
3217 if NewD or OldD then
3219 -- The old default value has been analyzed because the
3220 -- current full declaration will have frozen everything
3221 -- before. The new default values have not been
3222 -- analyzed, so analyze them now before we check for
3227 Analyze_Per_Use_Expression
3228 (Default_Value (New_Formal), Etype (New_Formal));
3232 if not (NewD and OldD)
3233 or else not Fully_Conformant_Expressions
3234 (Default_Value (Old_Formal),
3235 Default_Value (New_Formal))
3238 ("default expression for & does not match!",
3247 -- A couple of special checks for Ada 83 mode. These checks are
3248 -- skipped if either entity is an operator in package Standard.
3249 -- or if either old or new instance is not from the source program.
3251 if Ada_Version = Ada_83
3252 and then Sloc (Old_Id) > Standard_Location
3253 and then Sloc (New_Id) > Standard_Location
3254 and then Comes_From_Source (Old_Id)
3255 and then Comes_From_Source (New_Id)
3258 Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
3259 New_Param : constant Node_Id := Declaration_Node (New_Formal);
3262 -- Explicit IN must be present or absent in both cases. This
3263 -- test is required only in the full conformance case.
3265 if In_Present (Old_Param) /= In_Present (New_Param)
3266 and then Ctype = Fully_Conformant
3269 ("(Ada 83) IN must appear in both declarations",
3274 -- Grouping (use of comma in param lists) must be the same
3275 -- This is where we catch a misconformance like:
3278 -- A : Integer; B : Integer
3280 -- which are represented identically in the tree except
3281 -- for the setting of the flags More_Ids and Prev_Ids.
3283 if More_Ids (Old_Param) /= More_Ids (New_Param)
3284 or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
3287 ("grouping of & does not match!", New_Formal);
3293 -- This label is required when skipping controlling formals
3295 <<Skip_Controlling_Formal>>
3297 Next_Formal (Old_Formal);
3298 Next_Formal (New_Formal);
3301 if Present (Old_Formal) then
3302 Conformance_Error ("too few parameters!");
3305 elsif Present (New_Formal) then
3306 Conformance_Error ("too many parameters!", New_Formal);
3309 end Check_Conformance;
3311 -----------------------
3312 -- Check_Conventions --
3313 -----------------------
3315 procedure Check_Conventions (Typ : Entity_Id) is
3316 procedure Check_Convention
3318 Search_From : Elmt_Id);
3319 -- Verify that the convention of inherited dispatching operation
3320 -- Op is consistent among all subprograms it overrides. In order
3321 -- to minimize the search, Search_From is utilized to designate
3322 -- a specific point in the list rather than iterating over the
3323 -- whole list once more.
3325 ----------------------
3326 -- Check_Convention --
3327 ----------------------
3329 procedure Check_Convention
3331 Search_From : Elmt_Id)
3333 procedure Error_Msg_Operation (Op : Entity_Id);
3334 -- Emit a continuation to an error message depicting the kind,
3335 -- name, convention and source location of subprogram Op.
3337 -------------------------
3338 -- Error_Msg_Operation --
3339 -------------------------
3341 procedure Error_Msg_Operation (Op : Entity_Id) is
3343 Error_Msg_Name_1 := Chars (Op);
3345 -- Error messages of primitive subprograms do not contain a
3346 -- convention attribute since the convention may have been
3347 -- first inherited from a parent subprogram, then changed by
3350 if Comes_From_Source (Op) then
3351 Error_Msg_Sloc := Sloc (Op);
3353 ("\ primitive % defined #", Typ);
3356 Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
3358 if Present (Abstract_Interface_Alias (Op)) then
3359 Error_Msg_Sloc := Sloc (Abstract_Interface_Alias (Op));
3360 Error_Msg_N ("\\overridden operation % with " &
3361 "convention % defined #", Typ);
3363 else pragma Assert (Present (Alias (Op)));
3364 Error_Msg_Sloc := Sloc (Alias (Op));
3365 Error_Msg_N ("\\inherited operation % with " &
3366 "convention % defined #", Typ);
3369 end Error_Msg_Operation;
3373 Prim_Op : Entity_Id;
3374 Prim_Op_Elmt : Elmt_Id;
3376 -- Start of processing for Check_Convention
3379 Prim_Op_Elmt := Next_Elmt (Search_From);
3380 while Present (Prim_Op_Elmt) loop
3381 Prim_Op := Node (Prim_Op_Elmt);
3383 -- A small optimization, skip the predefined dispatching
3384 -- operations since they always have the same convention.
3385 -- Also do not consider abstract primitives since those
3386 -- are left by an erroneous overriding.
3388 if not Is_Predefined_Dispatching_Operation (Prim_Op)
3389 and then not Is_Abstract_Subprogram (Prim_Op)
3390 and then Chars (Prim_Op) = Chars (Op)
3391 and then Type_Conformant (Prim_Op, Op)
3392 and then Convention (Prim_Op) /= Convention (Op)
3395 ("inconsistent conventions in primitive operations", Typ);
3397 Error_Msg_Operation (Op);
3398 Error_Msg_Operation (Prim_Op);
3400 -- Avoid cascading errors
3405 Next_Elmt (Prim_Op_Elmt);
3407 end Check_Convention;
3411 Prim_Op : Entity_Id;
3412 Prim_Op_Elmt : Elmt_Id;
3414 -- Start of processing for Check_Conventions
3417 -- The algorithm checks every overriding dispatching operation
3418 -- against all the corresponding overridden dispatching operations,
3419 -- detecting differences in coventions.
3421 Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ));
3422 while Present (Prim_Op_Elmt) loop
3423 Prim_Op := Node (Prim_Op_Elmt);
3425 -- A small optimization, skip the predefined dispatching operations
3426 -- since they always have the same convention. Also avoid processing
3427 -- of abstract primitives left from an erroneous overriding.
3429 if not Is_Predefined_Dispatching_Operation (Prim_Op)
3430 and then not Is_Abstract_Subprogram (Prim_Op)
3434 Search_From => Prim_Op_Elmt);
3437 Next_Elmt (Prim_Op_Elmt);
3439 end Check_Conventions;
3441 ------------------------------
3442 -- Check_Delayed_Subprogram --
3443 ------------------------------
3445 procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
3448 procedure Possible_Freeze (T : Entity_Id);
3449 -- T is the type of either a formal parameter or of the return type.
3450 -- If T is not yet frozen and needs a delayed freeze, then the
3451 -- subprogram itself must be delayed.
3453 ---------------------
3454 -- Possible_Freeze --
3455 ---------------------
3457 procedure Possible_Freeze (T : Entity_Id) is
3459 if Has_Delayed_Freeze (T)
3460 and then not Is_Frozen (T)
3462 Set_Has_Delayed_Freeze (Designator);
3464 elsif Is_Access_Type (T)
3465 and then Has_Delayed_Freeze (Designated_Type (T))
3466 and then not Is_Frozen (Designated_Type (T))
3468 Set_Has_Delayed_Freeze (Designator);
3470 end Possible_Freeze;
3472 -- Start of processing for Check_Delayed_Subprogram
3475 -- Never need to freeze abstract subprogram
3477 if Ekind (Designator) /= E_Subprogram_Type
3478 and then Is_Abstract_Subprogram (Designator)
3482 -- Need delayed freeze if return type itself needs a delayed
3483 -- freeze and is not yet frozen.
3485 Possible_Freeze (Etype (Designator));
3486 Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
3488 -- Need delayed freeze if any of the formal types themselves need
3489 -- a delayed freeze and are not yet frozen.
3491 F := First_Formal (Designator);
3492 while Present (F) loop
3493 Possible_Freeze (Etype (F));
3494 Possible_Freeze (Base_Type (Etype (F))); -- needed ???
3499 -- Mark functions that return by reference. Note that it cannot be
3500 -- done for delayed_freeze subprograms because the underlying
3501 -- returned type may not be known yet (for private types)
3503 if not Has_Delayed_Freeze (Designator)
3504 and then Expander_Active
3507 Typ : constant Entity_Id := Etype (Designator);
3508 Utyp : constant Entity_Id := Underlying_Type (Typ);
3511 if Is_Inherently_Limited_Type (Typ) then
3512 Set_Returns_By_Ref (Designator);
3514 elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
3515 Set_Returns_By_Ref (Designator);
3519 end Check_Delayed_Subprogram;
3521 ------------------------------------
3522 -- Check_Discriminant_Conformance --
3523 ------------------------------------
3525 procedure Check_Discriminant_Conformance
3530 Old_Discr : Entity_Id := First_Discriminant (Prev);
3531 New_Discr : Node_Id := First (Discriminant_Specifications (N));
3532 New_Discr_Id : Entity_Id;
3533 New_Discr_Type : Entity_Id;
3535 procedure Conformance_Error (Msg : String; N : Node_Id);
3536 -- Post error message for conformance error on given node. Two messages
3537 -- are output. The first points to the previous declaration with a
3538 -- general "no conformance" message. The second is the detailed reason,
3539 -- supplied as Msg. The parameter N provide information for a possible
3540 -- & insertion in the message.
3542 -----------------------
3543 -- Conformance_Error --
3544 -----------------------
3546 procedure Conformance_Error (Msg : String; N : Node_Id) is
3548 Error_Msg_Sloc := Sloc (Prev_Loc);
3549 Error_Msg_N ("not fully conformant with declaration#!", N);
3550 Error_Msg_NE (Msg, N, N);
3551 end Conformance_Error;
3553 -- Start of processing for Check_Discriminant_Conformance
3556 while Present (Old_Discr) and then Present (New_Discr) loop
3558 New_Discr_Id := Defining_Identifier (New_Discr);
3560 -- The subtype mark of the discriminant on the full type has not
3561 -- been analyzed so we do it here. For an access discriminant a new
3564 if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
3566 Access_Definition (N, Discriminant_Type (New_Discr));
3569 Analyze (Discriminant_Type (New_Discr));
3570 New_Discr_Type := Etype (Discriminant_Type (New_Discr));
3573 if not Conforming_Types
3574 (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
3576 Conformance_Error ("type of & does not match!", New_Discr_Id);
3579 -- Treat the new discriminant as an occurrence of the old one,
3580 -- for navigation purposes, and fill in some semantic
3581 -- information, for completeness.
3583 Generate_Reference (Old_Discr, New_Discr_Id, 'r');
3584 Set_Etype (New_Discr_Id, Etype (Old_Discr));
3585 Set_Scope (New_Discr_Id, Scope (Old_Discr));
3590 if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
3591 Conformance_Error ("name & does not match!", New_Discr_Id);
3595 -- Default expressions must match
3598 NewD : constant Boolean :=
3599 Present (Expression (New_Discr));
3600 OldD : constant Boolean :=
3601 Present (Expression (Parent (Old_Discr)));
3604 if NewD or OldD then
3606 -- The old default value has been analyzed and expanded,
3607 -- because the current full declaration will have frozen
3608 -- everything before. The new default values have not been
3609 -- expanded, so expand now to check conformance.
3612 Analyze_Per_Use_Expression
3613 (Expression (New_Discr), New_Discr_Type);
3616 if not (NewD and OldD)
3617 or else not Fully_Conformant_Expressions
3618 (Expression (Parent (Old_Discr)),
3619 Expression (New_Discr))
3623 ("default expression for & does not match!",
3630 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
3632 if Ada_Version = Ada_83 then
3634 Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
3637 -- Grouping (use of comma in param lists) must be the same
3638 -- This is where we catch a misconformance like:
3641 -- A : Integer; B : Integer
3643 -- which are represented identically in the tree except
3644 -- for the setting of the flags More_Ids and Prev_Ids.
3646 if More_Ids (Old_Disc) /= More_Ids (New_Discr)
3647 or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
3650 ("grouping of & does not match!", New_Discr_Id);
3656 Next_Discriminant (Old_Discr);
3660 if Present (Old_Discr) then
3661 Conformance_Error ("too few discriminants!", Defining_Identifier (N));
3664 elsif Present (New_Discr) then
3666 ("too many discriminants!", Defining_Identifier (New_Discr));
3669 end Check_Discriminant_Conformance;
3671 ----------------------------
3672 -- Check_Fully_Conformant --
3673 ----------------------------
3675 procedure Check_Fully_Conformant
3676 (New_Id : Entity_Id;
3678 Err_Loc : Node_Id := Empty)
3683 (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
3684 end Check_Fully_Conformant;
3686 ---------------------------
3687 -- Check_Mode_Conformant --
3688 ---------------------------
3690 procedure Check_Mode_Conformant
3691 (New_Id : Entity_Id;
3693 Err_Loc : Node_Id := Empty;
3694 Get_Inst : Boolean := False)
3700 (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
3701 end Check_Mode_Conformant;
3703 --------------------------------
3704 -- Check_Overriding_Indicator --
3705 --------------------------------
3707 procedure Check_Overriding_Indicator
3709 Overridden_Subp : Entity_Id := Empty)
3715 -- No overriding indicator for literals
3717 if Ekind (Subp) = E_Enumeration_Literal then
3720 elsif Ekind (Subp) = E_Entry then
3721 Decl := Parent (Subp);
3724 Decl := Unit_Declaration_Node (Subp);
3727 if Nkind (Decl) = N_Subprogram_Body
3728 or else Nkind (Decl) = N_Subprogram_Body_Stub
3729 or else Nkind (Decl) = N_Subprogram_Declaration
3730 or else Nkind (Decl) = N_Abstract_Subprogram_Declaration
3731 or else Nkind (Decl) = N_Subprogram_Renaming_Declaration
3733 Spec := Specification (Decl);
3735 elsif Nkind (Decl) = N_Entry_Declaration then
3742 if Present (Overridden_Subp) then
3743 if Must_Not_Override (Spec) then
3744 Error_Msg_Sloc := Sloc (Overridden_Subp);
3746 if Ekind (Subp) = E_Entry then
3747 Error_Msg_NE ("entry & overrides inherited operation #",
3751 Error_Msg_NE ("subprogram & overrides inherited operation #",
3756 -- If Subp is an operator, it may override a predefined operation.
3757 -- In that case overridden_subp is empty because of our implicit
3758 -- representation for predefined operators. We have to check whether
3759 -- the signature of Subp matches that of a predefined operator.
3760 -- Note that first argument provides the name of the operator, and
3761 -- the second argument the signature that may match that of a standard
3764 elsif Nkind (Subp) = N_Defining_Operator_Symbol
3765 and then Must_Not_Override (Spec)
3767 if Operator_Matches_Spec (Subp, Subp) then
3769 ("subprogram & overrides predefined operation ",
3774 if Must_Override (Spec) then
3775 if Ekind (Subp) = E_Entry then
3776 Error_Msg_NE ("entry & is not overriding", Spec, Subp);
3778 elsif Nkind (Subp) = N_Defining_Operator_Symbol then
3779 if not Operator_Matches_Spec (Subp, Subp) then
3781 ("subprogram & is not overriding", Spec, Subp);
3785 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
3789 end Check_Overriding_Indicator;
3795 procedure Check_Returns
3799 Proc : Entity_Id := Empty)
3803 procedure Check_Statement_Sequence (L : List_Id);
3804 -- Internal recursive procedure to check a list of statements for proper
3805 -- termination by a return statement (or a transfer of control or a
3806 -- compound statement that is itself internally properly terminated).
3808 ------------------------------
3809 -- Check_Statement_Sequence --
3810 ------------------------------
3812 procedure Check_Statement_Sequence (L : List_Id) is
3816 Raise_Exception_Call : Boolean;
3817 -- Set True if statement sequence terminated by Raise_Exception call
3818 -- or a Reraise_Occurrence call.
3821 Raise_Exception_Call := False;
3823 -- Get last real statement
3825 Last_Stm := Last (L);
3827 -- Don't count pragmas
3829 while Nkind (Last_Stm) = N_Pragma
3831 -- Don't count call to SS_Release (can happen after Raise_Exception)
3834 (Nkind (Last_Stm) = N_Procedure_Call_Statement
3836 Nkind (Name (Last_Stm)) = N_Identifier
3838 Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
3840 -- Don't count exception junk
3843 ((Nkind (Last_Stm) = N_Goto_Statement
3844 or else Nkind (Last_Stm) = N_Label
3845 or else Nkind (Last_Stm) = N_Object_Declaration)
3846 and then Exception_Junk (Last_Stm))
3851 -- Here we have the "real" last statement
3853 Kind := Nkind (Last_Stm);
3855 -- Transfer of control, OK. Note that in the No_Return procedure
3856 -- case, we already diagnosed any explicit return statements, so
3857 -- we can treat them as OK in this context.
3859 if Is_Transfer (Last_Stm) then
3862 -- Check cases of explicit non-indirect procedure calls
3864 elsif Kind = N_Procedure_Call_Statement
3865 and then Is_Entity_Name (Name (Last_Stm))
3867 -- Check call to Raise_Exception procedure which is treated
3868 -- specially, as is a call to Reraise_Occurrence.
3870 -- We suppress the warning in these cases since it is likely that
3871 -- the programmer really does not expect to deal with the case
3872 -- of Null_Occurrence, and thus would find a warning about a
3873 -- missing return curious, and raising Program_Error does not
3874 -- seem such a bad behavior if this does occur.
3876 -- Note that in the Ada 2005 case for Raise_Exception, the actual
3877 -- behavior will be to raise Constraint_Error (see AI-329).
3879 if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
3881 Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
3883 Raise_Exception_Call := True;
3885 -- For Raise_Exception call, test first argument, if it is
3886 -- an attribute reference for a 'Identity call, then we know
3887 -- that the call cannot possibly return.
3890 Arg : constant Node_Id :=
3891 Original_Node (First_Actual (Last_Stm));
3893 if Nkind (Arg) = N_Attribute_Reference
3894 and then Attribute_Name (Arg) = Name_Identity
3901 -- If statement, need to look inside if there is an else and check
3902 -- each constituent statement sequence for proper termination.
3904 elsif Kind = N_If_Statement
3905 and then Present (Else_Statements (Last_Stm))
3907 Check_Statement_Sequence (Then_Statements (Last_Stm));
3908 Check_Statement_Sequence (Else_Statements (Last_Stm));
3910 if Present (Elsif_Parts (Last_Stm)) then
3912 Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
3915 while Present (Elsif_Part) loop
3916 Check_Statement_Sequence (Then_Statements (Elsif_Part));
3924 -- Case statement, check each case for proper termination
3926 elsif Kind = N_Case_Statement then
3931 Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
3932 while Present (Case_Alt) loop
3933 Check_Statement_Sequence (Statements (Case_Alt));
3934 Next_Non_Pragma (Case_Alt);
3940 -- Block statement, check its handled sequence of statements
3942 elsif Kind = N_Block_Statement then
3948 (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
3957 -- Loop statement. If there is an iteration scheme, we can definitely
3958 -- fall out of the loop. Similarly if there is an exit statement, we
3959 -- can fall out. In either case we need a following return.
3961 elsif Kind = N_Loop_Statement then
3962 if Present (Iteration_Scheme (Last_Stm))
3963 or else Has_Exit (Entity (Identifier (Last_Stm)))
3967 -- A loop with no exit statement or iteration scheme if either
3968 -- an inifite loop, or it has some other exit (raise/return).
3969 -- In either case, no warning is required.
3975 -- Timed entry call, check entry call and delay alternatives
3977 -- Note: in expanded code, the timed entry call has been converted
3978 -- to a set of expanded statements on which the check will work
3979 -- correctly in any case.
3981 elsif Kind = N_Timed_Entry_Call then
3983 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
3984 DCA : constant Node_Id := Delay_Alternative (Last_Stm);
3987 -- If statement sequence of entry call alternative is missing,
3988 -- then we can definitely fall through, and we post the error
3989 -- message on the entry call alternative itself.
3991 if No (Statements (ECA)) then
3994 -- If statement sequence of delay alternative is missing, then
3995 -- we can definitely fall through, and we post the error
3996 -- message on the delay alternative itself.
3998 -- Note: if both ECA and DCA are missing the return, then we
3999 -- post only one message, should be enough to fix the bugs.
4000 -- If not we will get a message next time on the DCA when the
4003 elsif No (Statements (DCA)) then
4006 -- Else check both statement sequences
4009 Check_Statement_Sequence (Statements (ECA));
4010 Check_Statement_Sequence (Statements (DCA));
4015 -- Conditional entry call, check entry call and else part
4017 -- Note: in expanded code, the conditional entry call has been
4018 -- converted to a set of expanded statements on which the check
4019 -- will work correctly in any case.
4021 elsif Kind = N_Conditional_Entry_Call then
4023 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
4026 -- If statement sequence of entry call alternative is missing,
4027 -- then we can definitely fall through, and we post the error
4028 -- message on the entry call alternative itself.
4030 if No (Statements (ECA)) then
4033 -- Else check statement sequence and else part
4036 Check_Statement_Sequence (Statements (ECA));
4037 Check_Statement_Sequence (Else_Statements (Last_Stm));
4043 -- If we fall through, issue appropriate message
4046 if not Raise_Exception_Call then
4048 ("?RETURN statement missing following this statement",
4051 ("\?Program_Error may be raised at run time",
4055 -- Note: we set Err even though we have not issued a warning
4056 -- because we still have a case of a missing return. This is
4057 -- an extremely marginal case, probably will never be noticed
4058 -- but we might as well get it right.
4062 -- Otherwise we have the case of a procedure marked No_Return
4066 ("?implied return after this statement will raise Program_Error",
4069 ("?procedure & is marked as No_Return",
4073 RE : constant Node_Id :=
4074 Make_Raise_Program_Error (Sloc (Last_Stm),
4075 Reason => PE_Implicit_Return);
4077 Insert_After (Last_Stm, RE);
4081 end Check_Statement_Sequence;
4083 -- Start of processing for Check_Returns
4087 Check_Statement_Sequence (Statements (HSS));
4089 if Present (Exception_Handlers (HSS)) then
4090 Handler := First_Non_Pragma (Exception_Handlers (HSS));
4091 while Present (Handler) loop
4092 Check_Statement_Sequence (Statements (Handler));
4093 Next_Non_Pragma (Handler);
4098 ----------------------------
4099 -- Check_Subprogram_Order --
4100 ----------------------------
4102 procedure Check_Subprogram_Order (N : Node_Id) is
4104 function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
4105 -- This is used to check if S1 > S2 in the sense required by this
4106 -- test, for example nameab < namec, but name2 < name10.
4108 -----------------------------
4109 -- Subprogram_Name_Greater --
4110 -----------------------------
4112 function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
4117 -- Remove trailing numeric parts
4120 while S1 (L1) in '0' .. '9' loop
4125 while S2 (L2) in '0' .. '9' loop
4129 -- If non-numeric parts non-equal, that's decisive
4131 if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
4134 elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
4137 -- If non-numeric parts equal, compare suffixed numeric parts. Note
4138 -- that a missing suffix is treated as numeric zero in this test.
4142 while L1 < S1'Last loop
4144 N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
4148 while L2 < S2'Last loop
4150 N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
4155 end Subprogram_Name_Greater;
4157 -- Start of processing for Check_Subprogram_Order
4160 -- Check body in alpha order if this is option
4163 and then Style_Check_Order_Subprograms
4164 and then Nkind (N) = N_Subprogram_Body
4165 and then Comes_From_Source (N)
4166 and then In_Extended_Main_Source_Unit (N)
4170 renames Scope_Stack.Table
4171 (Scope_Stack.Last).Last_Subprogram_Name;
4173 Body_Id : constant Entity_Id :=
4174 Defining_Entity (Specification (N));
4177 Get_Decoded_Name_String (Chars (Body_Id));
4180 if Subprogram_Name_Greater
4181 (LSN.all, Name_Buffer (1 .. Name_Len))
4183 Style.Subprogram_Not_In_Alpha_Order (Body_Id);
4189 LSN := new String'(Name_Buffer (1 .. Name_Len));
4192 end Check_Subprogram_Order;
4194 ------------------------------
4195 -- Check_Subtype_Conformant --
4196 ------------------------------
4198 procedure Check_Subtype_Conformant
4199 (New_Id : Entity_Id;
4201 Err_Loc : Node_Id := Empty)
4206 (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc);
4207 end Check_Subtype_Conformant;
4209 ---------------------------
4210 -- Check_Type_Conformant --
4211 ---------------------------
4213 procedure Check_Type_Conformant
4214 (New_Id : Entity_Id;
4216 Err_Loc : Node_Id := Empty)
4221 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
4222 end Check_Type_Conformant;
4224 ----------------------
4225 -- Conforming_Types --
4226 ----------------------
4228 function Conforming_Types
4231 Ctype : Conformance_Type;
4232 Get_Inst : Boolean := False) return Boolean
4234 Type_1 : Entity_Id := T1;
4235 Type_2 : Entity_Id := T2;
4236 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
4238 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
4239 -- If neither T1 nor T2 are generic actual types, or if they are
4240 -- in different scopes (e.g. parent and child instances), then verify
4241 -- that the base types are equal. Otherwise T1 and T2 must be
4242 -- on the same subtype chain. The whole purpose of this procedure
4243 -- is to prevent spurious ambiguities in an instantiation that may
4244 -- arise if two distinct generic types are instantiated with the
4247 ----------------------
4248 -- Base_Types_Match --
4249 ----------------------
4251 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
4256 elsif Base_Type (T1) = Base_Type (T2) then
4258 -- The following is too permissive. A more precise test must
4259 -- check that the generic actual is an ancestor subtype of the
4262 return not Is_Generic_Actual_Type (T1)
4263 or else not Is_Generic_Actual_Type (T2)
4264 or else Scope (T1) /= Scope (T2);
4266 -- In some cases a type imported through a limited_with clause,
4267 -- and its non-limited view are both visible, for example in an
4268 -- anonymous access_to_classwide type in a formal. Both entities
4269 -- designate the same type.
4271 elsif From_With_Type (T1)
4272 and then Ekind (T1) = E_Incomplete_Type
4273 and then T2 = Non_Limited_View (T1)
4277 elsif From_With_Type (T2)
4278 and then Ekind (T2) = E_Incomplete_Type
4279 and then T1 = Non_Limited_View (T2)
4286 end Base_Types_Match;
4288 -- Start of processing for Conforming_Types
4291 -- The context is an instance association for a formal
4292 -- access-to-subprogram type; the formal parameter types require
4293 -- mapping because they may denote other formal parameters of the
4297 Type_1 := Get_Instance_Of (T1);
4298 Type_2 := Get_Instance_Of (T2);
4301 -- First see if base types match
4303 if Base_Types_Match (Type_1, Type_2) then
4304 return Ctype <= Mode_Conformant
4305 or else Subtypes_Statically_Match (Type_1, Type_2);
4307 elsif Is_Incomplete_Or_Private_Type (Type_1)
4308 and then Present (Full_View (Type_1))
4309 and then Base_Types_Match (Full_View (Type_1), Type_2)
4311 return Ctype <= Mode_Conformant
4312 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
4314 elsif Ekind (Type_2) = E_Incomplete_Type
4315 and then Present (Full_View (Type_2))
4316 and then Base_Types_Match (Type_1, Full_View (Type_2))
4318 return Ctype <= Mode_Conformant
4319 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
4321 elsif Is_Private_Type (Type_2)
4322 and then In_Instance
4323 and then Present (Full_View (Type_2))
4324 and then Base_Types_Match (Type_1, Full_View (Type_2))
4326 return Ctype <= Mode_Conformant
4327 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
4330 -- Ada 2005 (AI-254): Anonymous access to subprogram types must be
4331 -- treated recursively because they carry a signature.
4333 Are_Anonymous_Access_To_Subprogram_Types :=
4334 Ekind (Type_1) = Ekind (Type_2)
4336 (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
4338 Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
4340 -- Test anonymous access type case. For this case, static subtype
4341 -- matching is required for mode conformance (RM 6.3.1(15))
4343 if (Ekind (Type_1) = E_Anonymous_Access_Type
4344 and then Ekind (Type_2) = E_Anonymous_Access_Type)
4345 or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
4348 Desig_1 : Entity_Id;
4349 Desig_2 : Entity_Id;
4352 Desig_1 := Directly_Designated_Type (Type_1);
4354 -- An access parameter can designate an incomplete type
4355 -- If the incomplete type is the limited view of a type
4356 -- from a limited_with_clause, check whether the non-limited
4357 -- view is available.
4359 if Ekind (Desig_1) = E_Incomplete_Type then
4360 if Present (Full_View (Desig_1)) then
4361 Desig_1 := Full_View (Desig_1);
4363 elsif Present (Non_Limited_View (Desig_1)) then
4364 Desig_1 := Non_Limited_View (Desig_1);
4368 Desig_2 := Directly_Designated_Type (Type_2);
4370 if Ekind (Desig_2) = E_Incomplete_Type then
4371 if Present (Full_View (Desig_2)) then
4372 Desig_2 := Full_View (Desig_2);
4373 elsif Present (Non_Limited_View (Desig_2)) then
4374 Desig_2 := Non_Limited_View (Desig_2);
4378 -- The context is an instance association for a formal
4379 -- access-to-subprogram type; formal access parameter designated
4380 -- types require mapping because they may denote other formal
4381 -- parameters of the generic unit.
4384 Desig_1 := Get_Instance_Of (Desig_1);
4385 Desig_2 := Get_Instance_Of (Desig_2);
4388 -- It is possible for a Class_Wide_Type to be introduced for an
4389 -- incomplete type, in which case there is a separate class_ wide
4390 -- type for the full view. The types conform if their Etypes
4391 -- conform, i.e. one may be the full view of the other. This can
4392 -- only happen in the context of an access parameter, other uses
4393 -- of an incomplete Class_Wide_Type are illegal.
4395 if Is_Class_Wide_Type (Desig_1)
4396 and then Is_Class_Wide_Type (Desig_2)
4400 (Etype (Base_Type (Desig_1)),
4401 Etype (Base_Type (Desig_2)), Ctype);
4403 elsif Are_Anonymous_Access_To_Subprogram_Types then
4404 if Ada_Version < Ada_05 then
4405 return Ctype = Type_Conformant
4407 Subtypes_Statically_Match (Desig_1, Desig_2);
4409 -- We must check the conformance of the signatures themselves
4413 Conformant : Boolean;
4416 (Desig_1, Desig_2, Ctype, False, Conformant);
4422 return Base_Type (Desig_1) = Base_Type (Desig_2)
4423 and then (Ctype = Type_Conformant
4425 Subtypes_Statically_Match (Desig_1, Desig_2));
4429 -- Otherwise definitely no match
4432 if ((Ekind (Type_1) = E_Anonymous_Access_Type
4433 and then Is_Access_Type (Type_2))
4434 or else (Ekind (Type_2) = E_Anonymous_Access_Type
4435 and then Is_Access_Type (Type_1)))
4438 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
4440 May_Hide_Profile := True;
4445 end Conforming_Types;
4447 --------------------------
4448 -- Create_Extra_Formals --
4449 --------------------------
4451 procedure Create_Extra_Formals (E : Entity_Id) is
4453 First_Extra : Entity_Id := Empty;
4454 Last_Extra : Entity_Id;
4455 Formal_Type : Entity_Id;
4456 P_Formal : Entity_Id := Empty;
4458 function Add_Extra_Formal
4459 (Assoc_Entity : Entity_Id;
4462 Suffix : String) return Entity_Id;
4463 -- Add an extra formal to the current list of formals and extra formals.
4464 -- The extra formal is added to the end of the list of extra formals,
4465 -- and also returned as the result. These formals are always of mode IN.
4466 -- The new formal has the type Typ, is declared in Scope, and its name
4467 -- is given by a concatenation of the name of Assoc_Entity and Suffix.
4469 ----------------------
4470 -- Add_Extra_Formal --
4471 ----------------------
4473 function Add_Extra_Formal
4474 (Assoc_Entity : Entity_Id;
4477 Suffix : String) return Entity_Id
4479 EF : constant Entity_Id :=
4480 Make_Defining_Identifier (Sloc (Assoc_Entity),
4481 Chars => New_External_Name (Chars (Assoc_Entity),
4485 -- A little optimization. Never generate an extra formal for the
4486 -- _init operand of an initialization procedure, since it could
4489 if Chars (Formal) = Name_uInit then
4493 Set_Ekind (EF, E_In_Parameter);
4494 Set_Actual_Subtype (EF, Typ);
4495 Set_Etype (EF, Typ);
4496 Set_Scope (EF, Scope);
4497 Set_Mechanism (EF, Default_Mechanism);
4498 Set_Formal_Validity (EF);
4500 if No (First_Extra) then
4502 Set_Extra_Formals (Scope, First_Extra);
4505 if Present (Last_Extra) then
4506 Set_Extra_Formal (Last_Extra, EF);
4512 end Add_Extra_Formal;
4514 -- Start of processing for Create_Extra_Formals
4517 -- We never generate extra formals if expansion is not active
4518 -- because we don't need them unless we are generating code.
4520 if not Expander_Active then
4524 -- If this is a derived subprogram then the subtypes of the parent
4525 -- subprogram's formal parameters will be used to to determine the need
4526 -- for extra formals.
4528 if Is_Overloadable (E) and then Present (Alias (E)) then
4529 P_Formal := First_Formal (Alias (E));
4532 Last_Extra := Empty;
4533 Formal := First_Formal (E);
4534 while Present (Formal) loop
4535 Last_Extra := Formal;
4536 Next_Formal (Formal);
4539 -- If Extra_formals were already created, don't do it again. This
4540 -- situation may arise for subprogram types created as part of
4541 -- dispatching calls (see Expand_Dispatching_Call)
4543 if Present (Last_Extra) and then
4544 Present (Extra_Formal (Last_Extra))
4549 Formal := First_Formal (E);
4551 while Present (Formal) loop
4553 -- Create extra formal for supporting the attribute 'Constrained.
4554 -- The case of a private type view without discriminants also
4555 -- requires the extra formal if the underlying type has defaulted
4558 if Ekind (Formal) /= E_In_Parameter then
4559 if Present (P_Formal) then
4560 Formal_Type := Etype (P_Formal);
4562 Formal_Type := Etype (Formal);
4565 -- Do not produce extra formals for Unchecked_Union parameters.
4566 -- Jump directly to the end of the loop.
4568 if Is_Unchecked_Union (Base_Type (Formal_Type)) then
4569 goto Skip_Extra_Formal_Generation;
4572 if not Has_Discriminants (Formal_Type)
4573 and then Ekind (Formal_Type) in Private_Kind
4574 and then Present (Underlying_Type (Formal_Type))
4576 Formal_Type := Underlying_Type (Formal_Type);
4579 if Has_Discriminants (Formal_Type)
4580 and then not Is_Constrained (Formal_Type)
4581 and then not Is_Indefinite_Subtype (Formal_Type)
4583 Set_Extra_Constrained
4586 (Formal, Standard_Boolean, Scope (Formal), "F"));
4590 -- Create extra formal for supporting accessibility checking
4592 -- This is suppressed if we specifically suppress accessibility
4593 -- checks at the package level for either the subprogram, or the
4594 -- package in which it resides. However, we do not suppress it
4595 -- simply if the scope has accessibility checks suppressed, since
4596 -- this could cause trouble when clients are compiled with a
4597 -- different suppression setting. The explicit checks at the
4598 -- package level are safe from this point of view.
4600 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
4602 (Explicit_Suppress (E, Accessibility_Check)
4604 Explicit_Suppress (Scope (E), Accessibility_Check))
4607 or else Present (Extra_Accessibility (P_Formal)))
4609 -- Temporary kludge: for now we avoid creating the extra formal
4610 -- for access parameters of protected operations because of
4611 -- problem with the case of internal protected calls. ???
4613 if Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Definition
4614 and then Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Body
4616 Set_Extra_Accessibility
4619 (Formal, Standard_Natural, Scope (Formal), "F"));
4623 -- This label is required when skipping extra formal generation for
4624 -- Unchecked_Union parameters.
4626 <<Skip_Extra_Formal_Generation>>
4628 if Present (P_Formal) then
4629 Next_Formal (P_Formal);
4632 Next_Formal (Formal);
4635 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
4636 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
4638 if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function (E) then
4640 Result_Subt : constant Entity_Id := Etype (E);
4642 Discard : Entity_Id;
4643 pragma Warnings (Off, Discard);
4646 -- In the case of functions with unconstrained result subtypes,
4647 -- add a 3-state formal indicating whether the return object is
4648 -- allocated by the caller (0), or should be allocated by the
4649 -- callee on the secondary stack (1) or in the global heap (2).
4650 -- For the moment we just use Natural for the type of this formal.
4651 -- Note that this formal isn't needed in the case where the
4652 -- result subtype is constrained.
4654 if not Is_Constrained (Result_Subt) then
4657 (E, Standard_Natural,
4658 E, BIP_Formal_Suffix (BIP_Alloc_Form));
4661 -- In the case of functions whose result type has controlled
4662 -- parts, we have an extra formal of type
4663 -- System.Finalization_Implementation.Finalizable_Ptr_Ptr. That
4664 -- is, we are passing a pointer to a finalization list (which is
4665 -- itself a pointer). This extra formal is then passed along to
4666 -- Move_Final_List in case of successful completion of a return
4667 -- statement. We cannot pass an 'in out' parameter, because we
4668 -- need to update the finalization list during an abort-deferred
4669 -- region, rather than using copy-back after the function
4670 -- returns. This is true even if we are able to get away with
4671 -- having 'in out' parameters, which are normally illegal for
4674 if Is_Controlled (Result_Subt)
4675 or else Has_Controlled_Component (Result_Subt)
4679 (E, RTE (RE_Finalizable_Ptr_Ptr),
4680 E, BIP_Formal_Suffix (BIP_Final_List));
4683 -- If the result type contains tasks, we have two extra formals:
4684 -- the master of the tasks to be created, and the caller's
4685 -- activation chain.
4687 if Has_Task (Result_Subt) then
4690 (E, RTE (RE_Master_Id),
4691 E, BIP_Formal_Suffix (BIP_Master));
4694 (E, RTE (RE_Activation_Chain_Access),
4695 E, BIP_Formal_Suffix (BIP_Activation_Chain));
4698 -- All build-in-place functions get an extra formal that will be
4699 -- passed the address of the return object within the caller.
4702 Formal_Type : constant Entity_Id :=
4704 (E_Anonymous_Access_Type, E,
4705 Scope_Id => Scope (E));
4707 Set_Directly_Designated_Type (Formal_Type, Result_Subt);
4708 Set_Etype (Formal_Type, Formal_Type);
4709 Init_Size_Align (Formal_Type);
4710 Set_Depends_On_Private
4711 (Formal_Type, Has_Private_Component (Formal_Type));
4712 Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
4713 Set_Is_Access_Constant (Formal_Type, False);
4715 -- Ada 2005 (AI-50217): Propagate the attribute that indicates
4716 -- the designated type comes from the limited view (for
4717 -- back-end purposes).
4719 Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt));
4721 Layout_Type (Formal_Type);
4725 (E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access));
4729 end Create_Extra_Formals;
4731 -----------------------------
4732 -- Enter_Overloaded_Entity --
4733 -----------------------------
4735 procedure Enter_Overloaded_Entity (S : Entity_Id) is
4736 E : Entity_Id := Current_Entity_In_Scope (S);
4737 C_E : Entity_Id := Current_Entity (S);
4741 Set_Has_Homonym (E);
4742 Set_Has_Homonym (S);
4745 Set_Is_Immediately_Visible (S);
4746 Set_Scope (S, Current_Scope);
4748 -- Chain new entity if front of homonym in current scope, so that
4749 -- homonyms are contiguous.
4754 while Homonym (C_E) /= E loop
4755 C_E := Homonym (C_E);
4758 Set_Homonym (C_E, S);
4762 Set_Current_Entity (S);
4767 Append_Entity (S, Current_Scope);
4768 Set_Public_Status (S);
4770 if Debug_Flag_E then
4771 Write_Str ("New overloaded entity chain: ");
4772 Write_Name (Chars (S));
4775 while Present (E) loop
4776 Write_Str (" "); Write_Int (Int (E));
4783 -- Generate warning for hiding
4786 and then Comes_From_Source (S)
4787 and then In_Extended_Main_Source_Unit (S)
4794 -- Warn unless genuine overloading
4796 if (not Is_Overloadable (E) or else Subtype_Conformant (E, S))
4797 and then (Is_Immediately_Visible (E)
4799 Is_Potentially_Use_Visible (S))
4801 Error_Msg_Sloc := Sloc (E);
4802 Error_Msg_N ("declaration of & hides one#?", S);
4806 end Enter_Overloaded_Entity;
4808 -----------------------------
4809 -- Find_Corresponding_Spec --
4810 -----------------------------
4812 function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is
4813 Spec : constant Node_Id := Specification (N);
4814 Designator : constant Entity_Id := Defining_Entity (Spec);
4819 E := Current_Entity (Designator);
4821 while Present (E) loop
4823 -- We are looking for a matching spec. It must have the same scope,
4824 -- and the same name, and either be type conformant, or be the case
4825 -- of a library procedure spec and its body (which belong to one
4826 -- another regardless of whether they are type conformant or not).
4828 if Scope (E) = Current_Scope then
4829 if Current_Scope = Standard_Standard
4830 or else (Ekind (E) = Ekind (Designator)
4831 and then Type_Conformant (E, Designator))
4833 -- Within an instantiation, we know that spec and body are
4834 -- subtype conformant, because they were subtype conformant
4835 -- in the generic. We choose the subtype-conformant entity
4836 -- here as well, to resolve spurious ambiguities in the
4837 -- instance that were not present in the generic (i.e. when
4838 -- two different types are given the same actual). If we are
4839 -- looking for a spec to match a body, full conformance is
4843 Set_Convention (Designator, Convention (E));
4845 if Nkind (N) = N_Subprogram_Body
4846 and then Present (Homonym (E))
4847 and then not Fully_Conformant (E, Designator)
4851 elsif not Subtype_Conformant (E, Designator) then
4856 if not Has_Completion (E) then
4858 if Nkind (N) /= N_Subprogram_Body_Stub then
4859 Set_Corresponding_Spec (N, E);
4862 Set_Has_Completion (E);
4865 elsif Nkind (Parent (N)) = N_Subunit then
4867 -- If this is the proper body of a subunit, the completion
4868 -- flag is set when analyzing the stub.
4872 -- If body already exists, this is an error unless the
4873 -- previous declaration is the implicit declaration of
4874 -- a derived subprogram, or this is a spurious overloading
4877 elsif No (Alias (E))
4878 and then not Is_Intrinsic_Subprogram (E)
4879 and then not In_Instance
4881 Error_Msg_Sloc := Sloc (E);
4882 if Is_Imported (E) then
4884 ("body not allowed for imported subprogram & declared#",
4887 Error_Msg_NE ("duplicate body for & declared#", N, E);
4891 elsif Is_Child_Unit (E)
4893 Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
4895 Nkind (Parent (Unit_Declaration_Node (Designator)))
4896 = N_Compilation_Unit
4899 -- Child units cannot be overloaded, so a conformance mismatch
4900 -- between body and a previous spec is an error.
4903 ("body of child unit does not match previous declaration", N);
4911 -- On exit, we know that no previous declaration of subprogram exists
4914 end Find_Corresponding_Spec;
4916 ----------------------
4917 -- Fully_Conformant --
4918 ----------------------
4920 function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
4923 Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
4925 end Fully_Conformant;
4927 ----------------------------------
4928 -- Fully_Conformant_Expressions --
4929 ----------------------------------
4931 function Fully_Conformant_Expressions
4932 (Given_E1 : Node_Id;
4933 Given_E2 : Node_Id) return Boolean
4935 E1 : constant Node_Id := Original_Node (Given_E1);
4936 E2 : constant Node_Id := Original_Node (Given_E2);
4937 -- We always test conformance on original nodes, since it is possible
4938 -- for analysis and/or expansion to make things look as though they
4939 -- conform when they do not, e.g. by converting 1+2 into 3.
4941 function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
4942 renames Fully_Conformant_Expressions;
4944 function FCL (L1, L2 : List_Id) return Boolean;
4945 -- Compare elements of two lists for conformance. Elements have to
4946 -- be conformant, and actuals inserted as default parameters do not
4947 -- match explicit actuals with the same value.
4949 function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
4950 -- Compare an operator node with a function call
4956 function FCL (L1, L2 : List_Id) return Boolean is
4960 if L1 = No_List then
4966 if L2 = No_List then
4972 -- Compare two lists, skipping rewrite insertions (we want to
4973 -- compare the original trees, not the expanded versions!)
4976 if Is_Rewrite_Insertion (N1) then
4978 elsif Is_Rewrite_Insertion (N2) then
4984 elsif not FCE (N1, N2) then
4997 function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
4998 Actuals : constant List_Id := Parameter_Associations (Call_Node);
5003 or else Entity (Op_Node) /= Entity (Name (Call_Node))
5008 Act := First (Actuals);
5010 if Nkind (Op_Node) in N_Binary_Op then
5012 if not FCE (Left_Opnd (Op_Node), Act) then
5019 return Present (Act)
5020 and then FCE (Right_Opnd (Op_Node), Act)
5021 and then No (Next (Act));
5025 -- Start of processing for Fully_Conformant_Expressions
5028 -- Non-conformant if paren count does not match. Note: if some idiot
5029 -- complains that we don't do this right for more than 3 levels of
5030 -- parentheses, they will be treated with the respect they deserve :-)
5032 if Paren_Count (E1) /= Paren_Count (E2) then
5035 -- If same entities are referenced, then they are conformant even if
5036 -- they have different forms (RM 8.3.1(19-20)).
5038 elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
5039 if Present (Entity (E1)) then
5040 return Entity (E1) = Entity (E2)
5041 or else (Chars (Entity (E1)) = Chars (Entity (E2))
5042 and then Ekind (Entity (E1)) = E_Discriminant
5043 and then Ekind (Entity (E2)) = E_In_Parameter);
5045 elsif Nkind (E1) = N_Expanded_Name
5046 and then Nkind (E2) = N_Expanded_Name
5047 and then Nkind (Selector_Name (E1)) = N_Character_Literal
5048 and then Nkind (Selector_Name (E2)) = N_Character_Literal
5050 return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
5053 -- Identifiers in component associations don't always have
5054 -- entities, but their names must conform.
5056 return Nkind (E1) = N_Identifier
5057 and then Nkind (E2) = N_Identifier
5058 and then Chars (E1) = Chars (E2);
5061 elsif Nkind (E1) = N_Character_Literal
5062 and then Nkind (E2) = N_Expanded_Name
5064 return Nkind (Selector_Name (E2)) = N_Character_Literal
5065 and then Chars (E1) = Chars (Selector_Name (E2));
5067 elsif Nkind (E2) = N_Character_Literal
5068 and then Nkind (E1) = N_Expanded_Name
5070 return Nkind (Selector_Name (E1)) = N_Character_Literal
5071 and then Chars (E2) = Chars (Selector_Name (E1));
5073 elsif Nkind (E1) in N_Op
5074 and then Nkind (E2) = N_Function_Call
5076 return FCO (E1, E2);
5078 elsif Nkind (E2) in N_Op
5079 and then Nkind (E1) = N_Function_Call
5081 return FCO (E2, E1);
5083 -- Otherwise we must have the same syntactic entity
5085 elsif Nkind (E1) /= Nkind (E2) then
5088 -- At this point, we specialize by node type
5095 FCL (Expressions (E1), Expressions (E2))
5096 and then FCL (Component_Associations (E1),
5097 Component_Associations (E2));
5100 if Nkind (Expression (E1)) = N_Qualified_Expression
5102 Nkind (Expression (E2)) = N_Qualified_Expression
5104 return FCE (Expression (E1), Expression (E2));
5106 -- Check that the subtype marks and any constraints
5111 Indic1 : constant Node_Id := Expression (E1);
5112 Indic2 : constant Node_Id := Expression (E2);
5117 if Nkind (Indic1) /= N_Subtype_Indication then
5119 Nkind (Indic2) /= N_Subtype_Indication
5120 and then Entity (Indic1) = Entity (Indic2);
5122 elsif Nkind (Indic2) /= N_Subtype_Indication then
5124 Nkind (Indic1) /= N_Subtype_Indication
5125 and then Entity (Indic1) = Entity (Indic2);
5128 if Entity (Subtype_Mark (Indic1)) /=
5129 Entity (Subtype_Mark (Indic2))
5134 Elt1 := First (Constraints (Constraint (Indic1)));
5135 Elt2 := First (Constraints (Constraint (Indic2)));
5137 while Present (Elt1) and then Present (Elt2) loop
5138 if not FCE (Elt1, Elt2) then
5151 when N_Attribute_Reference =>
5153 Attribute_Name (E1) = Attribute_Name (E2)
5154 and then FCL (Expressions (E1), Expressions (E2));
5158 Entity (E1) = Entity (E2)
5159 and then FCE (Left_Opnd (E1), Left_Opnd (E2))
5160 and then FCE (Right_Opnd (E1), Right_Opnd (E2));
5162 when N_And_Then | N_Or_Else | N_Membership_Test =>
5164 FCE (Left_Opnd (E1), Left_Opnd (E2))
5166 FCE (Right_Opnd (E1), Right_Opnd (E2));
5168 when N_Character_Literal =>
5170 Char_Literal_Value (E1) = Char_Literal_Value (E2);
5172 when N_Component_Association =>
5174 FCL (Choices (E1), Choices (E2))
5175 and then FCE (Expression (E1), Expression (E2));
5177 when N_Conditional_Expression =>
5179 FCL (Expressions (E1), Expressions (E2));
5181 when N_Explicit_Dereference =>
5183 FCE (Prefix (E1), Prefix (E2));
5185 when N_Extension_Aggregate =>
5187 FCL (Expressions (E1), Expressions (E2))
5188 and then Null_Record_Present (E1) =
5189 Null_Record_Present (E2)
5190 and then FCL (Component_Associations (E1),
5191 Component_Associations (E2));
5193 when N_Function_Call =>
5195 FCE (Name (E1), Name (E2))
5196 and then FCL (Parameter_Associations (E1),
5197 Parameter_Associations (E2));
5199 when N_Indexed_Component =>
5201 FCE (Prefix (E1), Prefix (E2))
5202 and then FCL (Expressions (E1), Expressions (E2));
5204 when N_Integer_Literal =>
5205 return (Intval (E1) = Intval (E2));
5210 when N_Operator_Symbol =>
5212 Chars (E1) = Chars (E2);
5214 when N_Others_Choice =>
5217 when N_Parameter_Association =>
5219 Chars (Selector_Name (E1)) = Chars (Selector_Name (E2))
5220 and then FCE (Explicit_Actual_Parameter (E1),
5221 Explicit_Actual_Parameter (E2));
5223 when N_Qualified_Expression =>
5225 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
5226 and then FCE (Expression (E1), Expression (E2));
5230 FCE (Low_Bound (E1), Low_Bound (E2))
5231 and then FCE (High_Bound (E1), High_Bound (E2));
5233 when N_Real_Literal =>
5234 return (Realval (E1) = Realval (E2));
5236 when N_Selected_Component =>
5238 FCE (Prefix (E1), Prefix (E2))
5239 and then FCE (Selector_Name (E1), Selector_Name (E2));
5243 FCE (Prefix (E1), Prefix (E2))
5244 and then FCE (Discrete_Range (E1), Discrete_Range (E2));
5246 when N_String_Literal =>
5248 S1 : constant String_Id := Strval (E1);
5249 S2 : constant String_Id := Strval (E2);
5250 L1 : constant Nat := String_Length (S1);
5251 L2 : constant Nat := String_Length (S2);
5258 for J in 1 .. L1 loop
5259 if Get_String_Char (S1, J) /=
5260 Get_String_Char (S2, J)
5270 when N_Type_Conversion =>
5272 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
5273 and then FCE (Expression (E1), Expression (E2));
5277 Entity (E1) = Entity (E2)
5278 and then FCE (Right_Opnd (E1), Right_Opnd (E2));
5280 when N_Unchecked_Type_Conversion =>
5282 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
5283 and then FCE (Expression (E1), Expression (E2));
5285 -- All other node types cannot appear in this context. Strictly
5286 -- we should raise a fatal internal error. Instead we just ignore
5287 -- the nodes. This means that if anyone makes a mistake in the
5288 -- expander and mucks an expression tree irretrievably, the
5289 -- result will be a failure to detect a (probably very obscure)
5290 -- case of non-conformance, which is better than bombing on some
5291 -- case where two expressions do in fact conform.
5298 end Fully_Conformant_Expressions;
5300 ----------------------------------------
5301 -- Fully_Conformant_Discrete_Subtypes --
5302 ----------------------------------------
5304 function Fully_Conformant_Discrete_Subtypes
5305 (Given_S1 : Node_Id;
5306 Given_S2 : Node_Id) return Boolean
5308 S1 : constant Node_Id := Original_Node (Given_S1);
5309 S2 : constant Node_Id := Original_Node (Given_S2);
5311 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean;
5312 -- Special-case for a bound given by a discriminant, which in the body
5313 -- is replaced with the discriminal of the enclosing type.
5315 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean;
5316 -- Check both bounds
5318 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is
5320 if Is_Entity_Name (B1)
5321 and then Is_Entity_Name (B2)
5322 and then Ekind (Entity (B1)) = E_Discriminant
5324 return Chars (B1) = Chars (B2);
5327 return Fully_Conformant_Expressions (B1, B2);
5329 end Conforming_Bounds;
5331 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is
5334 Conforming_Bounds (Low_Bound (R1), Low_Bound (R2))
5336 Conforming_Bounds (High_Bound (R1), High_Bound (R2));
5337 end Conforming_Ranges;
5339 -- Start of processing for Fully_Conformant_Discrete_Subtypes
5342 if Nkind (S1) /= Nkind (S2) then
5345 elsif Is_Entity_Name (S1) then
5346 return Entity (S1) = Entity (S2);
5348 elsif Nkind (S1) = N_Range then
5349 return Conforming_Ranges (S1, S2);
5351 elsif Nkind (S1) = N_Subtype_Indication then
5353 Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2))
5356 (Range_Expression (Constraint (S1)),
5357 Range_Expression (Constraint (S2)));
5361 end Fully_Conformant_Discrete_Subtypes;
5363 --------------------
5364 -- Install_Entity --
5365 --------------------
5367 procedure Install_Entity (E : Entity_Id) is
5368 Prev : constant Entity_Id := Current_Entity (E);
5370 Set_Is_Immediately_Visible (E);
5371 Set_Current_Entity (E);
5372 Set_Homonym (E, Prev);
5375 ---------------------
5376 -- Install_Formals --
5377 ---------------------
5379 procedure Install_Formals (Id : Entity_Id) is
5382 F := First_Formal (Id);
5383 while Present (F) loop
5387 end Install_Formals;
5389 ---------------------------------
5390 -- Is_Non_Overriding_Operation --
5391 ---------------------------------
5393 function Is_Non_Overriding_Operation
5394 (Prev_E : Entity_Id;
5395 New_E : Entity_Id) return Boolean
5399 G_Typ : Entity_Id := Empty;
5401 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
5402 -- If F_Type is a derived type associated with a generic actual
5403 -- subtype, then return its Generic_Parent_Type attribute, else return
5406 function Types_Correspond
5407 (P_Type : Entity_Id;
5408 N_Type : Entity_Id) return Boolean;
5409 -- Returns true if and only if the types (or designated types in the
5410 -- case of anonymous access types) are the same or N_Type is derived
5411 -- directly or indirectly from P_Type.
5413 -----------------------------
5414 -- Get_Generic_Parent_Type --
5415 -----------------------------
5417 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
5422 if Is_Derived_Type (F_Typ)
5423 and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
5425 -- The tree must be traversed to determine the parent subtype in
5426 -- the generic unit, which unfortunately isn't always available
5427 -- via semantic attributes. ??? (Note: The use of Original_Node
5428 -- is needed for cases where a full derived type has been
5431 Indic := Subtype_Indication
5432 (Type_Definition (Original_Node (Parent (F_Typ))));
5434 if Nkind (Indic) = N_Subtype_Indication then
5435 G_Typ := Entity (Subtype_Mark (Indic));
5437 G_Typ := Entity (Indic);
5440 if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
5441 and then Present (Generic_Parent_Type (Parent (G_Typ)))
5443 return Generic_Parent_Type (Parent (G_Typ));
5448 end Get_Generic_Parent_Type;
5450 ----------------------
5451 -- Types_Correspond --
5452 ----------------------
5454 function Types_Correspond
5455 (P_Type : Entity_Id;
5456 N_Type : Entity_Id) return Boolean
5458 Prev_Type : Entity_Id := Base_Type (P_Type);
5459 New_Type : Entity_Id := Base_Type (N_Type);
5462 if Ekind (Prev_Type) = E_Anonymous_Access_Type then
5463 Prev_Type := Designated_Type (Prev_Type);
5466 if Ekind (New_Type) = E_Anonymous_Access_Type then
5467 New_Type := Designated_Type (New_Type);
5470 if Prev_Type = New_Type then
5473 elsif not Is_Class_Wide_Type (New_Type) then
5474 while Etype (New_Type) /= New_Type loop
5475 New_Type := Etype (New_Type);
5476 if New_Type = Prev_Type then
5482 end Types_Correspond;
5484 -- Start of processing for Is_Non_Overriding_Operation
5487 -- In the case where both operations are implicit derived subprograms
5488 -- then neither overrides the other. This can only occur in certain
5489 -- obscure cases (e.g., derivation from homographs created in a generic
5492 if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
5495 elsif Ekind (Current_Scope) = E_Package
5496 and then Is_Generic_Instance (Current_Scope)
5497 and then In_Private_Part (Current_Scope)
5498 and then Comes_From_Source (New_E)
5500 -- We examine the formals and result subtype of the inherited
5501 -- operation, to determine whether their type is derived from (the
5502 -- instance of) a generic type.
5504 Formal := First_Formal (Prev_E);
5506 while Present (Formal) loop
5507 F_Typ := Base_Type (Etype (Formal));
5509 if Ekind (F_Typ) = E_Anonymous_Access_Type then
5510 F_Typ := Designated_Type (F_Typ);
5513 G_Typ := Get_Generic_Parent_Type (F_Typ);
5515 Next_Formal (Formal);
5518 if No (G_Typ) and then Ekind (Prev_E) = E_Function then
5519 G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
5526 -- If the generic type is a private type, then the original
5527 -- operation was not overriding in the generic, because there was
5528 -- no primitive operation to override.
5530 if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
5531 and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
5532 N_Formal_Private_Type_Definition
5536 -- The generic parent type is the ancestor of a formal derived
5537 -- type declaration. We need to check whether it has a primitive
5538 -- operation that should be overridden by New_E in the generic.
5542 P_Formal : Entity_Id;
5543 N_Formal : Entity_Id;
5547 Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
5550 while Present (Prim_Elt) loop
5551 P_Prim := Node (Prim_Elt);
5553 if Chars (P_Prim) = Chars (New_E)
5554 and then Ekind (P_Prim) = Ekind (New_E)
5556 P_Formal := First_Formal (P_Prim);
5557 N_Formal := First_Formal (New_E);
5558 while Present (P_Formal) and then Present (N_Formal) loop
5559 P_Typ := Etype (P_Formal);
5560 N_Typ := Etype (N_Formal);
5562 if not Types_Correspond (P_Typ, N_Typ) then
5566 Next_Entity (P_Formal);
5567 Next_Entity (N_Formal);
5570 -- Found a matching primitive operation belonging to the
5571 -- formal ancestor type, so the new subprogram is
5575 and then No (N_Formal)
5576 and then (Ekind (New_E) /= E_Function
5579 (Etype (P_Prim), Etype (New_E)))
5585 Next_Elmt (Prim_Elt);
5588 -- If no match found, then the new subprogram does not
5589 -- override in the generic (nor in the instance).
5597 end Is_Non_Overriding_Operation;
5599 ------------------------------
5600 -- Make_Inequality_Operator --
5601 ------------------------------
5603 -- S is the defining identifier of an equality operator. We build a
5604 -- subprogram declaration with the right signature. This operation is
5605 -- intrinsic, because it is always expanded as the negation of the
5606 -- call to the equality function.
5608 procedure Make_Inequality_Operator (S : Entity_Id) is
5609 Loc : constant Source_Ptr := Sloc (S);
5612 Op_Name : Entity_Id;
5614 FF : constant Entity_Id := First_Formal (S);
5615 NF : constant Entity_Id := Next_Formal (FF);
5618 -- Check that equality was properly defined, ignore call if not
5625 A : constant Entity_Id :=
5626 Make_Defining_Identifier (Sloc (FF),
5627 Chars => Chars (FF));
5629 B : constant Entity_Id :=
5630 Make_Defining_Identifier (Sloc (NF),
5631 Chars => Chars (NF));
5634 Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
5636 Formals := New_List (
5637 Make_Parameter_Specification (Loc,
5638 Defining_Identifier => A,
5640 New_Reference_To (Etype (First_Formal (S)),
5641 Sloc (Etype (First_Formal (S))))),
5643 Make_Parameter_Specification (Loc,
5644 Defining_Identifier => B,
5646 New_Reference_To (Etype (Next_Formal (First_Formal (S))),
5647 Sloc (Etype (Next_Formal (First_Formal (S)))))));
5650 Make_Subprogram_Declaration (Loc,
5652 Make_Function_Specification (Loc,
5653 Defining_Unit_Name => Op_Name,
5654 Parameter_Specifications => Formals,
5655 Result_Definition =>
5656 New_Reference_To (Standard_Boolean, Loc)));
5658 -- Insert inequality right after equality if it is explicit or after
5659 -- the derived type when implicit. These entities are created only
5660 -- for visibility purposes, and eventually replaced in the course of
5661 -- expansion, so they do not need to be attached to the tree and seen
5662 -- by the back-end. Keeping them internal also avoids spurious
5663 -- freezing problems. The declaration is inserted in the tree for
5664 -- analysis, and removed afterwards. If the equality operator comes
5665 -- from an explicit declaration, attach the inequality immediately
5666 -- after. Else the equality is inherited from a derived type
5667 -- declaration, so insert inequality after that declaration.
5669 if No (Alias (S)) then
5670 Insert_After (Unit_Declaration_Node (S), Decl);
5671 elsif Is_List_Member (Parent (S)) then
5672 Insert_After (Parent (S), Decl);
5674 Insert_After (Parent (Etype (First_Formal (S))), Decl);
5677 Mark_Rewrite_Insertion (Decl);
5678 Set_Is_Intrinsic_Subprogram (Op_Name);
5681 Set_Has_Completion (Op_Name);
5682 Set_Corresponding_Equality (Op_Name, S);
5683 Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S));
5685 end Make_Inequality_Operator;
5687 ----------------------
5688 -- May_Need_Actuals --
5689 ----------------------
5691 procedure May_Need_Actuals (Fun : Entity_Id) is
5696 F := First_Formal (Fun);
5699 while Present (F) loop
5700 if No (Default_Value (F)) then
5708 Set_Needs_No_Actuals (Fun, B);
5709 end May_Need_Actuals;
5711 ---------------------
5712 -- Mode_Conformant --
5713 ---------------------
5715 function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
5718 Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
5720 end Mode_Conformant;
5722 ---------------------------
5723 -- New_Overloaded_Entity --
5724 ---------------------------
5726 procedure New_Overloaded_Entity
5728 Derived_Type : Entity_Id := Empty)
5730 Overridden_Subp : Entity_Id := Empty;
5731 -- Set if the current scope has an operation that is type-conformant
5732 -- with S, and becomes hidden by S.
5735 -- Entity that S overrides
5737 Prev_Vis : Entity_Id := Empty;
5738 -- Predecessor of E in Homonym chain
5740 procedure Check_Synchronized_Overriding
5741 (Def_Id : Entity_Id;
5742 First_Hom : Entity_Id;
5743 Overridden_Subp : out Entity_Id);
5744 -- First determine if Def_Id is an entry or a subprogram either defined
5745 -- in the scope of a task or protected type, or is a primitive of such
5746 -- a type. Check whether Def_Id overrides a subprogram of an interface
5747 -- implemented by the synchronized type, return the overridden entity
5750 function Is_Private_Declaration (E : Entity_Id) return Boolean;
5751 -- Check that E is declared in the private part of the current package,
5752 -- or in the package body, where it may hide a previous declaration.
5753 -- We can't use In_Private_Part by itself because this flag is also
5754 -- set when freezing entities, so we must examine the place of the
5755 -- declaration in the tree, and recognize wrapper packages as well.
5757 procedure Maybe_Primitive_Operation (Is_Overriding : Boolean := False);
5758 -- If the subprogram being analyzed is a primitive operation of
5759 -- the type of one of its formals, set the corresponding flag.
5761 -----------------------------------
5762 -- Check_Synchronized_Overriding --
5763 -----------------------------------
5765 procedure Check_Synchronized_Overriding
5766 (Def_Id : Entity_Id;
5767 First_Hom : Entity_Id;
5768 Overridden_Subp : out Entity_Id)
5770 Ifaces_List : Elist_Id;
5775 Overridden_Subp := Empty;
5777 -- Def_Id must be an entry or a subprogram
5779 if Ekind (Def_Id) /= E_Entry
5780 and then Ekind (Def_Id) /= E_Function
5781 and then Ekind (Def_Id) /= E_Procedure
5786 -- Def_Id must be declared withing the scope of a protected or
5787 -- task type or be a primitive operation of such a type.
5789 if Present (Scope (Def_Id))
5790 and then Is_Concurrent_Type (Scope (Def_Id))
5791 and then not Is_Generic_Actual_Type (Scope (Def_Id))
5793 Typ := Scope (Def_Id);
5796 elsif Present (First_Formal (Def_Id))
5797 and then Is_Concurrent_Type (Etype (First_Formal (Def_Id)))
5798 and then not Is_Generic_Actual_Type (Etype (First_Formal (Def_Id)))
5800 Typ := Etype (First_Formal (Def_Id));
5807 -- Gather all limited, protected and task interfaces that Typ
5808 -- implements. Do not collect the interfaces in case of full type
5809 -- declarations because they don't have interface lists.
5811 if Nkind (Parent (Typ)) /= N_Full_Type_Declaration then
5812 Collect_Abstract_Interfaces (Typ, Ifaces_List);
5814 if not Is_Empty_Elmt_List (Ifaces_List) then
5816 Overrides_Synchronized_Primitive
5817 (Def_Id, First_Hom, Ifaces_List, In_Scope);
5820 end Check_Synchronized_Overriding;
5822 ----------------------------
5823 -- Is_Private_Declaration --
5824 ----------------------------
5826 function Is_Private_Declaration (E : Entity_Id) return Boolean is
5827 Priv_Decls : List_Id;
5828 Decl : constant Node_Id := Unit_Declaration_Node (E);
5831 if Is_Package_Or_Generic_Package (Current_Scope)
5832 and then In_Private_Part (Current_Scope)
5835 Private_Declarations (
5836 Specification (Unit_Declaration_Node (Current_Scope)));
5838 return In_Package_Body (Current_Scope)
5840 (Is_List_Member (Decl)
5841 and then List_Containing (Decl) = Priv_Decls)
5842 or else (Nkind (Parent (Decl)) = N_Package_Specification
5843 and then not Is_Compilation_Unit (
5844 Defining_Entity (Parent (Decl)))
5845 and then List_Containing (Parent (Parent (Decl)))
5850 end Is_Private_Declaration;
5852 -------------------------------
5853 -- Maybe_Primitive_Operation --
5854 -------------------------------
5856 procedure Maybe_Primitive_Operation (Is_Overriding : Boolean := False) is
5861 function Visible_Part_Type (T : Entity_Id) return Boolean;
5862 -- Returns true if T is declared in the visible part of
5863 -- the current package scope; otherwise returns false.
5864 -- Assumes that T is declared in a package.
5866 procedure Check_Private_Overriding (T : Entity_Id);
5867 -- Checks that if a primitive abstract subprogram of a visible
5868 -- abstract type is declared in a private part, then it must
5869 -- override an abstract subprogram declared in the visible part.
5870 -- Also checks that if a primitive function with a controlling
5871 -- result is declared in a private part, then it must override
5872 -- a function declared in the visible part.
5874 ------------------------------
5875 -- Check_Private_Overriding --
5876 ------------------------------
5878 procedure Check_Private_Overriding (T : Entity_Id) is
5880 if Ekind (Current_Scope) = E_Package
5881 and then In_Private_Part (Current_Scope)
5882 and then Visible_Part_Type (T)
5883 and then not In_Instance
5885 if Is_Abstract_Type (T)
5886 and then Is_Abstract_Subprogram (S)
5887 and then (not Is_Overriding
5888 or else not Is_Abstract_Subprogram (E))
5890 Error_Msg_N ("abstract subprograms must be visible "
5891 & "('R'M 3.9.3(10))!", S);
5893 elsif Ekind (S) = E_Function
5894 and then Is_Tagged_Type (T)
5895 and then T = Base_Type (Etype (S))
5896 and then not Is_Overriding
5899 ("private function with tagged result must"
5900 & " override visible-part function", S);
5902 ("\move subprogram to the visible part"
5903 & " ('R'M 3.9.3(10))", S);
5906 end Check_Private_Overriding;
5908 -----------------------
5909 -- Visible_Part_Type --
5910 -----------------------
5912 function Visible_Part_Type (T : Entity_Id) return Boolean is
5913 P : constant Node_Id := Unit_Declaration_Node (Scope (T));
5917 -- If the entity is a private type, then it must be
5918 -- declared in a visible part.
5920 if Ekind (T) in Private_Kind then
5924 -- Otherwise, we traverse the visible part looking for its
5925 -- corresponding declaration. We cannot use the declaration
5926 -- node directly because in the private part the entity of a
5927 -- private type is the one in the full view, which does not
5928 -- indicate that it is the completion of something visible.
5930 N := First (Visible_Declarations (Specification (P)));
5931 while Present (N) loop
5932 if Nkind (N) = N_Full_Type_Declaration
5933 and then Present (Defining_Identifier (N))
5934 and then T = Defining_Identifier (N)
5938 elsif (Nkind (N) = N_Private_Type_Declaration
5940 Nkind (N) = N_Private_Extension_Declaration)
5941 and then Present (Defining_Identifier (N))
5942 and then T = Full_View (Defining_Identifier (N))
5951 end Visible_Part_Type;
5953 -- Start of processing for Maybe_Primitive_Operation
5956 if not Comes_From_Source (S) then
5959 -- If the subprogram is at library level, it is not primitive
5962 elsif Current_Scope = Standard_Standard then
5965 elsif (Ekind (Current_Scope) = E_Package
5966 and then not In_Package_Body (Current_Scope))
5967 or else Is_Overriding
5969 -- For function, check return type
5971 if Ekind (S) = E_Function then
5972 B_Typ := Base_Type (Etype (S));
5974 if Scope (B_Typ) = Current_Scope then
5975 Set_Has_Primitive_Operations (B_Typ);
5976 Check_Private_Overriding (B_Typ);
5980 -- For all subprograms, check formals
5982 Formal := First_Formal (S);
5983 while Present (Formal) loop
5984 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
5985 F_Typ := Designated_Type (Etype (Formal));
5987 F_Typ := Etype (Formal);
5990 B_Typ := Base_Type (F_Typ);
5992 if Ekind (B_Typ) = E_Access_Subtype then
5993 B_Typ := Base_Type (B_Typ);
5996 if Scope (B_Typ) = Current_Scope then
5997 Set_Has_Primitive_Operations (B_Typ);
5998 Check_Private_Overriding (B_Typ);
6001 Next_Formal (Formal);
6004 end Maybe_Primitive_Operation;
6006 -- Start of processing for New_Overloaded_Entity
6009 -- We need to look for an entity that S may override. This must be a
6010 -- homonym in the current scope, so we look for the first homonym of
6011 -- S in the current scope as the starting point for the search.
6013 E := Current_Entity_In_Scope (S);
6015 -- If there is no homonym then this is definitely not overriding
6018 Enter_Overloaded_Entity (S);
6019 Check_Dispatching_Operation (S, Empty);
6020 Maybe_Primitive_Operation;
6022 -- If subprogram has an explicit declaration, check whether it
6023 -- has an overriding indicator.
6025 if Comes_From_Source (S) then
6026 Check_Synchronized_Overriding (S, Homonym (S), Overridden_Subp);
6027 Check_Overriding_Indicator (S, Overridden_Subp);
6030 -- If there is a homonym that is not overloadable, then we have an
6031 -- error, except for the special cases checked explicitly below.
6033 elsif not Is_Overloadable (E) then
6035 -- Check for spurious conflict produced by a subprogram that has the
6036 -- same name as that of the enclosing generic package. The conflict
6037 -- occurs within an instance, between the subprogram and the renaming
6038 -- declaration for the package. After the subprogram, the package
6039 -- renaming declaration becomes hidden.
6041 if Ekind (E) = E_Package
6042 and then Present (Renamed_Object (E))
6043 and then Renamed_Object (E) = Current_Scope
6044 and then Nkind (Parent (Renamed_Object (E))) =
6045 N_Package_Specification
6046 and then Present (Generic_Parent (Parent (Renamed_Object (E))))
6049 Set_Is_Immediately_Visible (E, False);
6050 Enter_Overloaded_Entity (S);
6051 Set_Homonym (S, Homonym (E));
6052 Check_Dispatching_Operation (S, Empty);
6053 Check_Overriding_Indicator (S, Empty);
6055 -- If the subprogram is implicit it is hidden by the previous
6056 -- declaration. However if it is dispatching, it must appear in the
6057 -- dispatch table anyway, because it can be dispatched to even if it
6058 -- cannot be called directly.
6060 elsif Present (Alias (S))
6061 and then not Comes_From_Source (S)
6063 Set_Scope (S, Current_Scope);
6065 if Is_Dispatching_Operation (Alias (S)) then
6066 Check_Dispatching_Operation (S, Empty);
6072 Error_Msg_Sloc := Sloc (E);
6073 Error_Msg_N ("& conflicts with declaration#", S);
6075 -- Useful additional warning
6077 if Is_Generic_Unit (E) then
6078 Error_Msg_N ("\previous generic unit cannot be overloaded", S);
6084 -- E exists and is overloadable
6087 -- Ada 2005 (AI-251): Derivation of abstract interface primitives
6088 -- need no check against the homonym chain. They are directly added
6089 -- to the list of primitive operations of Derived_Type.
6091 if Ada_Version >= Ada_05
6092 and then Present (Derived_Type)
6093 and then Is_Dispatching_Operation (Alias (S))
6094 and then Present (Find_Dispatching_Type (Alias (S)))
6095 and then Is_Interface (Find_Dispatching_Type (Alias (S)))
6096 and then not Is_Predefined_Dispatching_Operation (Alias (S))
6098 goto Add_New_Entity;
6101 Check_Synchronized_Overriding (S, E, Overridden_Subp);
6103 -- Loop through E and its homonyms to determine if any of them is
6104 -- the candidate for overriding by S.
6106 while Present (E) loop
6108 -- Definitely not interesting if not in the current scope
6110 if Scope (E) /= Current_Scope then
6113 -- Check if we have type conformance
6115 elsif Type_Conformant (E, S) then
6117 -- If the old and new entities have the same profile and one
6118 -- is not the body of the other, then this is an error, unless
6119 -- one of them is implicitly declared.
6121 -- There are some cases when both can be implicit, for example
6122 -- when both a literal and a function that overrides it are
6123 -- inherited in a derivation, or when an inhertited operation
6124 -- of a tagged full type overrides the inherited operation of
6125 -- a private extension. Ada 83 had a special rule for the the
6126 -- literal case. In Ada95, the later implicit operation hides
6127 -- the former, and the literal is always the former. In the
6128 -- odd case where both are derived operations declared at the
6129 -- same point, both operations should be declared, and in that
6130 -- case we bypass the following test and proceed to the next
6131 -- part (this can only occur for certain obscure cases
6132 -- involving homographs in instances and can't occur for
6133 -- dispatching operations ???). Note that the following
6134 -- condition is less than clear. For example, it's not at all
6135 -- clear why there's a test for E_Entry here. ???
6137 if Present (Alias (S))
6138 and then (No (Alias (E))
6139 or else Comes_From_Source (E)
6140 or else Is_Dispatching_Operation (E))
6142 (Ekind (E) = E_Entry
6143 or else Ekind (E) /= E_Enumeration_Literal)
6145 -- When an derived operation is overloaded it may be due to
6146 -- the fact that the full view of a private extension
6147 -- re-inherits. It has to be dealt with.
6149 if Is_Package_Or_Generic_Package (Current_Scope)
6150 and then In_Private_Part (Current_Scope)
6152 Check_Operation_From_Private_View (S, E);
6155 -- In any case the implicit operation remains hidden by
6156 -- the existing declaration, which is overriding.
6158 Set_Is_Overriding_Operation (E);
6160 if Comes_From_Source (E) then
6161 Check_Overriding_Indicator (E, S);
6163 -- Indicate that E overrides the operation from which
6166 if Present (Alias (S)) then
6167 Set_Overridden_Operation (E, Alias (S));
6169 Set_Overridden_Operation (E, S);
6175 -- Within an instance, the renaming declarations for
6176 -- actual subprograms may become ambiguous, but they do
6177 -- not hide each other.
6179 elsif Ekind (E) /= E_Entry
6180 and then not Comes_From_Source (E)
6181 and then not Is_Generic_Instance (E)
6182 and then (Present (Alias (E))
6183 or else Is_Intrinsic_Subprogram (E))
6184 and then (not In_Instance
6185 or else No (Parent (E))
6186 or else Nkind (Unit_Declaration_Node (E)) /=
6187 N_Subprogram_Renaming_Declaration)
6189 -- A subprogram child unit is not allowed to override
6190 -- an inherited subprogram (10.1.1(20)).
6192 if Is_Child_Unit (S) then
6194 ("child unit overrides inherited subprogram in parent",
6199 if Is_Non_Overriding_Operation (E, S) then
6200 Enter_Overloaded_Entity (S);
6201 if No (Derived_Type)
6202 or else Is_Tagged_Type (Derived_Type)
6204 Check_Dispatching_Operation (S, Empty);
6210 -- E is a derived operation or an internal operator which
6211 -- is being overridden. Remove E from further visibility.
6212 -- Furthermore, if E is a dispatching operation, it must be
6213 -- replaced in the list of primitive operations of its type
6214 -- (see Override_Dispatching_Operation).
6216 Overridden_Subp := E;
6222 Prev := First_Entity (Current_Scope);
6224 while Present (Prev)
6225 and then Next_Entity (Prev) /= E
6230 -- It is possible for E to be in the current scope and
6231 -- yet not in the entity chain. This can only occur in a
6232 -- generic context where E is an implicit concatenation
6233 -- in the formal part, because in a generic body the
6234 -- entity chain starts with the formals.
6237 (Present (Prev) or else Chars (E) = Name_Op_Concat);
6239 -- E must be removed both from the entity_list of the
6240 -- current scope, and from the visibility chain
6242 if Debug_Flag_E then
6243 Write_Str ("Override implicit operation ");
6244 Write_Int (Int (E));
6248 -- If E is a predefined concatenation, it stands for four
6249 -- different operations. As a result, a single explicit
6250 -- declaration does not hide it. In a possible ambiguous
6251 -- situation, Disambiguate chooses the user-defined op,
6252 -- so it is correct to retain the previous internal one.
6254 if Chars (E) /= Name_Op_Concat
6255 or else Ekind (E) /= E_Operator
6257 -- For nondispatching derived operations that are
6258 -- overridden by a subprogram declared in the private
6259 -- part of a package, we retain the derived
6260 -- subprogram but mark it as not immediately visible.
6261 -- If the derived operation was declared in the
6262 -- visible part then this ensures that it will still
6263 -- be visible outside the package with the proper
6264 -- signature (calls from outside must also be
6265 -- directed to this version rather than the
6266 -- overriding one, unlike the dispatching case).
6267 -- Calls from inside the package will still resolve
6268 -- to the overriding subprogram since the derived one
6269 -- is marked as not visible within the package.
6271 -- If the private operation is dispatching, we achieve
6272 -- the overriding by keeping the implicit operation
6273 -- but setting its alias to be the overriding one. In
6274 -- this fashion the proper body is executed in all
6275 -- cases, but the original signature is used outside
6278 -- If the overriding is not in the private part, we
6279 -- remove the implicit operation altogether.
6281 if Is_Private_Declaration (S) then
6283 if not Is_Dispatching_Operation (E) then
6284 Set_Is_Immediately_Visible (E, False);
6286 -- Work done in Override_Dispatching_Operation,
6287 -- so nothing else need to be done here.
6293 -- Find predecessor of E in Homonym chain
6295 if E = Current_Entity (E) then
6298 Prev_Vis := Current_Entity (E);
6299 while Homonym (Prev_Vis) /= E loop
6300 Prev_Vis := Homonym (Prev_Vis);
6304 if Prev_Vis /= Empty then
6306 -- Skip E in the visibility chain
6308 Set_Homonym (Prev_Vis, Homonym (E));
6311 Set_Name_Entity_Id (Chars (E), Homonym (E));
6314 Set_Next_Entity (Prev, Next_Entity (E));
6316 if No (Next_Entity (Prev)) then
6317 Set_Last_Entity (Current_Scope, Prev);
6323 Enter_Overloaded_Entity (S);
6324 Set_Is_Overriding_Operation (S);
6325 Check_Overriding_Indicator (S, E);
6327 -- Indicate that S overrides the operation from which
6330 if Comes_From_Source (S) then
6331 if Present (Alias (E)) then
6332 Set_Overridden_Operation (S, Alias (E));
6334 Set_Overridden_Operation (S, E);
6338 if Is_Dispatching_Operation (E) then
6340 -- An overriding dispatching subprogram inherits the
6341 -- convention of the overridden subprogram (by
6344 Set_Convention (S, Convention (E));
6345 Check_Dispatching_Operation (S, E);
6348 Check_Dispatching_Operation (S, Empty);
6351 Maybe_Primitive_Operation (Is_Overriding => True);
6352 goto Check_Inequality;
6355 -- Apparent redeclarations in instances can occur when two
6356 -- formal types get the same actual type. The subprograms in
6357 -- in the instance are legal, even if not callable from the
6358 -- outside. Calls from within are disambiguated elsewhere.
6359 -- For dispatching operations in the visible part, the usual
6360 -- rules apply, and operations with the same profile are not
6363 elsif (In_Instance_Visible_Part
6364 and then not Is_Dispatching_Operation (E))
6365 or else In_Instance_Not_Visible
6369 -- Here we have a real error (identical profile)
6372 Error_Msg_Sloc := Sloc (E);
6374 -- Avoid cascaded errors if the entity appears in
6375 -- subsequent calls.
6377 Set_Scope (S, Current_Scope);
6379 Error_Msg_N ("& conflicts with declaration#", S);
6381 if Is_Generic_Instance (S)
6382 and then not Has_Completion (E)
6385 ("\instantiation cannot provide body for it", S);
6392 -- If one subprogram has an access parameter and the other
6393 -- a parameter of an access type, calls to either might be
6394 -- ambiguous. Verify that parameters match except for the
6395 -- access parameter.
6397 if May_Hide_Profile then
6402 F1 := First_Formal (S);
6403 F2 := First_Formal (E);
6404 while Present (F1) and then Present (F2) loop
6405 if Is_Access_Type (Etype (F1)) then
6406 if not Is_Access_Type (Etype (F2))
6407 or else not Conforming_Types
6408 (Designated_Type (Etype (F1)),
6409 Designated_Type (Etype (F2)),
6412 May_Hide_Profile := False;
6416 not Conforming_Types
6417 (Etype (F1), Etype (F2), Type_Conformant)
6419 May_Hide_Profile := False;
6430 Error_Msg_NE ("calls to& may be ambiguous?", S, S);
6441 -- On exit, we know that S is a new entity
6443 Enter_Overloaded_Entity (S);
6444 Maybe_Primitive_Operation;
6445 Check_Overriding_Indicator (S, Overridden_Subp);
6447 -- If S is a derived operation for an untagged type then by
6448 -- definition it's not a dispatching operation (even if the parent
6449 -- operation was dispatching), so we don't call
6450 -- Check_Dispatching_Operation in that case.
6452 if No (Derived_Type)
6453 or else Is_Tagged_Type (Derived_Type)
6455 Check_Dispatching_Operation (S, Empty);
6459 -- If this is a user-defined equality operator that is not a derived
6460 -- subprogram, create the corresponding inequality. If the operation is
6461 -- dispatching, the expansion is done elsewhere, and we do not create
6462 -- an explicit inequality operation.
6464 <<Check_Inequality>>
6465 if Chars (S) = Name_Op_Eq
6466 and then Etype (S) = Standard_Boolean
6467 and then Present (Parent (S))
6468 and then not Is_Dispatching_Operation (S)
6470 Make_Inequality_Operator (S);
6472 end New_Overloaded_Entity;
6474 ---------------------
6475 -- Process_Formals --
6476 ---------------------
6478 procedure Process_Formals
6480 Related_Nod : Node_Id)
6482 Param_Spec : Node_Id;
6484 Formal_Type : Entity_Id;
6488 function Is_Class_Wide_Default (D : Node_Id) return Boolean;
6489 -- Check whether the default has a class-wide type. After analysis the
6490 -- default has the type of the formal, so we must also check explicitly
6491 -- for an access attribute.
6493 ---------------------------
6494 -- Is_Class_Wide_Default --
6495 ---------------------------
6497 function Is_Class_Wide_Default (D : Node_Id) return Boolean is
6499 return Is_Class_Wide_Type (Designated_Type (Etype (D)))
6500 or else (Nkind (D) = N_Attribute_Reference
6501 and then Attribute_Name (D) = Name_Access
6502 and then Is_Class_Wide_Type (Etype (Prefix (D))));
6503 end Is_Class_Wide_Default;
6505 -- Start of processing for Process_Formals
6508 -- In order to prevent premature use of the formals in the same formal
6509 -- part, the Ekind is left undefined until all default expressions are
6510 -- analyzed. The Ekind is established in a separate loop at the end.
6512 Param_Spec := First (T);
6514 while Present (Param_Spec) loop
6516 Formal := Defining_Identifier (Param_Spec);
6517 Enter_Name (Formal);
6519 -- Case of ordinary parameters
6521 if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
6522 Find_Type (Parameter_Type (Param_Spec));
6523 Ptype := Parameter_Type (Param_Spec);
6525 if Ptype = Error then
6529 Formal_Type := Entity (Ptype);
6531 if Is_Incomplete_Type (Formal_Type)
6533 (Is_Class_Wide_Type (Formal_Type)
6534 and then Is_Incomplete_Type (Root_Type (Formal_Type)))
6536 -- Ada 2005 (AI-326): Tagged incomplete types allowed
6538 if Is_Tagged_Type (Formal_Type) then
6541 elsif Nkind (Parent (T)) /= N_Access_Function_Definition
6542 and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
6544 Error_Msg_N ("invalid use of incomplete type", Param_Spec);
6547 elsif Ekind (Formal_Type) = E_Void then
6548 Error_Msg_NE ("premature use of&",
6549 Parameter_Type (Param_Spec), Formal_Type);
6552 -- Ada 2005 (AI-231): Create and decorate an internal subtype
6553 -- declaration corresponding to the null-excluding type of the
6554 -- formal in the enclosing scope. Finally, replace the parameter
6555 -- type of the formal with the internal subtype.
6557 if Ada_Version >= Ada_05
6558 and then Null_Exclusion_Present (Param_Spec)
6560 if not Is_Access_Type (Formal_Type) then
6561 Error_Msg_N ("null-exclusion must be applied to an " &
6562 "access type", Param_Spec);
6564 if Can_Never_Be_Null (Formal_Type)
6565 and then Comes_From_Source (Related_Nod)
6568 ("null-exclusion cannot be applied to " &
6569 "a null excluding type", Param_Spec);
6573 Create_Null_Excluding_Itype
6575 Related_Nod => Related_Nod,
6576 Scope_Id => Scope (Current_Scope));
6580 -- An access formal type
6584 Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
6586 -- No need to continue if we already notified errors
6588 if not Present (Formal_Type) then
6592 -- Ada 2005 (AI-254)
6595 AD : constant Node_Id :=
6596 Access_To_Subprogram_Definition
6597 (Parameter_Type (Param_Spec));
6599 if Present (AD) and then Protected_Present (AD) then
6601 Replace_Anonymous_Access_To_Protected_Subprogram
6607 Set_Etype (Formal, Formal_Type);
6608 Default := Expression (Param_Spec);
6610 if Present (Default) then
6611 if Out_Present (Param_Spec) then
6613 ("default initialization only allowed for IN parameters",
6617 -- Do the special preanalysis of the expression (see section on
6618 -- "Handling of Default Expressions" in the spec of package Sem).
6620 Analyze_Per_Use_Expression (Default, Formal_Type);
6622 -- Check that the designated type of an access parameter's default
6623 -- is not a class-wide type unless the parameter's designated type
6624 -- is also class-wide.
6626 if Ekind (Formal_Type) = E_Anonymous_Access_Type
6627 and then not From_With_Type (Formal_Type)
6628 and then Is_Class_Wide_Default (Default)
6629 and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
6632 ("access to class-wide expression not allowed here", Default);
6636 -- Ada 2005 (AI-231): Static checks
6638 if Ada_Version >= Ada_05
6639 and then Is_Access_Type (Etype (Formal))
6640 and then Can_Never_Be_Null (Etype (Formal))
6642 Null_Exclusion_Static_Checks (Param_Spec);
6649 -- If this is the formal part of a function specification, analyze the
6650 -- subtype mark in the context where the formals are visible but not
6651 -- yet usable, and may hide outer homographs.
6653 if Nkind (Related_Nod) = N_Function_Specification then
6654 Analyze_Return_Type (Related_Nod);
6657 -- Now set the kind (mode) of each formal
6659 Param_Spec := First (T);
6661 while Present (Param_Spec) loop
6662 Formal := Defining_Identifier (Param_Spec);
6663 Set_Formal_Mode (Formal);
6665 if Ekind (Formal) = E_In_Parameter then
6666 Set_Default_Value (Formal, Expression (Param_Spec));
6668 if Present (Expression (Param_Spec)) then
6669 Default := Expression (Param_Spec);
6671 if Is_Scalar_Type (Etype (Default)) then
6673 (Parameter_Type (Param_Spec)) /= N_Access_Definition
6675 Formal_Type := Entity (Parameter_Type (Param_Spec));
6678 Formal_Type := Access_Definition
6679 (Related_Nod, Parameter_Type (Param_Spec));
6682 Apply_Scalar_Range_Check (Default, Formal_Type);
6690 end Process_Formals;
6692 ----------------------------
6693 -- Reference_Body_Formals --
6694 ----------------------------
6696 procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is
6701 if Error_Posted (Spec) then
6705 Fs := First_Formal (Spec);
6706 Fb := First_Formal (Bod);
6708 while Present (Fs) loop
6709 Generate_Reference (Fs, Fb, 'b');
6712 Style.Check_Identifier (Fb, Fs);
6715 Set_Spec_Entity (Fb, Fs);
6716 Set_Referenced (Fs, False);
6720 end Reference_Body_Formals;
6722 -------------------------
6723 -- Set_Actual_Subtypes --
6724 -------------------------
6726 procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
6727 Loc : constant Source_Ptr := Sloc (N);
6731 First_Stmt : Node_Id := Empty;
6732 AS_Needed : Boolean;
6735 -- If this is an emtpy initialization procedure, no need to create
6736 -- actual subtypes (small optimization).
6738 if Ekind (Subp) = E_Procedure
6739 and then Is_Null_Init_Proc (Subp)
6744 Formal := First_Formal (Subp);
6745 while Present (Formal) loop
6746 T := Etype (Formal);
6748 -- We never need an actual subtype for a constrained formal
6750 if Is_Constrained (T) then
6753 -- If we have unknown discriminants, then we do not need an actual
6754 -- subtype, or more accurately we cannot figure it out! Note that
6755 -- all class-wide types have unknown discriminants.
6757 elsif Has_Unknown_Discriminants (T) then
6760 -- At this stage we have an unconstrained type that may need an
6761 -- actual subtype. For sure the actual subtype is needed if we have
6762 -- an unconstrained array type.
6764 elsif Is_Array_Type (T) then
6767 -- The only other case needing an actual subtype is an unconstrained
6768 -- record type which is an IN parameter (we cannot generate actual
6769 -- subtypes for the OUT or IN OUT case, since an assignment can
6770 -- change the discriminant values. However we exclude the case of
6771 -- initialization procedures, since discriminants are handled very
6772 -- specially in this context, see the section entitled "Handling of
6773 -- Discriminants" in Einfo.
6775 -- We also exclude the case of Discrim_SO_Functions (functions used
6776 -- in front end layout mode for size/offset values), since in such
6777 -- functions only discriminants are referenced, and not only are such
6778 -- subtypes not needed, but they cannot always be generated, because
6779 -- of order of elaboration issues.
6781 elsif Is_Record_Type (T)
6782 and then Ekind (Formal) = E_In_Parameter
6783 and then Chars (Formal) /= Name_uInit
6784 and then not Is_Unchecked_Union (T)
6785 and then not Is_Discrim_SO_Function (Subp)
6789 -- All other cases do not need an actual subtype
6795 -- Generate actual subtypes for unconstrained arrays and
6796 -- unconstrained discriminated records.
6799 if Nkind (N) = N_Accept_Statement then
6801 -- If expansion is active, The formal is replaced by a local
6802 -- variable that renames the corresponding entry of the
6803 -- parameter block, and it is this local variable that may
6804 -- require an actual subtype.
6806 if Expander_Active then
6807 Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
6809 Decl := Build_Actual_Subtype (T, Formal);
6812 if Present (Handled_Statement_Sequence (N)) then
6814 First (Statements (Handled_Statement_Sequence (N)));
6815 Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
6816 Mark_Rewrite_Insertion (Decl);
6818 -- If the accept statement has no body, there will be no
6819 -- reference to the actuals, so no need to compute actual
6826 Decl := Build_Actual_Subtype (T, Formal);
6827 Prepend (Decl, Declarations (N));
6828 Mark_Rewrite_Insertion (Decl);
6831 -- The declaration uses the bounds of an existing object, and
6832 -- therefore needs no constraint checks.
6834 Analyze (Decl, Suppress => All_Checks);
6836 -- We need to freeze manually the generated type when it is
6837 -- inserted anywhere else than in a declarative part.
6839 if Present (First_Stmt) then
6840 Insert_List_Before_And_Analyze (First_Stmt,
6841 Freeze_Entity (Defining_Identifier (Decl), Loc));
6844 if Nkind (N) = N_Accept_Statement
6845 and then Expander_Active
6847 Set_Actual_Subtype (Renamed_Object (Formal),
6848 Defining_Identifier (Decl));
6850 Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
6854 Next_Formal (Formal);
6856 end Set_Actual_Subtypes;
6858 ---------------------
6859 -- Set_Formal_Mode --
6860 ---------------------
6862 procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
6863 Spec : constant Node_Id := Parent (Formal_Id);
6866 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
6867 -- since we ensure that corresponding actuals are always valid at the
6868 -- point of the call.
6870 if Out_Present (Spec) then
6871 if Ekind (Scope (Formal_Id)) = E_Function
6872 or else Ekind (Scope (Formal_Id)) = E_Generic_Function
6874 Error_Msg_N ("functions can only have IN parameters", Spec);
6875 Set_Ekind (Formal_Id, E_In_Parameter);
6877 elsif In_Present (Spec) then
6878 Set_Ekind (Formal_Id, E_In_Out_Parameter);
6881 Set_Ekind (Formal_Id, E_Out_Parameter);
6882 Set_Never_Set_In_Source (Formal_Id, True);
6883 Set_Is_True_Constant (Formal_Id, False);
6884 Set_Current_Value (Formal_Id, Empty);
6888 Set_Ekind (Formal_Id, E_In_Parameter);
6891 -- Set Is_Known_Non_Null for access parameters since the language
6892 -- guarantees that access parameters are always non-null. We also set
6893 -- Can_Never_Be_Null, since there is no way to change the value.
6895 if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
6897 -- Ada 2005 (AI-231): In Ada95, access parameters are always non-
6898 -- null; In Ada 2005, only if then null_exclusion is explicit.
6900 if Ada_Version < Ada_05
6901 or else Can_Never_Be_Null (Etype (Formal_Id))
6903 Set_Is_Known_Non_Null (Formal_Id);
6904 Set_Can_Never_Be_Null (Formal_Id);
6907 -- Ada 2005 (AI-231): Null-exclusion access subtype
6909 elsif Is_Access_Type (Etype (Formal_Id))
6910 and then Can_Never_Be_Null (Etype (Formal_Id))
6912 Set_Is_Known_Non_Null (Formal_Id);
6915 Set_Mechanism (Formal_Id, Default_Mechanism);
6916 Set_Formal_Validity (Formal_Id);
6917 end Set_Formal_Mode;
6919 -------------------------
6920 -- Set_Formal_Validity --
6921 -------------------------
6923 procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
6925 -- If no validity checking, then we cannot assume anything about the
6926 -- validity of parameters, since we do not know there is any checking
6927 -- of the validity on the call side.
6929 if not Validity_Checks_On then
6932 -- If validity checking for parameters is enabled, this means we are
6933 -- not supposed to make any assumptions about argument values.
6935 elsif Validity_Check_Parameters then
6938 -- If we are checking in parameters, we will assume that the caller is
6939 -- also checking parameters, so we can assume the parameter is valid.
6941 elsif Ekind (Formal_Id) = E_In_Parameter
6942 and then Validity_Check_In_Params
6944 Set_Is_Known_Valid (Formal_Id, True);
6946 -- Similar treatment for IN OUT parameters
6948 elsif Ekind (Formal_Id) = E_In_Out_Parameter
6949 and then Validity_Check_In_Out_Params
6951 Set_Is_Known_Valid (Formal_Id, True);
6953 end Set_Formal_Validity;
6955 ------------------------
6956 -- Subtype_Conformant --
6957 ------------------------
6959 function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
6962 Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result);
6964 end Subtype_Conformant;
6966 ---------------------
6967 -- Type_Conformant --
6968 ---------------------
6970 function Type_Conformant
6971 (New_Id : Entity_Id;
6973 Skip_Controlling_Formals : Boolean := False) return Boolean
6977 May_Hide_Profile := False;
6980 (New_Id, Old_Id, Type_Conformant, False, Result,
6981 Skip_Controlling_Formals => Skip_Controlling_Formals);
6983 end Type_Conformant;
6985 -------------------------------
6986 -- Valid_Operator_Definition --
6987 -------------------------------
6989 procedure Valid_Operator_Definition (Designator : Entity_Id) is
6992 Id : constant Name_Id := Chars (Designator);
6996 F := First_Formal (Designator);
6997 while Present (F) loop
7000 if Present (Default_Value (F)) then
7002 ("default values not allowed for operator parameters",
7009 -- Verify that user-defined operators have proper number of arguments
7010 -- First case of operators which can only be unary
7013 or else Id = Name_Op_Abs
7017 -- Case of operators which can be unary or binary
7019 elsif Id = Name_Op_Add
7020 or Id = Name_Op_Subtract
7022 N_OK := (N in 1 .. 2);
7024 -- All other operators can only be binary
7032 ("incorrect number of arguments for operator", Designator);
7036 and then Base_Type (Etype (Designator)) = Standard_Boolean
7037 and then not Is_Intrinsic_Subprogram (Designator)
7040 ("explicit definition of inequality not allowed", Designator);
7042 end Valid_Operator_Definition;