1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Expander; use Expander;
33 with Exp_Ch6; use Exp_Ch6;
34 with Exp_Ch7; use Exp_Ch7;
35 with Exp_Ch9; use Exp_Ch9;
36 with Exp_Disp; use Exp_Disp;
37 with Exp_Tss; use Exp_Tss;
38 with Exp_Util; use Exp_Util;
39 with Fname; use Fname;
40 with Freeze; use Freeze;
41 with Itypes; use Itypes;
42 with Lib.Xref; use Lib.Xref;
43 with Layout; use Layout;
44 with Namet; use Namet;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
49 with Output; use Output;
50 with Restrict; use Restrict;
51 with Rident; use Rident;
52 with Rtsfind; use Rtsfind;
54 with Sem_Aux; use Sem_Aux;
55 with Sem_Cat; use Sem_Cat;
56 with Sem_Ch3; use Sem_Ch3;
57 with Sem_Ch4; use Sem_Ch4;
58 with Sem_Ch5; use Sem_Ch5;
59 with Sem_Ch8; use Sem_Ch8;
60 with Sem_Ch10; use Sem_Ch10;
61 with Sem_Ch12; use Sem_Ch12;
62 with Sem_Ch13; use Sem_Ch13;
63 with Sem_Disp; use Sem_Disp;
64 with Sem_Dist; use Sem_Dist;
65 with Sem_Elim; use Sem_Elim;
66 with Sem_Eval; use Sem_Eval;
67 with Sem_Mech; use Sem_Mech;
68 with Sem_Prag; use Sem_Prag;
69 with Sem_Res; use Sem_Res;
70 with Sem_Util; use Sem_Util;
71 with Sem_Type; use Sem_Type;
72 with Sem_Warn; use Sem_Warn;
73 with Sinput; use Sinput;
74 with Stand; use Stand;
75 with Sinfo; use Sinfo;
76 with Sinfo.CN; use Sinfo.CN;
77 with Snames; use Snames;
78 with Stringt; use Stringt;
80 with Stylesw; use Stylesw;
81 with Tbuild; use Tbuild;
82 with Uintp; use Uintp;
83 with Urealp; use Urealp;
84 with Validsw; use Validsw;
86 package body Sem_Ch6 is
88 May_Hide_Profile : Boolean := False;
89 -- This flag is used to indicate that two formals in two subprograms being
90 -- checked for conformance differ only in that one is an access parameter
91 -- while the other is of a general access type with the same designated
92 -- type. In this case, if the rest of the signatures match, a call to
93 -- either subprogram may be ambiguous, which is worth a warning. The flag
94 -- is set in Compatible_Types, and the warning emitted in
95 -- New_Overloaded_Entity.
97 -----------------------
98 -- Local Subprograms --
99 -----------------------
101 procedure Analyze_Return_Statement (N : Node_Id);
102 -- Common processing for simple and extended return statements
104 procedure Analyze_Function_Return (N : Node_Id);
105 -- Subsidiary to Analyze_Return_Statement. Called when the return statement
106 -- applies to a [generic] function.
108 procedure Analyze_Return_Type (N : Node_Id);
109 -- Subsidiary to Process_Formals: analyze subtype mark in function
110 -- specification in a context where the formals are visible and hide
113 procedure Analyze_Subprogram_Body_Helper (N : Node_Id);
114 -- Does all the real work of Analyze_Subprogram_Body. This is split out so
115 -- that we can use RETURN but not skip the debug output at the end.
117 procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
118 -- Analyze a generic subprogram body. N is the body to be analyzed, and
119 -- Gen_Id is the defining entity Id for the corresponding spec.
121 procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
122 -- If a subprogram has pragma Inline and inlining is active, use generic
123 -- machinery to build an unexpanded body for the subprogram. This body is
124 -- subsequently used for inline expansions at call sites. If subprogram can
125 -- be inlined (depending on size and nature of local declarations) this
126 -- function returns true. Otherwise subprogram body is treated normally.
127 -- If proper warnings are enabled and the subprogram contains a construct
128 -- that cannot be inlined, the offending construct is flagged accordingly.
130 function Can_Override_Operator (Subp : Entity_Id) return Boolean;
131 -- Returns true if Subp can override a predefined operator.
133 procedure Check_Conformance
136 Ctype : Conformance_Type;
138 Conforms : out Boolean;
139 Err_Loc : Node_Id := Empty;
140 Get_Inst : Boolean := False;
141 Skip_Controlling_Formals : Boolean := False);
142 -- Given two entities, this procedure checks that the profiles associated
143 -- with these entities meet the conformance criterion given by the third
144 -- parameter. If they conform, Conforms is set True and control returns
145 -- to the caller. If they do not conform, Conforms is set to False, and
146 -- in addition, if Errmsg is True on the call, proper messages are output
147 -- to complain about the conformance failure. If Err_Loc is non_Empty
148 -- the error messages are placed on Err_Loc, if Err_Loc is empty, then
149 -- error messages are placed on the appropriate part of the construct
150 -- denoted by New_Id. If Get_Inst is true, then this is a mode conformance
151 -- against a formal access-to-subprogram type so Get_Instance_Of must
154 procedure Check_Subprogram_Order (N : Node_Id);
155 -- N is the N_Subprogram_Body node for a subprogram. This routine applies
156 -- the alpha ordering rule for N if this ordering requirement applicable.
158 procedure Check_Returns
162 Proc : Entity_Id := Empty);
163 -- Called to check for missing return statements in a function body, or for
164 -- returns present in a procedure body which has No_Return set. HSS is the
165 -- handled statement sequence for the subprogram body. This procedure
166 -- checks all flow paths to make sure they either have return (Mode = 'F',
167 -- used for functions) or do not have a return (Mode = 'P', used for
168 -- No_Return procedures). The flag Err is set if there are any control
169 -- paths not explicitly terminated by a return in the function case, and is
170 -- True otherwise. Proc is the entity for the procedure case and is used
171 -- in posting the warning message.
173 procedure Check_Untagged_Equality (Eq_Op : Entity_Id);
174 -- In Ada 2012, a primitive equality operator on an untagged record type
175 -- must appear before the type is frozen, and have the same visibility as
176 -- that of the type. This procedure checks that this rule is met, and
177 -- otherwise emits an error on the subprogram declaration and a warning
178 -- on the earlier freeze point if it is easy to locate.
180 procedure Enter_Overloaded_Entity (S : Entity_Id);
181 -- This procedure makes S, a new overloaded entity, into the first visible
182 -- entity with that name.
184 procedure Install_Entity (E : Entity_Id);
185 -- Make single entity visible (used for generic formals as well)
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 Process_PPCs
207 Body_Id : Entity_Id);
208 -- Called from Analyze[_Generic]_Subprogram_Body to deal with scanning post
209 -- conditions for the body and assembling and inserting the _postconditions
210 -- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are
211 -- the entities for the body and separate spec (if there is no separate
212 -- spec, Spec_Id is Empty). Note that invariants and predicates may also
213 -- provide postconditions, and are also handled in this procedure.
215 procedure Set_Formal_Validity (Formal_Id : Entity_Id);
216 -- Formal_Id is an formal parameter entity. This procedure deals with
217 -- setting the proper validity status for this entity, which depends on
218 -- the kind of parameter and the validity checking mode.
220 ---------------------------------------------
221 -- Analyze_Abstract_Subprogram_Declaration --
222 ---------------------------------------------
224 procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
225 Designator : constant Entity_Id :=
226 Analyze_Subprogram_Specification (Specification (N));
227 Scop : constant Entity_Id := Current_Scope;
230 Check_SPARK_Restriction ("abstract subprogram is not allowed", N);
232 Generate_Definition (Designator);
233 Set_Is_Abstract_Subprogram (Designator);
234 New_Overloaded_Entity (Designator);
235 Check_Delayed_Subprogram (Designator);
237 Set_Categorization_From_Scope (Designator, Scop);
239 if Ekind (Scope (Designator)) = E_Protected_Type then
241 ("abstract subprogram not allowed in protected type", N);
243 -- Issue a warning if the abstract subprogram is neither a dispatching
244 -- operation nor an operation that overrides an inherited subprogram or
245 -- predefined operator, since this most likely indicates a mistake.
247 elsif Warn_On_Redundant_Constructs
248 and then not Is_Dispatching_Operation (Designator)
249 and then not Present (Overridden_Operation (Designator))
250 and then (not Is_Operator_Symbol_Name (Chars (Designator))
251 or else Scop /= Scope (Etype (First_Formal (Designator))))
254 ("?abstract subprogram is not dispatching or overriding", N);
257 Generate_Reference_To_Formals (Designator);
258 Check_Eliminated (Designator);
260 if Has_Aspects (N) then
261 Analyze_Aspect_Specifications (N, Designator);
263 end Analyze_Abstract_Subprogram_Declaration;
265 ---------------------------------
266 -- Analyze_Expression_Function --
267 ---------------------------------
269 procedure Analyze_Expression_Function (N : Node_Id) is
270 Loc : constant Source_Ptr := Sloc (N);
271 LocX : constant Source_Ptr := Sloc (Expression (N));
272 Def_Id : constant Entity_Id := Defining_Entity (Specification (N));
276 Prev : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
277 -- If the expression is a completion, Prev is the entity whose
278 -- declaration is completed.
281 -- This is one of the occasions on which we transform the tree during
282 -- semantic analysis. If this is a completion, transform the expression
283 -- function into an equivalent subprogram body, and analyze it.
285 -- Expression functions are inlined unconditionally. The back-end will
286 -- determine whether this is possible.
288 Inline_Processing_Required := True;
291 Make_Subprogram_Body (Loc,
292 Specification => Specification (N),
293 Declarations => Empty_List,
294 Handled_Statement_Sequence =>
295 Make_Handled_Sequence_Of_Statements (LocX,
296 Statements => New_List (
297 Make_Simple_Return_Statement (LocX,
298 Expression => Expression (N)))));
301 and then Ekind (Prev) = E_Generic_Function
303 -- If the expression completes a generic subprogram, we must create a
304 -- separate node for the body, because at instantiation the original
305 -- node of the generic copy must be a generic subprogram body, and
306 -- cannot be a expression function. Otherwise we just rewrite the
307 -- expression with the non-generic body.
309 Insert_After (N, New_Body);
310 Rewrite (N, Make_Null_Statement (Loc));
313 Set_Is_Inlined (Prev);
315 elsif Present (Prev) then
316 Rewrite (N, New_Body);
317 Set_Is_Inlined (Prev);
320 -- If this is not a completion, create both a declaration and a body,
321 -- so that the expression can be inlined whenever possible.
325 Make_Subprogram_Declaration (Loc,
326 Specification => Specification (N));
327 Rewrite (N, New_Decl);
329 Set_Is_Inlined (Defining_Entity (New_Decl));
331 -- Create new set of formals for specification in body.
333 Set_Specification (New_Body,
334 Make_Function_Specification (Loc,
335 Defining_Unit_Name =>
336 Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))),
337 Parameter_Specifications =>
338 Copy_Parameter_List (Defining_Entity (New_Decl)),
340 New_Copy_Tree (Result_Definition (Specification (New_Decl)))));
342 Insert_After (N, New_Body);
345 end Analyze_Expression_Function;
347 ----------------------------------------
348 -- Analyze_Extended_Return_Statement --
349 ----------------------------------------
351 procedure Analyze_Extended_Return_Statement (N : Node_Id) is
353 Analyze_Return_Statement (N);
354 end Analyze_Extended_Return_Statement;
356 ----------------------------
357 -- Analyze_Function_Call --
358 ----------------------------
360 procedure Analyze_Function_Call (N : Node_Id) is
361 P : constant Node_Id := Name (N);
362 Actuals : constant List_Id := Parameter_Associations (N);
368 -- A call of the form A.B (X) may be an Ada05 call, which is rewritten
369 -- as B (A, X). If the rewriting is successful, the call has been
370 -- analyzed and we just return.
372 if Nkind (P) = N_Selected_Component
373 and then Name (N) /= P
374 and then Is_Rewrite_Substitution (N)
375 and then Present (Etype (N))
380 -- If error analyzing name, then set Any_Type as result type and return
382 if Etype (P) = Any_Type then
383 Set_Etype (N, Any_Type);
387 -- Otherwise analyze the parameters
389 if Present (Actuals) then
390 Actual := First (Actuals);
391 while Present (Actual) loop
393 Check_Parameterless_Call (Actual);
399 end Analyze_Function_Call;
401 -----------------------------
402 -- Analyze_Function_Return --
403 -----------------------------
405 procedure Analyze_Function_Return (N : Node_Id) is
406 Loc : constant Source_Ptr := Sloc (N);
407 Stm_Entity : constant Entity_Id := Return_Statement_Entity (N);
408 Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity);
410 R_Type : constant Entity_Id := Etype (Scope_Id);
411 -- Function result subtype
413 procedure Check_Limited_Return (Expr : Node_Id);
414 -- Check the appropriate (Ada 95 or Ada 2005) rules for returning
415 -- limited types. Used only for simple return statements.
416 -- Expr is the expression returned.
418 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
419 -- Check that the return_subtype_indication properly matches the result
420 -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
422 --------------------------
423 -- Check_Limited_Return --
424 --------------------------
426 procedure Check_Limited_Return (Expr : Node_Id) is
428 -- Ada 2005 (AI-318-02): Return-by-reference types have been
429 -- removed and replaced by anonymous access results. This is an
430 -- incompatibility with Ada 95. Not clear whether this should be
431 -- enforced yet or perhaps controllable with special switch. ???
433 if Is_Limited_Type (R_Type)
434 and then Comes_From_Source (N)
435 and then not In_Instance_Body
436 and then not OK_For_Limited_Init_In_05 (R_Type, Expr)
440 if Ada_Version >= Ada_2005
441 and then not Debug_Flag_Dot_L
442 and then not GNAT_Mode
445 ("(Ada 2005) cannot copy object of a limited type " &
446 "(RM-2005 6.5(5.5/2))", Expr);
448 if Is_Immutably_Limited_Type (R_Type) then
450 ("\return by reference not permitted in Ada 2005", Expr);
453 -- Warn in Ada 95 mode, to give folks a heads up about this
456 -- In GNAT mode, this is just a warning, to allow it to be
457 -- evilly turned off. Otherwise it is a real error.
459 -- In a generic context, simplify the warning because it makes
460 -- no sense to discuss pass-by-reference or copy.
462 elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
463 if Inside_A_Generic then
465 ("return of limited object not permitted in Ada2005 "
466 & "(RM-2005 6.5(5.5/2))?", Expr);
468 elsif Is_Immutably_Limited_Type (R_Type) then
470 ("return by reference not permitted in Ada 2005 "
471 & "(RM-2005 6.5(5.5/2))?", Expr);
474 ("cannot copy object of a limited type in Ada 2005 "
475 & "(RM-2005 6.5(5.5/2))?", Expr);
478 -- Ada 95 mode, compatibility warnings disabled
481 return; -- skip continuation messages below
484 if not Inside_A_Generic then
486 ("\consider switching to return of access type", Expr);
487 Explain_Limited_Type (R_Type, Expr);
490 end Check_Limited_Return;
492 -------------------------------------
493 -- Check_Return_Subtype_Indication --
494 -------------------------------------
496 procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is
497 Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl);
499 R_Stm_Type : constant Entity_Id := Etype (Return_Obj);
500 -- Subtype given in the extended return statement (must match R_Type)
502 Subtype_Ind : constant Node_Id :=
503 Object_Definition (Original_Node (Obj_Decl));
505 R_Type_Is_Anon_Access :
507 Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
509 Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
511 Ekind (R_Type) = E_Anonymous_Access_Type;
512 -- True if return type of the function is an anonymous access type
513 -- Can't we make Is_Anonymous_Access_Type in einfo ???
515 R_Stm_Type_Is_Anon_Access :
517 Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type
519 Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type
521 Ekind (R_Stm_Type) = E_Anonymous_Access_Type;
522 -- True if type of the return object is an anonymous access type
525 -- First, avoid cascaded errors
527 if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then
531 -- "return access T" case; check that the return statement also has
532 -- "access T", and that the subtypes statically match:
533 -- if this is an access to subprogram the signatures must match.
535 if R_Type_Is_Anon_Access then
536 if R_Stm_Type_Is_Anon_Access then
538 Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
540 if Base_Type (Designated_Type (R_Stm_Type)) /=
541 Base_Type (Designated_Type (R_Type))
542 or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
545 ("subtype must statically match function result subtype",
546 Subtype_Mark (Subtype_Ind));
550 -- For two anonymous access to subprogram types, the
551 -- types themselves must be type conformant.
553 if not Conforming_Types
554 (R_Stm_Type, R_Type, Fully_Conformant)
557 ("subtype must statically match function result subtype",
563 Error_Msg_N ("must use anonymous access type", Subtype_Ind);
566 -- Subtype indication case: check that the return object's type is
567 -- covered by the result type, and that the subtypes statically match
568 -- when the result subtype is constrained. Also handle record types
569 -- with unknown discriminants for which we have built the underlying
570 -- record view. Coverage is needed to allow specific-type return
571 -- objects when the result type is class-wide (see AI05-32).
573 elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type))
574 or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type))
578 Underlying_Record_View (Base_Type (R_Stm_Type))))
580 -- A null exclusion may be present on the return type, on the
581 -- function specification, on the object declaration or on the
584 if Is_Access_Type (R_Type)
586 (Can_Never_Be_Null (R_Type)
587 or else Null_Exclusion_Present (Parent (Scope_Id))) /=
588 Can_Never_Be_Null (R_Stm_Type)
591 ("subtype must statically match function result subtype",
595 -- AI05-103: for elementary types, subtypes must statically match
597 if Is_Constrained (R_Type)
598 or else Is_Access_Type (R_Type)
600 if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
602 ("subtype must statically match function result subtype",
607 elsif Etype (Base_Type (R_Type)) = R_Stm_Type
608 and then Is_Null_Extension (Base_Type (R_Type))
614 ("wrong type for return_subtype_indication", Subtype_Ind);
616 end Check_Return_Subtype_Indication;
618 ---------------------
619 -- Local Variables --
620 ---------------------
624 -- Start of processing for Analyze_Function_Return
627 Set_Return_Present (Scope_Id);
629 if Nkind (N) = N_Simple_Return_Statement then
630 Expr := Expression (N);
631 Analyze_And_Resolve (Expr, R_Type);
632 Check_Limited_Return (Expr);
634 -- RETURN only allowed in SPARK is as the last statement function
636 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
638 (Nkind (Parent (Parent (N))) /= N_Subprogram_Body
639 or else Present (Next (N)))
641 Mark_Non_ALFA_Subprogram;
642 Check_SPARK_Restriction
643 ("RETURN should be the last statement in function", N);
647 Mark_Non_ALFA_Subprogram;
648 Check_SPARK_Restriction ("extended RETURN is not allowed", N);
650 -- Analyze parts specific to extended_return_statement:
653 Obj_Decl : constant Node_Id :=
654 Last (Return_Object_Declarations (N));
656 HSS : constant Node_Id := Handled_Statement_Sequence (N);
659 Expr := Expression (Obj_Decl);
661 -- Note: The check for OK_For_Limited_Init will happen in
662 -- Analyze_Object_Declaration; we treat it as a normal
663 -- object declaration.
665 Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
668 Check_Return_Subtype_Indication (Obj_Decl);
670 if Present (HSS) then
673 if Present (Exception_Handlers (HSS)) then
675 -- ???Has_Nested_Block_With_Handler needs to be set.
676 -- Probably by creating an actual N_Block_Statement.
677 -- Probably in Expand.
683 -- Mark the return object as referenced, since the return is an
684 -- implicit reference of the object.
686 Set_Referenced (Defining_Identifier (Obj_Decl));
688 Check_References (Stm_Entity);
692 -- Case of Expr present
696 -- Defend against previous errors
698 and then Nkind (Expr) /= N_Empty
699 and then Present (Etype (Expr))
701 -- Apply constraint check. Note that this is done before the implicit
702 -- conversion of the expression done for anonymous access types to
703 -- ensure correct generation of the null-excluding check associated
704 -- with null-excluding expressions found in return statements.
706 Apply_Constraint_Check (Expr, R_Type);
708 -- Ada 2005 (AI-318-02): When the result type is an anonymous access
709 -- type, apply an implicit conversion of the expression to that type
710 -- to force appropriate static and run-time accessibility checks.
712 if Ada_Version >= Ada_2005
713 and then Ekind (R_Type) = E_Anonymous_Access_Type
715 Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
716 Analyze_And_Resolve (Expr, R_Type);
719 -- If the result type is class-wide, then check that the return
720 -- expression's type is not declared at a deeper level than the
721 -- function (RM05-6.5(5.6/2)).
723 if Ada_Version >= Ada_2005
724 and then Is_Class_Wide_Type (R_Type)
726 if Type_Access_Level (Etype (Expr)) >
727 Subprogram_Access_Level (Scope_Id)
730 ("level of return expression type is deeper than " &
731 "class-wide function!", Expr);
735 -- Check incorrect use of dynamically tagged expression
737 if Is_Tagged_Type (R_Type) then
738 Check_Dynamically_Tagged_Expression
744 -- ??? A real run-time accessibility check is needed in cases
745 -- involving dereferences of access parameters. For now we just
746 -- check the static cases.
748 if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
749 and then Is_Immutably_Limited_Type (Etype (Scope_Id))
750 and then Object_Access_Level (Expr) >
751 Subprogram_Access_Level (Scope_Id)
754 -- Suppress the message in a generic, where the rewriting
757 if Inside_A_Generic then
762 Make_Raise_Program_Error (Loc,
763 Reason => PE_Accessibility_Check_Failed));
767 ("cannot return a local value by reference?", N);
769 ("\& will be raised at run time?",
770 N, Standard_Program_Error);
775 and then Nkind (Parent (Scope_Id)) = N_Function_Specification
776 and then Null_Exclusion_Present (Parent (Scope_Id))
778 Apply_Compile_Time_Constraint_Error
780 Msg => "(Ada 2005) null not allowed for "
781 & "null-excluding return?",
782 Reason => CE_Null_Not_Allowed);
785 -- Apply checks suggested by AI05-0144 (dangerous order dependence)
787 Check_Order_Dependence;
789 end Analyze_Function_Return;
791 -------------------------------------
792 -- Analyze_Generic_Subprogram_Body --
793 -------------------------------------
795 procedure Analyze_Generic_Subprogram_Body
799 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id);
800 Kind : constant Entity_Kind := Ekind (Gen_Id);
806 -- Copy body and disable expansion while analyzing the generic For a
807 -- stub, do not copy the stub (which would load the proper body), this
808 -- will be done when the proper body is analyzed.
810 if Nkind (N) /= N_Subprogram_Body_Stub then
811 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
816 Spec := Specification (N);
818 -- Within the body of the generic, the subprogram is callable, and
819 -- behaves like the corresponding non-generic unit.
821 Body_Id := Defining_Entity (Spec);
823 if Kind = E_Generic_Procedure
824 and then Nkind (Spec) /= N_Procedure_Specification
826 Error_Msg_N ("invalid body for generic procedure ", Body_Id);
829 elsif Kind = E_Generic_Function
830 and then Nkind (Spec) /= N_Function_Specification
832 Error_Msg_N ("invalid body for generic function ", Body_Id);
836 Set_Corresponding_Body (Gen_Decl, Body_Id);
838 if Has_Completion (Gen_Id)
839 and then Nkind (Parent (N)) /= N_Subunit
841 Error_Msg_N ("duplicate generic body", N);
844 Set_Has_Completion (Gen_Id);
847 if Nkind (N) = N_Subprogram_Body_Stub then
848 Set_Ekind (Defining_Entity (Specification (N)), Kind);
850 Set_Corresponding_Spec (N, Gen_Id);
853 if Nkind (Parent (N)) = N_Compilation_Unit then
854 Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
857 -- Make generic parameters immediately visible in the body. They are
858 -- needed to process the formals declarations. Then make the formals
859 -- visible in a separate step.
865 First_Ent : Entity_Id;
868 First_Ent := First_Entity (Gen_Id);
871 while Present (E) and then not Is_Formal (E) loop
876 Set_Use (Generic_Formal_Declarations (Gen_Decl));
878 -- Now generic formals are visible, and the specification can be
879 -- analyzed, for subsequent conformance check.
881 Body_Id := Analyze_Subprogram_Specification (Spec);
883 -- Make formal parameters visible
887 -- E is the first formal parameter, we loop through the formals
888 -- installing them so that they will be visible.
890 Set_First_Entity (Gen_Id, E);
891 while Present (E) loop
897 -- Visible generic entity is callable within its own body
899 Set_Ekind (Gen_Id, Ekind (Body_Id));
900 Set_Ekind (Body_Id, E_Subprogram_Body);
901 Set_Convention (Body_Id, Convention (Gen_Id));
902 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
903 Set_Scope (Body_Id, Scope (Gen_Id));
904 Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
906 if Nkind (N) = N_Subprogram_Body_Stub then
908 -- No body to analyze, so restore state of generic unit
910 Set_Ekind (Gen_Id, Kind);
911 Set_Ekind (Body_Id, Kind);
913 if Present (First_Ent) then
914 Set_First_Entity (Gen_Id, First_Ent);
921 -- If this is a compilation unit, it must be made visible explicitly,
922 -- because the compilation of the declaration, unlike other library
923 -- unit declarations, does not. If it is not a unit, the following
924 -- is redundant but harmless.
926 Set_Is_Immediately_Visible (Gen_Id);
927 Reference_Body_Formals (Gen_Id, Body_Id);
929 if Is_Child_Unit (Gen_Id) then
930 Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False);
933 Set_Actual_Subtypes (N, Current_Scope);
934 Process_PPCs (N, Gen_Id, Body_Id);
936 -- If the generic unit carries pre- or post-conditions, copy them
937 -- to the original generic tree, so that they are properly added
938 -- to any instantiation.
941 Orig : constant Node_Id := Original_Node (N);
945 Cond := First (Declarations (N));
946 while Present (Cond) loop
947 if Nkind (Cond) = N_Pragma
948 and then Pragma_Name (Cond) = Name_Check
950 Prepend (New_Copy_Tree (Cond), Declarations (Orig));
952 elsif Nkind (Cond) = N_Pragma
953 and then Pragma_Name (Cond) = Name_Postcondition
955 Set_Ekind (Defining_Entity (Orig), Ekind (Gen_Id));
956 Prepend (New_Copy_Tree (Cond), Declarations (Orig));
965 Analyze_Declarations (Declarations (N));
967 Analyze (Handled_Statement_Sequence (N));
969 Save_Global_References (Original_Node (N));
971 -- Prior to exiting the scope, include generic formals again (if any
972 -- are present) in the set of local entities.
974 if Present (First_Ent) then
975 Set_First_Entity (Gen_Id, First_Ent);
978 Check_References (Gen_Id);
981 Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
983 Check_Subprogram_Order (N);
985 -- Outside of its body, unit is generic again
987 Set_Ekind (Gen_Id, Kind);
988 Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
991 Style.Check_Identifier (Body_Id, Gen_Id);
995 end Analyze_Generic_Subprogram_Body;
997 -----------------------------
998 -- Analyze_Operator_Symbol --
999 -----------------------------
1001 -- An operator symbol such as "+" or "and" may appear in context where the
1002 -- literal denotes an entity name, such as "+"(x, y) or in context when it
1003 -- is just a string, as in (conjunction = "or"). In these cases the parser
1004 -- generates this node, and the semantics does the disambiguation. Other
1005 -- such case are actuals in an instantiation, the generic unit in an
1006 -- instantiation, and pragma arguments.
1008 procedure Analyze_Operator_Symbol (N : Node_Id) is
1009 Par : constant Node_Id := Parent (N);
1012 if (Nkind (Par) = N_Function_Call
1013 and then N = Name (Par))
1014 or else Nkind (Par) = N_Function_Instantiation
1015 or else (Nkind (Par) = N_Indexed_Component
1016 and then N = Prefix (Par))
1017 or else (Nkind (Par) = N_Pragma_Argument_Association
1018 and then not Is_Pragma_String_Literal (Par))
1019 or else Nkind (Par) = N_Subprogram_Renaming_Declaration
1020 or else (Nkind (Par) = N_Attribute_Reference
1021 and then Attribute_Name (Par) /= Name_Value)
1023 Find_Direct_Name (N);
1026 Change_Operator_Symbol_To_String_Literal (N);
1029 end Analyze_Operator_Symbol;
1031 -----------------------------------
1032 -- Analyze_Parameter_Association --
1033 -----------------------------------
1035 procedure Analyze_Parameter_Association (N : Node_Id) is
1037 Analyze (Explicit_Actual_Parameter (N));
1038 end Analyze_Parameter_Association;
1040 ----------------------------
1041 -- Analyze_Procedure_Call --
1042 ----------------------------
1044 procedure Analyze_Procedure_Call (N : Node_Id) is
1045 Loc : constant Source_Ptr := Sloc (N);
1046 P : constant Node_Id := Name (N);
1047 Actuals : constant List_Id := Parameter_Associations (N);
1051 procedure Analyze_Call_And_Resolve;
1052 -- Do Analyze and Resolve calls for procedure call
1053 -- At end, check illegal order dependence.
1055 ------------------------------
1056 -- Analyze_Call_And_Resolve --
1057 ------------------------------
1059 procedure Analyze_Call_And_Resolve is
1061 if Nkind (N) = N_Procedure_Call_Statement then
1063 Resolve (N, Standard_Void_Type);
1065 -- Apply checks suggested by AI05-0144
1067 Check_Order_Dependence;
1072 end Analyze_Call_And_Resolve;
1074 -- Start of processing for Analyze_Procedure_Call
1077 -- The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
1078 -- a procedure call or an entry call. The prefix may denote an access
1079 -- to subprogram type, in which case an implicit dereference applies.
1080 -- If the prefix is an indexed component (without implicit dereference)
1081 -- then the construct denotes a call to a member of an entire family.
1082 -- If the prefix is a simple name, it may still denote a call to a
1083 -- parameterless member of an entry family. Resolution of these various
1084 -- interpretations is delicate.
1088 -- If this is a call of the form Obj.Op, the call may have been
1089 -- analyzed and possibly rewritten into a block, in which case
1092 if Analyzed (N) then
1096 -- If there is an error analyzing the name (which may have been
1097 -- rewritten if the original call was in prefix notation) then error
1098 -- has been emitted already, mark node and return.
1101 or else Etype (Name (N)) = Any_Type
1103 Set_Etype (N, Any_Type);
1107 -- Otherwise analyze the parameters
1109 if Present (Actuals) then
1110 Actual := First (Actuals);
1112 while Present (Actual) loop
1114 Check_Parameterless_Call (Actual);
1119 -- Special processing for Elab_Spec and Elab_Body calls
1121 if Nkind (P) = N_Attribute_Reference
1122 and then (Attribute_Name (P) = Name_Elab_Spec
1123 or else Attribute_Name (P) = Name_Elab_Body)
1125 if Present (Actuals) then
1127 ("no parameters allowed for this call", First (Actuals));
1131 Set_Etype (N, Standard_Void_Type);
1134 elsif Is_Entity_Name (P)
1135 and then Is_Record_Type (Etype (Entity (P)))
1136 and then Remote_AST_I_Dereference (P)
1140 elsif Is_Entity_Name (P)
1141 and then Ekind (Entity (P)) /= E_Entry_Family
1143 if Is_Access_Type (Etype (P))
1144 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1145 and then No (Actuals)
1146 and then Comes_From_Source (N)
1148 Error_Msg_N ("missing explicit dereference in call", N);
1151 Analyze_Call_And_Resolve;
1153 -- If the prefix is the simple name of an entry family, this is
1154 -- a parameterless call from within the task body itself.
1156 elsif Is_Entity_Name (P)
1157 and then Nkind (P) = N_Identifier
1158 and then Ekind (Entity (P)) = E_Entry_Family
1159 and then Present (Actuals)
1160 and then No (Next (First (Actuals)))
1162 -- Can be call to parameterless entry family. What appears to be the
1163 -- sole argument is in fact the entry index. Rewrite prefix of node
1164 -- accordingly. Source representation is unchanged by this
1168 Make_Indexed_Component (Loc,
1170 Make_Selected_Component (Loc,
1171 Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
1172 Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
1173 Expressions => Actuals);
1174 Set_Name (N, New_N);
1175 Set_Etype (New_N, Standard_Void_Type);
1176 Set_Parameter_Associations (N, No_List);
1177 Analyze_Call_And_Resolve;
1179 elsif Nkind (P) = N_Explicit_Dereference then
1180 if Ekind (Etype (P)) = E_Subprogram_Type then
1181 Analyze_Call_And_Resolve;
1183 Error_Msg_N ("expect access to procedure in call", P);
1186 -- The name can be a selected component or an indexed component that
1187 -- yields an access to subprogram. Such a prefix is legal if the call
1188 -- has parameter associations.
1190 elsif Is_Access_Type (Etype (P))
1191 and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1193 if Present (Actuals) then
1194 Analyze_Call_And_Resolve;
1196 Error_Msg_N ("missing explicit dereference in call ", N);
1199 -- If not an access to subprogram, then the prefix must resolve to the
1200 -- name of an entry, entry family, or protected operation.
1202 -- For the case of a simple entry call, P is a selected component where
1203 -- the prefix is the task and the selector name is the entry. A call to
1204 -- a protected procedure will have the same syntax. If the protected
1205 -- object contains overloaded operations, the entity may appear as a
1206 -- function, the context will select the operation whose type is Void.
1208 elsif Nkind (P) = N_Selected_Component
1209 and then (Ekind (Entity (Selector_Name (P))) = E_Entry
1211 Ekind (Entity (Selector_Name (P))) = E_Procedure
1213 Ekind (Entity (Selector_Name (P))) = E_Function)
1215 Analyze_Call_And_Resolve;
1217 elsif Nkind (P) = N_Selected_Component
1218 and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
1219 and then Present (Actuals)
1220 and then No (Next (First (Actuals)))
1222 -- Can be call to parameterless entry family. What appears to be the
1223 -- sole argument is in fact the entry index. Rewrite prefix of node
1224 -- accordingly. Source representation is unchanged by this
1228 Make_Indexed_Component (Loc,
1229 Prefix => New_Copy (P),
1230 Expressions => Actuals);
1231 Set_Name (N, New_N);
1232 Set_Etype (New_N, Standard_Void_Type);
1233 Set_Parameter_Associations (N, No_List);
1234 Analyze_Call_And_Resolve;
1236 -- For the case of a reference to an element of an entry family, P is
1237 -- an indexed component whose prefix is a selected component (task and
1238 -- entry family), and whose index is the entry family index.
1240 elsif Nkind (P) = N_Indexed_Component
1241 and then Nkind (Prefix (P)) = N_Selected_Component
1242 and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
1244 Analyze_Call_And_Resolve;
1246 -- If the prefix is the name of an entry family, it is a call from
1247 -- within the task body itself.
1249 elsif Nkind (P) = N_Indexed_Component
1250 and then Nkind (Prefix (P)) = N_Identifier
1251 and then Ekind (Entity (Prefix (P))) = E_Entry_Family
1254 Make_Selected_Component (Loc,
1255 Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
1256 Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
1257 Rewrite (Prefix (P), New_N);
1259 Analyze_Call_And_Resolve;
1261 -- Anything else is an error
1264 Error_Msg_N ("invalid procedure or entry call", N);
1266 end Analyze_Procedure_Call;
1268 ------------------------------
1269 -- Analyze_Return_Statement --
1270 ------------------------------
1272 procedure Analyze_Return_Statement (N : Node_Id) is
1274 pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
1275 N_Extended_Return_Statement));
1277 Returns_Object : constant Boolean :=
1278 Nkind (N) = N_Extended_Return_Statement
1280 (Nkind (N) = N_Simple_Return_Statement
1281 and then Present (Expression (N)));
1282 -- True if we're returning something; that is, "return <expression>;"
1283 -- or "return Result : T [:= ...]". False for "return;". Used for error
1284 -- checking: If Returns_Object is True, N should apply to a function
1285 -- body; otherwise N should apply to a procedure body, entry body,
1286 -- accept statement, or extended return statement.
1288 function Find_What_It_Applies_To return Entity_Id;
1289 -- Find the entity representing the innermost enclosing body, accept
1290 -- statement, or extended return statement. If the result is a callable
1291 -- construct or extended return statement, then this will be the value
1292 -- of the Return_Applies_To attribute. Otherwise, the program is
1293 -- illegal. See RM-6.5(4/2).
1295 -----------------------------
1296 -- Find_What_It_Applies_To --
1297 -----------------------------
1299 function Find_What_It_Applies_To return Entity_Id is
1300 Result : Entity_Id := Empty;
1303 -- Loop outward through the Scope_Stack, skipping blocks and loops
1305 for J in reverse 0 .. Scope_Stack.Last loop
1306 Result := Scope_Stack.Table (J).Entity;
1307 exit when Ekind (Result) /= E_Block and then
1308 Ekind (Result) /= E_Loop;
1311 pragma Assert (Present (Result));
1313 end Find_What_It_Applies_To;
1315 -- Local declarations
1317 Scope_Id : constant Entity_Id := Find_What_It_Applies_To;
1318 Kind : constant Entity_Kind := Ekind (Scope_Id);
1319 Loc : constant Source_Ptr := Sloc (N);
1320 Stm_Entity : constant Entity_Id :=
1322 (E_Return_Statement, Current_Scope, Loc, 'R');
1324 -- Start of processing for Analyze_Return_Statement
1327 Set_Return_Statement_Entity (N, Stm_Entity);
1329 Set_Etype (Stm_Entity, Standard_Void_Type);
1330 Set_Return_Applies_To (Stm_Entity, Scope_Id);
1332 -- Place Return entity on scope stack, to simplify enforcement of 6.5
1333 -- (4/2): an inner return statement will apply to this extended return.
1335 if Nkind (N) = N_Extended_Return_Statement then
1336 Push_Scope (Stm_Entity);
1339 -- Check that pragma No_Return is obeyed. Don't complain about the
1340 -- implicitly-generated return that is placed at the end.
1342 if No_Return (Scope_Id) and then Comes_From_Source (N) then
1343 Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
1346 -- Warn on any unassigned OUT parameters if in procedure
1348 if Ekind (Scope_Id) = E_Procedure then
1349 Warn_On_Unassigned_Out_Parameter (N, Scope_Id);
1352 -- Check that functions return objects, and other things do not
1354 if Kind = E_Function or else Kind = E_Generic_Function then
1355 if not Returns_Object then
1356 Error_Msg_N ("missing expression in return from function", N);
1359 elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
1360 if Returns_Object then
1361 Error_Msg_N ("procedure cannot return value (use function)", N);
1364 elsif Kind = E_Entry or else Kind = E_Entry_Family then
1365 if Returns_Object then
1366 if Is_Protected_Type (Scope (Scope_Id)) then
1367 Error_Msg_N ("entry body cannot return value", N);
1369 Error_Msg_N ("accept statement cannot return value", N);
1373 elsif Kind = E_Return_Statement then
1375 -- We are nested within another return statement, which must be an
1376 -- extended_return_statement.
1378 if Returns_Object then
1380 ("extended_return_statement cannot return value; " &
1381 "use `""RETURN;""`", N);
1385 Error_Msg_N ("illegal context for return statement", N);
1388 if Ekind_In (Kind, E_Function, E_Generic_Function) then
1389 Analyze_Function_Return (N);
1391 elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then
1392 Set_Return_Present (Scope_Id);
1395 if Nkind (N) = N_Extended_Return_Statement then
1399 Kill_Current_Values (Last_Assignment_Only => True);
1400 Check_Unreachable_Code (N);
1401 end Analyze_Return_Statement;
1403 -------------------------------------
1404 -- Analyze_Simple_Return_Statement --
1405 -------------------------------------
1407 procedure Analyze_Simple_Return_Statement (N : Node_Id) is
1409 if Present (Expression (N)) then
1410 Mark_Coextensions (N, Expression (N));
1413 Analyze_Return_Statement (N);
1414 end Analyze_Simple_Return_Statement;
1416 -------------------------
1417 -- Analyze_Return_Type --
1418 -------------------------
1420 procedure Analyze_Return_Type (N : Node_Id) is
1421 Designator : constant Entity_Id := Defining_Entity (N);
1422 Typ : Entity_Id := Empty;
1425 -- Normal case where result definition does not indicate an error
1427 if Result_Definition (N) /= Error then
1428 if Nkind (Result_Definition (N)) = N_Access_Definition then
1429 Check_SPARK_Restriction
1430 ("access result is not allowed", Result_Definition (N));
1432 -- Ada 2005 (AI-254): Handle anonymous access to subprograms
1435 AD : constant Node_Id :=
1436 Access_To_Subprogram_Definition (Result_Definition (N));
1438 if Present (AD) and then Protected_Present (AD) then
1439 Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N);
1441 Typ := Access_Definition (N, Result_Definition (N));
1445 Set_Parent (Typ, Result_Definition (N));
1446 Set_Is_Local_Anonymous_Access (Typ);
1447 Set_Etype (Designator, Typ);
1449 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1451 Null_Exclusion_Static_Checks (N);
1453 -- Subtype_Mark case
1456 Find_Type (Result_Definition (N));
1457 Typ := Entity (Result_Definition (N));
1458 Set_Etype (Designator, Typ);
1460 -- If the result type of a subprogram is not in ALFA, then the
1461 -- subprogram is not in ALFA.
1463 if not Is_In_ALFA (Typ) then
1464 Set_Is_In_ALFA (Designator, False);
1467 -- Unconstrained array as result is not allowed in SPARK
1469 if Is_Array_Type (Typ)
1470 and then not Is_Constrained (Typ)
1472 Check_SPARK_Restriction
1473 ("returning an unconstrained array is not allowed",
1474 Result_Definition (N));
1477 -- Ada 2005 (AI-231): Ensure proper usage of null exclusion
1479 Null_Exclusion_Static_Checks (N);
1481 -- If a null exclusion is imposed on the result type, then create
1482 -- a null-excluding itype (an access subtype) and use it as the
1483 -- function's Etype. Note that the null exclusion checks are done
1484 -- right before this, because they don't get applied to types that
1485 -- do not come from source.
1487 if Is_Access_Type (Typ)
1488 and then Null_Exclusion_Present (N)
1490 Set_Etype (Designator,
1491 Create_Null_Excluding_Itype
1494 Scope_Id => Scope (Current_Scope)));
1496 -- The new subtype must be elaborated before use because
1497 -- it is visible outside of the function. However its base
1498 -- type may not be frozen yet, so the reference that will
1499 -- force elaboration must be attached to the freezing of
1502 -- If the return specification appears on a proper body,
1503 -- the subtype will have been created already on the spec.
1505 if Is_Frozen (Typ) then
1506 if Nkind (Parent (N)) = N_Subprogram_Body
1507 and then Nkind (Parent (Parent (N))) = N_Subunit
1511 Build_Itype_Reference (Etype (Designator), Parent (N));
1515 Ensure_Freeze_Node (Typ);
1518 IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
1520 Set_Itype (IR, Etype (Designator));
1521 Append_Freeze_Actions (Typ, New_List (IR));
1526 Set_Etype (Designator, Typ);
1529 if Ekind (Typ) = E_Incomplete_Type
1530 and then Is_Value_Type (Typ)
1534 elsif Ekind (Typ) = E_Incomplete_Type
1535 or else (Is_Class_Wide_Type (Typ)
1537 Ekind (Root_Type (Typ)) = E_Incomplete_Type)
1539 -- AI05-0151: Tagged incomplete types are allowed in all formal
1540 -- parts. Untagged incomplete types are not allowed in bodies.
1542 if Ada_Version >= Ada_2012 then
1543 if Is_Tagged_Type (Typ) then
1546 elsif Nkind_In (Parent (Parent (N)),
1552 ("invalid use of untagged incomplete type&",
1558 ("invalid use of incomplete type&", Designator, Typ);
1563 -- Case where result definition does indicate an error
1566 Set_Etype (Designator, Any_Type);
1568 end Analyze_Return_Type;
1570 -----------------------------
1571 -- Analyze_Subprogram_Body --
1572 -----------------------------
1574 procedure Analyze_Subprogram_Body (N : Node_Id) is
1575 Loc : constant Source_Ptr := Sloc (N);
1576 Body_Spec : constant Node_Id := Specification (N);
1577 Body_Id : constant Entity_Id := Defining_Entity (Body_Spec);
1580 if Debug_Flag_C then
1581 Write_Str ("==> subprogram body ");
1582 Write_Name (Chars (Body_Id));
1583 Write_Str (" from ");
1584 Write_Location (Loc);
1589 Trace_Scope (N, Body_Id, " Analyze subprogram: ");
1591 -- The real work is split out into the helper, so it can do "return;"
1592 -- without skipping the debug output:
1594 Analyze_Subprogram_Body_Helper (N);
1596 if Debug_Flag_C then
1598 Write_Str ("<== subprogram body ");
1599 Write_Name (Chars (Body_Id));
1600 Write_Str (" from ");
1601 Write_Location (Loc);
1604 end Analyze_Subprogram_Body;
1606 ------------------------------------
1607 -- Analyze_Subprogram_Body_Helper --
1608 ------------------------------------
1610 -- This procedure is called for regular subprogram bodies, generic bodies,
1611 -- and for subprogram stubs of both kinds. In the case of stubs, only the
1612 -- specification matters, and is used to create a proper declaration for
1613 -- the subprogram, or to perform conformance checks.
1615 procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is
1616 Loc : constant Source_Ptr := Sloc (N);
1617 Body_Deleted : constant Boolean := False;
1618 Body_Spec : constant Node_Id := Specification (N);
1619 Body_Id : Entity_Id := Defining_Entity (Body_Spec);
1620 Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
1621 Conformant : Boolean;
1624 Prot_Typ : Entity_Id := Empty;
1625 Spec_Id : Entity_Id;
1626 Spec_Decl : Node_Id := Empty;
1628 Last_Real_Spec_Entity : Entity_Id := Empty;
1629 -- When we analyze a separate spec, the entity chain ends up containing
1630 -- the formals, as well as any itypes generated during analysis of the
1631 -- default expressions for parameters, or the arguments of associated
1632 -- precondition/postcondition pragmas (which are analyzed in the context
1633 -- of the spec since they have visibility on formals).
1635 -- These entities belong with the spec and not the body. However we do
1636 -- the analysis of the body in the context of the spec (again to obtain
1637 -- visibility to the formals), and all the entities generated during
1638 -- this analysis end up also chained to the entity chain of the spec.
1639 -- But they really belong to the body, and there is circuitry to move
1640 -- them from the spec to the body.
1642 -- However, when we do this move, we don't want to move the real spec
1643 -- entities (first para above) to the body. The Last_Real_Spec_Entity
1644 -- variable points to the last real spec entity, so we only move those
1645 -- chained beyond that point. It is initialized to Empty to deal with
1646 -- the case where there is no separate spec.
1648 procedure Check_Anonymous_Return;
1649 -- Ada 2005: if a function returns an access type that denotes a task,
1650 -- or a type that contains tasks, we must create a master entity for
1651 -- the anonymous type, which typically will be used in an allocator
1652 -- in the body of the function.
1654 procedure Check_Inline_Pragma (Spec : in out Node_Id);
1655 -- Look ahead to recognize a pragma that may appear after the body.
1656 -- If there is a previous spec, check that it appears in the same
1657 -- declarative part. If the pragma is Inline_Always, perform inlining
1658 -- unconditionally, otherwise only if Front_End_Inlining is requested.
1659 -- If the body acts as a spec, and inlining is required, we create a
1660 -- subprogram declaration for it, in order to attach the body to inline.
1661 -- If pragma does not appear after the body, check whether there is
1662 -- an inline pragma before any local declarations.
1664 procedure Check_Missing_Return;
1665 -- Checks for a function with a no return statements, and also performs
1666 -- the warning checks implemented by Check_Returns. In formal mode, also
1667 -- verify that a function ends with a RETURN and that a procedure does
1668 -- not contain any RETURN.
1670 function Disambiguate_Spec return Entity_Id;
1671 -- When a primitive is declared between the private view and the full
1672 -- view of a concurrent type which implements an interface, a special
1673 -- mechanism is used to find the corresponding spec of the primitive
1676 function Is_Private_Concurrent_Primitive
1677 (Subp_Id : Entity_Id) return Boolean;
1678 -- Determine whether subprogram Subp_Id is a primitive of a concurrent
1679 -- type that implements an interface and has a private view.
1681 procedure Set_Trivial_Subprogram (N : Node_Id);
1682 -- Sets the Is_Trivial_Subprogram flag in both spec and body of the
1683 -- subprogram whose body is being analyzed. N is the statement node
1684 -- causing the flag to be set, if the following statement is a return
1685 -- of an entity, we mark the entity as set in source to suppress any
1686 -- warning on the stylized use of function stubs with a dummy return.
1688 procedure Verify_Overriding_Indicator;
1689 -- If there was a previous spec, the entity has been entered in the
1690 -- current scope previously. If the body itself carries an overriding
1691 -- indicator, check that it is consistent with the known status of the
1694 ----------------------------
1695 -- Check_Anonymous_Return --
1696 ----------------------------
1698 procedure Check_Anonymous_Return is
1704 if Present (Spec_Id) then
1710 if Ekind (Scop) = E_Function
1711 and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type
1712 and then not Is_Thunk (Scop)
1713 and then (Has_Task (Designated_Type (Etype (Scop)))
1715 (Is_Class_Wide_Type (Designated_Type (Etype (Scop)))
1717 Is_Limited_Record (Designated_Type (Etype (Scop)))))
1718 and then Expander_Active
1720 -- Avoid cases with no tasking support
1722 and then RTE_Available (RE_Current_Master)
1723 and then not Restriction_Active (No_Task_Hierarchy)
1726 Make_Object_Declaration (Loc,
1727 Defining_Identifier =>
1728 Make_Defining_Identifier (Loc, Name_uMaster),
1729 Constant_Present => True,
1730 Object_Definition =>
1731 New_Reference_To (RTE (RE_Master_Id), Loc),
1733 Make_Explicit_Dereference (Loc,
1734 New_Reference_To (RTE (RE_Current_Master), Loc)));
1736 if Present (Declarations (N)) then
1737 Prepend (Decl, Declarations (N));
1739 Set_Declarations (N, New_List (Decl));
1742 Set_Master_Id (Etype (Scop), Defining_Identifier (Decl));
1743 Set_Has_Master_Entity (Scop);
1745 -- Now mark the containing scope as a task master
1748 while Nkind (Par) /= N_Compilation_Unit loop
1749 Par := Parent (Par);
1750 pragma Assert (Present (Par));
1752 -- If we fall off the top, we are at the outer level, and
1753 -- the environment task is our effective master, so nothing
1757 (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body)
1759 Set_Is_Task_Master (Par, True);
1764 end Check_Anonymous_Return;
1766 -------------------------
1767 -- Check_Inline_Pragma --
1768 -------------------------
1770 procedure Check_Inline_Pragma (Spec : in out Node_Id) is
1774 function Is_Inline_Pragma (N : Node_Id) return Boolean;
1775 -- True when N is a pragma Inline or Inline_Always that applies
1776 -- to this subprogram.
1778 -----------------------
1779 -- Is_Inline_Pragma --
1780 -----------------------
1782 function Is_Inline_Pragma (N : Node_Id) return Boolean is
1785 Nkind (N) = N_Pragma
1787 (Pragma_Name (N) = Name_Inline_Always
1790 and then Pragma_Name (N) = Name_Inline))
1793 (Expression (First (Pragma_Argument_Associations (N))))
1795 end Is_Inline_Pragma;
1797 -- Start of processing for Check_Inline_Pragma
1800 if not Expander_Active then
1804 if Is_List_Member (N)
1805 and then Present (Next (N))
1806 and then Is_Inline_Pragma (Next (N))
1810 elsif Nkind (N) /= N_Subprogram_Body_Stub
1811 and then Present (Declarations (N))
1812 and then Is_Inline_Pragma (First (Declarations (N)))
1814 Prag := First (Declarations (N));
1820 if Present (Prag) then
1821 if Present (Spec_Id) then
1822 if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then
1827 -- Create a subprogram declaration, to make treatment uniform
1830 Subp : constant Entity_Id :=
1831 Make_Defining_Identifier (Loc, Chars (Body_Id));
1832 Decl : constant Node_Id :=
1833 Make_Subprogram_Declaration (Loc,
1835 New_Copy_Tree (Specification (N)));
1838 Set_Defining_Unit_Name (Specification (Decl), Subp);
1840 if Present (First_Formal (Body_Id)) then
1841 Plist := Copy_Parameter_List (Body_Id);
1842 Set_Parameter_Specifications
1843 (Specification (Decl), Plist);
1846 Insert_Before (N, Decl);
1849 Set_Has_Pragma_Inline (Subp);
1851 if Pragma_Name (Prag) = Name_Inline_Always then
1852 Set_Is_Inlined (Subp);
1853 Set_Has_Pragma_Inline_Always (Subp);
1860 end Check_Inline_Pragma;
1862 --------------------------
1863 -- Check_Missing_Return --
1864 --------------------------
1866 procedure Check_Missing_Return is
1868 Missing_Ret : Boolean;
1871 if Nkind (Body_Spec) = N_Function_Specification then
1872 if Present (Spec_Id) then
1878 if Return_Present (Id) then
1879 Check_Returns (HSS, 'F', Missing_Ret);
1882 Set_Has_Missing_Return (Id);
1885 elsif (Is_Generic_Subprogram (Id)
1886 or else not Is_Machine_Code_Subprogram (Id))
1887 and then not Body_Deleted
1889 Error_Msg_N ("missing RETURN statement in function body", N);
1892 -- If procedure with No_Return, check returns
1894 elsif Nkind (Body_Spec) = N_Procedure_Specification
1895 and then Present (Spec_Id)
1896 and then No_Return (Spec_Id)
1898 Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
1901 -- Special checks in formal mode
1903 if Nkind (Body_Spec) = N_Function_Specification then
1905 -- In formal mode, last statement of a function should be a return
1908 Stat : constant Node_Id := Last_Source_Statement (HSS);
1911 and then not Nkind_In (Stat, N_Simple_Return_Statement,
1912 N_Extended_Return_Statement)
1914 Set_Body_Is_In_ALFA (Id, False);
1915 Check_SPARK_Restriction
1916 ("last statement in function should be RETURN", Stat);
1920 -- In formal mode, verify that a procedure has no return
1922 elsif Nkind (Body_Spec) = N_Procedure_Specification then
1923 if Present (Spec_Id) then
1929 -- Would be nice to point to return statement here, can we
1930 -- borrow the Check_Returns procedure here ???
1932 if Return_Present (Id) then
1933 Set_Body_Is_In_ALFA (Id, False);
1934 Check_SPARK_Restriction
1935 ("procedure should not have RETURN", N);
1938 end Check_Missing_Return;
1940 -----------------------
1941 -- Disambiguate_Spec --
1942 -----------------------
1944 function Disambiguate_Spec return Entity_Id is
1945 Priv_Spec : Entity_Id;
1948 procedure Replace_Types (To_Corresponding : Boolean);
1949 -- Depending on the flag, replace the type of formal parameters of
1950 -- Body_Id if it is a concurrent type implementing interfaces with
1951 -- the corresponding record type or the other way around.
1953 procedure Replace_Types (To_Corresponding : Boolean) is
1955 Formal_Typ : Entity_Id;
1958 Formal := First_Formal (Body_Id);
1959 while Present (Formal) loop
1960 Formal_Typ := Etype (Formal);
1962 -- From concurrent type to corresponding record
1964 if To_Corresponding then
1965 if Is_Concurrent_Type (Formal_Typ)
1966 and then Present (Corresponding_Record_Type (Formal_Typ))
1967 and then Present (Interfaces (
1968 Corresponding_Record_Type (Formal_Typ)))
1971 Corresponding_Record_Type (Formal_Typ));
1974 -- From corresponding record to concurrent type
1977 if Is_Concurrent_Record_Type (Formal_Typ)
1978 and then Present (Interfaces (Formal_Typ))
1981 Corresponding_Concurrent_Type (Formal_Typ));
1985 Next_Formal (Formal);
1989 -- Start of processing for Disambiguate_Spec
1992 -- Try to retrieve the specification of the body as is. All error
1993 -- messages are suppressed because the body may not have a spec in
1994 -- its current state.
1996 Spec_N := Find_Corresponding_Spec (N, False);
1998 -- It is possible that this is the body of a primitive declared
1999 -- between a private and a full view of a concurrent type. The
2000 -- controlling parameter of the spec carries the concurrent type,
2001 -- not the corresponding record type as transformed by Analyze_
2002 -- Subprogram_Specification. In such cases, we undo the change
2003 -- made by the analysis of the specification and try to find the
2006 -- Note that wrappers already have their corresponding specs and
2007 -- bodies set during their creation, so if the candidate spec is
2008 -- a wrapper, then we definitely need to swap all types to their
2009 -- original concurrent status.
2012 or else Is_Primitive_Wrapper (Spec_N)
2014 -- Restore all references of corresponding record types to the
2015 -- original concurrent types.
2017 Replace_Types (To_Corresponding => False);
2018 Priv_Spec := Find_Corresponding_Spec (N, False);
2020 -- The current body truly belongs to a primitive declared between
2021 -- a private and a full view. We leave the modified body as is,
2022 -- and return the true spec.
2024 if Present (Priv_Spec)
2025 and then Is_Private_Primitive (Priv_Spec)
2030 -- In case that this is some sort of error, restore the original
2031 -- state of the body.
2033 Replace_Types (To_Corresponding => True);
2037 end Disambiguate_Spec;
2039 -------------------------------------
2040 -- Is_Private_Concurrent_Primitive --
2041 -------------------------------------
2043 function Is_Private_Concurrent_Primitive
2044 (Subp_Id : Entity_Id) return Boolean
2046 Formal_Typ : Entity_Id;
2049 if Present (First_Formal (Subp_Id)) then
2050 Formal_Typ := Etype (First_Formal (Subp_Id));
2052 if Is_Concurrent_Record_Type (Formal_Typ) then
2053 Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ);
2056 -- The type of the first formal is a concurrent tagged type with
2060 Is_Concurrent_Type (Formal_Typ)
2061 and then Is_Tagged_Type (Formal_Typ)
2062 and then Has_Private_Declaration (Formal_Typ);
2066 end Is_Private_Concurrent_Primitive;
2068 ----------------------------
2069 -- Set_Trivial_Subprogram --
2070 ----------------------------
2072 procedure Set_Trivial_Subprogram (N : Node_Id) is
2073 Nxt : constant Node_Id := Next (N);
2076 Set_Is_Trivial_Subprogram (Body_Id);
2078 if Present (Spec_Id) then
2079 Set_Is_Trivial_Subprogram (Spec_Id);
2083 and then Nkind (Nxt) = N_Simple_Return_Statement
2084 and then No (Next (Nxt))
2085 and then Present (Expression (Nxt))
2086 and then Is_Entity_Name (Expression (Nxt))
2088 Set_Never_Set_In_Source (Entity (Expression (Nxt)), False);
2090 end Set_Trivial_Subprogram;
2092 ---------------------------------
2093 -- Verify_Overriding_Indicator --
2094 ---------------------------------
2096 procedure Verify_Overriding_Indicator is
2098 if Must_Override (Body_Spec) then
2099 if Nkind (Spec_Id) = N_Defining_Operator_Symbol
2100 and then Operator_Matches_Spec (Spec_Id, Spec_Id)
2104 elsif not Present (Overridden_Operation (Spec_Id)) then
2106 ("subprogram& is not overriding", Body_Spec, Spec_Id);
2109 elsif Must_Not_Override (Body_Spec) then
2110 if Present (Overridden_Operation (Spec_Id)) then
2112 ("subprogram& overrides inherited operation",
2113 Body_Spec, Spec_Id);
2115 elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol
2116 and then Operator_Matches_Spec (Spec_Id, Spec_Id)
2119 ("subprogram & overrides predefined operator ",
2120 Body_Spec, Spec_Id);
2122 -- If this is not a primitive operation or protected subprogram,
2123 -- then the overriding indicator is altogether illegal.
2125 elsif not Is_Primitive (Spec_Id)
2126 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
2129 ("overriding indicator only allowed " &
2130 "if subprogram is primitive",
2135 and then Present (Overridden_Operation (Spec_Id))
2137 pragma Assert (Unit_Declaration_Node (Body_Id) = N);
2138 Style.Missing_Overriding (N, Body_Id);
2141 and then Can_Override_Operator (Spec_Id)
2142 and then not Is_Predefined_File_Name
2143 (Unit_File_Name (Get_Source_Unit (Spec_Id)))
2145 pragma Assert (Unit_Declaration_Node (Body_Id) = N);
2146 Style.Missing_Overriding (N, Body_Id);
2148 end Verify_Overriding_Indicator;
2150 -- Start of processing for Analyze_Subprogram_Body_Helper
2153 -- Generic subprograms are handled separately. They always have a
2154 -- generic specification. Determine whether current scope has a
2155 -- previous declaration.
2157 -- If the subprogram body is defined within an instance of the same
2158 -- name, the instance appears as a package renaming, and will be hidden
2159 -- within the subprogram.
2161 if Present (Prev_Id)
2162 and then not Is_Overloadable (Prev_Id)
2163 and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
2164 or else Comes_From_Source (Prev_Id))
2166 if Is_Generic_Subprogram (Prev_Id) then
2168 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
2169 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
2171 Analyze_Generic_Subprogram_Body (N, Spec_Id);
2173 if Nkind (N) = N_Subprogram_Body then
2174 HSS := Handled_Statement_Sequence (N);
2175 Check_Missing_Return;
2181 -- Previous entity conflicts with subprogram name. Attempting to
2182 -- enter name will post error.
2184 Enter_Name (Body_Id);
2188 -- Non-generic case, find the subprogram declaration, if one was seen,
2189 -- or enter new overloaded entity in the current scope. If the
2190 -- Current_Entity is the Body_Id itself, the unit is being analyzed as
2191 -- part of the context of one of its subunits. No need to redo the
2194 elsif Prev_Id = Body_Id
2195 and then Has_Completion (Body_Id)
2200 Body_Id := Analyze_Subprogram_Specification (Body_Spec);
2202 if Nkind (N) = N_Subprogram_Body_Stub
2203 or else No (Corresponding_Spec (N))
2205 if Is_Private_Concurrent_Primitive (Body_Id) then
2206 Spec_Id := Disambiguate_Spec;
2208 Spec_Id := Find_Corresponding_Spec (N);
2211 -- If this is a duplicate body, no point in analyzing it
2213 if Error_Posted (N) then
2217 -- A subprogram body should cause freezing of its own declaration,
2218 -- but if there was no previous explicit declaration, then the
2219 -- subprogram will get frozen too late (there may be code within
2220 -- the body that depends on the subprogram having been frozen,
2221 -- such as uses of extra formals), so we force it to be frozen
2222 -- here. Same holds if the body and spec are compilation units.
2223 -- Finally, if the return type is an anonymous access to protected
2224 -- subprogram, it must be frozen before the body because its
2225 -- expansion has generated an equivalent type that is used when
2226 -- elaborating the body.
2228 if No (Spec_Id) then
2229 Freeze_Before (N, Body_Id);
2231 elsif Nkind (Parent (N)) = N_Compilation_Unit then
2232 Freeze_Before (N, Spec_Id);
2234 elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then
2235 Freeze_Before (N, Etype (Body_Id));
2239 Spec_Id := Corresponding_Spec (N);
2243 -- By default, consider that the subprogram body is in ALFA if the spec
2244 -- is in ALFA. This is reversed later if some expression or statement is
2250 if Present (Spec_Id) then
2256 if Is_In_ALFA (Id) then
2257 Set_Body_Is_In_ALFA (Id);
2261 -- Do not inline any subprogram that contains nested subprograms, since
2262 -- the backend inlining circuit seems to generate uninitialized
2263 -- references in this case. We know this happens in the case of front
2264 -- end ZCX support, but it also appears it can happen in other cases as
2265 -- well. The backend often rejects attempts to inline in the case of
2266 -- nested procedures anyway, so little if anything is lost by this.
2267 -- Note that this is test is for the benefit of the back-end. There is
2268 -- a separate test for front-end inlining that also rejects nested
2271 -- Do not do this test if errors have been detected, because in some
2272 -- error cases, this code blows up, and we don't need it anyway if
2273 -- there have been errors, since we won't get to the linker anyway.
2275 if Comes_From_Source (Body_Id)
2276 and then Serious_Errors_Detected = 0
2280 P_Ent := Scope (P_Ent);
2281 exit when No (P_Ent) or else P_Ent = Standard_Standard;
2283 if Is_Subprogram (P_Ent) then
2284 Set_Is_Inlined (P_Ent, False);
2286 if Comes_From_Source (P_Ent)
2287 and then Has_Pragma_Inline (P_Ent)
2290 ("cannot inline& (nested subprogram)?",
2297 Check_Inline_Pragma (Spec_Id);
2299 -- Deal with special case of a fully private operation in the body of
2300 -- the protected type. We must create a declaration for the subprogram,
2301 -- in order to attach the protected subprogram that will be used in
2302 -- internal calls. We exclude compiler generated bodies from the
2303 -- expander since the issue does not arise for those cases.
2306 and then Comes_From_Source (N)
2307 and then Is_Protected_Type (Current_Scope)
2309 Spec_Id := Build_Private_Protected_Declaration (N);
2312 -- If a separate spec is present, then deal with freezing issues
2314 if Present (Spec_Id) then
2315 Spec_Decl := Unit_Declaration_Node (Spec_Id);
2316 Verify_Overriding_Indicator;
2318 -- In general, the spec will be frozen when we start analyzing the
2319 -- body. However, for internally generated operations, such as
2320 -- wrapper functions for inherited operations with controlling
2321 -- results, the spec may not have been frozen by the time we
2322 -- expand the freeze actions that include the bodies. In particular,
2323 -- extra formals for accessibility or for return-in-place may need
2324 -- to be generated. Freeze nodes, if any, are inserted before the
2327 if not Is_Frozen (Spec_Id)
2328 and then Expander_Active
2330 -- Force the generation of its freezing node to ensure proper
2331 -- management of access types in the backend.
2333 -- This is definitely needed for some cases, but it is not clear
2334 -- why, to be investigated further???
2336 Set_Has_Delayed_Freeze (Spec_Id);
2337 Freeze_Before (N, Spec_Id);
2341 -- Mark presence of postcondition procedure in current scope and mark
2342 -- the procedure itself as needing debug info. The latter is important
2343 -- when analyzing decision coverage (for example, for MC/DC coverage).
2345 if Chars (Body_Id) = Name_uPostconditions then
2346 Set_Has_Postconditions (Current_Scope);
2347 Set_Debug_Info_Needed (Body_Id);
2350 -- Place subprogram on scope stack, and make formals visible. If there
2351 -- is a spec, the visible entity remains that of the spec.
2353 if Present (Spec_Id) then
2354 Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
2356 if Is_Child_Unit (Spec_Id) then
2357 Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False);
2361 Style.Check_Identifier (Body_Id, Spec_Id);
2364 Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
2365 Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
2367 if Is_Abstract_Subprogram (Spec_Id) then
2368 Error_Msg_N ("an abstract subprogram cannot have a body", N);
2372 Set_Convention (Body_Id, Convention (Spec_Id));
2373 Set_Has_Completion (Spec_Id);
2375 if Is_Protected_Type (Scope (Spec_Id)) then
2376 Prot_Typ := Scope (Spec_Id);
2379 -- If this is a body generated for a renaming, do not check for
2380 -- full conformance. The check is redundant, because the spec of
2381 -- the body is a copy of the spec in the renaming declaration,
2382 -- and the test can lead to spurious errors on nested defaults.
2384 if Present (Spec_Decl)
2385 and then not Comes_From_Source (N)
2387 (Nkind (Original_Node (Spec_Decl)) =
2388 N_Subprogram_Renaming_Declaration
2389 or else (Present (Corresponding_Body (Spec_Decl))
2391 Nkind (Unit_Declaration_Node
2392 (Corresponding_Body (Spec_Decl))) =
2393 N_Subprogram_Renaming_Declaration))
2397 -- Conversely, the spec may have been generated for specless body
2398 -- with an inline pragma.
2400 elsif Comes_From_Source (N)
2401 and then not Comes_From_Source (Spec_Id)
2402 and then Has_Pragma_Inline (Spec_Id)
2409 Fully_Conformant, True, Conformant, Body_Id);
2412 -- If the body is not fully conformant, we have to decide if we
2413 -- should analyze it or not. If it has a really messed up profile
2414 -- then we probably should not analyze it, since we will get too
2415 -- many bogus messages.
2417 -- Our decision is to go ahead in the non-fully conformant case
2418 -- only if it is at least mode conformant with the spec. Note
2419 -- that the call to Check_Fully_Conformant has issued the proper
2420 -- error messages to complain about the lack of conformance.
2423 and then not Mode_Conformant (Body_Id, Spec_Id)
2429 if Spec_Id /= Body_Id then
2430 Reference_Body_Formals (Spec_Id, Body_Id);
2433 if Nkind (N) /= N_Subprogram_Body_Stub then
2434 Set_Corresponding_Spec (N, Spec_Id);
2436 -- Ada 2005 (AI-345): If the operation is a primitive operation
2437 -- of a concurrent type, the type of the first parameter has been
2438 -- replaced with the corresponding record, which is the proper
2439 -- run-time structure to use. However, within the body there may
2440 -- be uses of the formals that depend on primitive operations
2441 -- of the type (in particular calls in prefixed form) for which
2442 -- we need the original concurrent type. The operation may have
2443 -- several controlling formals, so the replacement must be done
2446 if Comes_From_Source (Spec_Id)
2447 and then Present (First_Entity (Spec_Id))
2448 and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
2449 and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
2451 Present (Interfaces (Etype (First_Entity (Spec_Id))))
2454 (Corresponding_Concurrent_Type
2455 (Etype (First_Entity (Spec_Id))))
2458 Typ : constant Entity_Id := Etype (First_Entity (Spec_Id));
2462 Form := First_Formal (Spec_Id);
2463 while Present (Form) loop
2464 if Etype (Form) = Typ then
2465 Set_Etype (Form, Corresponding_Concurrent_Type (Typ));
2473 -- Make the formals visible, and place subprogram on scope stack.
2474 -- This is also the point at which we set Last_Real_Spec_Entity
2475 -- to mark the entities which will not be moved to the body.
2477 Install_Formals (Spec_Id);
2478 Last_Real_Spec_Entity := Last_Entity (Spec_Id);
2479 Push_Scope (Spec_Id);
2481 -- Make sure that the subprogram is immediately visible. For
2482 -- child units that have no separate spec this is indispensable.
2483 -- Otherwise it is safe albeit redundant.
2485 Set_Is_Immediately_Visible (Spec_Id);
2488 Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
2489 Set_Ekind (Body_Id, E_Subprogram_Body);
2490 Set_Scope (Body_Id, Scope (Spec_Id));
2491 Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
2492 Set_Is_In_ALFA (Body_Id, False);
2494 -- Case of subprogram body with no previous spec
2497 -- Check for style warning required
2501 -- Only apply check for source level subprograms for which checks
2502 -- have not been suppressed.
2504 and then Comes_From_Source (Body_Id)
2505 and then not Suppress_Style_Checks (Body_Id)
2507 -- No warnings within an instance
2509 and then not In_Instance
2511 -- No warnings for expression functions
2513 and then Nkind (Original_Node (N)) /= N_Expression_Function
2515 Style.Body_With_No_Spec (N);
2518 New_Overloaded_Entity (Body_Id);
2520 if Nkind (N) /= N_Subprogram_Body_Stub then
2521 Set_Acts_As_Spec (N);
2522 Generate_Definition (Body_Id);
2524 (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
2525 Generate_Reference_To_Formals (Body_Id);
2526 Install_Formals (Body_Id);
2527 Push_Scope (Body_Id);
2531 -- If the return type is an anonymous access type whose designated type
2532 -- is the limited view of a class-wide type and the non-limited view is
2533 -- available, update the return type accordingly.
2535 if Ada_Version >= Ada_2005
2536 and then Comes_From_Source (N)
2543 Rtyp := Etype (Current_Scope);
2545 if Ekind (Rtyp) = E_Anonymous_Access_Type then
2546 Etyp := Directly_Designated_Type (Rtyp);
2548 if Is_Class_Wide_Type (Etyp)
2549 and then From_With_Type (Etyp)
2551 Set_Directly_Designated_Type
2552 (Etype (Current_Scope), Available_View (Etyp));
2558 -- If this is the proper body of a stub, we must verify that the stub
2559 -- conforms to the body, and to the previous spec if one was present.
2560 -- we know already that the body conforms to that spec. This test is
2561 -- only required for subprograms that come from source.
2563 if Nkind (Parent (N)) = N_Subunit
2564 and then Comes_From_Source (N)
2565 and then not Error_Posted (Body_Id)
2566 and then Nkind (Corresponding_Stub (Parent (N))) =
2567 N_Subprogram_Body_Stub
2570 Old_Id : constant Entity_Id :=
2572 (Specification (Corresponding_Stub (Parent (N))));
2574 Conformant : Boolean := False;
2577 if No (Spec_Id) then
2578 Check_Fully_Conformant (Body_Id, Old_Id);
2582 (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
2584 if not Conformant then
2586 -- The stub was taken to be a new declaration. Indicate
2587 -- that it lacks a body.
2589 Set_Has_Completion (Old_Id, False);
2595 Set_Has_Completion (Body_Id);
2596 Check_Eliminated (Body_Id);
2598 if Nkind (N) = N_Subprogram_Body_Stub then
2601 elsif Present (Spec_Id)
2602 and then Expander_Active
2604 (Has_Pragma_Inline_Always (Spec_Id)
2605 or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
2607 Build_Body_To_Inline (N, Spec_Id);
2610 -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
2611 -- if its specification we have to install the private withed units.
2612 -- This holds for child units as well.
2614 if Is_Compilation_Unit (Body_Id)
2615 or else Nkind (Parent (N)) = N_Compilation_Unit
2617 Install_Private_With_Clauses (Body_Id);
2620 Check_Anonymous_Return;
2622 -- Set the Protected_Formal field of each extra formal of the protected
2623 -- subprogram to reference the corresponding extra formal of the
2624 -- subprogram that implements it. For regular formals this occurs when
2625 -- the protected subprogram's declaration is expanded, but the extra
2626 -- formals don't get created until the subprogram is frozen. We need to
2627 -- do this before analyzing the protected subprogram's body so that any
2628 -- references to the original subprogram's extra formals will be changed
2629 -- refer to the implementing subprogram's formals (see Expand_Formal).
2631 if Present (Spec_Id)
2632 and then Is_Protected_Type (Scope (Spec_Id))
2633 and then Present (Protected_Body_Subprogram (Spec_Id))
2636 Impl_Subp : constant Entity_Id :=
2637 Protected_Body_Subprogram (Spec_Id);
2638 Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id);
2639 Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp);
2641 while Present (Prot_Ext_Formal) loop
2642 pragma Assert (Present (Impl_Ext_Formal));
2643 Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
2644 Next_Formal_With_Extras (Prot_Ext_Formal);
2645 Next_Formal_With_Extras (Impl_Ext_Formal);
2650 -- Now we can go on to analyze the body
2652 HSS := Handled_Statement_Sequence (N);
2653 Set_Actual_Subtypes (N, Current_Scope);
2655 -- Deal with preconditions and postconditions
2657 Process_PPCs (N, Spec_Id, Body_Id);
2659 -- Add a declaration for the Protection object, renaming declarations
2660 -- for discriminals and privals and finally a declaration for the entry
2661 -- family index (if applicable). This form of early expansion is done
2662 -- when the Expander is active because Install_Private_Data_Declarations
2663 -- references entities which were created during regular expansion.
2666 and then Comes_From_Source (N)
2667 and then Present (Prot_Typ)
2668 and then Present (Spec_Id)
2669 and then not Is_Eliminated (Spec_Id)
2671 Install_Private_Data_Declarations
2672 (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N));
2675 -- Analyze the declarations (this call will analyze the precondition
2676 -- Check pragmas we prepended to the list, as well as the declaration
2677 -- of the _Postconditions procedure).
2679 Analyze_Declarations (Declarations (N));
2681 -- Check completion, and analyze the statements
2684 Inspect_Deferred_Constant_Completion (Declarations (N));
2687 -- Deal with end of scope processing for the body
2689 Process_End_Label (HSS, 't', Current_Scope);
2691 Check_Subprogram_Order (N);
2692 Set_Analyzed (Body_Id);
2694 -- If we have a separate spec, then the analysis of the declarations
2695 -- caused the entities in the body to be chained to the spec id, but
2696 -- we want them chained to the body id. Only the formal parameters
2697 -- end up chained to the spec id in this case.
2699 if Present (Spec_Id) then
2701 -- We must conform to the categorization of our spec
2703 Validate_Categorization_Dependency (N, Spec_Id);
2705 -- And if this is a child unit, the parent units must conform
2707 if Is_Child_Unit (Spec_Id) then
2708 Validate_Categorization_Dependency
2709 (Unit_Declaration_Node (Spec_Id), Spec_Id);
2712 -- Here is where we move entities from the spec to the body
2714 -- Case where there are entities that stay with the spec
2716 if Present (Last_Real_Spec_Entity) then
2718 -- No body entities (happens when the only real spec entities
2719 -- come from precondition and postcondition pragmas)
2721 if No (Last_Entity (Body_Id)) then
2723 (Body_Id, Next_Entity (Last_Real_Spec_Entity));
2725 -- Body entities present (formals), so chain stuff past them
2729 (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity));
2732 Set_Next_Entity (Last_Real_Spec_Entity, Empty);
2733 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
2734 Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity);
2736 -- Case where there are no spec entities, in this case there can
2737 -- be no body entities either, so just move everything.
2740 pragma Assert (No (Last_Entity (Body_Id)));
2741 Set_First_Entity (Body_Id, First_Entity (Spec_Id));
2742 Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
2743 Set_First_Entity (Spec_Id, Empty);
2744 Set_Last_Entity (Spec_Id, Empty);
2748 Check_Missing_Return;
2750 -- Now we are going to check for variables that are never modified in
2751 -- the body of the procedure. But first we deal with a special case
2752 -- where we want to modify this check. If the body of the subprogram
2753 -- starts with a raise statement or its equivalent, or if the body
2754 -- consists entirely of a null statement, then it is pretty obvious
2755 -- that it is OK to not reference the parameters. For example, this
2756 -- might be the following common idiom for a stubbed function:
2757 -- statement of the procedure raises an exception. In particular this
2758 -- deals with the common idiom of a stubbed function, which might
2759 -- appear as something like
2761 -- function F (A : Integer) return Some_Type;
2764 -- raise Program_Error;
2768 -- Here the purpose of X is simply to satisfy the annoying requirement
2769 -- in Ada that there be at least one return, and we certainly do not
2770 -- want to go posting warnings on X that it is not initialized! On
2771 -- the other hand, if X is entirely unreferenced that should still
2774 -- What we do is to detect these cases, and if we find them, flag the
2775 -- subprogram as being Is_Trivial_Subprogram and then use that flag to
2776 -- suppress unwanted warnings. For the case of the function stub above
2777 -- we have a special test to set X as apparently assigned to suppress
2784 -- Skip initial labels (for one thing this occurs when we are in
2785 -- front end ZCX mode, but in any case it is irrelevant), and also
2786 -- initial Push_xxx_Error_Label nodes, which are also irrelevant.
2788 Stm := First (Statements (HSS));
2789 while Nkind (Stm) = N_Label
2790 or else Nkind (Stm) in N_Push_xxx_Label
2795 -- Do the test on the original statement before expansion
2798 Ostm : constant Node_Id := Original_Node (Stm);
2801 -- If explicit raise statement, turn on flag
2803 if Nkind (Ostm) = N_Raise_Statement then
2804 Set_Trivial_Subprogram (Stm);
2806 -- If null statement, and no following statements, turn on flag
2808 elsif Nkind (Stm) = N_Null_Statement
2809 and then Comes_From_Source (Stm)
2810 and then No (Next (Stm))
2812 Set_Trivial_Subprogram (Stm);
2814 -- Check for explicit call cases which likely raise an exception
2816 elsif Nkind (Ostm) = N_Procedure_Call_Statement then
2817 if Is_Entity_Name (Name (Ostm)) then
2819 Ent : constant Entity_Id := Entity (Name (Ostm));
2822 -- If the procedure is marked No_Return, then likely it
2823 -- raises an exception, but in any case it is not coming
2824 -- back here, so turn on the flag.
2826 if Ekind (Ent) = E_Procedure
2827 and then No_Return (Ent)
2829 Set_Trivial_Subprogram (Stm);
2837 -- Check for variables that are never modified
2843 -- If there is a separate spec, then transfer Never_Set_In_Source
2844 -- flags from out parameters to the corresponding entities in the
2845 -- body. The reason we do that is we want to post error flags on
2846 -- the body entities, not the spec entities.
2848 if Present (Spec_Id) then
2849 E1 := First_Entity (Spec_Id);
2850 while Present (E1) loop
2851 if Ekind (E1) = E_Out_Parameter then
2852 E2 := First_Entity (Body_Id);
2853 while Present (E2) loop
2854 exit when Chars (E1) = Chars (E2);
2858 if Present (E2) then
2859 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
2867 -- Check references in body unless it was deleted. Note that the
2868 -- check of Body_Deleted here is not just for efficiency, it is
2869 -- necessary to avoid junk warnings on formal parameters.
2871 if not Body_Deleted then
2872 Check_References (Body_Id);
2875 end Analyze_Subprogram_Body_Helper;
2877 ------------------------------------
2878 -- Analyze_Subprogram_Declaration --
2879 ------------------------------------
2881 procedure Analyze_Subprogram_Declaration (N : Node_Id) is
2882 Loc : constant Source_Ptr := Sloc (N);
2883 Scop : constant Entity_Id := Current_Scope;
2884 Designator : Entity_Id;
2886 Null_Body : Node_Id := Empty;
2888 -- Start of processing for Analyze_Subprogram_Declaration
2891 -- Null procedures are not allowed in SPARK
2893 if Nkind (Specification (N)) = N_Procedure_Specification
2894 and then Null_Present (Specification (N))
2896 Check_SPARK_Restriction ("null procedure is not allowed", N);
2899 -- For a null procedure, capture the profile before analysis, for
2900 -- expansion at the freeze point and at each point of call. The body
2901 -- will only be used if the procedure has preconditions. In that case
2902 -- the body is analyzed at the freeze point.
2904 if Nkind (Specification (N)) = N_Procedure_Specification
2905 and then Null_Present (Specification (N))
2906 and then Expander_Active
2909 Make_Subprogram_Body (Loc,
2911 New_Copy_Tree (Specification (N)),
2914 Handled_Statement_Sequence =>
2915 Make_Handled_Sequence_Of_Statements (Loc,
2916 Statements => New_List (Make_Null_Statement (Loc))));
2918 -- Create new entities for body and formals
2920 Set_Defining_Unit_Name (Specification (Null_Body),
2921 Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))));
2922 Set_Corresponding_Body (N, Defining_Entity (Null_Body));
2924 Form := First (Parameter_Specifications (Specification (Null_Body)));
2925 while Present (Form) loop
2926 Set_Defining_Identifier (Form,
2927 Make_Defining_Identifier (Loc,
2928 Chars (Defining_Identifier (Form))));
2930 -- Resolve the types of the formals now, because the freeze point
2931 -- may appear in a different context, e.g. an instantiation.
2933 if Nkind (Parameter_Type (Form)) /= N_Access_Definition then
2934 Find_Type (Parameter_Type (Form));
2937 No (Access_To_Subprogram_Definition (Parameter_Type (Form)))
2939 Find_Type (Subtype_Mark (Parameter_Type (Form)));
2943 -- the case of a null procedure with a formal that is an
2944 -- access_to_subprogram type, and that is used as an actual
2945 -- in an instantiation is left to the enthusiastic reader.
2953 if Is_Protected_Type (Current_Scope) then
2954 Error_Msg_N ("protected operation cannot be a null procedure", N);
2958 Designator := Analyze_Subprogram_Specification (Specification (N));
2959 Generate_Definition (Designator);
2961 if Debug_Flag_C then
2962 Write_Str ("==> subprogram spec ");
2963 Write_Name (Chars (Designator));
2964 Write_Str (" from ");
2965 Write_Location (Sloc (N));
2970 if Nkind (Specification (N)) = N_Procedure_Specification
2971 and then Null_Present (Specification (N))
2973 Set_Has_Completion (Designator);
2975 if Present (Null_Body) then
2976 Set_Corresponding_Body (N, Defining_Entity (Null_Body));
2977 Set_Body_To_Inline (N, Null_Body);
2978 Set_Is_Inlined (Designator);
2982 Validate_RCI_Subprogram_Declaration (N);
2983 New_Overloaded_Entity (Designator);
2984 Check_Delayed_Subprogram (Designator);
2986 -- If the type of the first formal of the current subprogram is a
2987 -- nongeneric tagged private type, mark the subprogram as being a
2988 -- private primitive. Ditto if this is a function with controlling
2989 -- result, and the return type is currently private. In both cases,
2990 -- the type of the controlling argument or result must be in the
2991 -- current scope for the operation to be primitive.
2993 if Has_Controlling_Result (Designator)
2994 and then Is_Private_Type (Etype (Designator))
2995 and then Scope (Etype (Designator)) = Current_Scope
2996 and then not Is_Generic_Actual_Type (Etype (Designator))
2998 Set_Is_Private_Primitive (Designator);
3000 elsif Present (First_Formal (Designator)) then
3002 Formal_Typ : constant Entity_Id :=
3003 Etype (First_Formal (Designator));
3005 Set_Is_Private_Primitive (Designator,
3006 Is_Tagged_Type (Formal_Typ)
3007 and then Scope (Formal_Typ) = Current_Scope
3008 and then Is_Private_Type (Formal_Typ)
3009 and then not Is_Generic_Actual_Type (Formal_Typ));
3013 -- Ada 2005 (AI-251): Abstract interface primitives must be abstract
3016 if Ada_Version >= Ada_2005
3017 and then Comes_From_Source (N)
3018 and then Is_Dispatching_Operation (Designator)
3025 if Has_Controlling_Result (Designator) then
3026 Etyp := Etype (Designator);
3029 E := First_Entity (Designator);
3031 and then Is_Formal (E)
3032 and then not Is_Controlling_Formal (E)
3040 if Is_Access_Type (Etyp) then
3041 Etyp := Directly_Designated_Type (Etyp);
3044 if Is_Interface (Etyp)
3045 and then not Is_Abstract_Subprogram (Designator)
3046 and then not (Ekind (Designator) = E_Procedure
3047 and then Null_Present (Specification (N)))
3049 Error_Msg_Name_1 := Chars (Defining_Entity (N));
3051 ("(Ada 2005) interface subprogram % must be abstract or null",
3057 -- What is the following code for, it used to be
3059 -- ??? Set_Suppress_Elaboration_Checks
3060 -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
3062 -- The following seems equivalent, but a bit dubious
3064 if Elaboration_Checks_Suppressed (Designator) then
3065 Set_Kill_Elaboration_Checks (Designator);
3068 if Scop /= Standard_Standard
3069 and then not Is_Child_Unit (Designator)
3071 Set_Categorization_From_Scope (Designator, Scop);
3073 -- For a compilation unit, check for library-unit pragmas
3075 Push_Scope (Designator);
3076 Set_Categorization_From_Pragmas (N);
3077 Validate_Categorization_Dependency (N, Designator);
3081 -- For a compilation unit, set body required. This flag will only be
3082 -- reset if a valid Import or Interface pragma is processed later on.
3084 if Nkind (Parent (N)) = N_Compilation_Unit then
3085 Set_Body_Required (Parent (N), True);
3087 if Ada_Version >= Ada_2005
3088 and then Nkind (Specification (N)) = N_Procedure_Specification
3089 and then Null_Present (Specification (N))
3092 ("null procedure cannot be declared at library level", N);
3096 Generate_Reference_To_Formals (Designator);
3097 Check_Eliminated (Designator);
3099 if Debug_Flag_C then
3101 Write_Str ("<== subprogram spec ");
3102 Write_Name (Chars (Designator));
3103 Write_Str (" from ");
3104 Write_Location (Sloc (N));
3108 if Is_Protected_Type (Current_Scope) then
3110 -- Indicate that this is a protected operation, because it may be
3111 -- used in subsequent declarations within the protected type.
3113 Set_Convention (Designator, Convention_Protected);
3116 List_Inherited_Pre_Post_Aspects (Designator);
3118 if Has_Aspects (N) then
3119 Analyze_Aspect_Specifications (N, Designator);
3121 end Analyze_Subprogram_Declaration;
3123 --------------------------------------
3124 -- Analyze_Subprogram_Specification --
3125 --------------------------------------
3127 -- Reminder: N here really is a subprogram specification (not a subprogram
3128 -- declaration). This procedure is called to analyze the specification in
3129 -- both subprogram bodies and subprogram declarations (specs).
3131 function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
3132 Designator : constant Entity_Id := Defining_Entity (N);
3133 Formals : constant List_Id := Parameter_Specifications (N);
3135 -- Start of processing for Analyze_Subprogram_Specification
3138 -- By default, consider that the subprogram spec is in ALFA. This is
3139 -- reversed later if some parameter or result is not in ALFA.
3141 Set_Is_In_ALFA (Designator);
3143 -- User-defined operator is not allowed in SPARK, except as a renaming
3145 if Nkind (Defining_Unit_Name (N)) = N_Defining_Operator_Symbol
3146 and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
3148 Check_SPARK_Restriction ("user-defined operator is not allowed", N);
3151 -- Proceed with analysis
3153 Generate_Definition (Designator);
3155 if Nkind (N) = N_Function_Specification then
3156 Set_Ekind (Designator, E_Function);
3157 Set_Mechanism (Designator, Default_Mechanism);
3159 Set_Ekind (Designator, E_Procedure);
3160 Set_Etype (Designator, Standard_Void_Type);
3163 -- Introduce new scope for analysis of the formals and the return type
3165 Set_Scope (Designator, Current_Scope);
3167 if Present (Formals) then
3168 Push_Scope (Designator);
3169 Process_Formals (Formals, N);
3171 -- Ada 2005 (AI-345): If this is an overriding operation of an
3172 -- inherited interface operation, and the controlling type is
3173 -- a synchronized type, replace the type with its corresponding
3174 -- record, to match the proper signature of an overriding operation.
3175 -- Same processing for an access parameter whose designated type is
3176 -- derived from a synchronized interface.
3178 if Ada_Version >= Ada_2005 then
3181 Formal_Typ : Entity_Id;
3182 Rec_Typ : Entity_Id;
3183 Desig_Typ : Entity_Id;
3186 Formal := First_Formal (Designator);
3187 while Present (Formal) loop
3188 Formal_Typ := Etype (Formal);
3190 if Is_Concurrent_Type (Formal_Typ)
3191 and then Present (Corresponding_Record_Type (Formal_Typ))
3193 Rec_Typ := Corresponding_Record_Type (Formal_Typ);
3195 if Present (Interfaces (Rec_Typ)) then
3196 Set_Etype (Formal, Rec_Typ);
3199 elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then
3200 Desig_Typ := Designated_Type (Formal_Typ);
3202 if Is_Concurrent_Type (Desig_Typ)
3203 and then Present (Corresponding_Record_Type (Desig_Typ))
3205 Rec_Typ := Corresponding_Record_Type (Desig_Typ);
3207 if Present (Interfaces (Rec_Typ)) then
3208 Set_Directly_Designated_Type (Formal_Typ, Rec_Typ);
3213 Next_Formal (Formal);
3220 -- The subprogram scope is pushed and popped around the processing of
3221 -- the return type for consistency with call above to Process_Formals
3222 -- (which itself can call Analyze_Return_Type), and to ensure that any
3223 -- itype created for the return type will be associated with the proper
3226 elsif Nkind (N) = N_Function_Specification then
3227 Push_Scope (Designator);
3228 Analyze_Return_Type (N);
3234 if Nkind (N) = N_Function_Specification then
3236 -- Deal with operator symbol case
3238 if Nkind (Designator) = N_Defining_Operator_Symbol then
3239 Valid_Operator_Definition (Designator);
3242 May_Need_Actuals (Designator);
3244 -- Ada 2005 (AI-251): If the return type is abstract, verify that
3245 -- the subprogram is abstract also. This does not apply to renaming
3246 -- declarations, where abstractness is inherited.
3248 -- In case of primitives associated with abstract interface types
3249 -- the check is applied later (see Analyze_Subprogram_Declaration).
3251 if not Nkind_In (Parent (N), N_Subprogram_Renaming_Declaration,
3252 N_Abstract_Subprogram_Declaration,
3253 N_Formal_Abstract_Subprogram_Declaration)
3255 if Is_Abstract_Type (Etype (Designator))
3256 and then not Is_Interface (Etype (Designator))
3259 ("function that returns abstract type must be abstract", N);
3261 -- Ada 2012 (AI-0073): Extend this test to subprograms with an
3262 -- access result whose designated type is abstract.
3264 elsif Nkind (Result_Definition (N)) = N_Access_Definition
3266 not Is_Class_Wide_Type (Designated_Type (Etype (Designator)))
3267 and then Is_Abstract_Type (Designated_Type (Etype (Designator)))
3268 and then Ada_Version >= Ada_2012
3270 Error_Msg_N ("function whose access result designates "
3271 & "abstract type must be abstract", N);
3277 end Analyze_Subprogram_Specification;
3279 --------------------------
3280 -- Build_Body_To_Inline --
3281 --------------------------
3283 procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
3284 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
3285 Original_Body : Node_Id;
3286 Body_To_Analyze : Node_Id;
3287 Max_Size : constant := 10;
3288 Stat_Count : Integer := 0;
3290 function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
3291 -- Check for declarations that make inlining not worthwhile
3293 function Has_Excluded_Statement (Stats : List_Id) return Boolean;
3294 -- Check for statements that make inlining not worthwhile: any tasking
3295 -- statement, nested at any level. Keep track of total number of
3296 -- elementary statements, as a measure of acceptable size.
3298 function Has_Pending_Instantiation return Boolean;
3299 -- If some enclosing body contains instantiations that appear before the
3300 -- corresponding generic body, the enclosing body has a freeze node so
3301 -- that it can be elaborated after the generic itself. This might
3302 -- conflict with subsequent inlinings, so that it is unsafe to try to
3303 -- inline in such a case.
3305 function Has_Single_Return return Boolean;
3306 -- In general we cannot inline functions that return unconstrained type.
3307 -- However, we can handle such functions if all return statements return
3308 -- a local variable that is the only declaration in the body of the
3309 -- function. In that case the call can be replaced by that local
3310 -- variable as is done for other inlined calls.
3312 procedure Remove_Pragmas;
3313 -- A pragma Unreferenced or pragma Unmodified that mentions a formal
3314 -- parameter has no meaning when the body is inlined and the formals
3315 -- are rewritten. Remove it from body to inline. The analysis of the
3316 -- non-inlined body will handle the pragma properly.
3318 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
3319 -- If the body of the subprogram includes a call that returns an
3320 -- unconstrained type, the secondary stack is involved, and it
3321 -- is not worth inlining.
3323 ------------------------------
3324 -- Has_Excluded_Declaration --
3325 ------------------------------
3327 function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
3330 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
3331 -- Nested subprograms make a given body ineligible for inlining, but
3332 -- we make an exception for instantiations of unchecked conversion.
3333 -- The body has not been analyzed yet, so check the name, and verify
3334 -- that the visible entity with that name is the predefined unit.
3336 -----------------------------
3337 -- Is_Unchecked_Conversion --
3338 -----------------------------
3340 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
3341 Id : constant Node_Id := Name (D);
3345 if Nkind (Id) = N_Identifier
3346 and then Chars (Id) = Name_Unchecked_Conversion
3348 Conv := Current_Entity (Id);
3350 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
3351 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
3353 Conv := Current_Entity (Selector_Name (Id));
3358 return Present (Conv)
3359 and then Is_Predefined_File_Name
3360 (Unit_File_Name (Get_Source_Unit (Conv)))
3361 and then Is_Intrinsic_Subprogram (Conv);
3362 end Is_Unchecked_Conversion;
3364 -- Start of processing for Has_Excluded_Declaration
3368 while Present (D) loop
3369 if (Nkind (D) = N_Function_Instantiation
3370 and then not Is_Unchecked_Conversion (D))
3371 or else Nkind_In (D, N_Protected_Type_Declaration,
3372 N_Package_Declaration,
3373 N_Package_Instantiation,
3375 N_Procedure_Instantiation,
3376 N_Task_Type_Declaration)
3379 ("cannot inline & (non-allowed declaration)?", D, Subp);
3387 end Has_Excluded_Declaration;
3389 ----------------------------
3390 -- Has_Excluded_Statement --
3391 ----------------------------
3393 function Has_Excluded_Statement (Stats : List_Id) return Boolean is
3399 while Present (S) loop
3400 Stat_Count := Stat_Count + 1;
3402 if Nkind_In (S, N_Abort_Statement,
3403 N_Asynchronous_Select,
3404 N_Conditional_Entry_Call,
3405 N_Delay_Relative_Statement,
3406 N_Delay_Until_Statement,
3411 ("cannot inline & (non-allowed statement)?", S, Subp);
3414 elsif Nkind (S) = N_Block_Statement then
3415 if Present (Declarations (S))
3416 and then Has_Excluded_Declaration (Declarations (S))
3420 elsif Present (Handled_Statement_Sequence (S))
3423 (Exception_Handlers (Handled_Statement_Sequence (S)))
3425 Has_Excluded_Statement
3426 (Statements (Handled_Statement_Sequence (S))))
3431 elsif Nkind (S) = N_Case_Statement then
3432 E := First (Alternatives (S));
3433 while Present (E) loop
3434 if Has_Excluded_Statement (Statements (E)) then
3441 elsif Nkind (S) = N_If_Statement then
3442 if Has_Excluded_Statement (Then_Statements (S)) then
3446 if Present (Elsif_Parts (S)) then
3447 E := First (Elsif_Parts (S));
3448 while Present (E) loop
3449 if Has_Excluded_Statement (Then_Statements (E)) then
3456 if Present (Else_Statements (S))
3457 and then Has_Excluded_Statement (Else_Statements (S))
3462 elsif Nkind (S) = N_Loop_Statement
3463 and then Has_Excluded_Statement (Statements (S))
3467 elsif Nkind (S) = N_Extended_Return_Statement then
3468 if Has_Excluded_Statement
3469 (Statements (Handled_Statement_Sequence (S)))
3471 (Exception_Handlers (Handled_Statement_Sequence (S)))
3481 end Has_Excluded_Statement;
3483 -------------------------------
3484 -- Has_Pending_Instantiation --
3485 -------------------------------
3487 function Has_Pending_Instantiation return Boolean is
3492 while Present (S) loop
3493 if Is_Compilation_Unit (S)
3494 or else Is_Child_Unit (S)
3498 elsif Ekind (S) = E_Package
3499 and then Has_Forward_Instantiation (S)
3508 end Has_Pending_Instantiation;
3510 ------------------------
3511 -- Has_Single_Return --
3512 ------------------------
3514 function Has_Single_Return return Boolean is
3515 Return_Statement : Node_Id := Empty;
3517 function Check_Return (N : Node_Id) return Traverse_Result;
3523 function Check_Return (N : Node_Id) return Traverse_Result is
3525 if Nkind (N) = N_Simple_Return_Statement then
3526 if Present (Expression (N))
3527 and then Is_Entity_Name (Expression (N))
3529 if No (Return_Statement) then
3530 Return_Statement := N;
3533 elsif Chars (Expression (N)) =
3534 Chars (Expression (Return_Statement))
3542 -- A return statement within an extended return is a noop
3545 elsif No (Expression (N))
3546 and then Nkind (Parent (Parent (N))) =
3547 N_Extended_Return_Statement
3552 -- Expression has wrong form
3557 -- We can only inline a build-in-place function if
3558 -- it has a single extended return.
3560 elsif Nkind (N) = N_Extended_Return_Statement then
3561 if No (Return_Statement) then
3562 Return_Statement := N;
3574 function Check_All_Returns is new Traverse_Func (Check_Return);
3576 -- Start of processing for Has_Single_Return
3579 if Check_All_Returns (N) /= OK then
3582 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
3586 return Present (Declarations (N))
3587 and then Present (First (Declarations (N)))
3588 and then Chars (Expression (Return_Statement)) =
3589 Chars (Defining_Identifier (First (Declarations (N))));
3591 end Has_Single_Return;
3593 --------------------
3594 -- Remove_Pragmas --
3595 --------------------
3597 procedure Remove_Pragmas is
3602 Decl := First (Declarations (Body_To_Analyze));
3603 while Present (Decl) loop
3606 if Nkind (Decl) = N_Pragma
3607 and then (Pragma_Name (Decl) = Name_Unreferenced
3609 Pragma_Name (Decl) = Name_Unmodified)
3618 --------------------------
3619 -- Uses_Secondary_Stack --
3620 --------------------------
3622 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
3623 function Check_Call (N : Node_Id) return Traverse_Result;
3624 -- Look for function calls that return an unconstrained type
3630 function Check_Call (N : Node_Id) return Traverse_Result is
3632 if Nkind (N) = N_Function_Call
3633 and then Is_Entity_Name (Name (N))
3634 and then Is_Composite_Type (Etype (Entity (Name (N))))
3635 and then not Is_Constrained (Etype (Entity (Name (N))))
3638 ("cannot inline & (call returns unconstrained type)?",
3646 function Check_Calls is new Traverse_Func (Check_Call);
3649 return Check_Calls (Bod) = Abandon;
3650 end Uses_Secondary_Stack;
3652 -- Start of processing for Build_Body_To_Inline
3655 -- Return immediately if done already
3657 if Nkind (Decl) = N_Subprogram_Declaration
3658 and then Present (Body_To_Inline (Decl))
3662 -- Functions that return unconstrained composite types require
3663 -- secondary stack handling, and cannot currently be inlined, unless
3664 -- all return statements return a local variable that is the first
3665 -- local declaration in the body.
3667 elsif Ekind (Subp) = E_Function
3668 and then not Is_Scalar_Type (Etype (Subp))
3669 and then not Is_Access_Type (Etype (Subp))
3670 and then not Is_Constrained (Etype (Subp))
3672 if not Has_Single_Return then
3674 ("cannot inline & (unconstrained return type)?", N, Subp);
3678 -- Ditto for functions that return controlled types, where controlled
3679 -- actions interfere in complex ways with inlining.
3681 elsif Ekind (Subp) = E_Function
3682 and then Needs_Finalization (Etype (Subp))
3685 ("cannot inline & (controlled return type)?", N, Subp);
3689 if Present (Declarations (N))
3690 and then Has_Excluded_Declaration (Declarations (N))
3695 if Present (Handled_Statement_Sequence (N)) then
3696 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
3698 ("cannot inline& (exception handler)?",
3699 First (Exception_Handlers (Handled_Statement_Sequence (N))),
3703 Has_Excluded_Statement
3704 (Statements (Handled_Statement_Sequence (N)))
3710 -- We do not inline a subprogram that is too large, unless it is
3711 -- marked Inline_Always. This pragma does not suppress the other
3712 -- checks on inlining (forbidden declarations, handlers, etc).
3714 if Stat_Count > Max_Size
3715 and then not Has_Pragma_Inline_Always (Subp)
3717 Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
3721 if Has_Pending_Instantiation then
3723 ("cannot inline& (forward instance within enclosing body)?",
3728 -- Within an instance, the body to inline must be treated as a nested
3729 -- generic, so that the proper global references are preserved.
3731 -- Note that we do not do this at the library level, because it is not
3732 -- needed, and furthermore this causes trouble if front end inlining
3733 -- is activated (-gnatN).
3735 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
3736 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
3737 Original_Body := Copy_Generic_Node (N, Empty, True);
3739 Original_Body := Copy_Separate_Tree (N);
3742 -- We need to capture references to the formals in order to substitute
3743 -- the actuals at the point of inlining, i.e. instantiation. To treat
3744 -- the formals as globals to the body to inline, we nest it within
3745 -- a dummy parameterless subprogram, declared within the real one.
3746 -- To avoid generating an internal name (which is never public, and
3747 -- which affects serial numbers of other generated names), we use
3748 -- an internal symbol that cannot conflict with user declarations.
3750 Set_Parameter_Specifications (Specification (Original_Body), No_List);
3751 Set_Defining_Unit_Name
3752 (Specification (Original_Body),
3753 Make_Defining_Identifier (Sloc (N), Name_uParent));
3754 Set_Corresponding_Spec (Original_Body, Empty);
3756 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
3758 -- Set return type of function, which is also global and does not need
3761 if Ekind (Subp) = E_Function then
3762 Set_Result_Definition (Specification (Body_To_Analyze),
3763 New_Occurrence_Of (Etype (Subp), Sloc (N)));
3766 if No (Declarations (N)) then
3767 Set_Declarations (N, New_List (Body_To_Analyze));
3769 Append (Body_To_Analyze, Declarations (N));
3772 Expander_Mode_Save_And_Set (False);
3775 Analyze (Body_To_Analyze);
3776 Push_Scope (Defining_Entity (Body_To_Analyze));
3777 Save_Global_References (Original_Body);
3779 Remove (Body_To_Analyze);
3781 Expander_Mode_Restore;
3783 -- Restore environment if previously saved
3785 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
3789 -- If secondary stk used there is no point in inlining. We have
3790 -- already issued the warning in this case, so nothing to do.
3792 if Uses_Secondary_Stack (Body_To_Analyze) then
3796 Set_Body_To_Inline (Decl, Original_Body);
3797 Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
3798 Set_Is_Inlined (Subp);
3799 end Build_Body_To_Inline;
3805 procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is
3807 -- Do not emit warning if this is a predefined unit which is not the
3808 -- main unit. With validity checks enabled, some predefined subprograms
3809 -- may contain nested subprograms and become ineligible for inlining.
3811 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
3812 and then not In_Extended_Main_Source_Unit (Subp)
3816 elsif Has_Pragma_Inline_Always (Subp) then
3818 -- Remove last character (question mark) to make this into an error,
3819 -- because the Inline_Always pragma cannot be obeyed.
3821 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
3823 elsif Ineffective_Inline_Warnings then
3824 Error_Msg_NE (Msg, N, Subp);
3828 -----------------------
3829 -- Check_Conformance --
3830 -----------------------
3832 procedure Check_Conformance
3833 (New_Id : Entity_Id;
3835 Ctype : Conformance_Type;
3837 Conforms : out Boolean;
3838 Err_Loc : Node_Id := Empty;
3839 Get_Inst : Boolean := False;
3840 Skip_Controlling_Formals : Boolean := False)
3842 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
3843 -- Sets Conforms to False. If Errmsg is False, then that's all it does.
3844 -- If Errmsg is True, then processing continues to post an error message
3845 -- for conformance error on given node. Two messages are output. The
3846 -- first message points to the previous declaration with a general "no
3847 -- conformance" message. The second is the detailed reason, supplied as
3848 -- Msg. The parameter N provide information for a possible & insertion
3849 -- in the message, and also provides the location for posting the
3850 -- message in the absence of a specified Err_Loc location.
3852 -----------------------
3853 -- Conformance_Error --
3854 -----------------------
3856 procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
3863 if No (Err_Loc) then
3869 Error_Msg_Sloc := Sloc (Old_Id);
3872 when Type_Conformant =>
3873 Error_Msg_N -- CODEFIX
3874 ("not type conformant with declaration#!", Enode);
3876 when Mode_Conformant =>
3877 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3879 ("not mode conformant with operation inherited#!",
3883 ("not mode conformant with declaration#!", Enode);
3886 when Subtype_Conformant =>
3887 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3889 ("not subtype conformant with operation inherited#!",
3893 ("not subtype conformant with declaration#!", Enode);
3896 when Fully_Conformant =>
3897 if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3898 Error_Msg_N -- CODEFIX
3899 ("not fully conformant with operation inherited#!",
3902 Error_Msg_N -- CODEFIX
3903 ("not fully conformant with declaration#!", Enode);
3907 Error_Msg_NE (Msg, Enode, N);
3909 end Conformance_Error;
3913 Old_Type : constant Entity_Id := Etype (Old_Id);
3914 New_Type : constant Entity_Id := Etype (New_Id);
3915 Old_Formal : Entity_Id;
3916 New_Formal : Entity_Id;
3917 Access_Types_Match : Boolean;
3918 Old_Formal_Base : Entity_Id;
3919 New_Formal_Base : Entity_Id;
3921 -- Start of processing for Check_Conformance
3926 -- We need a special case for operators, since they don't appear
3929 if Ctype = Type_Conformant then
3930 if Ekind (New_Id) = E_Operator
3931 and then Operator_Matches_Spec (New_Id, Old_Id)
3937 -- If both are functions/operators, check return types conform
3939 if Old_Type /= Standard_Void_Type
3940 and then New_Type /= Standard_Void_Type
3943 -- If we are checking interface conformance we omit controlling
3944 -- arguments and result, because we are only checking the conformance
3945 -- of the remaining parameters.
3947 if Has_Controlling_Result (Old_Id)
3948 and then Has_Controlling_Result (New_Id)
3949 and then Skip_Controlling_Formals
3953 elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
3954 Conformance_Error ("\return type does not match!", New_Id);
3958 -- Ada 2005 (AI-231): In case of anonymous access types check the
3959 -- null-exclusion and access-to-constant attributes match.
3961 if Ada_Version >= Ada_2005
3962 and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
3964 (Can_Never_Be_Null (Old_Type)
3965 /= Can_Never_Be_Null (New_Type)
3966 or else Is_Access_Constant (Etype (Old_Type))
3967 /= Is_Access_Constant (Etype (New_Type)))
3969 Conformance_Error ("\return type does not match!", New_Id);
3973 -- If either is a function/operator and the other isn't, error
3975 elsif Old_Type /= Standard_Void_Type
3976 or else New_Type /= Standard_Void_Type
3978 Conformance_Error ("\functions can only match functions!", New_Id);
3982 -- In subtype conformant case, conventions must match (RM 6.3.1(16)).
3983 -- If this is a renaming as body, refine error message to indicate that
3984 -- the conflict is with the original declaration. If the entity is not
3985 -- frozen, the conventions don't have to match, the one of the renamed
3986 -- entity is inherited.
3988 if Ctype >= Subtype_Conformant then
3989 if Convention (Old_Id) /= Convention (New_Id) then
3991 if not Is_Frozen (New_Id) then
3994 elsif Present (Err_Loc)
3995 and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
3996 and then Present (Corresponding_Spec (Err_Loc))
3998 Error_Msg_Name_1 := Chars (New_Id);
4000 Name_Ada + Convention_Id'Pos (Convention (New_Id));
4001 Conformance_Error ("\prior declaration for% has convention %!");
4004 Conformance_Error ("\calling conventions do not match!");
4009 elsif Is_Formal_Subprogram (Old_Id)
4010 or else Is_Formal_Subprogram (New_Id)
4012 Conformance_Error ("\formal subprograms not allowed!");
4017 -- Deal with parameters
4019 -- Note: we use the entity information, rather than going directly
4020 -- to the specification in the tree. This is not only simpler, but
4021 -- absolutely necessary for some cases of conformance tests between
4022 -- operators, where the declaration tree simply does not exist!
4024 Old_Formal := First_Formal (Old_Id);
4025 New_Formal := First_Formal (New_Id);
4026 while Present (Old_Formal) and then Present (New_Formal) loop
4027 if Is_Controlling_Formal (Old_Formal)
4028 and then Is_Controlling_Formal (New_Formal)
4029 and then Skip_Controlling_Formals
4031 -- The controlling formals will have different types when
4032 -- comparing an interface operation with its match, but both
4033 -- or neither must be access parameters.
4035 if Is_Access_Type (Etype (Old_Formal))
4037 Is_Access_Type (Etype (New_Formal))
4039 goto Skip_Controlling_Formal;
4042 ("\access parameter does not match!", New_Formal);
4046 if Ctype = Fully_Conformant then
4048 -- Names must match. Error message is more accurate if we do
4049 -- this before checking that the types of the formals match.
4051 if Chars (Old_Formal) /= Chars (New_Formal) then
4052 Conformance_Error ("\name & does not match!", New_Formal);
4054 -- Set error posted flag on new formal as well to stop
4055 -- junk cascaded messages in some cases.
4057 Set_Error_Posted (New_Formal);
4061 -- Null exclusion must match
4063 if Null_Exclusion_Present (Parent (Old_Formal))
4065 Null_Exclusion_Present (Parent (New_Formal))
4067 -- Only give error if both come from source. This should be
4068 -- investigated some time, since it should not be needed ???
4070 if Comes_From_Source (Old_Formal)
4072 Comes_From_Source (New_Formal)
4075 ("\null exclusion for & does not match", New_Formal);
4077 -- Mark error posted on the new formal to avoid duplicated
4078 -- complaint about types not matching.
4080 Set_Error_Posted (New_Formal);
4085 -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
4086 -- case occurs whenever a subprogram is being renamed and one of its
4087 -- parameters imposes a null exclusion. For example:
4089 -- type T is null record;
4090 -- type Acc_T is access T;
4091 -- subtype Acc_T_Sub is Acc_T;
4093 -- procedure P (Obj : not null Acc_T_Sub); -- itype
4094 -- procedure Ren_P (Obj : Acc_T_Sub) -- subtype
4097 Old_Formal_Base := Etype (Old_Formal);
4098 New_Formal_Base := Etype (New_Formal);
4101 Old_Formal_Base := Get_Instance_Of (Old_Formal_Base);
4102 New_Formal_Base := Get_Instance_Of (New_Formal_Base);
4105 Access_Types_Match := Ada_Version >= Ada_2005
4107 -- Ensure that this rule is only applied when New_Id is a
4108 -- renaming of Old_Id.
4110 and then Nkind (Parent (Parent (New_Id))) =
4111 N_Subprogram_Renaming_Declaration
4112 and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity
4113 and then Present (Entity (Name (Parent (Parent (New_Id)))))
4114 and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
4116 -- Now handle the allowed access-type case
4118 and then Is_Access_Type (Old_Formal_Base)
4119 and then Is_Access_Type (New_Formal_Base)
4121 -- The type kinds must match. The only exception occurs with
4122 -- multiple generics of the form:
4125 -- type F is private; type A is private;
4126 -- type F_Ptr is access F; type A_Ptr is access A;
4127 -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
4128 -- package F_Pack is ... package A_Pack is
4129 -- package F_Inst is
4130 -- new F_Pack (A, A_Ptr, A_P);
4132 -- When checking for conformance between the parameters of A_P
4133 -- and F_P, the type kinds of F_Ptr and A_Ptr will not match
4134 -- because the compiler has transformed A_Ptr into a subtype of
4135 -- F_Ptr. We catch this case in the code below.
4137 and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base)
4139 (Is_Generic_Type (Old_Formal_Base)
4140 and then Is_Generic_Type (New_Formal_Base)
4141 and then Is_Internal (New_Formal_Base)
4142 and then Etype (Etype (New_Formal_Base)) =
4144 and then Directly_Designated_Type (Old_Formal_Base) =
4145 Directly_Designated_Type (New_Formal_Base)
4146 and then ((Is_Itype (Old_Formal_Base)
4147 and then Can_Never_Be_Null (Old_Formal_Base))
4149 (Is_Itype (New_Formal_Base)
4150 and then Can_Never_Be_Null (New_Formal_Base)));
4152 -- Types must always match. In the visible part of an instance,
4153 -- usual overloading rules for dispatching operations apply, and
4154 -- we check base types (not the actual subtypes).
4156 if In_Instance_Visible_Part
4157 and then Is_Dispatching_Operation (New_Id)
4159 if not Conforming_Types
4160 (T1 => Base_Type (Etype (Old_Formal)),
4161 T2 => Base_Type (Etype (New_Formal)),
4163 Get_Inst => Get_Inst)
4164 and then not Access_Types_Match
4166 Conformance_Error ("\type of & does not match!", New_Formal);
4170 elsif not Conforming_Types
4171 (T1 => Old_Formal_Base,
4172 T2 => New_Formal_Base,
4174 Get_Inst => Get_Inst)
4175 and then not Access_Types_Match
4177 -- Don't give error message if old type is Any_Type. This test
4178 -- avoids some cascaded errors, e.g. in case of a bad spec.
4180 if Errmsg and then Old_Formal_Base = Any_Type then
4183 Conformance_Error ("\type of & does not match!", New_Formal);
4189 -- For mode conformance, mode must match
4191 if Ctype >= Mode_Conformant then
4192 if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then
4193 Conformance_Error ("\mode of & does not match!", New_Formal);
4196 -- Part of mode conformance for access types is having the same
4197 -- constant modifier.
4199 elsif Access_Types_Match
4200 and then Is_Access_Constant (Old_Formal_Base) /=
4201 Is_Access_Constant (New_Formal_Base)
4204 ("\constant modifier does not match!", New_Formal);
4209 if Ctype >= Subtype_Conformant then
4211 -- Ada 2005 (AI-231): In case of anonymous access types check
4212 -- the null-exclusion and access-to-constant attributes must
4213 -- match. For null exclusion, we test the types rather than the
4214 -- formals themselves, since the attribute is only set reliably
4215 -- on the formals in the Ada 95 case, and we exclude the case
4216 -- where Old_Formal is marked as controlling, to avoid errors
4217 -- when matching completing bodies with dispatching declarations
4218 -- (access formals in the bodies aren't marked Can_Never_Be_Null).
4220 if Ada_Version >= Ada_2005
4221 and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
4222 and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type
4224 ((Can_Never_Be_Null (Etype (Old_Formal)) /=
4225 Can_Never_Be_Null (Etype (New_Formal))
4227 not Is_Controlling_Formal (Old_Formal))
4229 Is_Access_Constant (Etype (Old_Formal)) /=
4230 Is_Access_Constant (Etype (New_Formal)))
4232 -- Do not complain if error already posted on New_Formal. This
4233 -- avoids some redundant error messages.
4235 and then not Error_Posted (New_Formal)
4237 -- It is allowed to omit the null-exclusion in case of stream
4238 -- attribute subprograms. We recognize stream subprograms
4239 -- through their TSS-generated suffix.
4242 TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id);
4244 if TSS_Name /= TSS_Stream_Read
4245 and then TSS_Name /= TSS_Stream_Write
4246 and then TSS_Name /= TSS_Stream_Input
4247 and then TSS_Name /= TSS_Stream_Output
4250 ("\type of & does not match!", New_Formal);
4257 -- Full conformance checks
4259 if Ctype = Fully_Conformant then
4261 -- We have checked already that names match
4263 if Parameter_Mode (Old_Formal) = E_In_Parameter then
4265 -- Check default expressions for in parameters
4268 NewD : constant Boolean :=
4269 Present (Default_Value (New_Formal));
4270 OldD : constant Boolean :=
4271 Present (Default_Value (Old_Formal));
4273 if NewD or OldD then
4275 -- The old default value has been analyzed because the
4276 -- current full declaration will have frozen everything
4277 -- before. The new default value has not been analyzed,
4278 -- so analyze it now before we check for conformance.
4281 Push_Scope (New_Id);
4282 Preanalyze_Spec_Expression
4283 (Default_Value (New_Formal), Etype (New_Formal));
4287 if not (NewD and OldD)
4288 or else not Fully_Conformant_Expressions
4289 (Default_Value (Old_Formal),
4290 Default_Value (New_Formal))
4293 ("\default expression for & does not match!",
4302 -- A couple of special checks for Ada 83 mode. These checks are
4303 -- skipped if either entity is an operator in package Standard,
4304 -- or if either old or new instance is not from the source program.
4306 if Ada_Version = Ada_83
4307 and then Sloc (Old_Id) > Standard_Location
4308 and then Sloc (New_Id) > Standard_Location
4309 and then Comes_From_Source (Old_Id)
4310 and then Comes_From_Source (New_Id)
4313 Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
4314 New_Param : constant Node_Id := Declaration_Node (New_Formal);
4317 -- Explicit IN must be present or absent in both cases. This
4318 -- test is required only in the full conformance case.
4320 if In_Present (Old_Param) /= In_Present (New_Param)
4321 and then Ctype = Fully_Conformant
4324 ("\(Ada 83) IN must appear in both declarations",
4329 -- Grouping (use of comma in param lists) must be the same
4330 -- This is where we catch a misconformance like:
4333 -- A : Integer; B : Integer
4335 -- which are represented identically in the tree except
4336 -- for the setting of the flags More_Ids and Prev_Ids.
4338 if More_Ids (Old_Param) /= More_Ids (New_Param)
4339 or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
4342 ("\grouping of & does not match!", New_Formal);
4348 -- This label is required when skipping controlling formals
4350 <<Skip_Controlling_Formal>>
4352 Next_Formal (Old_Formal);
4353 Next_Formal (New_Formal);
4356 if Present (Old_Formal) then
4357 Conformance_Error ("\too few parameters!");
4360 elsif Present (New_Formal) then
4361 Conformance_Error ("\too many parameters!", New_Formal);
4364 end Check_Conformance;
4366 -----------------------
4367 -- Check_Conventions --
4368 -----------------------
4370 procedure Check_Conventions (Typ : Entity_Id) is
4371 Ifaces_List : Elist_Id;
4373 procedure Check_Convention (Op : Entity_Id);
4374 -- Verify that the convention of inherited dispatching operation Op is
4375 -- consistent among all subprograms it overrides. In order to minimize
4376 -- the search, Search_From is utilized to designate a specific point in
4377 -- the list rather than iterating over the whole list once more.
4379 ----------------------
4380 -- Check_Convention --
4381 ----------------------
4383 procedure Check_Convention (Op : Entity_Id) is
4384 Iface_Elmt : Elmt_Id;
4385 Iface_Prim_Elmt : Elmt_Id;
4386 Iface_Prim : Entity_Id;
4389 Iface_Elmt := First_Elmt (Ifaces_List);
4390 while Present (Iface_Elmt) loop
4392 First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
4393 while Present (Iface_Prim_Elmt) loop
4394 Iface_Prim := Node (Iface_Prim_Elmt);
4396 if Is_Interface_Conformant (Typ, Iface_Prim, Op)
4397 and then Convention (Iface_Prim) /= Convention (Op)
4400 ("inconsistent conventions in primitive operations", Typ);
4402 Error_Msg_Name_1 := Chars (Op);
4403 Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
4404 Error_Msg_Sloc := Sloc (Op);
4406 if Comes_From_Source (Op) or else No (Alias (Op)) then
4407 if not Present (Overridden_Operation (Op)) then
4408 Error_Msg_N ("\\primitive % defined #", Typ);
4411 ("\\overriding operation % with " &
4412 "convention % defined #", Typ);
4415 else pragma Assert (Present (Alias (Op)));
4416 Error_Msg_Sloc := Sloc (Alias (Op));
4418 ("\\inherited operation % with " &
4419 "convention % defined #", Typ);
4422 Error_Msg_Name_1 := Chars (Op);
4424 Get_Convention_Name (Convention (Iface_Prim));
4425 Error_Msg_Sloc := Sloc (Iface_Prim);
4427 ("\\overridden operation % with " &
4428 "convention % defined #", Typ);
4430 -- Avoid cascading errors
4435 Next_Elmt (Iface_Prim_Elmt);
4438 Next_Elmt (Iface_Elmt);
4440 end Check_Convention;
4444 Prim_Op : Entity_Id;
4445 Prim_Op_Elmt : Elmt_Id;
4447 -- Start of processing for Check_Conventions
4450 if not Has_Interfaces (Typ) then
4454 Collect_Interfaces (Typ, Ifaces_List);
4456 -- The algorithm checks every overriding dispatching operation against
4457 -- all the corresponding overridden dispatching operations, detecting
4458 -- differences in conventions.
4460 Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ));
4461 while Present (Prim_Op_Elmt) loop
4462 Prim_Op := Node (Prim_Op_Elmt);
4464 -- A small optimization: skip the predefined dispatching operations
4465 -- since they always have the same convention.
4467 if not Is_Predefined_Dispatching_Operation (Prim_Op) then
4468 Check_Convention (Prim_Op);
4471 Next_Elmt (Prim_Op_Elmt);
4473 end Check_Conventions;
4475 ------------------------------
4476 -- Check_Delayed_Subprogram --
4477 ------------------------------
4479 procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
4482 procedure Possible_Freeze (T : Entity_Id);
4483 -- T is the type of either a formal parameter or of the return type.
4484 -- If T is not yet frozen and needs a delayed freeze, then the
4485 -- subprogram itself must be delayed. If T is the limited view of an
4486 -- incomplete type the subprogram must be frozen as well, because
4487 -- T may depend on local types that have not been frozen yet.
4489 ---------------------
4490 -- Possible_Freeze --
4491 ---------------------
4493 procedure Possible_Freeze (T : Entity_Id) is
4495 if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
4496 Set_Has_Delayed_Freeze (Designator);
4498 elsif Is_Access_Type (T)
4499 and then Has_Delayed_Freeze (Designated_Type (T))
4500 and then not Is_Frozen (Designated_Type (T))
4502 Set_Has_Delayed_Freeze (Designator);
4504 elsif Ekind (T) = E_Incomplete_Type and then From_With_Type (T) then
4505 Set_Has_Delayed_Freeze (Designator);
4508 end Possible_Freeze;
4510 -- Start of processing for Check_Delayed_Subprogram
4513 -- All subprograms, including abstract subprograms, may need a freeze
4514 -- node if some formal type or the return type needs one.
4516 Possible_Freeze (Etype (Designator));
4517 Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
4519 -- Need delayed freeze if any of the formal types themselves need
4520 -- a delayed freeze and are not yet frozen.
4522 F := First_Formal (Designator);
4523 while Present (F) loop
4524 Possible_Freeze (Etype (F));
4525 Possible_Freeze (Base_Type (Etype (F))); -- needed ???
4529 -- Mark functions that return by reference. Note that it cannot be
4530 -- done for delayed_freeze subprograms because the underlying
4531 -- returned type may not be known yet (for private types)
4533 if not Has_Delayed_Freeze (Designator)
4534 and then Expander_Active
4537 Typ : constant Entity_Id := Etype (Designator);
4538 Utyp : constant Entity_Id := Underlying_Type (Typ);
4541 if Is_Immutably_Limited_Type (Typ) then
4542 Set_Returns_By_Ref (Designator);
4544 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
4545 Set_Returns_By_Ref (Designator);
4549 end Check_Delayed_Subprogram;
4551 ------------------------------------
4552 -- Check_Discriminant_Conformance --
4553 ------------------------------------
4555 procedure Check_Discriminant_Conformance
4560 Old_Discr : Entity_Id := First_Discriminant (Prev);
4561 New_Discr : Node_Id := First (Discriminant_Specifications (N));
4562 New_Discr_Id : Entity_Id;
4563 New_Discr_Type : Entity_Id;
4565 procedure Conformance_Error (Msg : String; N : Node_Id);
4566 -- Post error message for conformance error on given node. Two messages
4567 -- are output. The first points to the previous declaration with a
4568 -- general "no conformance" message. The second is the detailed reason,
4569 -- supplied as Msg. The parameter N provide information for a possible
4570 -- & insertion in the message.
4572 -----------------------
4573 -- Conformance_Error --
4574 -----------------------
4576 procedure Conformance_Error (Msg : String; N : Node_Id) is
4578 Error_Msg_Sloc := Sloc (Prev_Loc);
4579 Error_Msg_N -- CODEFIX
4580 ("not fully conformant with declaration#!", N);
4581 Error_Msg_NE (Msg, N, N);
4582 end Conformance_Error;
4584 -- Start of processing for Check_Discriminant_Conformance
4587 while Present (Old_Discr) and then Present (New_Discr) loop
4589 New_Discr_Id := Defining_Identifier (New_Discr);
4591 -- The subtype mark of the discriminant on the full type has not
4592 -- been analyzed so we do it here. For an access discriminant a new
4595 if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
4597 Access_Definition (N, Discriminant_Type (New_Discr));
4600 Analyze (Discriminant_Type (New_Discr));
4601 New_Discr_Type := Etype (Discriminant_Type (New_Discr));
4603 -- Ada 2005: if the discriminant definition carries a null
4604 -- exclusion, create an itype to check properly for consistency
4605 -- with partial declaration.
4607 if Is_Access_Type (New_Discr_Type)
4608 and then Null_Exclusion_Present (New_Discr)
4611 Create_Null_Excluding_Itype
4612 (T => New_Discr_Type,
4613 Related_Nod => New_Discr,
4614 Scope_Id => Current_Scope);
4618 if not Conforming_Types
4619 (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
4621 Conformance_Error ("type of & does not match!", New_Discr_Id);
4624 -- Treat the new discriminant as an occurrence of the old one,
4625 -- for navigation purposes, and fill in some semantic
4626 -- information, for completeness.
4628 Generate_Reference (Old_Discr, New_Discr_Id, 'r');
4629 Set_Etype (New_Discr_Id, Etype (Old_Discr));
4630 Set_Scope (New_Discr_Id, Scope (Old_Discr));
4635 if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
4636 Conformance_Error ("name & does not match!", New_Discr_Id);
4640 -- Default expressions must match
4643 NewD : constant Boolean :=
4644 Present (Expression (New_Discr));
4645 OldD : constant Boolean :=
4646 Present (Expression (Parent (Old_Discr)));
4649 if NewD or OldD then
4651 -- The old default value has been analyzed and expanded,
4652 -- because the current full declaration will have frozen
4653 -- everything before. The new default values have not been
4654 -- expanded, so expand now to check conformance.
4657 Preanalyze_Spec_Expression
4658 (Expression (New_Discr), New_Discr_Type);
4661 if not (NewD and OldD)
4662 or else not Fully_Conformant_Expressions
4663 (Expression (Parent (Old_Discr)),
4664 Expression (New_Discr))
4668 ("default expression for & does not match!",
4675 -- In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
4677 if Ada_Version = Ada_83 then
4679 Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
4682 -- Grouping (use of comma in param lists) must be the same
4683 -- This is where we catch a misconformance like:
4686 -- A : Integer; B : Integer
4688 -- which are represented identically in the tree except
4689 -- for the setting of the flags More_Ids and Prev_Ids.
4691 if More_Ids (Old_Disc) /= More_Ids (New_Discr)
4692 or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
4695 ("grouping of & does not match!", New_Discr_Id);
4701 Next_Discriminant (Old_Discr);
4705 if Present (Old_Discr) then
4706 Conformance_Error ("too few discriminants!", Defining_Identifier (N));
4709 elsif Present (New_Discr) then
4711 ("too many discriminants!", Defining_Identifier (New_Discr));
4714 end Check_Discriminant_Conformance;
4716 ----------------------------
4717 -- Check_Fully_Conformant --
4718 ----------------------------
4720 procedure Check_Fully_Conformant
4721 (New_Id : Entity_Id;
4723 Err_Loc : Node_Id := Empty)
4726 pragma Warnings (Off, Result);
4729 (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
4730 end Check_Fully_Conformant;
4732 ---------------------------
4733 -- Check_Mode_Conformant --
4734 ---------------------------
4736 procedure Check_Mode_Conformant
4737 (New_Id : Entity_Id;
4739 Err_Loc : Node_Id := Empty;
4740 Get_Inst : Boolean := False)
4743 pragma Warnings (Off, Result);
4746 (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
4747 end Check_Mode_Conformant;
4749 --------------------------------
4750 -- Check_Overriding_Indicator --
4751 --------------------------------
4753 procedure Check_Overriding_Indicator
4755 Overridden_Subp : Entity_Id;
4756 Is_Primitive : Boolean)
4762 -- No overriding indicator for literals
4764 if Ekind (Subp) = E_Enumeration_Literal then
4767 elsif Ekind (Subp) = E_Entry then
4768 Decl := Parent (Subp);
4770 -- No point in analyzing a malformed operator
4772 elsif Nkind (Subp) = N_Defining_Operator_Symbol
4773 and then Error_Posted (Subp)
4778 Decl := Unit_Declaration_Node (Subp);
4781 if Nkind_In (Decl, N_Subprogram_Body,
4782 N_Subprogram_Body_Stub,
4783 N_Subprogram_Declaration,
4784 N_Abstract_Subprogram_Declaration,
4785 N_Subprogram_Renaming_Declaration)
4787 Spec := Specification (Decl);
4789 elsif Nkind (Decl) = N_Entry_Declaration then
4796 -- The overriding operation is type conformant with the overridden one,
4797 -- but the names of the formals are not required to match. If the names
4798 -- appear permuted in the overriding operation, this is a possible
4799 -- source of confusion that is worth diagnosing. Controlling formals
4800 -- often carry names that reflect the type, and it is not worthwhile
4801 -- requiring that their names match.
4803 if Present (Overridden_Subp)
4804 and then Nkind (Subp) /= N_Defining_Operator_Symbol
4811 Form1 := First_Formal (Subp);
4812 Form2 := First_Formal (Overridden_Subp);
4814 -- If the overriding operation is a synchronized operation, skip
4815 -- the first parameter of the overridden operation, which is
4816 -- implicit in the new one. If the operation is declared in the
4817 -- body it is not primitive and all formals must match.
4819 if Is_Concurrent_Type (Scope (Subp))
4820 and then Is_Tagged_Type (Scope (Subp))
4821 and then not Has_Completion (Scope (Subp))
4823 Form2 := Next_Formal (Form2);
4826 if Present (Form1) then
4827 Form1 := Next_Formal (Form1);
4828 Form2 := Next_Formal (Form2);
4831 while Present (Form1) loop
4832 if not Is_Controlling_Formal (Form1)
4833 and then Present (Next_Formal (Form2))
4834 and then Chars (Form1) = Chars (Next_Formal (Form2))
4836 Error_Msg_Node_2 := Alias (Overridden_Subp);
4837 Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
4839 ("& does not match corresponding formal of&#",
4844 Next_Formal (Form1);
4845 Next_Formal (Form2);
4850 -- If there is an overridden subprogram, then check that there is no
4851 -- "not overriding" indicator, and mark the subprogram as overriding.
4852 -- This is not done if the overridden subprogram is marked as hidden,
4853 -- which can occur for the case of inherited controlled operations
4854 -- (see Derive_Subprogram), unless the inherited subprogram's parent
4855 -- subprogram is not itself hidden. (Note: This condition could probably
4856 -- be simplified, leaving out the testing for the specific controlled
4857 -- cases, but it seems safer and clearer this way, and echoes similar
4858 -- special-case tests of this kind in other places.)
4860 if Present (Overridden_Subp)
4861 and then (not Is_Hidden (Overridden_Subp)
4863 ((Chars (Overridden_Subp) = Name_Initialize
4865 Chars (Overridden_Subp) = Name_Adjust
4867 Chars (Overridden_Subp) = Name_Finalize)
4868 and then Present (Alias (Overridden_Subp))
4869 and then not Is_Hidden (Alias (Overridden_Subp))))
4871 if Must_Not_Override (Spec) then
4872 Error_Msg_Sloc := Sloc (Overridden_Subp);
4874 if Ekind (Subp) = E_Entry then
4876 ("entry & overrides inherited operation #", Spec, Subp);
4879 ("subprogram & overrides inherited operation #", Spec, Subp);
4882 elsif Is_Subprogram (Subp) then
4883 if Is_Init_Proc (Subp) then
4886 elsif No (Overridden_Operation (Subp)) then
4888 -- For entities generated by Derive_Subprograms the overridden
4889 -- operation is the inherited primitive (which is available
4890 -- through the attribute alias)
4892 if (Is_Dispatching_Operation (Subp)
4893 or else Is_Dispatching_Operation (Overridden_Subp))
4894 and then not Comes_From_Source (Overridden_Subp)
4895 and then Find_Dispatching_Type (Overridden_Subp) =
4896 Find_Dispatching_Type (Subp)
4897 and then Present (Alias (Overridden_Subp))
4898 and then Comes_From_Source (Alias (Overridden_Subp))
4900 Set_Overridden_Operation (Subp, Alias (Overridden_Subp));
4903 Set_Overridden_Operation (Subp, Overridden_Subp);
4908 -- If primitive flag is set or this is a protected operation, then
4909 -- the operation is overriding at the point of its declaration, so
4910 -- warn if necessary. Otherwise it may have been declared before the
4911 -- operation it overrides and no check is required.
4914 and then not Must_Override (Spec)
4915 and then (Is_Primitive
4916 or else Ekind (Scope (Subp)) = E_Protected_Type)
4918 Style.Missing_Overriding (Decl, Subp);
4921 -- If Subp is an operator, it may override a predefined operation, if
4922 -- it is defined in the same scope as the type to which it applies.
4923 -- In that case Overridden_Subp is empty because of our implicit
4924 -- representation for predefined operators. We have to check whether the
4925 -- signature of Subp matches that of a predefined operator. Note that
4926 -- first argument provides the name of the operator, and the second
4927 -- argument the signature that may match that of a standard operation.
4928 -- If the indicator is overriding, then the operator must match a
4929 -- predefined signature, because we know already that there is no
4930 -- explicit overridden operation.
4932 elsif Nkind (Subp) = N_Defining_Operator_Symbol then
4933 if Must_Not_Override (Spec) then
4935 -- If this is not a primitive or a protected subprogram, then
4936 -- "not overriding" is illegal.
4939 and then Ekind (Scope (Subp)) /= E_Protected_Type
4942 ("overriding indicator only allowed "
4943 & "if subprogram is primitive", Subp);
4945 elsif Can_Override_Operator (Subp) then
4947 ("subprogram& overrides predefined operator ", Spec, Subp);
4950 elsif Must_Override (Spec) then
4951 if No (Overridden_Operation (Subp))
4952 and then not Can_Override_Operator (Subp)
4954 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
4957 elsif not Error_Posted (Subp)
4958 and then Style_Check
4959 and then Can_Override_Operator (Subp)
4961 not Is_Predefined_File_Name
4962 (Unit_File_Name (Get_Source_Unit (Subp)))
4964 -- If style checks are enabled, indicate that the indicator is
4965 -- missing. However, at the point of declaration, the type of
4966 -- which this is a primitive operation may be private, in which
4967 -- case the indicator would be premature.
4969 if Has_Private_Declaration (Etype (Subp))
4970 or else Has_Private_Declaration (Etype (First_Formal (Subp)))
4974 Style.Missing_Overriding (Decl, Subp);
4978 elsif Must_Override (Spec) then
4979 if Ekind (Subp) = E_Entry then
4980 Error_Msg_NE ("entry & is not overriding", Spec, Subp);
4982 Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
4985 -- If the operation is marked "not overriding" and it's not primitive
4986 -- then an error is issued, unless this is an operation of a task or
4987 -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
4988 -- has been specified have already been checked above.
4990 elsif Must_Not_Override (Spec)
4991 and then not Is_Primitive
4992 and then Ekind (Subp) /= E_Entry
4993 and then Ekind (Scope (Subp)) /= E_Protected_Type
4996 ("overriding indicator only allowed if subprogram is primitive",
5000 end Check_Overriding_Indicator;
5006 -- Note: this procedure needs to know far too much about how the expander
5007 -- messes with exceptions. The use of the flag Exception_Junk and the
5008 -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
5009 -- works, but is not very clean. It would be better if the expansion
5010 -- routines would leave Original_Node working nicely, and we could use
5011 -- Original_Node here to ignore all the peculiar expander messing ???
5013 procedure Check_Returns
5017 Proc : Entity_Id := Empty)
5021 procedure Check_Statement_Sequence (L : List_Id);
5022 -- Internal recursive procedure to check a list of statements for proper
5023 -- termination by a return statement (or a transfer of control or a
5024 -- compound statement that is itself internally properly terminated).
5026 ------------------------------
5027 -- Check_Statement_Sequence --
5028 ------------------------------
5030 procedure Check_Statement_Sequence (L : List_Id) is
5035 Raise_Exception_Call : Boolean;
5036 -- Set True if statement sequence terminated by Raise_Exception call
5037 -- or a Reraise_Occurrence call.
5040 Raise_Exception_Call := False;
5042 -- Get last real statement
5044 Last_Stm := Last (L);
5046 -- Deal with digging out exception handler statement sequences that
5047 -- have been transformed by the local raise to goto optimization.
5048 -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
5049 -- optimization has occurred, we are looking at something like:
5052 -- original stmts in block
5056 -- goto L1; | omitted if No_Exception_Propagation
5061 -- goto L3; -- skip handler when exception not raised
5063 -- <<L1>> -- target label for local exception
5077 -- and what we have to do is to dig out the estmts1 and estmts2
5078 -- sequences (which were the original sequences of statements in
5079 -- the exception handlers) and check them.
5081 if Nkind (Last_Stm) = N_Label
5082 and then Exception_Junk (Last_Stm)
5088 exit when Nkind (Stm) /= N_Block_Statement;
5089 exit when not Exception_Junk (Stm);
5092 exit when Nkind (Stm) /= N_Label;
5093 exit when not Exception_Junk (Stm);
5094 Check_Statement_Sequence
5095 (Statements (Handled_Statement_Sequence (Next (Stm))));
5100 exit when Nkind (Stm) /= N_Goto_Statement;
5101 exit when not Exception_Junk (Stm);
5105 -- Don't count pragmas
5107 while Nkind (Last_Stm) = N_Pragma
5109 -- Don't count call to SS_Release (can happen after Raise_Exception)
5112 (Nkind (Last_Stm) = N_Procedure_Call_Statement
5114 Nkind (Name (Last_Stm)) = N_Identifier
5116 Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
5118 -- Don't count exception junk
5121 (Nkind_In (Last_Stm, N_Goto_Statement,
5123 N_Object_Declaration)
5124 and then Exception_Junk (Last_Stm))
5125 or else Nkind (Last_Stm) in N_Push_xxx_Label
5126 or else Nkind (Last_Stm) in N_Pop_xxx_Label
5131 -- Here we have the "real" last statement
5133 Kind := Nkind (Last_Stm);
5135 -- Transfer of control, OK. Note that in the No_Return procedure
5136 -- case, we already diagnosed any explicit return statements, so
5137 -- we can treat them as OK in this context.
5139 if Is_Transfer (Last_Stm) then
5142 -- Check cases of explicit non-indirect procedure calls
5144 elsif Kind = N_Procedure_Call_Statement
5145 and then Is_Entity_Name (Name (Last_Stm))
5147 -- Check call to Raise_Exception procedure which is treated
5148 -- specially, as is a call to Reraise_Occurrence.
5150 -- We suppress the warning in these cases since it is likely that
5151 -- the programmer really does not expect to deal with the case
5152 -- of Null_Occurrence, and thus would find a warning about a
5153 -- missing return curious, and raising Program_Error does not
5154 -- seem such a bad behavior if this does occur.
5156 -- Note that in the Ada 2005 case for Raise_Exception, the actual
5157 -- behavior will be to raise Constraint_Error (see AI-329).
5159 if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
5161 Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
5163 Raise_Exception_Call := True;
5165 -- For Raise_Exception call, test first argument, if it is
5166 -- an attribute reference for a 'Identity call, then we know
5167 -- that the call cannot possibly return.
5170 Arg : constant Node_Id :=
5171 Original_Node (First_Actual (Last_Stm));
5173 if Nkind (Arg) = N_Attribute_Reference
5174 and then Attribute_Name (Arg) = Name_Identity
5181 -- If statement, need to look inside if there is an else and check
5182 -- each constituent statement sequence for proper termination.
5184 elsif Kind = N_If_Statement
5185 and then Present (Else_Statements (Last_Stm))
5187 Check_Statement_Sequence (Then_Statements (Last_Stm));
5188 Check_Statement_Sequence (Else_Statements (Last_Stm));
5190 if Present (Elsif_Parts (Last_Stm)) then
5192 Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
5195 while Present (Elsif_Part) loop
5196 Check_Statement_Sequence (Then_Statements (Elsif_Part));
5204 -- Case statement, check each case for proper termination
5206 elsif Kind = N_Case_Statement then
5210 Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
5211 while Present (Case_Alt) loop
5212 Check_Statement_Sequence (Statements (Case_Alt));
5213 Next_Non_Pragma (Case_Alt);
5219 -- Block statement, check its handled sequence of statements
5221 elsif Kind = N_Block_Statement then
5227 (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
5236 -- Loop statement. If there is an iteration scheme, we can definitely
5237 -- fall out of the loop. Similarly if there is an exit statement, we
5238 -- can fall out. In either case we need a following return.
5240 elsif Kind = N_Loop_Statement then
5241 if Present (Iteration_Scheme (Last_Stm))
5242 or else Has_Exit (Entity (Identifier (Last_Stm)))
5246 -- A loop with no exit statement or iteration scheme is either
5247 -- an infinite loop, or it has some other exit (raise/return).
5248 -- In either case, no warning is required.
5254 -- Timed entry call, check entry call and delay alternatives
5256 -- Note: in expanded code, the timed entry call has been converted
5257 -- to a set of expanded statements on which the check will work
5258 -- correctly in any case.
5260 elsif Kind = N_Timed_Entry_Call then
5262 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
5263 DCA : constant Node_Id := Delay_Alternative (Last_Stm);
5266 -- If statement sequence of entry call alternative is missing,
5267 -- then we can definitely fall through, and we post the error
5268 -- message on the entry call alternative itself.
5270 if No (Statements (ECA)) then
5273 -- If statement sequence of delay alternative is missing, then
5274 -- we can definitely fall through, and we post the error
5275 -- message on the delay alternative itself.
5277 -- Note: if both ECA and DCA are missing the return, then we
5278 -- post only one message, should be enough to fix the bugs.
5279 -- If not we will get a message next time on the DCA when the
5282 elsif No (Statements (DCA)) then
5285 -- Else check both statement sequences
5288 Check_Statement_Sequence (Statements (ECA));
5289 Check_Statement_Sequence (Statements (DCA));
5294 -- Conditional entry call, check entry call and else part
5296 -- Note: in expanded code, the conditional entry call has been
5297 -- converted to a set of expanded statements on which the check
5298 -- will work correctly in any case.
5300 elsif Kind = N_Conditional_Entry_Call then
5302 ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
5305 -- If statement sequence of entry call alternative is missing,
5306 -- then we can definitely fall through, and we post the error
5307 -- message on the entry call alternative itself.
5309 if No (Statements (ECA)) then
5312 -- Else check statement sequence and else part
5315 Check_Statement_Sequence (Statements (ECA));
5316 Check_Statement_Sequence (Else_Statements (Last_Stm));
5322 -- If we fall through, issue appropriate message
5325 if not Raise_Exception_Call then
5327 ("?RETURN statement missing following this statement!",
5330 ("\?Program_Error may be raised at run time!",
5334 -- Note: we set Err even though we have not issued a warning
5335 -- because we still have a case of a missing return. This is
5336 -- an extremely marginal case, probably will never be noticed
5337 -- but we might as well get it right.
5341 -- Otherwise we have the case of a procedure marked No_Return
5344 if not Raise_Exception_Call then
5346 ("?implied return after this statement " &
5347 "will raise Program_Error",
5350 ("\?procedure & is marked as No_Return!",
5355 RE : constant Node_Id :=
5356 Make_Raise_Program_Error (Sloc (Last_Stm),
5357 Reason => PE_Implicit_Return);
5359 Insert_After (Last_Stm, RE);
5363 end Check_Statement_Sequence;
5365 -- Start of processing for Check_Returns
5369 Check_Statement_Sequence (Statements (HSS));
5371 if Present (Exception_Handlers (HSS)) then
5372 Handler := First_Non_Pragma (Exception_Handlers (HSS));
5373 while Present (Handler) loop
5374 Check_Statement_Sequence (Statements (Handler));
5375 Next_Non_Pragma (Handler);
5380 ----------------------------
5381 -- Check_Subprogram_Order --
5382 ----------------------------
5384 procedure Check_Subprogram_Order (N : Node_Id) is
5386 function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
5387 -- This is used to check if S1 > S2 in the sense required by this
5388 -- test, for example nameab < namec, but name2 < name10.
5390 -----------------------------
5391 -- Subprogram_Name_Greater --
5392 -----------------------------
5394 function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
5399 -- Remove trailing numeric parts
5402 while S1 (L1) in '0' .. '9' loop
5407 while S2 (L2) in '0' .. '9' loop
5411 -- If non-numeric parts non-equal, that's decisive
5413 if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
5416 elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
5419 -- If non-numeric parts equal, compare suffixed numeric parts. Note
5420 -- that a missing suffix is treated as numeric zero in this test.
5424 while L1 < S1'Last loop
5426 N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
5430 while L2 < S2'Last loop
5432 N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
5437 end Subprogram_Name_Greater;
5439 -- Start of processing for Check_Subprogram_Order
5442 -- Check body in alpha order if this is option
5445 and then Style_Check_Order_Subprograms
5446 and then Nkind (N) = N_Subprogram_Body
5447 and then Comes_From_Source (N)
5448 and then In_Extended_Main_Source_Unit (N)
5452 renames Scope_Stack.Table
5453 (Scope_Stack.Last).Last_Subprogram_Name;
5455 Body_Id : constant Entity_Id :=
5456 Defining_Entity (Specification (N));
5459 Get_Decoded_Name_String (Chars (Body_Id));
5462 if Subprogram_Name_Greater
5463 (LSN.all, Name_Buffer (1 .. Name_Len))
5465 Style.Subprogram_Not_In_Alpha_Order (Body_Id);
5471 LSN := new String'(Name_Buffer (1 .. Name_Len));
5474 end Check_Subprogram_Order;
5476 ------------------------------
5477 -- Check_Subtype_Conformant --
5478 ------------------------------
5480 procedure Check_Subtype_Conformant
5481 (New_Id : Entity_Id;
5483 Err_Loc : Node_Id := Empty;
5484 Skip_Controlling_Formals : Boolean := False)
5487 pragma Warnings (Off, Result);
5490 (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
5491 Skip_Controlling_Formals => Skip_Controlling_Formals);
5492 end Check_Subtype_Conformant;
5494 ---------------------------
5495 -- Check_Type_Conformant --
5496 ---------------------------
5498 procedure Check_Type_Conformant
5499 (New_Id : Entity_Id;
5501 Err_Loc : Node_Id := Empty)
5504 pragma Warnings (Off, Result);
5507 (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
5508 end Check_Type_Conformant;
5510 ---------------------------
5511 -- Can_Override_Operator --
5512 ---------------------------
5514 function Can_Override_Operator (Subp : Entity_Id) return Boolean is
5517 if Nkind (Subp) /= N_Defining_Operator_Symbol then
5521 Typ := Base_Type (Etype (First_Formal (Subp)));
5523 return Operator_Matches_Spec (Subp, Subp)
5524 and then Scope (Subp) = Scope (Typ)
5525 and then not Is_Class_Wide_Type (Typ);
5527 end Can_Override_Operator;
5529 ----------------------
5530 -- Conforming_Types --
5531 ----------------------
5533 function Conforming_Types
5536 Ctype : Conformance_Type;
5537 Get_Inst : Boolean := False) return Boolean
5539 Type_1 : Entity_Id := T1;
5540 Type_2 : Entity_Id := T2;
5541 Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
5543 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
5544 -- If neither T1 nor T2 are generic actual types, or if they are in
5545 -- different scopes (e.g. parent and child instances), then verify that
5546 -- the base types are equal. Otherwise T1 and T2 must be on the same
5547 -- subtype chain. The whole purpose of this procedure is to prevent
5548 -- spurious ambiguities in an instantiation that may arise if two
5549 -- distinct generic types are instantiated with the same actual.
5551 function Find_Designated_Type (T : Entity_Id) return Entity_Id;
5552 -- An access parameter can designate an incomplete type. If the
5553 -- incomplete type is the limited view of a type from a limited_
5554 -- with_clause, check whether the non-limited view is available. If
5555 -- it is a (non-limited) incomplete type, get the full view.
5557 function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean;
5558 -- Returns True if and only if either T1 denotes a limited view of T2
5559 -- or T2 denotes a limited view of T1. This can arise when the limited
5560 -- with view of a type is used in a subprogram declaration and the
5561 -- subprogram body is in the scope of a regular with clause for the
5562 -- same unit. In such a case, the two type entities can be considered
5563 -- identical for purposes of conformance checking.
5565 ----------------------
5566 -- Base_Types_Match --
5567 ----------------------
5569 function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
5574 elsif Base_Type (T1) = Base_Type (T2) then
5576 -- The following is too permissive. A more precise test should
5577 -- check that the generic actual is an ancestor subtype of the
5580 return not Is_Generic_Actual_Type (T1)
5581 or else not Is_Generic_Actual_Type (T2)
5582 or else Scope (T1) /= Scope (T2);
5587 end Base_Types_Match;
5589 --------------------------
5590 -- Find_Designated_Type --
5591 --------------------------
5593 function Find_Designated_Type (T : Entity_Id) return Entity_Id is
5597 Desig := Directly_Designated_Type (T);
5599 if Ekind (Desig) = E_Incomplete_Type then
5601 -- If regular incomplete type, get full view if available
5603 if Present (Full_View (Desig)) then
5604 Desig := Full_View (Desig);
5606 -- If limited view of a type, get non-limited view if available,
5607 -- and check again for a regular incomplete type.
5609 elsif Present (Non_Limited_View (Desig)) then
5610 Desig := Get_Full_View (Non_Limited_View (Desig));
5615 end Find_Designated_Type;
5617 -------------------------------
5618 -- Matches_Limited_With_View --
5619 -------------------------------
5621 function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is
5623 -- In some cases a type imported through a limited_with clause, and
5624 -- its nonlimited view are both visible, for example in an anonymous
5625 -- access-to-class-wide type in a formal. Both entities designate the
5628 if From_With_Type (T1)
5629 and then T2 = Available_View (T1)
5633 elsif From_With_Type (T2)
5634 and then T1 = Available_View (T2)
5641 end Matches_Limited_With_View;
5643 -- Start of processing for Conforming_Types
5646 -- The context is an instance association for a formal
5647 -- access-to-subprogram type; the formal parameter types require
5648 -- mapping because they may denote other formal parameters of the
5652 Type_1 := Get_Instance_Of (T1);
5653 Type_2 := Get_Instance_Of (T2);
5656 -- If one of the types is a view of the other introduced by a limited
5657 -- with clause, treat these as conforming for all purposes.
5659 if Matches_Limited_With_View (T1, T2) then
5662 elsif Base_Types_Match (Type_1, Type_2) then
5663 return Ctype <= Mode_Conformant
5664 or else Subtypes_Statically_Match (Type_1, Type_2);
5666 elsif Is_Incomplete_Or_Private_Type (Type_1)
5667 and then Present (Full_View (Type_1))
5668 and then Base_Types_Match (Full_View (Type_1), Type_2)
5670 return Ctype <= Mode_Conformant
5671 or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
5673 elsif Ekind (Type_2) = E_Incomplete_Type
5674 and then Present (Full_View (Type_2))
5675 and then Base_Types_Match (Type_1, Full_View (Type_2))
5677 return Ctype <= Mode_Conformant
5678 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
5680 elsif Is_Private_Type (Type_2)
5681 and then In_Instance
5682 and then Present (Full_View (Type_2))
5683 and then Base_Types_Match (Type_1, Full_View (Type_2))
5685 return Ctype <= Mode_Conformant
5686 or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
5689 -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
5690 -- treated recursively because they carry a signature.
5692 Are_Anonymous_Access_To_Subprogram_Types :=
5693 Ekind (Type_1) = Ekind (Type_2)
5695 (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
5697 Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
5699 -- Test anonymous access type case. For this case, static subtype
5700 -- matching is required for mode conformance (RM 6.3.1(15)). We check
5701 -- the base types because we may have built internal subtype entities
5702 -- to handle null-excluding types (see Process_Formals).
5704 if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
5706 Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
5707 or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
5710 Desig_1 : Entity_Id;
5711 Desig_2 : Entity_Id;
5714 -- In Ada2005, access constant indicators must match for
5715 -- subtype conformance.
5717 if Ada_Version >= Ada_2005
5718 and then Ctype >= Subtype_Conformant
5720 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
5725 Desig_1 := Find_Designated_Type (Type_1);
5726 Desig_2 := Find_Designated_Type (Type_2);
5728 -- If the context is an instance association for a formal
5729 -- access-to-subprogram type; formal access parameter designated
5730 -- types require mapping because they may denote other formal
5731 -- parameters of the generic unit.
5734 Desig_1 := Get_Instance_Of (Desig_1);
5735 Desig_2 := Get_Instance_Of (Desig_2);
5738 -- It is possible for a Class_Wide_Type to be introduced for an
5739 -- incomplete type, in which case there is a separate class_ wide
5740 -- type for the full view. The types conform if their Etypes
5741 -- conform, i.e. one may be the full view of the other. This can
5742 -- only happen in the context of an access parameter, other uses
5743 -- of an incomplete Class_Wide_Type are illegal.
5745 if Is_Class_Wide_Type (Desig_1)
5747 Is_Class_Wide_Type (Desig_2)
5751 (Etype (Base_Type (Desig_1)),
5752 Etype (Base_Type (Desig_2)), Ctype);
5754 elsif Are_Anonymous_Access_To_Subprogram_Types then
5755 if Ada_Version < Ada_2005 then
5756 return Ctype = Type_Conformant
5758 Subtypes_Statically_Match (Desig_1, Desig_2);
5760 -- We must check the conformance of the signatures themselves
5764 Conformant : Boolean;
5767 (Desig_1, Desig_2, Ctype, False, Conformant);
5773 return Base_Type (Desig_1) = Base_Type (Desig_2)
5774 and then (Ctype = Type_Conformant
5776 Subtypes_Statically_Match (Desig_1, Desig_2));
5780 -- Otherwise definitely no match
5783 if ((Ekind (Type_1) = E_Anonymous_Access_Type
5784 and then Is_Access_Type (Type_2))
5785 or else (Ekind (Type_2) = E_Anonymous_Access_Type
5786 and then Is_Access_Type (Type_1)))
5789 (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
5791 May_Hide_Profile := True;
5796 end Conforming_Types;
5798 --------------------------
5799 -- Create_Extra_Formals --
5800 --------------------------
5802 procedure Create_Extra_Formals (E : Entity_Id) is
5804 First_Extra : Entity_Id := Empty;
5805 Last_Extra : Entity_Id;
5806 Formal_Type : Entity_Id;
5807 P_Formal : Entity_Id := Empty;
5809 function Add_Extra_Formal
5810 (Assoc_Entity : Entity_Id;
5813 Suffix : String) return Entity_Id;
5814 -- Add an extra formal to the current list of formals and extra formals.
5815 -- The extra formal is added to the end of the list of extra formals,
5816 -- and also returned as the result. These formals are always of mode IN.
5817 -- The new formal has the type Typ, is declared in Scope, and its name
5818 -- is given by a concatenation of the name of Assoc_Entity and Suffix.
5819 -- The following suffixes are currently used. They should not be changed
5820 -- without coordinating with CodePeer, which makes use of these to
5821 -- provide better messages.
5823 -- O denotes the Constrained bit.
5824 -- L denotes the accessibility level.
5825 -- BIP_xxx denotes an extra formal for a build-in-place function. See
5826 -- the full list in exp_ch6.BIP_Formal_Kind.
5828 ----------------------
5829 -- Add_Extra_Formal --
5830 ----------------------
5832 function Add_Extra_Formal
5833 (Assoc_Entity : Entity_Id;
5836 Suffix : String) return Entity_Id
5838 EF : constant Entity_Id :=
5839 Make_Defining_Identifier (Sloc (Assoc_Entity),
5840 Chars => New_External_Name (Chars (Assoc_Entity),
5844 -- A little optimization. Never generate an extra formal for the
5845 -- _init operand of an initialization procedure, since it could
5848 if Chars (Formal) = Name_uInit then
5852 Set_Ekind (EF, E_In_Parameter);
5853 Set_Actual_Subtype (EF, Typ);
5854 Set_Etype (EF, Typ);
5855 Set_Scope (EF, Scope);
5856 Set_Mechanism (EF, Default_Mechanism);
5857 Set_Formal_Validity (EF);
5859 if No (First_Extra) then
5861 Set_Extra_Formals (Scope, First_Extra);
5864 if Present (Last_Extra) then
5865 Set_Extra_Formal (Last_Extra, EF);
5871 end Add_Extra_Formal;
5873 -- Start of processing for Create_Extra_Formals
5876 -- We never generate extra formals if expansion is not active
5877 -- because we don't need them unless we are generating code.
5879 if not Expander_Active then
5883 -- If this is a derived subprogram then the subtypes of the parent
5884 -- subprogram's formal parameters will be used to determine the need
5885 -- for extra formals.
5887 if Is_Overloadable (E) and then Present (Alias (E)) then
5888 P_Formal := First_Formal (Alias (E));
5891 Last_Extra := Empty;
5892 Formal := First_Formal (E);
5893 while Present (Formal) loop
5894 Last_Extra := Formal;
5895 Next_Formal (Formal);
5898 -- If Extra_formals were already created, don't do it again. This
5899 -- situation may arise for subprogram types created as part of
5900 -- dispatching calls (see Expand_Dispatching_Call)
5902 if Present (Last_Extra) and then
5903 Present (Extra_Formal (Last_Extra))
5908 -- If the subprogram is a predefined dispatching subprogram then don't
5909 -- generate any extra constrained or accessibility level formals. In
5910 -- general we suppress these for internal subprograms (by not calling
5911 -- Freeze_Subprogram and Create_Extra_Formals at all), but internally
5912 -- generated stream attributes do get passed through because extra
5913 -- build-in-place formals are needed in some cases (limited 'Input).
5915 if Is_Predefined_Internal_Operation (E) then
5916 goto Test_For_BIP_Extras;
5919 Formal := First_Formal (E);
5920 while Present (Formal) loop
5922 -- Create extra formal for supporting the attribute 'Constrained.
5923 -- The case of a private type view without discriminants also
5924 -- requires the extra formal if the underlying type has defaulted
5927 if Ekind (Formal) /= E_In_Parameter then
5928 if Present (P_Formal) then
5929 Formal_Type := Etype (P_Formal);
5931 Formal_Type := Etype (Formal);
5934 -- Do not produce extra formals for Unchecked_Union parameters.
5935 -- Jump directly to the end of the loop.
5937 if Is_Unchecked_Union (Base_Type (Formal_Type)) then
5938 goto Skip_Extra_Formal_Generation;
5941 if not Has_Discriminants (Formal_Type)
5942 and then Ekind (Formal_Type) in Private_Kind
5943 and then Present (Underlying_Type (Formal_Type))
5945 Formal_Type := Underlying_Type (Formal_Type);
5948 -- Suppress the extra formal if formal's subtype is constrained or
5949 -- indefinite, or we're compiling for Ada 2012 and the underlying
5950 -- type is tagged and limited. In Ada 2012, a limited tagged type
5951 -- can have defaulted discriminants, but 'Constrained is required
5952 -- to return True, so the formal is never needed (see AI05-0214).
5953 -- Note that this ensures consistency of calling sequences for
5954 -- dispatching operations when some types in a class have defaults
5955 -- on discriminants and others do not (and requiring the extra
5956 -- formal would introduce distributed overhead).
5958 if Has_Discriminants (Formal_Type)
5959 and then not Is_Constrained (Formal_Type)
5960 and then not Is_Indefinite_Subtype (Formal_Type)
5961 and then (Ada_Version < Ada_2012
5963 not (Is_Tagged_Type (Underlying_Type (Formal_Type))
5964 and then Is_Limited_Type (Formal_Type)))
5966 Set_Extra_Constrained
5967 (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O"));
5971 -- Create extra formal for supporting accessibility checking. This
5972 -- is done for both anonymous access formals and formals of named
5973 -- access types that are marked as controlling formals. The latter
5974 -- case can occur when Expand_Dispatching_Call creates a subprogram
5975 -- type and substitutes the types of access-to-class-wide actuals
5976 -- for the anonymous access-to-specific-type of controlling formals.
5977 -- Base_Type is applied because in cases where there is a null
5978 -- exclusion the formal may have an access subtype.
5980 -- This is suppressed if we specifically suppress accessibility
5981 -- checks at the package level for either the subprogram, or the
5982 -- package in which it resides. However, we do not suppress it
5983 -- simply if the scope has accessibility checks suppressed, since
5984 -- this could cause trouble when clients are compiled with a
5985 -- different suppression setting. The explicit checks at the
5986 -- package level are safe from this point of view.
5988 if (Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
5989 or else (Is_Controlling_Formal (Formal)
5990 and then Is_Access_Type (Base_Type (Etype (Formal)))))
5992 (Explicit_Suppress (E, Accessibility_Check)
5994 Explicit_Suppress (Scope (E), Accessibility_Check))
5997 or else Present (Extra_Accessibility (P_Formal)))
5999 Set_Extra_Accessibility
6000 (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L"));
6003 -- This label is required when skipping extra formal generation for
6004 -- Unchecked_Union parameters.
6006 <<Skip_Extra_Formal_Generation>>
6008 if Present (P_Formal) then
6009 Next_Formal (P_Formal);
6012 Next_Formal (Formal);
6015 <<Test_For_BIP_Extras>>
6017 -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
6018 -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
6020 if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then
6022 Result_Subt : constant Entity_Id := Etype (E);
6024 Discard : Entity_Id;
6025 pragma Warnings (Off, Discard);
6028 -- In the case of functions with unconstrained result subtypes,
6029 -- add a 4-state formal indicating whether the return object is
6030 -- allocated by the caller (1), or should be allocated by the
6031 -- callee on the secondary stack (2), in the global heap (3), or
6032 -- in a user-defined storage pool (4). For the moment we just use
6033 -- Natural for the type of this formal. Note that this formal
6034 -- isn't usually needed in the case where the result subtype is
6035 -- constrained, but it is needed when the function has a tagged
6036 -- result, because generally such functions can be called in a
6037 -- dispatching context and such calls must be handled like calls
6038 -- to a class-wide function.
6040 if not Is_Constrained (Underlying_Type (Result_Subt))
6041 or else Is_Tagged_Type (Underlying_Type (Result_Subt))
6045 (E, Standard_Natural,
6046 E, BIP_Formal_Suffix (BIP_Alloc_Form));
6049 -- For functions whose result type has controlled parts, we have
6050 -- an extra formal of type System.Finalization_Implementation.
6051 -- Finalizable_Ptr_Ptr. That is, we are passing a pointer to a
6052 -- finalization list (which is itself a pointer). This extra
6053 -- formal is then passed along to Move_Final_List in case of
6054 -- successful completion of a return statement. We cannot pass an
6055 -- 'in out' parameter, because we need to update the finalization
6056 -- list during an abort-deferred region, rather than using
6057 -- copy-back after the function returns. This is true even if we
6058 -- are able to get away with having 'in out' parameters, which are
6059 -- normally illegal for functions. This formal is also needed when
6060 -- the function has a tagged result.
6062 if Needs_BIP_Final_List (E) then
6065 (E, RTE (RE_Finalizable_Ptr_Ptr),
6066 E, BIP_Formal_Suffix (BIP_Final_List));
6069 -- If the result type contains tasks, we have two extra formals:
6070 -- the master of the tasks to be created, and the caller's
6071 -- activation chain.
6073 if Has_Task (Result_Subt) then
6076 (E, RTE (RE_Master_Id),
6077 E, BIP_Formal_Suffix (BIP_Master));
6080 (E, RTE (RE_Activation_Chain_Access),
6081 E, BIP_Formal_Suffix (BIP_Activation_Chain));
6084 -- All build-in-place functions get an extra formal that will be
6085 -- passed the address of the return object within the caller.
6088 Formal_Type : constant Entity_Id :=
6090 (E_Anonymous_Access_Type, E,
6091 Scope_Id => Scope (E));
6093 Set_Directly_Designated_Type (Formal_Type, Result_Subt);
6094 Set_Etype (Formal_Type, Formal_Type);
6095 Set_Depends_On_Private
6096 (Formal_Type, Has_Private_Component (Formal_Type));
6097 Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
6098 Set_Is_Access_Constant (Formal_Type, False);
6100 -- Ada 2005 (AI-50217): Propagate the attribute that indicates
6101 -- the designated type comes from the limited view (for
6102 -- back-end purposes).
6104 Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt));
6106 Layout_Type (Formal_Type);
6110 (E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access));
6114 end Create_Extra_Formals;
6116 -----------------------------
6117 -- Enter_Overloaded_Entity --
6118 -----------------------------
6120 procedure Enter_Overloaded_Entity (S : Entity_Id) is
6121 E : Entity_Id := Current_Entity_In_Scope (S);
6122 C_E : Entity_Id := Current_Entity (S);
6126 Set_Has_Homonym (E);
6127 Set_Has_Homonym (S);
6130 Set_Is_Immediately_Visible (S);
6131 Set_Scope (S, Current_Scope);
6133 -- Chain new entity if front of homonym in current scope, so that
6134 -- homonyms are contiguous.
6139 while Homonym (C_E) /= E loop
6140 C_E := Homonym (C_E);
6143 Set_Homonym (C_E, S);
6147 Set_Current_Entity (S);
6152 Append_Entity (S, Current_Scope);
6153 Set_Public_Status (S);
6155 if Debug_Flag_E then
6156 Write_Str ("New overloaded entity chain: ");
6157 Write_Name (Chars (S));
6160 while Present (E) loop
6161 Write_Str (" "); Write_Int (Int (E));
6168 -- Generate warning for hiding
6171 and then Comes_From_Source (S)
6172 and then In_Extended_Main_Source_Unit (S)
6179 -- Warn unless genuine overloading. Do not emit warning on
6180 -- hiding predefined operators in Standard (these are either an
6181 -- (artifact of our implicit declarations, or simple noise) but
6182 -- keep warning on a operator defined on a local subtype, because
6183 -- of the real danger that different operators may be applied in
6184 -- various parts of the program.
6186 -- Note that if E and S have the same scope, there is never any
6187 -- hiding. Either the two conflict, and the program is illegal,
6188 -- or S is overriding an implicit inherited subprogram.
6190 if Scope (E) /= Scope (S)
6191 and then (not Is_Overloadable (E)
6192 or else Subtype_Conformant (E, S))
6193 and then (Is_Immediately_Visible (E)
6195 Is_Potentially_Use_Visible (S))
6197 if Scope (E) /= Standard_Standard then
6198 Error_Msg_Sloc := Sloc (E);
6199 Error_Msg_N ("declaration of & hides one#?", S);
6201 elsif Nkind (S) = N_Defining_Operator_Symbol
6203 Scope (Base_Type (Etype (First_Formal (S)))) /= Scope (S)
6206 ("declaration of & hides predefined operator?", S);
6211 end Enter_Overloaded_Entity;
6213 -----------------------------
6214 -- Check_Untagged_Equality --
6215 -----------------------------
6217 procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
6218 Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
6219 Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
6223 if Nkind (Decl) = N_Subprogram_Declaration
6224 and then Is_Record_Type (Typ)
6225 and then not Is_Tagged_Type (Typ)
6227 -- If the type is not declared in a package, or if we are in the
6228 -- body of the package or in some other scope, the new operation is
6229 -- not primitive, and therefore legal, though suspicious. If the
6230 -- type is a generic actual (sub)type, the operation is not primitive
6231 -- either because the base type is declared elsewhere.
6233 if Is_Frozen (Typ) then
6234 if Ekind (Scope (Typ)) /= E_Package
6235 or else Scope (Typ) /= Current_Scope
6239 elsif Is_Generic_Actual_Type (Typ) then
6242 elsif In_Package_Body (Scope (Typ)) then
6244 ("equality operator must be declared "
6245 & "before type& is frozen", Eq_Op, Typ);
6247 ("\move declaration to package spec", Eq_Op);
6251 ("equality operator must be declared "
6252 & "before type& is frozen", Eq_Op, Typ);
6254 Obj_Decl := Next (Parent (Typ));
6255 while Present (Obj_Decl)
6256 and then Obj_Decl /= Decl
6258 if Nkind (Obj_Decl) = N_Object_Declaration
6259 and then Etype (Defining_Identifier (Obj_Decl)) = Typ
6261 Error_Msg_NE ("type& is frozen by declaration?",
6264 ("\an equality operator cannot be declared after this "
6265 & "point ('R'M 4.5.2 (9.8)) (Ada 2012))?", Obj_Decl);
6273 elsif not In_Same_List (Parent (Typ), Decl)
6274 and then not Is_Limited_Type (Typ)
6277 -- This makes it illegal to have a primitive equality declared in
6278 -- the private part if the type is visible.
6280 Error_Msg_N ("equality operator appears too late", Eq_Op);
6283 end Check_Untagged_Equality;
6285 -----------------------------
6286 -- Find_Corresponding_Spec --
6287 -----------------------------
6289 function Find_Corresponding_Spec
6291 Post_Error : Boolean := True) return Entity_Id
6293 Spec : constant Node_Id := Specification (N);
6294 Designator : constant Entity_Id := Defining_Entity (Spec);
6299 E := Current_Entity (Designator);
6300 while Present (E) loop
6302 -- We are looking for a matching spec. It must have the same scope,
6303 -- and the same name, and either be type conformant, or be the case
6304 -- of a library procedure spec and its body (which belong to one
6305 -- another regardless of whether they are type conformant or not).
6307 if Scope (E) = Current_Scope then
6308 if Current_Scope = Standard_Standard
6309 or else (Ekind (E) = Ekind (Designator)
6310 and then Type_Conformant (E, Designator))
6312 -- Within an instantiation, we know that spec and body are
6313 -- subtype conformant, because they were subtype conformant
6314 -- in the generic. We choose the subtype-conformant entity
6315 -- here as well, to resolve spurious ambiguities in the
6316 -- instance that were not present in the generic (i.e. when
6317 -- two different types are given the same actual). If we are
6318 -- looking for a spec to match a body, full conformance is
6322 Set_Convention (Designator, Convention (E));
6324 if Nkind (N) = N_Subprogram_Body
6325 and then Present (Homonym (E))
6326 and then not Fully_Conformant (Designator, E)
6330 elsif not Subtype_Conformant (Designator, E) then
6335 if not Has_Completion (E) then
6336 if Nkind (N) /= N_Subprogram_Body_Stub then
6337 Set_Corresponding_Spec (N, E);
6340 Set_Has_Completion (E);
6343 elsif Nkind (Parent (N)) = N_Subunit then
6345 -- If this is the proper body of a subunit, the completion
6346 -- flag is set when analyzing the stub.
6350 -- If E is an internal function with a controlling result
6351 -- that was created for an operation inherited by a null
6352 -- extension, it may be overridden by a body without a previous
6353 -- spec (one more reason why these should be shunned). In that
6354 -- case remove the generated body if present, because the
6355 -- current one is the explicit overriding.
6357 elsif Ekind (E) = E_Function
6358 and then Ada_Version >= Ada_2005
6359 and then not Comes_From_Source (E)
6360 and then Has_Controlling_Result (E)
6361 and then Is_Null_Extension (Etype (E))
6362 and then Comes_From_Source (Spec)
6364 Set_Has_Completion (E, False);
6367 and then Nkind (Parent (E)) = N_Function_Specification
6370 (Unit_Declaration_Node
6371 (Corresponding_Body (Unit_Declaration_Node (E))));
6375 -- If expansion is disabled, or if the wrapper function has
6376 -- not been generated yet, this a late body overriding an
6377 -- inherited operation, or it is an overriding by some other
6378 -- declaration before the controlling result is frozen. In
6379 -- either case this is a declaration of a new entity.
6385 -- If the body already exists, then this is an error unless
6386 -- the previous declaration is the implicit declaration of a
6387 -- derived subprogram, or this is a spurious overloading in an
6390 elsif No (Alias (E))
6391 and then not Is_Intrinsic_Subprogram (E)
6392 and then not In_Instance
6395 Error_Msg_Sloc := Sloc (E);
6397 if Is_Imported (E) then
6399 ("body not allowed for imported subprogram & declared#",
6402 Error_Msg_NE ("duplicate body for & declared#", N, E);
6406 -- Child units cannot be overloaded, so a conformance mismatch
6407 -- between body and a previous spec is an error.
6409 elsif Is_Child_Unit (E)
6411 Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
6413 Nkind (Parent (Unit_Declaration_Node (Designator))) =
6418 ("body of child unit does not match previous declaration", N);
6426 -- On exit, we know that no previous declaration of subprogram exists
6429 end Find_Corresponding_Spec;
6431 ----------------------
6432 -- Fully_Conformant --
6433 ----------------------
6435 function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
6438 Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
6440 end Fully_Conformant;
6442 ----------------------------------
6443 -- Fully_Conformant_Expressions --
6444 ----------------------------------
6446 function Fully_Conformant_Expressions
6447 (Given_E1 : Node_Id;
6448 Given_E2 : Node_Id) return Boolean
6450 E1 : constant Node_Id := Original_Node (Given_E1);
6451 E2 : constant Node_Id := Original_Node (Given_E2);
6452 -- We always test conformance on original nodes, since it is possible
6453 -- for analysis and/or expansion to make things look as though they
6454 -- conform when they do not, e.g. by converting 1+2 into 3.
6456 function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
6457 renames Fully_Conformant_Expressions;
6459 function FCL (L1, L2 : List_Id) return Boolean;
6460 -- Compare elements of two lists for conformance. Elements have to
6461 -- be conformant, and actuals inserted as default parameters do not
6462 -- match explicit actuals with the same value.
6464 function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
6465 -- Compare an operator node with a function call
6471 function FCL (L1, L2 : List_Id) return Boolean is
6475 if L1 = No_List then
6481 if L2 = No_List then
6487 -- Compare two lists, skipping rewrite insertions (we want to
6488 -- compare the original trees, not the expanded versions!)
6491 if Is_Rewrite_Insertion (N1) then
6493 elsif Is_Rewrite_Insertion (N2) then
6499 elsif not FCE (N1, N2) then
6512 function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
6513 Actuals : constant List_Id := Parameter_Associations (Call_Node);
6518 or else Entity (Op_Node) /= Entity (Name (Call_Node))
6523 Act := First (Actuals);
6525 if Nkind (Op_Node) in N_Binary_Op then
6526 if not FCE (Left_Opnd (Op_Node), Act) then
6533 return Present (Act)
6534 and then FCE (Right_Opnd (Op_Node), Act)
6535 and then No (Next (Act));
6539 -- Start of processing for Fully_Conformant_Expressions
6542 -- Non-conformant if paren count does not match. Note: if some idiot
6543 -- complains that we don't do this right for more than 3 levels of
6544 -- parentheses, they will be treated with the respect they deserve!
6546 if Paren_Count (E1) /= Paren_Count (E2) then
6549 -- If same entities are referenced, then they are conformant even if
6550 -- they have different forms (RM 8.3.1(19-20)).
6552 elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
6553 if Present (Entity (E1)) then
6554 return Entity (E1) = Entity (E2)
6555 or else (Chars (Entity (E1)) = Chars (Entity (E2))
6556 and then Ekind (Entity (E1)) = E_Discriminant
6557 and then Ekind (Entity (E2)) = E_In_Parameter);
6559 elsif Nkind (E1) = N_Expanded_Name
6560 and then Nkind (E2) = N_Expanded_Name
6561 and then Nkind (Selector_Name (E1)) = N_Character_Literal
6562 and then Nkind (Selector_Name (E2)) = N_Character_Literal
6564 return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
6567 -- Identifiers in component associations don't always have
6568 -- entities, but their names must conform.
6570 return Nkind (E1) = N_Identifier
6571 and then Nkind (E2) = N_Identifier
6572 and then Chars (E1) = Chars (E2);
6575 elsif Nkind (E1) = N_Character_Literal
6576 and then Nkind (E2) = N_Expanded_Name
6578 return Nkind (Selector_Name (E2)) = N_Character_Literal
6579 and then Chars (E1) = Chars (Selector_Name (E2));
6581 elsif Nkind (E2) = N_Character_Literal
6582 and then Nkind (E1) = N_Expanded_Name
6584 return Nkind (Selector_Name (E1)) = N_Character_Literal
6585 and then Chars (E2) = Chars (Selector_Name (E1));
6587 elsif Nkind (E1) in N_Op
6588 and then Nkind (E2) = N_Function_Call
6590 return FCO (E1, E2);
6592 elsif Nkind (E2) in N_Op
6593 and then Nkind (E1) = N_Function_Call
6595 return FCO (E2, E1);
6597 -- Otherwise we must have the same syntactic entity
6599 elsif Nkind (E1) /= Nkind (E2) then
6602 -- At this point, we specialize by node type
6609 FCL (Expressions (E1), Expressions (E2))
6611 FCL (Component_Associations (E1),
6612 Component_Associations (E2));
6615 if Nkind (Expression (E1)) = N_Qualified_Expression
6617 Nkind (Expression (E2)) = N_Qualified_Expression
6619 return FCE (Expression (E1), Expression (E2));
6621 -- Check that the subtype marks and any constraints
6626 Indic1 : constant Node_Id := Expression (E1);
6627 Indic2 : constant Node_Id := Expression (E2);
6632 if Nkind (Indic1) /= N_Subtype_Indication then
6634 Nkind (Indic2) /= N_Subtype_Indication
6635 and then Entity (Indic1) = Entity (Indic2);
6637 elsif Nkind (Indic2) /= N_Subtype_Indication then
6639 Nkind (Indic1) /= N_Subtype_Indication
6640 and then Entity (Indic1) = Entity (Indic2);
6643 if Entity (Subtype_Mark (Indic1)) /=
6644 Entity (Subtype_Mark (Indic2))
6649 Elt1 := First (Constraints (Constraint (Indic1)));
6650 Elt2 := First (Constraints (Constraint (Indic2)));
6651 while Present (Elt1) and then Present (Elt2) loop
6652 if not FCE (Elt1, Elt2) then
6665 when N_Attribute_Reference =>
6667 Attribute_Name (E1) = Attribute_Name (E2)
6668 and then FCL (Expressions (E1), Expressions (E2));
6672 Entity (E1) = Entity (E2)
6673 and then FCE (Left_Opnd (E1), Left_Opnd (E2))
6674 and then FCE (Right_Opnd (E1), Right_Opnd (E2));
6676 when N_Short_Circuit | N_Membership_Test =>
6678 FCE (Left_Opnd (E1), Left_Opnd (E2))
6680 FCE (Right_Opnd (E1), Right_Opnd (E2));
6682 when N_Case_Expression =>
6688 if not FCE (Expression (E1), Expression (E2)) then
6692 Alt1 := First (Alternatives (E1));
6693 Alt2 := First (Alternatives (E2));
6695 if Present (Alt1) /= Present (Alt2) then
6697 elsif No (Alt1) then
6701 if not FCE (Expression (Alt1), Expression (Alt2))
6702 or else not FCL (Discrete_Choices (Alt1),
6703 Discrete_Choices (Alt2))
6714 when N_Character_Literal =>
6716 Char_Literal_Value (E1) = Char_Literal_Value (E2);
6718 when N_Component_Association =>
6720 FCL (Choices (E1), Choices (E2))
6722 FCE (Expression (E1), Expression (E2));
6724 when N_Conditional_Expression =>
6726 FCL (Expressions (E1), Expressions (E2));
6728 when N_Explicit_Dereference =>
6730 FCE (Prefix (E1), Prefix (E2));
6732 when N_Extension_Aggregate =>
6734 FCL (Expressions (E1), Expressions (E2))
6735 and then Null_Record_Present (E1) =
6736 Null_Record_Present (E2)
6737 and then FCL (Component_Associations (E1),
6738 Component_Associations (E2));
6740 when N_Function_Call =>
6742 FCE (Name (E1), Name (E2))
6744 FCL (Parameter_Associations (E1),
6745 Parameter_Associations (E2));
6747 when N_Indexed_Component =>
6749 FCE (Prefix (E1), Prefix (E2))
6751 FCL (Expressions (E1), Expressions (E2));
6753 when N_Integer_Literal =>
6754 return (Intval (E1) = Intval (E2));
6759 when N_Operator_Symbol =>
6761 Chars (E1) = Chars (E2);
6763 when N_Others_Choice =>
6766 when N_Parameter_Association =>
6768 Chars (Selector_Name (E1)) = Chars (Selector_Name (E2))
6769 and then FCE (Explicit_Actual_Parameter (E1),
6770 Explicit_Actual_Parameter (E2));
6772 when N_Qualified_Expression =>
6774 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6776 FCE (Expression (E1), Expression (E2));
6778 when N_Quantified_Expression =>
6779 if not FCE (Condition (E1), Condition (E2)) then
6783 if Present (Loop_Parameter_Specification (E1))
6784 and then Present (Loop_Parameter_Specification (E2))
6787 L1 : constant Node_Id :=
6788 Loop_Parameter_Specification (E1);
6789 L2 : constant Node_Id :=
6790 Loop_Parameter_Specification (E2);
6794 Reverse_Present (L1) = Reverse_Present (L2)
6796 FCE (Defining_Identifier (L1),
6797 Defining_Identifier (L2))
6799 FCE (Discrete_Subtype_Definition (L1),
6800 Discrete_Subtype_Definition (L2));
6803 else -- quantified expression with an iterator
6805 I1 : constant Node_Id := Iterator_Specification (E1);
6806 I2 : constant Node_Id := Iterator_Specification (E2);
6810 FCE (Defining_Identifier (I1),
6811 Defining_Identifier (I2))
6813 Of_Present (I1) = Of_Present (I2)
6815 Reverse_Present (I1) = Reverse_Present (I2)
6816 and then FCE (Name (I1), Name (I2))
6817 and then FCE (Subtype_Indication (I1),
6818 Subtype_Indication (I2));
6824 FCE (Low_Bound (E1), Low_Bound (E2))
6826 FCE (High_Bound (E1), High_Bound (E2));
6828 when N_Real_Literal =>
6829 return (Realval (E1) = Realval (E2));
6831 when N_Selected_Component =>
6833 FCE (Prefix (E1), Prefix (E2))
6835 FCE (Selector_Name (E1), Selector_Name (E2));
6839 FCE (Prefix (E1), Prefix (E2))
6841 FCE (Discrete_Range (E1), Discrete_Range (E2));
6843 when N_String_Literal =>
6845 S1 : constant String_Id := Strval (E1);
6846 S2 : constant String_Id := Strval (E2);
6847 L1 : constant Nat := String_Length (S1);
6848 L2 : constant Nat := String_Length (S2);
6855 for J in 1 .. L1 loop
6856 if Get_String_Char (S1, J) /=
6857 Get_String_Char (S2, J)
6867 when N_Type_Conversion =>
6869 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6871 FCE (Expression (E1), Expression (E2));
6875 Entity (E1) = Entity (E2)
6877 FCE (Right_Opnd (E1), Right_Opnd (E2));
6879 when N_Unchecked_Type_Conversion =>
6881 FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6883 FCE (Expression (E1), Expression (E2));
6885 -- All other node types cannot appear in this context. Strictly
6886 -- we should raise a fatal internal error. Instead we just ignore
6887 -- the nodes. This means that if anyone makes a mistake in the
6888 -- expander and mucks an expression tree irretrievably, the
6889 -- result will be a failure to detect a (probably very obscure)
6890 -- case of non-conformance, which is better than bombing on some
6891 -- case where two expressions do in fact conform.
6898 end Fully_Conformant_Expressions;
6900 ----------------------------------------
6901 -- Fully_Conformant_Discrete_Subtypes --
6902 ----------------------------------------
6904 function Fully_Conformant_Discrete_Subtypes
6905 (Given_S1 : Node_Id;
6906 Given_S2 : Node_Id) return Boolean
6908 S1 : constant Node_Id := Original_Node (Given_S1);
6909 S2 : constant Node_Id := Original_Node (Given_S2);
6911 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean;
6912 -- Special-case for a bound given by a discriminant, which in the body
6913 -- is replaced with the discriminal of the enclosing type.
6915 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean;
6916 -- Check both bounds
6918 -----------------------
6919 -- Conforming_Bounds --
6920 -----------------------
6922 function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is
6924 if Is_Entity_Name (B1)
6925 and then Is_Entity_Name (B2)
6926 and then Ekind (Entity (B1)) = E_Discriminant
6928 return Chars (B1) = Chars (B2);
6931 return Fully_Conformant_Expressions (B1, B2);
6933 end Conforming_Bounds;
6935 -----------------------
6936 -- Conforming_Ranges --
6937 -----------------------
6939 function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is
6942 Conforming_Bounds (Low_Bound (R1), Low_Bound (R2))
6944 Conforming_Bounds (High_Bound (R1), High_Bound (R2));
6945 end Conforming_Ranges;
6947 -- Start of processing for Fully_Conformant_Discrete_Subtypes
6950 if Nkind (S1) /= Nkind (S2) then
6953 elsif Is_Entity_Name (S1) then
6954 return Entity (S1) = Entity (S2);
6956 elsif Nkind (S1) = N_Range then
6957 return Conforming_Ranges (S1, S2);
6959 elsif Nkind (S1) = N_Subtype_Indication then
6961 Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2))
6964 (Range_Expression (Constraint (S1)),
6965 Range_Expression (Constraint (S2)));
6969 end Fully_Conformant_Discrete_Subtypes;
6971 --------------------
6972 -- Install_Entity --
6973 --------------------
6975 procedure Install_Entity (E : Entity_Id) is
6976 Prev : constant Entity_Id := Current_Entity (E);
6978 Set_Is_Immediately_Visible (E);
6979 Set_Current_Entity (E);
6980 Set_Homonym (E, Prev);
6983 ---------------------
6984 -- Install_Formals --
6985 ---------------------
6987 procedure Install_Formals (Id : Entity_Id) is
6990 F := First_Formal (Id);
6991 while Present (F) loop
6995 end Install_Formals;
6997 -----------------------------
6998 -- Is_Interface_Conformant --
6999 -----------------------------
7001 function Is_Interface_Conformant
7002 (Tagged_Type : Entity_Id;
7003 Iface_Prim : Entity_Id;
7004 Prim : Entity_Id) return Boolean
7006 Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim);
7007 Typ : constant Entity_Id := Find_Dispatching_Type (Prim);
7010 pragma Assert (Is_Subprogram (Iface_Prim)
7011 and then Is_Subprogram (Prim)
7012 and then Is_Dispatching_Operation (Iface_Prim)
7013 and then Is_Dispatching_Operation (Prim));
7015 pragma Assert (Is_Interface (Iface)
7016 or else (Present (Alias (Iface_Prim))
7019 (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
7021 if Prim = Iface_Prim
7022 or else not Is_Subprogram (Prim)
7023 or else Ekind (Prim) /= Ekind (Iface_Prim)
7024 or else not Is_Dispatching_Operation (Prim)
7025 or else Scope (Prim) /= Scope (Tagged_Type)
7027 or else Base_Type (Typ) /= Tagged_Type
7028 or else not Primitive_Names_Match (Iface_Prim, Prim)
7032 -- Case of a procedure, or a function that does not have a controlling
7033 -- result (I or access I).
7035 elsif Ekind (Iface_Prim) = E_Procedure
7036 or else Etype (Prim) = Etype (Iface_Prim)
7037 or else not Has_Controlling_Result (Prim)
7039 return Type_Conformant
7040 (Iface_Prim, Prim, Skip_Controlling_Formals => True);
7042 -- Case of a function returning an interface, or an access to one.
7043 -- Check that the return types correspond.
7045 elsif Implements_Interface (Typ, Iface) then
7046 if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type)
7048 (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type)
7053 Type_Conformant (Prim, Iface_Prim,
7054 Skip_Controlling_Formals => True);
7060 end Is_Interface_Conformant;
7062 ---------------------------------
7063 -- Is_Non_Overriding_Operation --
7064 ---------------------------------
7066 function Is_Non_Overriding_Operation
7067 (Prev_E : Entity_Id;
7068 New_E : Entity_Id) return Boolean
7072 G_Typ : Entity_Id := Empty;
7074 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
7075 -- If F_Type is a derived type associated with a generic actual subtype,
7076 -- then return its Generic_Parent_Type attribute, else return Empty.
7078 function Types_Correspond
7079 (P_Type : Entity_Id;
7080 N_Type : Entity_Id) return Boolean;
7081 -- Returns true if and only if the types (or designated types in the
7082 -- case of anonymous access types) are the same or N_Type is derived
7083 -- directly or indirectly from P_Type.
7085 -----------------------------
7086 -- Get_Generic_Parent_Type --
7087 -----------------------------
7089 function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
7094 if Is_Derived_Type (F_Typ)
7095 and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
7097 -- The tree must be traversed to determine the parent subtype in
7098 -- the generic unit, which unfortunately isn't always available
7099 -- via semantic attributes. ??? (Note: The use of Original_Node
7100 -- is needed for cases where a full derived type has been
7103 Indic := Subtype_Indication
7104 (Type_Definition (Original_Node (Parent (F_Typ))));
7106 if Nkind (Indic) = N_Subtype_Indication then
7107 G_Typ := Entity (Subtype_Mark (Indic));
7109 G_Typ := Entity (Indic);
7112 if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
7113 and then Present (Generic_Parent_Type (Parent (G_Typ)))
7115 return Generic_Parent_Type (Parent (G_Typ));
7120 end Get_Generic_Parent_Type;
7122 ----------------------
7123 -- Types_Correspond --
7124 ----------------------
7126 function Types_Correspond
7127 (P_Type : Entity_Id;
7128 N_Type : Entity_Id) return Boolean
7130 Prev_Type : Entity_Id := Base_Type (P_Type);
7131 New_Type : Entity_Id := Base_Type (N_Type);
7134 if Ekind (Prev_Type) = E_Anonymous_Access_Type then
7135 Prev_Type := Designated_Type (Prev_Type);
7138 if Ekind (New_Type) = E_Anonymous_Access_Type then
7139 New_Type := Designated_Type (New_Type);
7142 if Prev_Type = New_Type then
7145 elsif not Is_Class_Wide_Type (New_Type) then
7146 while Etype (New_Type) /= New_Type loop
7147 New_Type := Etype (New_Type);
7148 if New_Type = Prev_Type then
7154 end Types_Correspond;
7156 -- Start of processing for Is_Non_Overriding_Operation
7159 -- In the case where both operations are implicit derived subprograms
7160 -- then neither overrides the other. This can only occur in certain
7161 -- obscure cases (e.g., derivation from homographs created in a generic
7164 if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
7167 elsif Ekind (Current_Scope) = E_Package
7168 and then Is_Generic_Instance (Current_Scope)
7169 and then In_Private_Part (Current_Scope)
7170 and then Comes_From_Source (New_E)
7172 -- We examine the formals and result subtype of the inherited
7173 -- operation, to determine whether their type is derived from (the
7174 -- instance of) a generic type.
7176 Formal := First_Formal (Prev_E);
7177 while Present (Formal) loop
7178 F_Typ := Base_Type (Etype (Formal));
7180 if Ekind (F_Typ) = E_Anonymous_Access_Type then
7181 F_Typ := Designated_Type (F_Typ);
7184 G_Typ := Get_Generic_Parent_Type (F_Typ);
7186 Next_Formal (Formal);
7189 if No (G_Typ) and then Ekind (Prev_E) = E_Function then
7190 G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
7197 -- If the generic type is a private type, then the original operation
7198 -- was not overriding in the generic, because there was no primitive
7199 -- operation to override.
7201 if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
7202 and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
7203 N_Formal_Private_Type_Definition
7207 -- The generic parent type is the ancestor of a formal derived
7208 -- type declaration. We need to check whether it has a primitive
7209 -- operation that should be overridden by New_E in the generic.
7213 P_Formal : Entity_Id;
7214 N_Formal : Entity_Id;
7218 Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
7221 while Present (Prim_Elt) loop
7222 P_Prim := Node (Prim_Elt);
7224 if Chars (P_Prim) = Chars (New_E)
7225 and then Ekind (P_Prim) = Ekind (New_E)
7227 P_Formal := First_Formal (P_Prim);
7228 N_Formal := First_Formal (New_E);
7229 while Present (P_Formal) and then Present (N_Formal) loop
7230 P_Typ := Etype (P_Formal);
7231 N_Typ := Etype (N_Formal);
7233 if not Types_Correspond (P_Typ, N_Typ) then
7237 Next_Entity (P_Formal);
7238 Next_Entity (N_Formal);
7241 -- Found a matching primitive operation belonging to the
7242 -- formal ancestor type, so the new subprogram is
7246 and then No (N_Formal)
7247 and then (Ekind (New_E) /= E_Function
7250 (Etype (P_Prim), Etype (New_E)))
7256 Next_Elmt (Prim_Elt);
7259 -- If no match found, then the new subprogram does not
7260 -- override in the generic (nor in the instance).
7268 end Is_Non_Overriding_Operation;
7270 -------------------------------------
7271 -- List_Inherited_Pre_Post_Aspects --
7272 -------------------------------------
7274 procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is
7276 if Opt.List_Inherited_Aspects
7277 and then (Is_Subprogram (E) or else Is_Generic_Subprogram (E))
7280 Inherited : constant Subprogram_List :=
7281 Inherited_Subprograms (E);
7285 for J in Inherited'Range loop
7286 P := Spec_PPC_List (Inherited (J));
7287 while Present (P) loop
7288 Error_Msg_Sloc := Sloc (P);
7290 if Class_Present (P) and then not Split_PPC (P) then
7291 if Pragma_Name (P) = Name_Precondition then
7293 ("?info: & inherits `Pre''Class` aspect from #", E);
7296 ("?info: & inherits `Post''Class` aspect from #", E);
7300 P := Next_Pragma (P);
7305 end List_Inherited_Pre_Post_Aspects;
7307 ------------------------------
7308 -- Make_Inequality_Operator --
7309 ------------------------------
7311 -- S is the defining identifier of an equality operator. We build a
7312 -- subprogram declaration with the right signature. This operation is
7313 -- intrinsic, because it is always expanded as the negation of the
7314 -- call to the equality function.
7316 procedure Make_Inequality_Operator (S : Entity_Id) is
7317 Loc : constant Source_Ptr := Sloc (S);
7320 Op_Name : Entity_Id;
7322 FF : constant Entity_Id := First_Formal (S);
7323 NF : constant Entity_Id := Next_Formal (FF);
7326 -- Check that equality was properly defined, ignore call if not
7333 A : constant Entity_Id :=
7334 Make_Defining_Identifier (Sloc (FF),
7335 Chars => Chars (FF));
7337 B : constant Entity_Id :=
7338 Make_Defining_Identifier (Sloc (NF),
7339 Chars => Chars (NF));
7342 Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
7344 Formals := New_List (
7345 Make_Parameter_Specification (Loc,
7346 Defining_Identifier => A,
7348 New_Reference_To (Etype (First_Formal (S)),
7349 Sloc (Etype (First_Formal (S))))),
7351 Make_Parameter_Specification (Loc,
7352 Defining_Identifier => B,
7354 New_Reference_To (Etype (Next_Formal (First_Formal (S))),
7355 Sloc (Etype (Next_Formal (First_Formal (S)))))));
7358 Make_Subprogram_Declaration (Loc,
7360 Make_Function_Specification (Loc,
7361 Defining_Unit_Name => Op_Name,
7362 Parameter_Specifications => Formals,
7363 Result_Definition =>
7364 New_Reference_To (Standard_Boolean, Loc)));
7366 -- Insert inequality right after equality if it is explicit or after
7367 -- the derived type when implicit. These entities are created only
7368 -- for visibility purposes, and eventually replaced in the course of
7369 -- expansion, so they do not need to be attached to the tree and seen
7370 -- by the back-end. Keeping them internal also avoids spurious
7371 -- freezing problems. The declaration is inserted in the tree for
7372 -- analysis, and removed afterwards. If the equality operator comes
7373 -- from an explicit declaration, attach the inequality immediately
7374 -- after. Else the equality is inherited from a derived type
7375 -- declaration, so insert inequality after that declaration.
7377 if No (Alias (S)) then
7378 Insert_After (Unit_Declaration_Node (S), Decl);
7379 elsif Is_List_Member (Parent (S)) then
7380 Insert_After (Parent (S), Decl);
7382 Insert_After (Parent (Etype (First_Formal (S))), Decl);
7385 Mark_Rewrite_Insertion (Decl);
7386 Set_Is_Intrinsic_Subprogram (Op_Name);
7389 Set_Has_Completion (Op_Name);
7390 Set_Corresponding_Equality (Op_Name, S);
7391 Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S));
7393 end Make_Inequality_Operator;
7395 ----------------------
7396 -- May_Need_Actuals --
7397 ----------------------
7399 procedure May_Need_Actuals (Fun : Entity_Id) is
7404 F := First_Formal (Fun);
7406 while Present (F) loop
7407 if No (Default_Value (F)) then
7415 Set_Needs_No_Actuals (Fun, B);
7416 end May_Need_Actuals;
7418 ---------------------
7419 -- Mode_Conformant --
7420 ---------------------
7422 function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
7425 Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
7427 end Mode_Conformant;
7429 ---------------------------
7430 -- New_Overloaded_Entity --
7431 ---------------------------
7433 procedure New_Overloaded_Entity
7435 Derived_Type : Entity_Id := Empty)
7437 Overridden_Subp : Entity_Id := Empty;
7438 -- Set if the current scope has an operation that is type-conformant
7439 -- with S, and becomes hidden by S.
7441 Is_Primitive_Subp : Boolean;
7442 -- Set to True if the new subprogram is primitive
7445 -- Entity that S overrides
7447 Prev_Vis : Entity_Id := Empty;
7448 -- Predecessor of E in Homonym chain
7450 procedure Check_For_Primitive_Subprogram
7451 (Is_Primitive : out Boolean;
7452 Is_Overriding : Boolean := False);
7453 -- If the subprogram being analyzed is a primitive operation of the type
7454 -- of a formal or result, set the Has_Primitive_Operations flag on the
7455 -- type, and set Is_Primitive to True (otherwise set to False). Set the
7456 -- corresponding flag on the entity itself for later use.
7458 procedure Check_Synchronized_Overriding
7459 (Def_Id : Entity_Id;
7460 Overridden_Subp : out Entity_Id);
7461 -- First determine if Def_Id is an entry or a subprogram either defined
7462 -- in the scope of a task or protected type, or is a primitive of such
7463 -- a type. Check whether Def_Id overrides a subprogram of an interface
7464 -- implemented by the synchronized type, return the overridden entity
7467 function Is_Private_Declaration (E : Entity_Id) return Boolean;
7468 -- Check that E is declared in the private part of the current package,
7469 -- or in the package body, where it may hide a previous declaration.
7470 -- We can't use In_Private_Part by itself because this flag is also
7471 -- set when freezing entities, so we must examine the place of the
7472 -- declaration in the tree, and recognize wrapper packages as well.
7474 function Is_Overriding_Alias
7476 New_E : Entity_Id) return Boolean;
7477 -- Check whether new subprogram and old subprogram are both inherited
7478 -- from subprograms that have distinct dispatch table entries. This can
7479 -- occur with derivations from instances with accidental homonyms.
7480 -- The function is conservative given that the converse is only true
7481 -- within instances that contain accidental overloadings.
7483 ------------------------------------
7484 -- Check_For_Primitive_Subprogram --
7485 ------------------------------------
7487 procedure Check_For_Primitive_Subprogram
7488 (Is_Primitive : out Boolean;
7489 Is_Overriding : Boolean := False)
7495 function Visible_Part_Type (T : Entity_Id) return Boolean;
7496 -- Returns true if T is declared in the visible part of the current
7497 -- package scope; otherwise returns false. Assumes that T is declared
7500 procedure Check_Private_Overriding (T : Entity_Id);
7501 -- Checks that if a primitive abstract subprogram of a visible
7502 -- abstract type is declared in a private part, then it must override
7503 -- an abstract subprogram declared in the visible part. Also checks
7504 -- that if a primitive function with a controlling result is declared
7505 -- in a private part, then it must override a function declared in
7506 -- the visible part.
7508 ------------------------------
7509 -- Check_Private_Overriding --
7510 ------------------------------
7512 procedure Check_Private_Overriding (T : Entity_Id) is
7514 if Is_Package_Or_Generic_Package (Current_Scope)
7515 and then In_Private_Part (Current_Scope)
7516 and then Visible_Part_Type (T)
7517 and then not In_Instance
7519 if Is_Abstract_Type (T)
7520 and then Is_Abstract_Subprogram (S)
7521 and then (not Is_Overriding
7522 or else not Is_Abstract_Subprogram (E))
7525 ("abstract subprograms must be visible "
7526 & "(RM 3.9.3(10))!", S);
7528 elsif Ekind (S) = E_Function
7529 and then not Is_Overriding
7531 if Is_Tagged_Type (T)
7532 and then T = Base_Type (Etype (S))
7535 ("private function with tagged result must"
7536 & " override visible-part function", S);
7538 ("\move subprogram to the visible part"
7539 & " (RM 3.9.3(10))", S);
7541 -- AI05-0073: extend this test to the case of a function
7542 -- with a controlling access result.
7544 elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
7545 and then Is_Tagged_Type (Designated_Type (Etype (S)))
7547 not Is_Class_Wide_Type (Designated_Type (Etype (S)))
7548 and then Ada_Version >= Ada_2012
7551 ("private function with controlling access result "
7552 & "must override visible-part function", S);
7554 ("\move subprogram to the visible part"
7555 & " (RM 3.9.3(10))", S);
7559 end Check_Private_Overriding;
7561 -----------------------
7562 -- Visible_Part_Type --
7563 -----------------------
7565 function Visible_Part_Type (T : Entity_Id) return Boolean is
7566 P : constant Node_Id := Unit_Declaration_Node (Scope (T));
7570 -- If the entity is a private type, then it must be declared in a
7573 if Ekind (T) in Private_Kind then
7577 -- Otherwise, we traverse the visible part looking for its
7578 -- corresponding declaration. We cannot use the declaration
7579 -- node directly because in the private part the entity of a
7580 -- private type is the one in the full view, which does not
7581 -- indicate that it is the completion of something visible.
7583 N := First (Visible_Declarations (Specification (P)));
7584 while Present (N) loop
7585 if Nkind (N) = N_Full_Type_Declaration
7586 and then Present (Defining_Identifier (N))
7587 and then T = Defining_Identifier (N)
7591 elsif Nkind_In (N, N_Private_Type_Declaration,
7592 N_Private_Extension_Declaration)
7593 and then Present (Defining_Identifier (N))
7594 and then T = Full_View (Defining_Identifier (N))
7603 end Visible_Part_Type;
7605 -- Start of processing for Check_For_Primitive_Subprogram
7608 Is_Primitive := False;
7610 if not Comes_From_Source (S) then
7613 -- If subprogram is at library level, it is not primitive operation
7615 elsif Current_Scope = Standard_Standard then
7618 elsif (Is_Package_Or_Generic_Package (Current_Scope)
7619 and then not In_Package_Body (Current_Scope))
7620 or else Is_Overriding
7622 -- For function, check return type
7624 if Ekind (S) = E_Function then
7625 if Ekind (Etype (S)) = E_Anonymous_Access_Type then
7626 F_Typ := Designated_Type (Etype (S));
7631 B_Typ := Base_Type (F_Typ);
7633 if Scope (B_Typ) = Current_Scope
7634 and then not Is_Class_Wide_Type (B_Typ)
7635 and then not Is_Generic_Type (B_Typ)
7637 Is_Primitive := True;
7638 Set_Has_Primitive_Operations (B_Typ);
7639 Set_Is_Primitive (S);
7640 Check_Private_Overriding (B_Typ);
7644 -- For all subprograms, check formals
7646 Formal := First_Formal (S);
7647 while Present (Formal) loop
7648 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
7649 F_Typ := Designated_Type (Etype (Formal));
7651 F_Typ := Etype (Formal);
7654 B_Typ := Base_Type (F_Typ);
7656 if Ekind (B_Typ) = E_Access_Subtype then
7657 B_Typ := Base_Type (B_Typ);
7660 if Scope (B_Typ) = Current_Scope
7661 and then not Is_Class_Wide_Type (B_Typ)
7662 and then not Is_Generic_Type (B_Typ)
7664 Is_Primitive := True;
7665 Set_Is_Primitive (S);
7666 Set_Has_Primitive_Operations (B_Typ);
7667 Check_Private_Overriding (B_Typ);
7670 Next_Formal (Formal);
7673 end Check_For_Primitive_Subprogram;
7675 -----------------------------------
7676 -- Check_Synchronized_Overriding --
7677 -----------------------------------
7679 procedure Check_Synchronized_Overriding
7680 (Def_Id : Entity_Id;
7681 Overridden_Subp : out Entity_Id)
7683 Ifaces_List : Elist_Id;
7687 function Matches_Prefixed_View_Profile
7688 (Prim_Params : List_Id;
7689 Iface_Params : List_Id) return Boolean;
7690 -- Determine whether a subprogram's parameter profile Prim_Params
7691 -- matches that of a potentially overridden interface subprogram
7692 -- Iface_Params. Also determine if the type of first parameter of
7693 -- Iface_Params is an implemented interface.
7695 -----------------------------------
7696 -- Matches_Prefixed_View_Profile --
7697 -----------------------------------
7699 function Matches_Prefixed_View_Profile
7700 (Prim_Params : List_Id;
7701 Iface_Params : List_Id) return Boolean
7703 Iface_Id : Entity_Id;
7704 Iface_Param : Node_Id;
7705 Iface_Typ : Entity_Id;
7706 Prim_Id : Entity_Id;
7707 Prim_Param : Node_Id;
7708 Prim_Typ : Entity_Id;
7710 function Is_Implemented
7711 (Ifaces_List : Elist_Id;
7712 Iface : Entity_Id) return Boolean;
7713 -- Determine if Iface is implemented by the current task or
7716 --------------------
7717 -- Is_Implemented --
7718 --------------------
7720 function Is_Implemented
7721 (Ifaces_List : Elist_Id;
7722 Iface : Entity_Id) return Boolean
7724 Iface_Elmt : Elmt_Id;
7727 Iface_Elmt := First_Elmt (Ifaces_List);
7728 while Present (Iface_Elmt) loop
7729 if Node (Iface_Elmt) = Iface then
7733 Next_Elmt (Iface_Elmt);
7739 -- Start of processing for Matches_Prefixed_View_Profile
7742 Iface_Param := First (Iface_Params);
7743 Iface_Typ := Etype (Defining_Identifier (Iface_Param));
7745 if Is_Access_Type (Iface_Typ) then
7746 Iface_Typ := Designated_Type (Iface_Typ);
7749 Prim_Param := First (Prim_Params);
7751 -- The first parameter of the potentially overridden subprogram
7752 -- must be an interface implemented by Prim.
7754 if not Is_Interface (Iface_Typ)
7755 or else not Is_Implemented (Ifaces_List, Iface_Typ)
7760 -- The checks on the object parameters are done, move onto the
7761 -- rest of the parameters.
7763 if not In_Scope then
7764 Prim_Param := Next (Prim_Param);
7767 Iface_Param := Next (Iface_Param);
7768 while Present (Iface_Param) and then Present (Prim_Param) loop
7769 Iface_Id := Defining_Identifier (Iface_Param);
7770 Iface_Typ := Find_Parameter_Type (Iface_Param);
7772 Prim_Id := Defining_Identifier (Prim_Param);
7773 Prim_Typ := Find_Parameter_Type (Prim_Param);
7775 if Ekind (Iface_Typ) = E_Anonymous_Access_Type
7776 and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
7777 and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
7779 Iface_Typ := Designated_Type (Iface_Typ);
7780 Prim_Typ := Designated_Type (Prim_Typ);
7783 -- Case of multiple interface types inside a parameter profile
7785 -- (Obj_Param : in out Iface; ...; Param : Iface)
7787 -- If the interface type is implemented, then the matching type
7788 -- in the primitive should be the implementing record type.
7790 if Ekind (Iface_Typ) = E_Record_Type
7791 and then Is_Interface (Iface_Typ)
7792 and then Is_Implemented (Ifaces_List, Iface_Typ)
7794 if Prim_Typ /= Typ then
7798 -- The two parameters must be both mode and subtype conformant
7800 elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
7802 Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
7811 -- One of the two lists contains more parameters than the other
7813 if Present (Iface_Param) or else Present (Prim_Param) then
7818 end Matches_Prefixed_View_Profile;
7820 -- Start of processing for Check_Synchronized_Overriding
7823 Overridden_Subp := Empty;
7825 -- Def_Id must be an entry or a subprogram. We should skip predefined
7826 -- primitives internally generated by the frontend; however at this
7827 -- stage predefined primitives are still not fully decorated. As a
7828 -- minor optimization we skip here internally generated subprograms.
7830 if (Ekind (Def_Id) /= E_Entry
7831 and then Ekind (Def_Id) /= E_Function
7832 and then Ekind (Def_Id) /= E_Procedure)
7833 or else not Comes_From_Source (Def_Id)
7838 -- Search for the concurrent declaration since it contains the list
7839 -- of all implemented interfaces. In this case, the subprogram is
7840 -- declared within the scope of a protected or a task type.
7842 if Present (Scope (Def_Id))
7843 and then Is_Concurrent_Type (Scope (Def_Id))
7844 and then not Is_Generic_Actual_Type (Scope (Def_Id))
7846 Typ := Scope (Def_Id);
7849 -- The enclosing scope is not a synchronized type and the subprogram
7852 elsif No (First_Formal (Def_Id)) then
7855 -- The subprogram has formals and hence it may be a primitive of a
7859 Typ := Etype (First_Formal (Def_Id));
7861 if Is_Access_Type (Typ) then
7862 Typ := Directly_Designated_Type (Typ);
7865 if Is_Concurrent_Type (Typ)
7866 and then not Is_Generic_Actual_Type (Typ)
7870 -- This case occurs when the concurrent type is declared within
7871 -- a generic unit. As a result the corresponding record has been
7872 -- built and used as the type of the first formal, we just have
7873 -- to retrieve the corresponding concurrent type.
7875 elsif Is_Concurrent_Record_Type (Typ)
7876 and then Present (Corresponding_Concurrent_Type (Typ))
7878 Typ := Corresponding_Concurrent_Type (Typ);
7886 -- There is no overriding to check if is an inherited operation in a
7887 -- type derivation on for a generic actual.
7889 Collect_Interfaces (Typ, Ifaces_List);
7891 if Is_Empty_Elmt_List (Ifaces_List) then
7895 -- Determine whether entry or subprogram Def_Id overrides a primitive
7896 -- operation that belongs to one of the interfaces in Ifaces_List.
7899 Candidate : Entity_Id := Empty;
7900 Hom : Entity_Id := Empty;
7901 Iface_Typ : Entity_Id;
7902 Subp : Entity_Id := Empty;
7905 -- Traverse the homonym chain, looking for a potentially
7906 -- overridden subprogram that belongs to an implemented
7909 Hom := Current_Entity_In_Scope (Def_Id);
7910 while Present (Hom) loop
7914 or else not Is_Overloadable (Subp)
7915 or else not Is_Primitive (Subp)
7916 or else not Is_Dispatching_Operation (Subp)
7917 or else not Present (Find_Dispatching_Type (Subp))
7918 or else not Is_Interface (Find_Dispatching_Type (Subp))
7922 -- Entries and procedures can override abstract or null
7923 -- interface procedures.
7925 elsif (Ekind (Def_Id) = E_Procedure
7926 or else Ekind (Def_Id) = E_Entry)
7927 and then Ekind (Subp) = E_Procedure
7928 and then Matches_Prefixed_View_Profile
7929 (Parameter_Specifications (Parent (Def_Id)),
7930 Parameter_Specifications (Parent (Subp)))
7934 -- For an overridden subprogram Subp, check whether the mode
7935 -- of its first parameter is correct depending on the kind
7936 -- of synchronized type.
7939 Formal : constant Node_Id := First_Formal (Candidate);
7942 -- In order for an entry or a protected procedure to
7943 -- override, the first parameter of the overridden
7944 -- routine must be of mode "out", "in out" or
7945 -- access-to-variable.
7947 if (Ekind (Candidate) = E_Entry
7948 or else Ekind (Candidate) = E_Procedure)
7949 and then Is_Protected_Type (Typ)
7950 and then Ekind (Formal) /= E_In_Out_Parameter
7951 and then Ekind (Formal) /= E_Out_Parameter
7952 and then Nkind (Parameter_Type (Parent (Formal)))
7953 /= N_Access_Definition
7957 -- All other cases are OK since a task entry or routine
7958 -- does not have a restriction on the mode of the first
7959 -- parameter of the overridden interface routine.
7962 Overridden_Subp := Candidate;
7967 -- Functions can override abstract interface functions
7969 elsif Ekind (Def_Id) = E_Function
7970 and then Ekind (Subp) = E_Function
7971 and then Matches_Prefixed_View_Profile
7972 (Parameter_Specifications (Parent (Def_Id)),
7973 Parameter_Specifications (Parent (Subp)))
7974 and then Etype (Result_Definition (Parent (Def_Id))) =
7975 Etype (Result_Definition (Parent (Subp)))
7977 Overridden_Subp := Subp;
7981 Hom := Homonym (Hom);
7984 -- After examining all candidates for overriding, we are left with
7985 -- the best match which is a mode incompatible interface routine.
7986 -- Do not emit an error if the Expander is active since this error
7987 -- will be detected later on after all concurrent types are
7988 -- expanded and all wrappers are built. This check is meant for
7989 -- spec-only compilations.
7991 if Present (Candidate) and then not Expander_Active then
7993 Find_Parameter_Type (Parent (First_Formal (Candidate)));
7995 -- Def_Id is primitive of a protected type, declared inside the
7996 -- type, and the candidate is primitive of a limited or
7997 -- synchronized interface.
8000 and then Is_Protected_Type (Typ)
8002 (Is_Limited_Interface (Iface_Typ)
8003 or else Is_Protected_Interface (Iface_Typ)
8004 or else Is_Synchronized_Interface (Iface_Typ)
8005 or else Is_Task_Interface (Iface_Typ))
8008 ("first formal of & must be of mode `OUT`, `IN OUT`"
8009 & " or access-to-variable", Typ, Candidate);
8011 ("\in order to be overridden by protected procedure or "
8012 & "entry (RM 9.4(11.9/2))", Typ);
8016 Overridden_Subp := Candidate;
8019 end Check_Synchronized_Overriding;
8021 ----------------------------
8022 -- Is_Private_Declaration --
8023 ----------------------------
8025 function Is_Private_Declaration (E : Entity_Id) return Boolean is
8026 Priv_Decls : List_Id;
8027 Decl : constant Node_Id := Unit_Declaration_Node (E);
8030 if Is_Package_Or_Generic_Package (Current_Scope)
8031 and then In_Private_Part (Current_Scope)
8034 Private_Declarations (
8035 Specification (Unit_Declaration_Node (Current_Scope)));
8037 return In_Package_Body (Current_Scope)
8039 (Is_List_Member (Decl)
8040 and then List_Containing (Decl) = Priv_Decls)
8041 or else (Nkind (Parent (Decl)) = N_Package_Specification
8044 (Defining_Entity (Parent (Decl)))
8045 and then List_Containing (Parent (Parent (Decl)))
8050 end Is_Private_Declaration;
8052 --------------------------
8053 -- Is_Overriding_Alias --
8054 --------------------------
8056 function Is_Overriding_Alias
8058 New_E : Entity_Id) return Boolean
8060 AO : constant Entity_Id := Alias (Old_E);
8061 AN : constant Entity_Id := Alias (New_E);
8064 return Scope (AO) /= Scope (AN)
8065 or else No (DTC_Entity (AO))
8066 or else No (DTC_Entity (AN))
8067 or else DT_Position (AO) = DT_Position (AN);
8068 end Is_Overriding_Alias;
8070 -- Start of processing for New_Overloaded_Entity
8073 -- We need to look for an entity that S may override. This must be a
8074 -- homonym in the current scope, so we look for the first homonym of
8075 -- S in the current scope as the starting point for the search.
8077 E := Current_Entity_In_Scope (S);
8079 -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
8080 -- They are directly added to the list of primitive operations of
8081 -- Derived_Type, unless this is a rederivation in the private part
8082 -- of an operation that was already derived in the visible part of
8083 -- the current package.
8085 if Ada_Version >= Ada_2005
8086 and then Present (Derived_Type)
8087 and then Present (Alias (S))
8088 and then Is_Dispatching_Operation (Alias (S))
8089 and then Present (Find_Dispatching_Type (Alias (S)))
8090 and then Is_Interface (Find_Dispatching_Type (Alias (S)))
8092 -- For private types, when the full-view is processed we propagate to
8093 -- the full view the non-overridden entities whose attribute "alias"
8094 -- references an interface primitive. These entities were added by
8095 -- Derive_Subprograms to ensure that interface primitives are
8098 -- Inside_Freeze_Actions is non zero when S corresponds with an
8099 -- internal entity that links an interface primitive with its
8100 -- covering primitive through attribute Interface_Alias (see
8101 -- Add_Internal_Interface_Entities).
8103 if Inside_Freezing_Actions = 0
8104 and then Is_Package_Or_Generic_Package (Current_Scope)
8105 and then In_Private_Part (Current_Scope)
8106 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
8107 and then Nkind (Parent (S)) = N_Full_Type_Declaration
8108 and then Full_View (Defining_Identifier (Parent (E)))
8109 = Defining_Identifier (Parent (S))
8110 and then Alias (E) = Alias (S)
8112 Check_Operation_From_Private_View (S, E);
8113 Set_Is_Dispatching_Operation (S);
8118 Enter_Overloaded_Entity (S);
8119 Check_Dispatching_Operation (S, Empty);
8120 Check_For_Primitive_Subprogram (Is_Primitive_Subp);
8126 -- If there is no homonym then this is definitely not overriding
8129 Enter_Overloaded_Entity (S);
8130 Check_Dispatching_Operation (S, Empty);
8131 Check_For_Primitive_Subprogram (Is_Primitive_Subp);
8133 -- If subprogram has an explicit declaration, check whether it
8134 -- has an overriding indicator.
8136 if Comes_From_Source (S) then
8137 Check_Synchronized_Overriding (S, Overridden_Subp);
8139 -- (Ada 2012: AI05-0125-1): If S is a dispatching operation then
8140 -- it may have overridden some hidden inherited primitive. Update
8141 -- Overridden_Subp to avoid spurious errors when checking the
8142 -- overriding indicator.
8144 if Ada_Version >= Ada_2012
8145 and then No (Overridden_Subp)
8146 and then Is_Dispatching_Operation (S)
8147 and then Present (Overridden_Operation (S))
8149 Overridden_Subp := Overridden_Operation (S);
8152 Check_Overriding_Indicator
8153 (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
8156 -- If there is a homonym that is not overloadable, then we have an
8157 -- error, except for the special cases checked explicitly below.
8159 elsif not Is_Overloadable (E) then
8161 -- Check for spurious conflict produced by a subprogram that has the
8162 -- same name as that of the enclosing generic package. The conflict
8163 -- occurs within an instance, between the subprogram and the renaming
8164 -- declaration for the package. After the subprogram, the package
8165 -- renaming declaration becomes hidden.
8167 if Ekind (E) = E_Package
8168 and then Present (Renamed_Object (E))
8169 and then Renamed_Object (E) = Current_Scope
8170 and then Nkind (Parent (Renamed_Object (E))) =
8171 N_Package_Specification
8172 and then Present (Generic_Parent (Parent (Renamed_Object (E))))
8175 Set_Is_Immediately_Visible (E, False);
8176 Enter_Overloaded_Entity (S);
8177 Set_Homonym (S, Homonym (E));
8178 Check_Dispatching_Operation (S, Empty);
8179 Check_Overriding_Indicator (S, Empty, Is_Primitive => False);
8181 -- If the subprogram is implicit it is hidden by the previous
8182 -- declaration. However if it is dispatching, it must appear in the
8183 -- dispatch table anyway, because it can be dispatched to even if it
8184 -- cannot be called directly.
8186 elsif Present (Alias (S)) and then not Comes_From_Source (S) then
8187 Set_Scope (S, Current_Scope);
8189 if Is_Dispatching_Operation (Alias (S)) then
8190 Check_Dispatching_Operation (S, Empty);
8196 Error_Msg_Sloc := Sloc (E);
8198 -- Generate message, with useful additional warning if in generic
8200 if Is_Generic_Unit (E) then
8201 Error_Msg_N ("previous generic unit cannot be overloaded", S);
8202 Error_Msg_N ("\& conflicts with declaration#", S);
8204 Error_Msg_N ("& conflicts with declaration#", S);
8210 -- E exists and is overloadable
8213 Check_Synchronized_Overriding (S, Overridden_Subp);
8215 -- Loop through E and its homonyms to determine if any of them is
8216 -- the candidate for overriding by S.
8218 while Present (E) loop
8220 -- Definitely not interesting if not in the current scope
8222 if Scope (E) /= Current_Scope then
8225 -- Check if we have type conformance
8227 elsif Type_Conformant (E, S) then
8229 -- If the old and new entities have the same profile and one
8230 -- is not the body of the other, then this is an error, unless
8231 -- one of them is implicitly declared.
8233 -- There are some cases when both can be implicit, for example
8234 -- when both a literal and a function that overrides it are
8235 -- inherited in a derivation, or when an inherited operation
8236 -- of a tagged full type overrides the inherited operation of
8237 -- a private extension. Ada 83 had a special rule for the
8238 -- literal case. In Ada95, the later implicit operation hides
8239 -- the former, and the literal is always the former. In the
8240 -- odd case where both are derived operations declared at the
8241 -- same point, both operations should be declared, and in that
8242 -- case we bypass the following test and proceed to the next
8243 -- part. This can only occur for certain obscure cases in
8244 -- instances, when an operation on a type derived from a formal
8245 -- private type does not override a homograph inherited from
8246 -- the actual. In subsequent derivations of such a type, the
8247 -- DT positions of these operations remain distinct, if they
8250 if Present (Alias (S))
8251 and then (No (Alias (E))
8252 or else Comes_From_Source (E)
8253 or else Is_Abstract_Subprogram (S)
8255 (Is_Dispatching_Operation (E)
8256 and then Is_Overriding_Alias (E, S)))
8257 and then Ekind (E) /= E_Enumeration_Literal
8259 -- When an derived operation is overloaded it may be due to
8260 -- the fact that the full view of a private extension
8261 -- re-inherits. It has to be dealt with.
8263 if Is_Package_Or_Generic_Package (Current_Scope)
8264 and then In_Private_Part (Current_Scope)
8266 Check_Operation_From_Private_View (S, E);
8269 -- In any case the implicit operation remains hidden by the
8270 -- existing declaration, which is overriding. Indicate that
8271 -- E overrides the operation from which S is inherited.
8273 if Present (Alias (S)) then
8274 Set_Overridden_Operation (E, Alias (S));
8276 Set_Overridden_Operation (E, S);
8279 if Comes_From_Source (E) then
8280 Check_Overriding_Indicator (E, S, Is_Primitive => False);
8285 -- Within an instance, the renaming declarations for actual
8286 -- subprograms may become ambiguous, but they do not hide each
8289 elsif Ekind (E) /= E_Entry
8290 and then not Comes_From_Source (E)
8291 and then not Is_Generic_Instance (E)
8292 and then (Present (Alias (E))
8293 or else Is_Intrinsic_Subprogram (E))
8294 and then (not In_Instance
8295 or else No (Parent (E))
8296 or else Nkind (Unit_Declaration_Node (E)) /=
8297 N_Subprogram_Renaming_Declaration)
8299 -- A subprogram child unit is not allowed to override an
8300 -- inherited subprogram (10.1.1(20)).
8302 if Is_Child_Unit (S) then
8304 ("child unit overrides inherited subprogram in parent",
8309 if Is_Non_Overriding_Operation (E, S) then
8310 Enter_Overloaded_Entity (S);
8312 if No (Derived_Type)
8313 or else Is_Tagged_Type (Derived_Type)
8315 Check_Dispatching_Operation (S, Empty);
8321 -- E is a derived operation or an internal operator which
8322 -- is being overridden. Remove E from further visibility.
8323 -- Furthermore, if E is a dispatching operation, it must be
8324 -- replaced in the list of primitive operations of its type
8325 -- (see Override_Dispatching_Operation).
8327 Overridden_Subp := E;
8333 Prev := First_Entity (Current_Scope);
8334 while Present (Prev)
8335 and then Next_Entity (Prev) /= E
8340 -- It is possible for E to be in the current scope and
8341 -- yet not in the entity chain. This can only occur in a
8342 -- generic context where E is an implicit concatenation
8343 -- in the formal part, because in a generic body the
8344 -- entity chain starts with the formals.
8347 (Present (Prev) or else Chars (E) = Name_Op_Concat);
8349 -- E must be removed both from the entity_list of the
8350 -- current scope, and from the visibility chain
8352 if Debug_Flag_E then
8353 Write_Str ("Override implicit operation ");
8354 Write_Int (Int (E));
8358 -- If E is a predefined concatenation, it stands for four
8359 -- different operations. As a result, a single explicit
8360 -- declaration does not hide it. In a possible ambiguous
8361 -- situation, Disambiguate chooses the user-defined op,
8362 -- so it is correct to retain the previous internal one.
8364 if Chars (E) /= Name_Op_Concat
8365 or else Ekind (E) /= E_Operator
8367 -- For nondispatching derived operations that are
8368 -- overridden by a subprogram declared in the private
8369 -- part of a package, we retain the derived subprogram
8370 -- but mark it as not immediately visible. If the
8371 -- derived operation was declared in the visible part
8372 -- then this ensures that it will still be visible
8373 -- outside the package with the proper signature
8374 -- (calls from outside must also be directed to this
8375 -- version rather than the overriding one, unlike the
8376 -- dispatching case). Calls from inside the package
8377 -- will still resolve to the overriding subprogram
8378 -- since the derived one is marked as not visible
8379 -- within the package.
8381 -- If the private operation is dispatching, we achieve
8382 -- the overriding by keeping the implicit operation
8383 -- but setting its alias to be the overriding one. In
8384 -- this fashion the proper body is executed in all
8385 -- cases, but the original signature is used outside
8388 -- If the overriding is not in the private part, we
8389 -- remove the implicit operation altogether.
8391 if Is_Private_Declaration (S) then
8392 if not Is_Dispatching_Operation (E) then
8393 Set_Is_Immediately_Visible (E, False);
8395 -- Work done in Override_Dispatching_Operation,
8396 -- so nothing else need to be done here.
8402 -- Find predecessor of E in Homonym chain
8404 if E = Current_Entity (E) then
8407 Prev_Vis := Current_Entity (E);
8408 while Homonym (Prev_Vis) /= E loop
8409 Prev_Vis := Homonym (Prev_Vis);
8413 if Prev_Vis /= Empty then
8415 -- Skip E in the visibility chain
8417 Set_Homonym (Prev_Vis, Homonym (E));
8420 Set_Name_Entity_Id (Chars (E), Homonym (E));
8423 Set_Next_Entity (Prev, Next_Entity (E));
8425 if No (Next_Entity (Prev)) then
8426 Set_Last_Entity (Current_Scope, Prev);
8431 Enter_Overloaded_Entity (S);
8433 -- For entities generated by Derive_Subprograms the
8434 -- overridden operation is the inherited primitive
8435 -- (which is available through the attribute alias).
8437 if not (Comes_From_Source (E))
8438 and then Is_Dispatching_Operation (E)
8439 and then Find_Dispatching_Type (E) =
8440 Find_Dispatching_Type (S)
8441 and then Present (Alias (E))
8442 and then Comes_From_Source (Alias (E))
8444 Set_Overridden_Operation (S, Alias (E));
8446 -- Normal case of setting entity as overridden
8448 -- Note: Static_Initialization and Overridden_Operation
8449 -- attributes use the same field in subprogram entities.
8450 -- Static_Initialization is only defined for internal
8451 -- initialization procedures, where Overridden_Operation
8452 -- is irrelevant. Therefore the setting of this attribute
8453 -- must check whether the target is an init_proc.
8455 elsif not Is_Init_Proc (S) then
8456 Set_Overridden_Operation (S, E);
8459 Check_Overriding_Indicator (S, E, Is_Primitive => True);
8461 -- If S is a user-defined subprogram or a null procedure
8462 -- expanded to override an inherited null procedure, or a
8463 -- predefined dispatching primitive then indicate that E
8464 -- overrides the operation from which S is inherited.
8466 if Comes_From_Source (S)
8468 (Present (Parent (S))
8470 Nkind (Parent (S)) = N_Procedure_Specification
8472 Null_Present (Parent (S)))
8474 (Present (Alias (E))
8476 Is_Predefined_Dispatching_Operation (Alias (E)))
8478 if Present (Alias (E)) then
8479 Set_Overridden_Operation (S, Alias (E));
8483 if Is_Dispatching_Operation (E) then
8485 -- An overriding dispatching subprogram inherits the
8486 -- convention of the overridden subprogram (AI-117).
8488 Set_Convention (S, Convention (E));
8489 Check_Dispatching_Operation (S, E);
8492 Check_Dispatching_Operation (S, Empty);
8495 Check_For_Primitive_Subprogram
8496 (Is_Primitive_Subp, Is_Overriding => True);
8497 goto Check_Inequality;
8500 -- Apparent redeclarations in instances can occur when two
8501 -- formal types get the same actual type. The subprograms in
8502 -- in the instance are legal, even if not callable from the
8503 -- outside. Calls from within are disambiguated elsewhere.
8504 -- For dispatching operations in the visible part, the usual
8505 -- rules apply, and operations with the same profile are not
8508 elsif (In_Instance_Visible_Part
8509 and then not Is_Dispatching_Operation (E))
8510 or else In_Instance_Not_Visible
8514 -- Here we have a real error (identical profile)
8517 Error_Msg_Sloc := Sloc (E);
8519 -- Avoid cascaded errors if the entity appears in
8520 -- subsequent calls.
8522 Set_Scope (S, Current_Scope);
8524 -- Generate error, with extra useful warning for the case
8525 -- of a generic instance with no completion.
8527 if Is_Generic_Instance (S)
8528 and then not Has_Completion (E)
8531 ("instantiation cannot provide body for&", S);
8532 Error_Msg_N ("\& conflicts with declaration#", S);
8534 Error_Msg_N ("& conflicts with declaration#", S);
8541 -- If one subprogram has an access parameter and the other
8542 -- a parameter of an access type, calls to either might be
8543 -- ambiguous. Verify that parameters match except for the
8544 -- access parameter.
8546 if May_Hide_Profile then
8552 F1 := First_Formal (S);
8553 F2 := First_Formal (E);
8554 while Present (F1) and then Present (F2) loop
8555 if Is_Access_Type (Etype (F1)) then
8556 if not Is_Access_Type (Etype (F2))
8557 or else not Conforming_Types
8558 (Designated_Type (Etype (F1)),
8559 Designated_Type (Etype (F2)),
8562 May_Hide_Profile := False;
8566 not Conforming_Types
8567 (Etype (F1), Etype (F2), Type_Conformant)
8569 May_Hide_Profile := False;
8580 Error_Msg_NE ("calls to& may be ambiguous?", S, S);
8589 -- On exit, we know that S is a new entity
8591 Enter_Overloaded_Entity (S);
8592 Check_For_Primitive_Subprogram (Is_Primitive_Subp);
8593 Check_Overriding_Indicator
8594 (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
8596 -- Overloading is not allowed in SPARK
8598 Error_Msg_Sloc := Sloc (Homonym (S));
8599 Check_SPARK_Restriction ("overloading not allowed with entity#", S);
8601 -- If S is a derived operation for an untagged type then by
8602 -- definition it's not a dispatching operation (even if the parent
8603 -- operation was dispatching), so we don't call
8604 -- Check_Dispatching_Operation in that case.
8606 if No (Derived_Type)
8607 or else Is_Tagged_Type (Derived_Type)
8609 Check_Dispatching_Operation (S, Empty);
8613 -- If this is a user-defined equality operator that is not a derived
8614 -- subprogram, create the corresponding inequality. If the operation is
8615 -- dispatching, the expansion is done elsewhere, and we do not create
8616 -- an explicit inequality operation.
8618 <<Check_Inequality>>
8619 if Chars (S) = Name_Op_Eq
8620 and then Etype (S) = Standard_Boolean
8621 and then Present (Parent (S))
8622 and then not Is_Dispatching_Operation (S)
8624 Make_Inequality_Operator (S);
8626 if Ada_Version >= Ada_2012 then
8627 Check_Untagged_Equality (S);
8630 end New_Overloaded_Entity;
8632 ---------------------
8633 -- Process_Formals --
8634 ---------------------
8636 procedure Process_Formals
8638 Related_Nod : Node_Id)
8640 Param_Spec : Node_Id;
8642 Formal_Type : Entity_Id;
8646 Num_Out_Params : Nat := 0;
8647 First_Out_Param : Entity_Id := Empty;
8648 -- Used for setting Is_Only_Out_Parameter
8650 function Designates_From_With_Type (Typ : Entity_Id) return Boolean;
8651 -- Determine whether an access type designates a type coming from a
8654 function Is_Class_Wide_Default (D : Node_Id) return Boolean;
8655 -- Check whether the default has a class-wide type. After analysis the
8656 -- default has the type of the formal, so we must also check explicitly
8657 -- for an access attribute.
8659 -------------------------------
8660 -- Designates_From_With_Type --
8661 -------------------------------
8663 function Designates_From_With_Type (Typ : Entity_Id) return Boolean is
8664 Desig : Entity_Id := Typ;
8667 if Is_Access_Type (Desig) then
8668 Desig := Directly_Designated_Type (Desig);
8671 if Is_Class_Wide_Type (Desig) then
8672 Desig := Root_Type (Desig);
8676 Ekind (Desig) = E_Incomplete_Type
8677 and then From_With_Type (Desig);
8678 end Designates_From_With_Type;
8680 ---------------------------
8681 -- Is_Class_Wide_Default --
8682 ---------------------------
8684 function Is_Class_Wide_Default (D : Node_Id) return Boolean is
8686 return Is_Class_Wide_Type (Designated_Type (Etype (D)))
8687 or else (Nkind (D) = N_Attribute_Reference
8688 and then Attribute_Name (D) = Name_Access
8689 and then Is_Class_Wide_Type (Etype (Prefix (D))));
8690 end Is_Class_Wide_Default;
8692 -- Start of processing for Process_Formals
8695 -- In order to prevent premature use of the formals in the same formal
8696 -- part, the Ekind is left undefined until all default expressions are
8697 -- analyzed. The Ekind is established in a separate loop at the end.
8699 Param_Spec := First (T);
8700 while Present (Param_Spec) loop
8701 Formal := Defining_Identifier (Param_Spec);
8702 Set_Never_Set_In_Source (Formal, True);
8703 Enter_Name (Formal);
8705 -- Case of ordinary parameters
8707 if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
8708 Find_Type (Parameter_Type (Param_Spec));
8709 Ptype := Parameter_Type (Param_Spec);
8711 if Ptype = Error then
8715 Formal_Type := Entity (Ptype);
8717 if Is_Incomplete_Type (Formal_Type)
8719 (Is_Class_Wide_Type (Formal_Type)
8720 and then Is_Incomplete_Type (Root_Type (Formal_Type)))
8722 -- Ada 2005 (AI-326): Tagged incomplete types allowed in
8723 -- primitive operations, as long as their completion is
8724 -- in the same declarative part. If in the private part
8725 -- this means that the type cannot be a Taft-amendment type.
8726 -- Check is done on package exit. For access to subprograms,
8727 -- the use is legal for Taft-amendment types.
8729 if Is_Tagged_Type (Formal_Type) then
8730 if Ekind (Scope (Current_Scope)) = E_Package
8731 and then not From_With_Type (Formal_Type)
8732 and then not Is_Class_Wide_Type (Formal_Type)
8735 (Parent (T), N_Access_Function_Definition,
8736 N_Access_Procedure_Definition)
8740 Private_Dependents (Base_Type (Formal_Type)));
8742 -- Freezing is delayed to ensure that Register_Prim
8743 -- will get called for this operation, which is needed
8744 -- in cases where static dispatch tables aren't built.
8745 -- (Note that the same is done for controlling access
8746 -- parameter cases in function Access_Definition.)
8748 Set_Has_Delayed_Freeze (Current_Scope);
8752 -- Special handling of Value_Type for CIL case
8754 elsif Is_Value_Type (Formal_Type) then
8757 elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
8758 N_Access_Procedure_Definition)
8761 -- AI05-0151: Tagged incomplete types are allowed in all
8762 -- formal parts. Untagged incomplete types are not allowed
8765 if Ada_Version >= Ada_2012 then
8766 if Is_Tagged_Type (Formal_Type) then
8769 elsif Nkind_In (Parent (Parent (T)), N_Accept_Statement,
8774 ("invalid use of untagged incomplete type&",
8775 Ptype, Formal_Type);
8780 ("invalid use of incomplete type&",
8781 Param_Spec, Formal_Type);
8783 -- Further checks on the legality of incomplete types
8784 -- in formal parts are delayed until the freeze point
8785 -- of the enclosing subprogram or access to subprogram.
8789 elsif Ekind (Formal_Type) = E_Void then
8791 ("premature use of&",
8792 Parameter_Type (Param_Spec), Formal_Type);
8795 -- Ada 2005 (AI-231): Create and decorate an internal subtype
8796 -- declaration corresponding to the null-excluding type of the
8797 -- formal in the enclosing scope. Finally, replace the parameter
8798 -- type of the formal with the internal subtype.
8800 if Ada_Version >= Ada_2005
8801 and then Null_Exclusion_Present (Param_Spec)
8803 if not Is_Access_Type (Formal_Type) then
8805 ("`NOT NULL` allowed only for an access type", Param_Spec);
8808 if Can_Never_Be_Null (Formal_Type)
8809 and then Comes_From_Source (Related_Nod)
8812 ("`NOT NULL` not allowed (& already excludes null)",
8813 Param_Spec, Formal_Type);
8817 Create_Null_Excluding_Itype
8819 Related_Nod => Related_Nod,
8820 Scope_Id => Scope (Current_Scope));
8822 -- If the designated type of the itype is an itype we
8823 -- decorate it with the Has_Delayed_Freeze attribute to
8824 -- avoid problems with the backend.
8827 -- type T is access procedure;
8828 -- procedure Op (O : not null T);
8830 if Is_Itype (Directly_Designated_Type (Formal_Type)) then
8831 Set_Has_Delayed_Freeze (Formal_Type);
8836 -- An access formal type
8840 Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
8842 -- No need to continue if we already notified errors
8844 if not Present (Formal_Type) then
8848 -- Ada 2005 (AI-254)
8851 AD : constant Node_Id :=
8852 Access_To_Subprogram_Definition
8853 (Parameter_Type (Param_Spec));
8855 if Present (AD) and then Protected_Present (AD) then
8857 Replace_Anonymous_Access_To_Protected_Subprogram
8863 Set_Etype (Formal, Formal_Type);
8865 -- If the type of a subprogram's formal parameter is not in ALFA,
8866 -- then the subprogram is not in ALFA.
8868 if Nkind (Parent (First (T))) in N_Subprogram_Specification
8869 and then not Is_In_ALFA (Formal_Type)
8871 Set_Is_In_ALFA (Defining_Entity (Parent (First (T))), False);
8874 Default := Expression (Param_Spec);
8876 if Present (Default) then
8877 Check_SPARK_Restriction
8878 ("default expression is not allowed", Default);
8880 if Out_Present (Param_Spec) then
8882 ("default initialization only allowed for IN parameters",
8886 -- Do the special preanalysis of the expression (see section on
8887 -- "Handling of Default Expressions" in the spec of package Sem).
8889 Preanalyze_Spec_Expression (Default, Formal_Type);
8891 -- An access to constant cannot be the default for
8892 -- an access parameter that is an access to variable.
8894 if Ekind (Formal_Type) = E_Anonymous_Access_Type
8895 and then not Is_Access_Constant (Formal_Type)
8896 and then Is_Access_Type (Etype (Default))
8897 and then Is_Access_Constant (Etype (Default))
8900 ("formal that is access to variable cannot be initialized " &
8901 "with an access-to-constant expression", Default);
8904 -- Check that the designated type of an access parameter's default
8905 -- is not a class-wide type unless the parameter's designated type
8906 -- is also class-wide.
8908 if Ekind (Formal_Type) = E_Anonymous_Access_Type
8909 and then not Designates_From_With_Type (Formal_Type)
8910 and then Is_Class_Wide_Default (Default)
8911 and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
8914 ("access to class-wide expression not allowed here", Default);
8917 -- Check incorrect use of dynamically tagged expressions
8919 if Is_Tagged_Type (Formal_Type) then
8920 Check_Dynamically_Tagged_Expression
8923 Related_Nod => Default);
8927 -- Ada 2005 (AI-231): Static checks
8929 if Ada_Version >= Ada_2005
8930 and then Is_Access_Type (Etype (Formal))
8931 and then Can_Never_Be_Null (Etype (Formal))
8933 Null_Exclusion_Static_Checks (Param_Spec);
8940 -- If this is the formal part of a function specification, analyze the
8941 -- subtype mark in the context where the formals are visible but not
8942 -- yet usable, and may hide outer homographs.
8944 if Nkind (Related_Nod) = N_Function_Specification then
8945 Analyze_Return_Type (Related_Nod);
8948 -- Now set the kind (mode) of each formal
8950 Param_Spec := First (T);
8951 while Present (Param_Spec) loop
8952 Formal := Defining_Identifier (Param_Spec);
8953 Set_Formal_Mode (Formal);
8955 if Ekind (Formal) = E_In_Parameter then
8956 Set_Default_Value (Formal, Expression (Param_Spec));
8958 if Present (Expression (Param_Spec)) then
8959 Default := Expression (Param_Spec);
8961 if Is_Scalar_Type (Etype (Default)) then
8963 (Parameter_Type (Param_Spec)) /= N_Access_Definition
8965 Formal_Type := Entity (Parameter_Type (Param_Spec));
8968 Formal_Type := Access_Definition
8969 (Related_Nod, Parameter_Type (Param_Spec));
8972 Apply_Scalar_Range_Check (Default, Formal_Type);
8976 elsif Ekind (Formal) = E_Out_Parameter then
8977 Num_Out_Params := Num_Out_Params + 1;
8979 if Num_Out_Params = 1 then
8980 First_Out_Param := Formal;
8983 elsif Ekind (Formal) = E_In_Out_Parameter then
8984 Num_Out_Params := Num_Out_Params + 1;
8990 if Present (First_Out_Param) and then Num_Out_Params = 1 then
8991 Set_Is_Only_Out_Parameter (First_Out_Param);
8993 end Process_Formals;
8999 procedure Process_PPCs
9001 Spec_Id : Entity_Id;
9002 Body_Id : Entity_Id)
9004 Loc : constant Source_Ptr := Sloc (N);
9008 Designator : Entity_Id;
9009 -- Subprogram designator, set from Spec_Id if present, else Body_Id
9011 Precond : Node_Id := Empty;
9012 -- Set non-Empty if we prepend precondition to the declarations. This
9013 -- is used to hook up inherited preconditions (adding the condition
9014 -- expression with OR ELSE, and adding the message).
9016 Inherited_Precond : Node_Id;
9017 -- Precondition inherited from parent subprogram
9019 Inherited : constant Subprogram_List :=
9020 Inherited_Subprograms (Spec_Id);
9021 -- List of subprograms inherited by this subprogram
9023 Plist : List_Id := No_List;
9024 -- List of generated postconditions
9026 function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id;
9027 -- Prag contains an analyzed precondition or postcondition pragma. This
9028 -- function copies the pragma, changes it to the corresponding Check
9029 -- pragma and returns the Check pragma as the result. If Pspec is non-
9030 -- empty, this is the case of inheriting a PPC, where we must change
9031 -- references to parameters of the inherited subprogram to point to the
9032 -- corresponding parameters of the current subprogram.
9034 function Invariants_Or_Predicates_Present return Boolean;
9035 -- Determines if any invariants or predicates are present for any OUT
9036 -- or IN OUT parameters of the subprogram, or (for a function) if the
9037 -- return value has an invariant.
9043 function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id is
9044 Nam : constant Name_Id := Pragma_Name (Prag);
9049 -- Prepare map if this is the case where we have to map entities of
9050 -- arguments in the overridden subprogram to corresponding entities
9051 -- of the current subprogram.
9062 Map := New_Elmt_List;
9063 PF := First_Formal (Pspec);
9064 CF := First_Formal (Designator);
9065 while Present (PF) loop
9066 Append_Elmt (PF, Map);
9067 Append_Elmt (CF, Map);
9074 -- Now we can copy the tree, doing any required substitutions
9076 CP := New_Copy_Tree (Prag, Map => Map, New_Scope => Current_Scope);
9078 -- Set Analyzed to false, since we want to reanalyze the check
9079 -- procedure. Note that it is only at the outer level that we
9080 -- do this fiddling, for the spec cases, the already preanalyzed
9081 -- parameters are not affected.
9083 Set_Analyzed (CP, False);
9085 -- We also make sure Comes_From_Source is False for the copy
9087 Set_Comes_From_Source (CP, False);
9089 -- For a postcondition pragma within a generic, preserve the pragma
9090 -- for later expansion.
9092 if Nam = Name_Postcondition
9093 and then not Expander_Active
9098 -- Change copy of pragma into corresponding pragma Check
9100 Prepend_To (Pragma_Argument_Associations (CP),
9101 Make_Pragma_Argument_Association (Sloc (Prag),
9102 Expression => Make_Identifier (Loc, Nam)));
9103 Set_Pragma_Identifier (CP, Make_Identifier (Sloc (Prag), Name_Check));
9105 -- If this is inherited case and the current message starts with
9106 -- "failed p", we change it to "failed inherited p...".
9108 if Present (Pspec) then
9110 Msg : constant Node_Id :=
9111 Last (Pragma_Argument_Associations (CP));
9114 if Chars (Msg) = Name_Message then
9115 String_To_Name_Buffer (Strval (Expression (Msg)));
9117 if Name_Buffer (1 .. 8) = "failed p" then
9118 Insert_Str_In_Name_Buffer ("inherited ", 8);
9120 (Expression (Last (Pragma_Argument_Associations (CP))),
9121 String_From_Name_Buffer);
9127 -- Return the check pragma
9132 --------------------------------------
9133 -- Invariants_Or_Predicates_Present --
9134 --------------------------------------
9136 function Invariants_Or_Predicates_Present return Boolean is
9140 -- Check function return result
9142 if Ekind (Designator) /= E_Procedure
9143 and then Has_Invariants (Etype (Designator))
9150 Formal := First_Formal (Designator);
9151 while Present (Formal) loop
9152 if Ekind (Formal) /= E_In_Parameter
9154 (Has_Invariants (Etype (Formal))
9155 or else Present (Predicate_Function (Etype (Formal))))
9160 Next_Formal (Formal);
9164 end Invariants_Or_Predicates_Present;
9166 -- Start of processing for Process_PPCs
9169 -- Capture designator from spec if present, else from body
9171 if Present (Spec_Id) then
9172 Designator := Spec_Id;
9174 Designator := Body_Id;
9177 -- Grab preconditions from spec
9179 if Present (Spec_Id) then
9181 -- Loop through PPC pragmas from spec. Note that preconditions from
9182 -- the body will be analyzed and converted when we scan the body
9183 -- declarations below.
9185 Prag := Spec_PPC_List (Spec_Id);
9186 while Present (Prag) loop
9187 if Pragma_Name (Prag) = Name_Precondition then
9189 -- For Pre (or Precondition pragma), we simply prepend the
9190 -- pragma to the list of declarations right away so that it
9191 -- will be executed at the start of the procedure. Note that
9192 -- this processing reverses the order of the list, which is
9193 -- what we want since new entries were chained to the head of
9194 -- the list. There can be more then one precondition when we
9195 -- use pragma Precondition
9197 if not Class_Present (Prag) then
9198 Prepend (Grab_PPC, Declarations (N));
9200 -- For Pre'Class there can only be one pragma, and we save
9201 -- it in Precond for now. We will add inherited Pre'Class
9202 -- stuff before inserting this pragma in the declarations.
9204 Precond := Grab_PPC;
9208 Prag := Next_Pragma (Prag);
9211 -- Now deal with inherited preconditions
9213 for J in Inherited'Range loop
9214 Prag := Spec_PPC_List (Inherited (J));
9216 while Present (Prag) loop
9217 if Pragma_Name (Prag) = Name_Precondition
9218 and then Class_Present (Prag)
9220 Inherited_Precond := Grab_PPC (Inherited (J));
9222 -- No precondition so far, so establish this as the first
9224 if No (Precond) then
9225 Precond := Inherited_Precond;
9227 -- Here we already have a precondition, add inherited one
9230 -- Add new precondition to old one using OR ELSE
9233 New_Expr : constant Node_Id :=
9237 (Pragma_Argument_Associations
9238 (Inherited_Precond))));
9239 Old_Expr : constant Node_Id :=
9243 (Pragma_Argument_Associations
9247 if Paren_Count (Old_Expr) = 0 then
9248 Set_Paren_Count (Old_Expr, 1);
9251 if Paren_Count (New_Expr) = 0 then
9252 Set_Paren_Count (New_Expr, 1);
9256 Make_Or_Else (Sloc (Old_Expr),
9257 Left_Opnd => Relocate_Node (Old_Expr),
9258 Right_Opnd => New_Expr));
9261 -- Add new message in the form:
9263 -- failed precondition from bla
9264 -- also failed inherited precondition from bla
9267 -- Skip this if exception locations are suppressed
9269 if not Exception_Locations_Suppressed then
9271 New_Msg : constant Node_Id :=
9274 (Pragma_Argument_Associations
9275 (Inherited_Precond)));
9276 Old_Msg : constant Node_Id :=
9279 (Pragma_Argument_Associations
9282 Start_String (Strval (Old_Msg));
9283 Store_String_Chars (ASCII.LF & " also ");
9284 Store_String_Chars (Strval (New_Msg));
9285 Set_Strval (Old_Msg, End_String);
9291 Prag := Next_Pragma (Prag);
9295 -- If we have built a precondition for Pre'Class (including any
9296 -- Pre'Class aspects inherited from parent subprograms), then we
9297 -- insert this composite precondition at this stage.
9299 if Present (Precond) then
9300 Prepend (Precond, Declarations (N));
9304 -- Build postconditions procedure if needed and prepend the following
9305 -- declaration to the start of the declarations for the subprogram.
9307 -- procedure _postconditions [(_Result : resulttype)] is
9309 -- pragma Check (Postcondition, condition [,message]);
9310 -- pragma Check (Postcondition, condition [,message]);
9312 -- Invariant_Procedure (_Result) ...
9313 -- Invariant_Procedure (Arg1)
9317 -- First we deal with the postconditions in the body
9319 if Is_Non_Empty_List (Declarations (N)) then
9321 -- Loop through declarations
9323 Prag := First (Declarations (N));
9324 while Present (Prag) loop
9325 if Nkind (Prag) = N_Pragma then
9327 -- If pragma, capture if enabled postcondition, else ignore
9329 if Pragma_Name (Prag) = Name_Postcondition
9330 and then Check_Enabled (Name_Postcondition)
9332 if Plist = No_List then
9333 Plist := Empty_List;
9338 -- If expansion is disabled, as in a generic unit, save
9339 -- pragma for later expansion.
9341 if not Expander_Active then
9342 Prepend (Grab_PPC, Declarations (N));
9344 Append (Grab_PPC, Plist);
9350 -- Not a pragma, if comes from source, then end scan
9352 elsif Comes_From_Source (Prag) then
9355 -- Skip stuff not coming from source
9363 -- Now deal with any postconditions from the spec
9365 if Present (Spec_Id) then
9366 Spec_Postconditions : declare
9367 procedure Process_Post_Conditions
9370 -- This processes the Spec_PPC_List from Spec, processing any
9371 -- postconditions from the list. If Class is True, then only
9372 -- postconditions marked with Class_Present are considered.
9373 -- The caller has checked that Spec_PPC_List is non-Empty.
9375 -----------------------------
9376 -- Process_Post_Conditions --
9377 -----------------------------
9379 procedure Process_Post_Conditions
9392 -- Loop through PPC pragmas from spec
9394 Prag := Spec_PPC_List (Spec);
9396 if Pragma_Name (Prag) = Name_Postcondition
9397 and then (not Class or else Class_Present (Prag))
9399 if Plist = No_List then
9400 Plist := Empty_List;
9403 if not Expander_Active then
9405 (Grab_PPC (Pspec), Declarations (N));
9407 Append (Grab_PPC (Pspec), Plist);
9411 Prag := Next_Pragma (Prag);
9412 exit when No (Prag);
9414 end Process_Post_Conditions;
9416 -- Start of processing for Spec_Postconditions
9419 if Present (Spec_PPC_List (Spec_Id)) then
9420 Process_Post_Conditions (Spec_Id, Class => False);
9423 -- Process inherited postconditions
9425 for J in Inherited'Range loop
9426 if Present (Spec_PPC_List (Inherited (J))) then
9427 Process_Post_Conditions (Inherited (J), Class => True);
9430 end Spec_Postconditions;
9433 -- If we had any postconditions and expansion is enabled, or if the
9434 -- procedure has invariants, then build the _Postconditions procedure.
9436 if (Present (Plist) or else Invariants_Or_Predicates_Present)
9437 and then Expander_Active
9440 Plist := Empty_List;
9443 -- Special processing for function case
9445 if Ekind (Designator) /= E_Procedure then
9447 Rent : constant Entity_Id :=
9448 Make_Defining_Identifier (Loc,
9449 Chars => Name_uResult);
9450 Ftyp : constant Entity_Id := Etype (Designator);
9453 Set_Etype (Rent, Ftyp);
9455 -- Add argument for return
9459 Make_Parameter_Specification (Loc,
9460 Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
9461 Defining_Identifier => Rent));
9463 -- Add invariant call if returning type with invariants
9465 if Has_Invariants (Etype (Rent))
9466 and then Present (Invariant_Procedure (Etype (Rent)))
9469 Make_Invariant_Call (New_Occurrence_Of (Rent, Loc)));
9473 -- Procedure rather than a function
9479 -- Add invariant calls and predicate calls for parameters. Note that
9480 -- this is done for functions as well, since in Ada 2012 they can
9481 -- have IN OUT args.
9488 Formal := First_Formal (Designator);
9489 while Present (Formal) loop
9490 if Ekind (Formal) /= E_In_Parameter then
9491 Ftype := Etype (Formal);
9493 if Has_Invariants (Ftype)
9494 and then Present (Invariant_Procedure (Ftype))
9498 (New_Occurrence_Of (Formal, Loc)));
9501 if Present (Predicate_Function (Ftype)) then
9503 Make_Predicate_Check
9504 (Ftype, New_Occurrence_Of (Formal, Loc)));
9508 Next_Formal (Formal);
9512 -- Build and insert postcondition procedure
9515 Post_Proc : constant Entity_Id :=
9516 Make_Defining_Identifier (Loc,
9517 Chars => Name_uPostconditions);
9518 -- The entity for the _Postconditions procedure
9521 Prepend_To (Declarations (N),
9522 Make_Subprogram_Body (Loc,
9524 Make_Procedure_Specification (Loc,
9525 Defining_Unit_Name => Post_Proc,
9526 Parameter_Specifications => Parms),
9528 Declarations => Empty_List,
9530 Handled_Statement_Sequence =>
9531 Make_Handled_Sequence_Of_Statements (Loc,
9532 Statements => Plist)));
9534 -- If this is a procedure, set the Postcondition_Proc attribute on
9535 -- the proper defining entity for the subprogram.
9537 if Ekind (Designator) = E_Procedure then
9538 Set_Postcondition_Proc (Designator, Post_Proc);
9542 Set_Has_Postconditions (Designator);
9546 ----------------------------
9547 -- Reference_Body_Formals --
9548 ----------------------------
9550 procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is
9555 if Error_Posted (Spec) then
9559 -- Iterate over both lists. They may be of different lengths if the two
9560 -- specs are not conformant.
9562 Fs := First_Formal (Spec);
9563 Fb := First_Formal (Bod);
9564 while Present (Fs) and then Present (Fb) loop
9565 Generate_Reference (Fs, Fb, 'b');
9568 Style.Check_Identifier (Fb, Fs);
9571 Set_Spec_Entity (Fb, Fs);
9572 Set_Referenced (Fs, False);
9576 end Reference_Body_Formals;
9578 -------------------------
9579 -- Set_Actual_Subtypes --
9580 -------------------------
9582 procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
9586 First_Stmt : Node_Id := Empty;
9587 AS_Needed : Boolean;
9590 -- If this is an empty initialization procedure, no need to create
9591 -- actual subtypes (small optimization).
9593 if Ekind (Subp) = E_Procedure
9594 and then Is_Null_Init_Proc (Subp)
9599 Formal := First_Formal (Subp);
9600 while Present (Formal) loop
9601 T := Etype (Formal);
9603 -- We never need an actual subtype for a constrained formal
9605 if Is_Constrained (T) then
9608 -- If we have unknown discriminants, then we do not need an actual
9609 -- subtype, or more accurately we cannot figure it out! Note that
9610 -- all class-wide types have unknown discriminants.
9612 elsif Has_Unknown_Discriminants (T) then
9615 -- At this stage we have an unconstrained type that may need an
9616 -- actual subtype. For sure the actual subtype is needed if we have
9617 -- an unconstrained array type.
9619 elsif Is_Array_Type (T) then
9622 -- The only other case needing an actual subtype is an unconstrained
9623 -- record type which is an IN parameter (we cannot generate actual
9624 -- subtypes for the OUT or IN OUT case, since an assignment can
9625 -- change the discriminant values. However we exclude the case of
9626 -- initialization procedures, since discriminants are handled very
9627 -- specially in this context, see the section entitled "Handling of
9628 -- Discriminants" in Einfo.
9630 -- We also exclude the case of Discrim_SO_Functions (functions used
9631 -- in front end layout mode for size/offset values), since in such
9632 -- functions only discriminants are referenced, and not only are such
9633 -- subtypes not needed, but they cannot always be generated, because
9634 -- of order of elaboration issues.
9636 elsif Is_Record_Type (T)
9637 and then Ekind (Formal) = E_In_Parameter
9638 and then Chars (Formal) /= Name_uInit
9639 and then not Is_Unchecked_Union (T)
9640 and then not Is_Discrim_SO_Function (Subp)
9644 -- All other cases do not need an actual subtype
9650 -- Generate actual subtypes for unconstrained arrays and
9651 -- unconstrained discriminated records.
9654 if Nkind (N) = N_Accept_Statement then
9656 -- If expansion is active, The formal is replaced by a local
9657 -- variable that renames the corresponding entry of the
9658 -- parameter block, and it is this local variable that may
9659 -- require an actual subtype.
9661 if Expander_Active then
9662 Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
9664 Decl := Build_Actual_Subtype (T, Formal);
9667 if Present (Handled_Statement_Sequence (N)) then
9669 First (Statements (Handled_Statement_Sequence (N)));
9670 Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
9671 Mark_Rewrite_Insertion (Decl);
9673 -- If the accept statement has no body, there will be no
9674 -- reference to the actuals, so no need to compute actual
9681 Decl := Build_Actual_Subtype (T, Formal);
9682 Prepend (Decl, Declarations (N));
9683 Mark_Rewrite_Insertion (Decl);
9686 -- The declaration uses the bounds of an existing object, and
9687 -- therefore needs no constraint checks.
9689 Analyze (Decl, Suppress => All_Checks);
9691 -- We need to freeze manually the generated type when it is
9692 -- inserted anywhere else than in a declarative part.
9694 if Present (First_Stmt) then
9695 Insert_List_Before_And_Analyze (First_Stmt,
9696 Freeze_Entity (Defining_Identifier (Decl), N));
9699 if Nkind (N) = N_Accept_Statement
9700 and then Expander_Active
9702 Set_Actual_Subtype (Renamed_Object (Formal),
9703 Defining_Identifier (Decl));
9705 Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
9709 Next_Formal (Formal);
9711 end Set_Actual_Subtypes;
9713 ---------------------
9714 -- Set_Formal_Mode --
9715 ---------------------
9717 procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
9718 Spec : constant Node_Id := Parent (Formal_Id);
9721 -- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
9722 -- since we ensure that corresponding actuals are always valid at the
9723 -- point of the call.
9725 if Out_Present (Spec) then
9726 if Ekind (Scope (Formal_Id)) = E_Function
9727 or else Ekind (Scope (Formal_Id)) = E_Generic_Function
9729 -- [IN] OUT parameters allowed for functions in Ada 2012
9731 if Ada_Version >= Ada_2012 then
9732 if In_Present (Spec) then
9733 Set_Ekind (Formal_Id, E_In_Out_Parameter);
9735 Set_Ekind (Formal_Id, E_Out_Parameter);
9738 -- But not in earlier versions of Ada
9741 Error_Msg_N ("functions can only have IN parameters", Spec);
9742 Set_Ekind (Formal_Id, E_In_Parameter);
9745 elsif In_Present (Spec) then
9746 Set_Ekind (Formal_Id, E_In_Out_Parameter);
9749 Set_Ekind (Formal_Id, E_Out_Parameter);
9750 Set_Never_Set_In_Source (Formal_Id, True);
9751 Set_Is_True_Constant (Formal_Id, False);
9752 Set_Current_Value (Formal_Id, Empty);
9756 Set_Ekind (Formal_Id, E_In_Parameter);
9759 -- Set Is_Known_Non_Null for access parameters since the language
9760 -- guarantees that access parameters are always non-null. We also set
9761 -- Can_Never_Be_Null, since there is no way to change the value.
9763 if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
9765 -- Ada 2005 (AI-231): In Ada95, access parameters are always non-
9766 -- null; In Ada 2005, only if then null_exclusion is explicit.
9768 if Ada_Version < Ada_2005
9769 or else Can_Never_Be_Null (Etype (Formal_Id))
9771 Set_Is_Known_Non_Null (Formal_Id);
9772 Set_Can_Never_Be_Null (Formal_Id);
9775 -- Ada 2005 (AI-231): Null-exclusion access subtype
9777 elsif Is_Access_Type (Etype (Formal_Id))
9778 and then Can_Never_Be_Null (Etype (Formal_Id))
9780 Set_Is_Known_Non_Null (Formal_Id);
9783 Set_Mechanism (Formal_Id, Default_Mechanism);
9784 Set_Formal_Validity (Formal_Id);
9785 end Set_Formal_Mode;
9787 -------------------------
9788 -- Set_Formal_Validity --
9789 -------------------------
9791 procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
9793 -- If no validity checking, then we cannot assume anything about the
9794 -- validity of parameters, since we do not know there is any checking
9795 -- of the validity on the call side.
9797 if not Validity_Checks_On then
9800 -- If validity checking for parameters is enabled, this means we are
9801 -- not supposed to make any assumptions about argument values.
9803 elsif Validity_Check_Parameters then
9806 -- If we are checking in parameters, we will assume that the caller is
9807 -- also checking parameters, so we can assume the parameter is valid.
9809 elsif Ekind (Formal_Id) = E_In_Parameter
9810 and then Validity_Check_In_Params
9812 Set_Is_Known_Valid (Formal_Id, True);
9814 -- Similar treatment for IN OUT parameters
9816 elsif Ekind (Formal_Id) = E_In_Out_Parameter
9817 and then Validity_Check_In_Out_Params
9819 Set_Is_Known_Valid (Formal_Id, True);
9821 end Set_Formal_Validity;
9823 ------------------------
9824 -- Subtype_Conformant --
9825 ------------------------
9827 function Subtype_Conformant
9828 (New_Id : Entity_Id;
9830 Skip_Controlling_Formals : Boolean := False) return Boolean
9834 Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result,
9835 Skip_Controlling_Formals => Skip_Controlling_Formals);
9837 end Subtype_Conformant;
9839 ---------------------
9840 -- Type_Conformant --
9841 ---------------------
9843 function Type_Conformant
9844 (New_Id : Entity_Id;
9846 Skip_Controlling_Formals : Boolean := False) return Boolean
9850 May_Hide_Profile := False;
9853 (New_Id, Old_Id, Type_Conformant, False, Result,
9854 Skip_Controlling_Formals => Skip_Controlling_Formals);
9856 end Type_Conformant;
9858 -------------------------------
9859 -- Valid_Operator_Definition --
9860 -------------------------------
9862 procedure Valid_Operator_Definition (Designator : Entity_Id) is
9865 Id : constant Name_Id := Chars (Designator);
9869 F := First_Formal (Designator);
9870 while Present (F) loop
9873 if Present (Default_Value (F)) then
9875 ("default values not allowed for operator parameters",
9882 -- Verify that user-defined operators have proper number of arguments
9883 -- First case of operators which can only be unary
9886 or else Id = Name_Op_Abs
9890 -- Case of operators which can be unary or binary
9892 elsif Id = Name_Op_Add
9893 or Id = Name_Op_Subtract
9895 N_OK := (N in 1 .. 2);
9897 -- All other operators can only be binary
9905 ("incorrect number of arguments for operator", Designator);
9909 and then Base_Type (Etype (Designator)) = Standard_Boolean
9910 and then not Is_Intrinsic_Subprogram (Designator)
9913 ("explicit definition of inequality not allowed", Designator);
9915 end Valid_Operator_Definition;