OSDN Git Service

gcc/ada/
[pf3gnuchains/gcc-fork.git] / gcc / ada / sem_ch6.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                              S E M _ C H 6                               --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
10 --                                                                          --
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.          --
20 --                                                                          --
21 -- GNAT was originally developed  by the GNAT team at  New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
23 --                                                                          --
24 ------------------------------------------------------------------------------
25
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_Tss;  use Exp_Tss;
37 with Exp_Util; use Exp_Util;
38 with Fname;    use Fname;
39 with Freeze;   use Freeze;
40 with Itypes;   use Itypes;
41 with Lib.Xref; use Lib.Xref;
42 with Layout;   use Layout;
43 with Namet;    use Namet;
44 with Lib;      use Lib;
45 with Nlists;   use Nlists;
46 with Nmake;    use Nmake;
47 with Opt;      use Opt;
48 with Output;   use Output;
49 with Rtsfind;  use Rtsfind;
50 with Sem;      use Sem;
51 with Sem_Cat;  use Sem_Cat;
52 with Sem_Ch3;  use Sem_Ch3;
53 with Sem_Ch4;  use Sem_Ch4;
54 with Sem_Ch5;  use Sem_Ch5;
55 with Sem_Ch8;  use Sem_Ch8;
56 with Sem_Ch10; use Sem_Ch10;
57 with Sem_Ch12; use Sem_Ch12;
58 with Sem_Disp; use Sem_Disp;
59 with Sem_Dist; use Sem_Dist;
60 with Sem_Elim; use Sem_Elim;
61 with Sem_Eval; use Sem_Eval;
62 with Sem_Mech; use Sem_Mech;
63 with Sem_Prag; use Sem_Prag;
64 with Sem_Res;  use Sem_Res;
65 with Sem_Util; use Sem_Util;
66 with Sem_Type; use Sem_Type;
67 with Sem_Warn; use Sem_Warn;
68 with Sinput;   use Sinput;
69 with Stand;    use Stand;
70 with Sinfo;    use Sinfo;
71 with Sinfo.CN; use Sinfo.CN;
72 with Snames;   use Snames;
73 with Stringt;  use Stringt;
74 with Style;
75 with Stylesw;  use Stylesw;
76 with Tbuild;   use Tbuild;
77 with Uintp;    use Uintp;
78 with Urealp;   use Urealp;
79 with Validsw;  use Validsw;
80
81 package body Sem_Ch6 is
82
83    May_Hide_Profile : Boolean := False;
84    --  This flag is used to indicate that two formals in two subprograms being
85    --  checked for conformance differ only in that one is an access parameter
86    --  while the other is of a general access type with the same designated
87    --  type. In this case, if the rest of the signatures match, a call to
88    --  either subprogram may be ambiguous, which is worth a warning. The flag
89    --  is set in Compatible_Types, and the warning emitted in
90    --  New_Overloaded_Entity.
91
92    -----------------------
93    -- Local Subprograms --
94    -----------------------
95
96    procedure Analyze_Return_Statement (N : Node_Id);
97    --  Common processing for simple_ and extended_return_statements
98
99    procedure Analyze_Function_Return (N : Node_Id);
100    --  Subsidiary to Analyze_Return_Statement. Called when the return statement
101    --  applies to a [generic] function.
102
103    procedure Analyze_Return_Type (N : Node_Id);
104    --  Subsidiary to Process_Formals: analyze subtype mark in function
105    --  specification, in a context where the formals are visible and hide
106    --  outer homographs.
107
108    procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
109    --  Analyze a generic subprogram body. N is the body to be analyzed, and
110    --  Gen_Id is the defining entity Id for the corresponding spec.
111
112    procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
113    --  If a subprogram has pragma Inline and inlining is active, use generic
114    --  machinery to build an unexpanded body for the subprogram. This body is
115    --  subsequenty used for inline expansions at call sites. If subprogram can
116    --  be inlined (depending on size and nature of local declarations) this
117    --  function returns true. Otherwise subprogram body is treated normally.
118    --  If proper warnings are enabled and the subprogram contains a construct
119    --  that cannot be inlined, the offending construct is flagged accordingly.
120
121    procedure Check_Conformance
122      (New_Id                   : Entity_Id;
123       Old_Id                   : Entity_Id;
124       Ctype                    : Conformance_Type;
125       Errmsg                   : Boolean;
126       Conforms                 : out Boolean;
127       Err_Loc                  : Node_Id := Empty;
128       Get_Inst                 : Boolean := False;
129       Skip_Controlling_Formals : Boolean := False);
130    --  Given two entities, this procedure checks that the profiles associated
131    --  with these entities meet the conformance criterion given by the third
132    --  parameter. If they conform, Conforms is set True and control returns
133    --  to the caller. If they do not conform, Conforms is set to False, and
134    --  in addition, if Errmsg is True on the call, proper messages are output
135    --  to complain about the conformance failure. If Err_Loc is non_Empty
136    --  the error messages are placed on Err_Loc, if Err_Loc is empty, then
137    --  error messages are placed on the appropriate part of the construct
138    --  denoted by New_Id. If Get_Inst is true, then this is a mode conformance
139    --  against a formal access-to-subprogram type so Get_Instance_Of must
140    --  be called.
141
142    procedure Check_Subprogram_Order (N : Node_Id);
143    --  N is the N_Subprogram_Body node for a subprogram. This routine applies
144    --  the alpha ordering rule for N if this ordering requirement applicable.
145
146    procedure Check_Returns
147      (HSS  : Node_Id;
148       Mode : Character;
149       Err  : out Boolean;
150       Proc : Entity_Id := Empty);
151    --  Called to check for missing return statements in a function body, or for
152    --  returns present in a procedure body which has No_Return set. HSS is the
153    --  handled statement sequence for the subprogram body. This procedure
154    --  checks all flow paths to make sure they either have return (Mode = 'F',
155    --  used for functions) or do not have a return (Mode = 'P', used for
156    --  No_Return procedures). The flag Err is set if there are any control
157    --  paths not explicitly terminated by a return in the function case, and is
158    --  True otherwise. Proc is the entity for the procedure case and is used
159    --  in posting the warning message.
160
161    procedure Enter_Overloaded_Entity (S : Entity_Id);
162    --  This procedure makes S, a new overloaded entity, into the first visible
163    --  entity with that name.
164
165    procedure Install_Entity (E : Entity_Id);
166    --  Make single entity visible. Used for generic formals as well
167
168    function Is_Non_Overriding_Operation
169      (Prev_E : Entity_Id;
170       New_E  : Entity_Id) return Boolean;
171    --  Enforce the rule given in 12.3(18): a private operation in an instance
172    --  overrides an inherited operation only if the corresponding operation
173    --  was overriding in the generic. This can happen for primitive operations
174    --  of types derived (in the generic unit) from formal private or formal
175    --  derived types.
176
177    procedure Make_Inequality_Operator (S : Entity_Id);
178    --  Create the declaration for an inequality operator that is implicitly
179    --  created by a user-defined equality operator that yields a boolean.
180
181    procedure May_Need_Actuals (Fun : Entity_Id);
182    --  Flag functions that can be called without parameters, i.e. those that
183    --  have no parameters, or those for which defaults exist for all parameters
184
185    procedure Process_PPCs
186      (N       : Node_Id;
187       Spec_Id : Entity_Id;
188       Body_Id : Entity_Id);
189    --  Called from Analyze_Body to deal with scanning post conditions for the
190    --  body and assembling and inserting the _postconditions procedure. N is
191    --  the node for the subprogram body and Body_Id/Spec_Id are the entities
192    --  for the body and separate spec (if there is no separate spec, Spec_Id
193    --  is Empty).
194
195    procedure Set_Formal_Validity (Formal_Id : Entity_Id);
196    --  Formal_Id is an formal parameter entity. This procedure deals with
197    --  setting the proper validity status for this entity, which depends
198    --  on the kind of parameter and the validity checking mode.
199
200    ------------------------------
201    -- Analyze_Return_Statement --
202    ------------------------------
203
204    procedure Analyze_Return_Statement (N : Node_Id) is
205
206       pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
207                                   N_Extended_Return_Statement));
208
209       Returns_Object : constant Boolean :=
210                          Nkind (N) = N_Extended_Return_Statement
211                            or else
212                             (Nkind (N) = N_Simple_Return_Statement
213                               and then Present (Expression (N)));
214       --  True if we're returning something; that is, "return <expression>;"
215       --  or "return Result : T [:= ...]". False for "return;". Used for error
216       --  checking: If Returns_Object is True, N should apply to a function
217       --  body; otherwise N should apply to a procedure body, entry body,
218       --  accept statement, or extended return statement.
219
220       function Find_What_It_Applies_To return Entity_Id;
221       --  Find the entity representing the innermost enclosing body, accept
222       --  statement, or extended return statement. If the result is a callable
223       --  construct or extended return statement, then this will be the value
224       --  of the Return_Applies_To attribute. Otherwise, the program is
225       --  illegal. See RM-6.5(4/2).
226
227       -----------------------------
228       -- Find_What_It_Applies_To --
229       -----------------------------
230
231       function Find_What_It_Applies_To return Entity_Id is
232          Result : Entity_Id := Empty;
233
234       begin
235          --  Loop outward through the Scope_Stack, skipping blocks and loops
236
237          for J in reverse 0 .. Scope_Stack.Last loop
238             Result := Scope_Stack.Table (J).Entity;
239             exit when Ekind (Result) /= E_Block and then
240                       Ekind (Result) /= E_Loop;
241          end loop;
242
243          pragma Assert (Present (Result));
244          return Result;
245       end Find_What_It_Applies_To;
246
247       --  Local declarations
248
249       Scope_Id   : constant Entity_Id   := Find_What_It_Applies_To;
250       Kind       : constant Entity_Kind := Ekind (Scope_Id);
251       Loc        : constant Source_Ptr  := Sloc (N);
252       Stm_Entity : constant Entity_Id   :=
253                      New_Internal_Entity
254                        (E_Return_Statement, Current_Scope, Loc, 'R');
255
256    --  Start of processing for Analyze_Return_Statement
257
258    begin
259       Set_Return_Statement_Entity (N, Stm_Entity);
260
261       Set_Etype (Stm_Entity, Standard_Void_Type);
262       Set_Return_Applies_To (Stm_Entity, Scope_Id);
263
264       --  Place Return entity on scope stack, to simplify enforcement of 6.5
265       --  (4/2): an inner return statement will apply to this extended return.
266
267       if Nkind (N) = N_Extended_Return_Statement then
268          Push_Scope (Stm_Entity);
269       end if;
270
271       --  Check that pragma No_Return is obeyed
272
273       if No_Return (Scope_Id) then
274          Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
275       end if;
276
277       --  Warn on any unassigned OUT parameters if in procedure
278
279       if Ekind (Scope_Id) = E_Procedure then
280          Warn_On_Unassigned_Out_Parameter (N, Scope_Id);
281       end if;
282
283       --  Check that functions return objects, and other things do not
284
285       if Kind = E_Function or else Kind = E_Generic_Function then
286          if not Returns_Object then
287             Error_Msg_N ("missing expression in return from function", N);
288          end if;
289
290       elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
291          if Returns_Object then
292             Error_Msg_N ("procedure cannot return value (use function)", N);
293          end if;
294
295       elsif Kind = E_Entry or else Kind = E_Entry_Family then
296          if Returns_Object then
297             if Is_Protected_Type (Scope (Scope_Id)) then
298                Error_Msg_N ("entry body cannot return value", N);
299             else
300                Error_Msg_N ("accept statement cannot return value", N);
301             end if;
302          end if;
303
304       elsif Kind = E_Return_Statement then
305
306          --  We are nested within another return statement, which must be an
307          --  extended_return_statement.
308
309          if Returns_Object then
310             Error_Msg_N
311               ("extended_return_statement cannot return value; " &
312                "use `""RETURN;""`", N);
313          end if;
314
315       else
316          Error_Msg_N ("illegal context for return statement", N);
317       end if;
318
319       if Kind = E_Function or else Kind = E_Generic_Function then
320          Analyze_Function_Return (N);
321       end if;
322
323       if Nkind (N) = N_Extended_Return_Statement then
324          End_Scope;
325       end if;
326
327       Kill_Current_Values (Last_Assignment_Only => True);
328       Check_Unreachable_Code (N);
329    end Analyze_Return_Statement;
330
331    ---------------------------------------------
332    -- Analyze_Abstract_Subprogram_Declaration --
333    ---------------------------------------------
334
335    procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
336       Designator : constant Entity_Id :=
337                      Analyze_Subprogram_Specification (Specification (N));
338       Scop       : constant Entity_Id := Current_Scope;
339
340    begin
341       Generate_Definition (Designator);
342       Set_Is_Abstract_Subprogram (Designator);
343       New_Overloaded_Entity (Designator);
344       Check_Delayed_Subprogram (Designator);
345
346       Set_Categorization_From_Scope (Designator, Scop);
347
348       if Ekind (Scope (Designator)) = E_Protected_Type then
349          Error_Msg_N
350            ("abstract subprogram not allowed in protected type", N);
351
352       --  Issue a warning if the abstract subprogram is neither a dispatching
353       --  operation nor an operation that overrides an inherited subprogram or
354       --  predefined operator, since this most likely indicates a mistake.
355
356       elsif Warn_On_Redundant_Constructs
357         and then not Is_Dispatching_Operation (Designator)
358         and then not Is_Overriding_Operation (Designator)
359         and then (not Is_Operator_Symbol_Name (Chars (Designator))
360                    or else Scop /= Scope (Etype (First_Formal (Designator))))
361       then
362          Error_Msg_N
363            ("?abstract subprogram is not dispatching or overriding", N);
364       end if;
365
366       Generate_Reference_To_Formals (Designator);
367    end Analyze_Abstract_Subprogram_Declaration;
368
369    ----------------------------------------
370    -- Analyze_Extended_Return_Statement  --
371    ----------------------------------------
372
373    procedure Analyze_Extended_Return_Statement (N : Node_Id) is
374    begin
375       Analyze_Return_Statement (N);
376    end Analyze_Extended_Return_Statement;
377
378    ----------------------------
379    -- Analyze_Function_Call  --
380    ----------------------------
381
382    procedure Analyze_Function_Call (N : Node_Id) is
383       P      : constant Node_Id := Name (N);
384       L      : constant List_Id := Parameter_Associations (N);
385       Actual : Node_Id;
386
387    begin
388       Analyze (P);
389
390       --  A call of the form A.B (X) may be an Ada05 call, which is rewritten
391       --  as B (A, X). If the rewriting is successful, the call has been
392       --  analyzed and we just return.
393
394       if Nkind (P) = N_Selected_Component
395         and then Name (N) /= P
396         and then Is_Rewrite_Substitution (N)
397         and then Present (Etype (N))
398       then
399          return;
400       end if;
401
402       --  If error analyzing name, then set Any_Type as result type and return
403
404       if Etype (P) = Any_Type then
405          Set_Etype (N, Any_Type);
406          return;
407       end if;
408
409       --  Otherwise analyze the parameters
410
411       if Present (L) then
412          Actual := First (L);
413          while Present (Actual) loop
414             Analyze (Actual);
415             Check_Parameterless_Call (Actual);
416             Next (Actual);
417          end loop;
418       end if;
419
420       Analyze_Call (N);
421    end Analyze_Function_Call;
422
423    -----------------------------
424    -- Analyze_Function_Return --
425    -----------------------------
426
427    procedure Analyze_Function_Return (N : Node_Id) is
428       Loc        : constant Source_Ptr  := Sloc (N);
429       Stm_Entity : constant Entity_Id   := Return_Statement_Entity (N);
430       Scope_Id   : constant Entity_Id   := Return_Applies_To (Stm_Entity);
431
432       R_Type : constant Entity_Id := Etype (Scope_Id);
433       --  Function result subtype
434
435       procedure Check_Limited_Return (Expr : Node_Id);
436       --  Check the appropriate (Ada 95 or Ada 2005) rules for returning
437       --  limited types. Used only for simple return statements.
438       --  Expr is the expression returned.
439
440       procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
441       --  Check that the return_subtype_indication properly matches the result
442       --  subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
443
444       --------------------------
445       -- Check_Limited_Return --
446       --------------------------
447
448       procedure Check_Limited_Return (Expr : Node_Id) is
449       begin
450          --  Ada 2005 (AI-318-02): Return-by-reference types have been
451          --  removed and replaced by anonymous access results. This is an
452          --  incompatibility with Ada 95. Not clear whether this should be
453          --  enforced yet or perhaps controllable with special switch. ???
454
455          if Is_Limited_Type (R_Type)
456            and then Comes_From_Source (N)
457            and then not In_Instance_Body
458            and then not OK_For_Limited_Init_In_05 (Expr)
459          then
460             --  Error in Ada 2005
461
462             if Ada_Version >= Ada_05
463               and then not Debug_Flag_Dot_L
464               and then not GNAT_Mode
465             then
466                Error_Msg_N
467                  ("(Ada 2005) cannot copy object of a limited type " &
468                   "(RM-2005 6.5(5.5/2))", Expr);
469                if Is_Inherently_Limited_Type (R_Type) then
470                   Error_Msg_N
471                     ("\return by reference not permitted in Ada 2005", Expr);
472                end if;
473
474             --  Warn in Ada 95 mode, to give folks a heads up about this
475             --  incompatibility.
476
477             --  In GNAT mode, this is just a warning, to allow it to be
478             --  evilly turned off. Otherwise it is a real error.
479
480             elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
481                if Is_Inherently_Limited_Type (R_Type) then
482                   Error_Msg_N
483                     ("return by reference not permitted in Ada 2005 " &
484                      "(RM-2005 6.5(5.5/2))?", Expr);
485                else
486                   Error_Msg_N
487                     ("cannot copy object of a limited type in Ada 2005 " &
488                      "(RM-2005 6.5(5.5/2))?", Expr);
489                end if;
490
491             --  Ada 95 mode, compatibility warnings disabled
492
493             else
494                return; --  skip continuation messages below
495             end if;
496
497             Error_Msg_N
498               ("\consider switching to return of access type", Expr);
499             Explain_Limited_Type (R_Type, Expr);
500          end if;
501       end Check_Limited_Return;
502
503       -------------------------------------
504       -- Check_Return_Subtype_Indication --
505       -------------------------------------
506
507       procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is
508          Return_Obj  : constant Node_Id   := Defining_Identifier (Obj_Decl);
509          R_Stm_Type  : constant Entity_Id := Etype (Return_Obj);
510          --  Subtype given in the extended return statement;
511          --  this must match R_Type.
512
513          Subtype_Ind : constant Node_Id :=
514                          Object_Definition (Original_Node (Obj_Decl));
515
516          R_Type_Is_Anon_Access :
517            constant Boolean :=
518              Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
519                or else
520              Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
521                or else
522              Ekind (R_Type) = E_Anonymous_Access_Type;
523          --  True if return type of the function is an anonymous access type
524          --  Can't we make Is_Anonymous_Access_Type in einfo ???
525
526          R_Stm_Type_Is_Anon_Access :
527            constant Boolean :=
528              Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type
529                or else
530              Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type
531                or else
532              Ekind (R_Stm_Type) = E_Anonymous_Access_Type;
533          --  True if type of the return object is an anonymous access type
534
535       begin
536          --  First, avoid cascade errors:
537
538          if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then
539             return;
540          end if;
541
542          --  "return access T" case; check that the return statement also has
543          --  "access T", and that the subtypes statically match:
544
545          if R_Type_Is_Anon_Access then
546             if R_Stm_Type_Is_Anon_Access then
547                if Base_Type (Designated_Type (R_Stm_Type)) /=
548                     Base_Type (Designated_Type (R_Type))
549                  or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
550                then
551                   Error_Msg_N
552                     ("subtype must statically match function result subtype",
553                      Subtype_Mark (Subtype_Ind));
554                end if;
555
556             else
557                Error_Msg_N ("must use anonymous access type", Subtype_Ind);
558             end if;
559
560          --  Subtype_indication case; check that the types are the same, and
561          --  statically match if appropriate. A null exclusion may be present
562          --  on the return type, on the function specification, on the object
563          --  declaration or on the subtype itself.
564
565          elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) then
566             if Is_Access_Type (R_Type)
567               and then
568                (Can_Never_Be_Null (R_Type)
569                  or else Null_Exclusion_Present (Parent (Scope_Id))) /=
570                                               Can_Never_Be_Null (R_Stm_Type)
571             then
572                Error_Msg_N
573                  ("subtype must statically match function result subtype",
574                   Subtype_Ind);
575             end if;
576
577             if Is_Constrained (R_Type) then
578                if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
579                   Error_Msg_N
580                     ("subtype must statically match function result subtype",
581                      Subtype_Ind);
582                end if;
583             end if;
584
585          --  If the function's result type doesn't match the return object
586          --  entity's type, then we check for the case where the result type
587          --  is class-wide, and allow the declaration if the type of the object
588          --  definition matches the class-wide type. This prevents rejection
589          --  in the case where the object declaration is initialized by a call
590          --  to a build-in-place function with a specific result type and the
591          --  object entity had its type changed to that specific type. (Note
592          --  that the ARG believes that return objects should be allowed to
593          --  have a type covered by a class-wide result type in any case, so
594          --  once that relaxation is made (see AI05-32), the above check for
595          --  type compatibility should be changed to test Covers rather than
596          --  equality, and then the following special test will no longer be
597          --  needed. ???)
598
599          elsif Is_Class_Wide_Type (R_Type)
600            and then
601              R_Type = Etype (Object_Definition (Original_Node (Obj_Decl)))
602          then
603             null;
604
605          else
606             Error_Msg_N
607               ("wrong type for return_subtype_indication", Subtype_Ind);
608          end if;
609       end Check_Return_Subtype_Indication;
610
611       ---------------------
612       -- Local Variables --
613       ---------------------
614
615       Expr : Node_Id;
616
617    --  Start of processing for Analyze_Function_Return
618
619    begin
620       Set_Return_Present (Scope_Id);
621
622       if Nkind (N) = N_Simple_Return_Statement then
623          Expr := Expression (N);
624          Analyze_And_Resolve (Expr, R_Type);
625          Check_Limited_Return (Expr);
626
627       else
628          --  Analyze parts specific to extended_return_statement:
629
630          declare
631             Obj_Decl : constant Node_Id :=
632                          Last (Return_Object_Declarations (N));
633
634             HSS : constant Node_Id := Handled_Statement_Sequence (N);
635
636          begin
637             Expr := Expression (Obj_Decl);
638
639             --  Note: The check for OK_For_Limited_Init will happen in
640             --  Analyze_Object_Declaration; we treat it as a normal
641             --  object declaration.
642
643             Analyze (Obj_Decl);
644
645             Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
646             Check_Return_Subtype_Indication (Obj_Decl);
647
648             if Present (HSS) then
649                Analyze (HSS);
650
651                if Present (Exception_Handlers (HSS)) then
652
653                   --  ???Has_Nested_Block_With_Handler needs to be set.
654                   --  Probably by creating an actual N_Block_Statement.
655                   --  Probably in Expand.
656
657                   null;
658                end if;
659             end if;
660
661             Check_References (Stm_Entity);
662          end;
663       end if;
664
665       --  Case of Expr present
666
667       if Present (Expr)
668
669          --  Defend against previous errors
670
671         and then Nkind (Expr) /= N_Empty
672         and then Present (Etype (Expr))
673       then
674          --  Apply constraint check. Note that this is done before the implicit
675          --  conversion of the expression done for anonymous access types to
676          --  ensure correct generation of the null-excluding check asssociated
677          --  with null-excluding expressions found in return statements.
678
679          Apply_Constraint_Check (Expr, R_Type);
680
681          --  Ada 2005 (AI-318-02): When the result type is an anonymous access
682          --  type, apply an implicit conversion of the expression to that type
683          --  to force appropriate static and run-time accessibility checks.
684
685          if Ada_Version >= Ada_05
686            and then Ekind (R_Type) = E_Anonymous_Access_Type
687          then
688             Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
689             Analyze_And_Resolve (Expr, R_Type);
690          end if;
691
692          --  If the result type is class-wide, then check that the return
693          --  expression's type is not declared at a deeper level than the
694          --  function (RM05-6.5(5.6/2)).
695
696          if Ada_Version >= Ada_05
697            and then Is_Class_Wide_Type (R_Type)
698          then
699             if Type_Access_Level (Etype (Expr)) >
700                  Subprogram_Access_Level (Scope_Id)
701             then
702                Error_Msg_N
703                  ("level of return expression type is deeper than " &
704                   "class-wide function!", Expr);
705             end if;
706          end if;
707
708          if (Is_Class_Wide_Type (Etype (Expr))
709               or else Is_Dynamically_Tagged (Expr))
710            and then not Is_Class_Wide_Type (R_Type)
711          then
712             Error_Msg_N
713               ("dynamically tagged expression not allowed!", Expr);
714          end if;
715
716          --  ??? A real run-time accessibility check is needed in cases
717          --  involving dereferences of access parameters. For now we just
718          --  check the static cases.
719
720          if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L)
721            and then Is_Inherently_Limited_Type (Etype (Scope_Id))
722            and then Object_Access_Level (Expr) >
723                       Subprogram_Access_Level (Scope_Id)
724          then
725             Rewrite (N,
726               Make_Raise_Program_Error (Loc,
727                 Reason => PE_Accessibility_Check_Failed));
728             Analyze (N);
729
730             Error_Msg_N
731               ("cannot return a local value by reference?", N);
732             Error_Msg_NE
733               ("\& will be raised at run time?",
734                N, Standard_Program_Error);
735          end if;
736
737          if Known_Null (Expr)
738            and then Nkind (Parent (Scope_Id)) = N_Function_Specification
739            and then Null_Exclusion_Present (Parent (Scope_Id))
740          then
741             Apply_Compile_Time_Constraint_Error
742               (N      => Expr,
743                Msg    => "(Ada 2005) null not allowed for "
744                          & "null-excluding return?",
745                Reason => CE_Null_Not_Allowed);
746          end if;
747       end if;
748    end Analyze_Function_Return;
749
750    -------------------------------------
751    -- Analyze_Generic_Subprogram_Body --
752    -------------------------------------
753
754    procedure Analyze_Generic_Subprogram_Body
755      (N      : Node_Id;
756       Gen_Id : Entity_Id)
757    is
758       Gen_Decl : constant Node_Id     := Unit_Declaration_Node (Gen_Id);
759       Kind     : constant Entity_Kind := Ekind (Gen_Id);
760       Body_Id  : Entity_Id;
761       New_N    : Node_Id;
762       Spec     : Node_Id;
763
764    begin
765       --  Copy body and disable expansion while analyzing the generic For a
766       --  stub, do not copy the stub (which would load the proper body), this
767       --  will be done when the proper body is analyzed.
768
769       if Nkind (N) /= N_Subprogram_Body_Stub then
770          New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
771          Rewrite (N, New_N);
772          Start_Generic;
773       end if;
774
775       Spec := Specification (N);
776
777       --  Within the body of the generic, the subprogram is callable, and
778       --  behaves like the corresponding non-generic unit.
779
780       Body_Id := Defining_Entity (Spec);
781
782       if Kind = E_Generic_Procedure
783         and then Nkind (Spec) /= N_Procedure_Specification
784       then
785          Error_Msg_N ("invalid body for generic procedure ", Body_Id);
786          return;
787
788       elsif Kind = E_Generic_Function
789         and then Nkind (Spec) /= N_Function_Specification
790       then
791          Error_Msg_N ("invalid body for generic function ", Body_Id);
792          return;
793       end if;
794
795       Set_Corresponding_Body (Gen_Decl, Body_Id);
796
797       if Has_Completion (Gen_Id)
798         and then Nkind (Parent (N)) /= N_Subunit
799       then
800          Error_Msg_N ("duplicate generic body", N);
801          return;
802       else
803          Set_Has_Completion (Gen_Id);
804       end if;
805
806       if Nkind (N) = N_Subprogram_Body_Stub then
807          Set_Ekind (Defining_Entity (Specification (N)), Kind);
808       else
809          Set_Corresponding_Spec (N, Gen_Id);
810       end if;
811
812       if Nkind (Parent (N)) = N_Compilation_Unit then
813          Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
814       end if;
815
816       --  Make generic parameters immediately visible in the body. They are
817       --  needed to process the formals declarations. Then make the formals
818       --  visible in a separate step.
819
820       Push_Scope (Gen_Id);
821
822       declare
823          E         : Entity_Id;
824          First_Ent : Entity_Id;
825
826       begin
827          First_Ent := First_Entity (Gen_Id);
828
829          E := First_Ent;
830          while Present (E) and then not Is_Formal (E) loop
831             Install_Entity (E);
832             Next_Entity (E);
833          end loop;
834
835          Set_Use (Generic_Formal_Declarations (Gen_Decl));
836
837          --  Now generic formals are visible, and the specification can be
838          --  analyzed, for subsequent conformance check.
839
840          Body_Id := Analyze_Subprogram_Specification (Spec);
841
842          --  Make formal parameters visible
843
844          if Present (E) then
845
846             --  E is the first formal parameter, we loop through the formals
847             --  installing them so that they will be visible.
848
849             Set_First_Entity (Gen_Id, E);
850             while Present (E) loop
851                Install_Entity (E);
852                Next_Formal (E);
853             end loop;
854          end if;
855
856          --  Visible generic entity is callable within its own body
857
858          Set_Ekind          (Gen_Id,  Ekind (Body_Id));
859          Set_Ekind          (Body_Id, E_Subprogram_Body);
860          Set_Convention     (Body_Id, Convention (Gen_Id));
861          Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
862          Set_Scope          (Body_Id, Scope (Gen_Id));
863          Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
864
865          if Nkind (N) = N_Subprogram_Body_Stub then
866
867             --  No body to analyze, so restore state of generic unit
868
869             Set_Ekind (Gen_Id, Kind);
870             Set_Ekind (Body_Id, Kind);
871
872             if Present (First_Ent) then
873                Set_First_Entity (Gen_Id, First_Ent);
874             end if;
875
876             End_Scope;
877             return;
878          end if;
879
880          --  If this is a compilation unit, it must be made visible explicitly,
881          --  because the compilation of the declaration, unlike other library
882          --  unit declarations, does not. If it is not a unit, the following
883          --  is redundant but harmless.
884
885          Set_Is_Immediately_Visible (Gen_Id);
886          Reference_Body_Formals (Gen_Id, Body_Id);
887
888          if Is_Child_Unit (Gen_Id) then
889             Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False);
890          end if;
891
892          Set_Actual_Subtypes (N, Current_Scope);
893          Analyze_Declarations (Declarations (N));
894          Check_Completion;
895          Analyze (Handled_Statement_Sequence (N));
896
897          Save_Global_References (Original_Node (N));
898
899          --  Prior to exiting the scope, include generic formals again (if any
900          --  are present) in the set of local entities.
901
902          if Present (First_Ent) then
903             Set_First_Entity (Gen_Id, First_Ent);
904          end if;
905
906          Check_References (Gen_Id);
907       end;
908
909       Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
910       End_Scope;
911       Check_Subprogram_Order (N);
912
913       --  Outside of its body, unit is generic again
914
915       Set_Ekind (Gen_Id, Kind);
916       Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
917
918       if Style_Check then
919          Style.Check_Identifier (Body_Id, Gen_Id);
920       end if;
921       End_Generic;
922    end Analyze_Generic_Subprogram_Body;
923
924    -----------------------------
925    -- Analyze_Operator_Symbol --
926    -----------------------------
927
928    --  An operator symbol such as "+" or "and" may appear in context where the
929    --  literal denotes an entity name, such as "+"(x, y) or in context when it
930    --  is just a string, as in (conjunction = "or"). In these cases the parser
931    --  generates this node, and the semantics does the disambiguation. Other
932    --  such case are actuals in an instantiation, the generic unit in an
933    --  instantiation, and pragma arguments.
934
935    procedure Analyze_Operator_Symbol (N : Node_Id) is
936       Par : constant Node_Id := Parent (N);
937
938    begin
939       if        (Nkind (Par) = N_Function_Call
940                    and then N = Name (Par))
941         or else  Nkind (Par) = N_Function_Instantiation
942         or else (Nkind (Par) = N_Indexed_Component
943                    and then N = Prefix (Par))
944         or else (Nkind (Par) = N_Pragma_Argument_Association
945                    and then not Is_Pragma_String_Literal (Par))
946         or else  Nkind (Par) = N_Subprogram_Renaming_Declaration
947         or else (Nkind (Par) = N_Attribute_Reference
948                   and then Attribute_Name (Par) /= Name_Value)
949       then
950          Find_Direct_Name (N);
951
952       else
953          Change_Operator_Symbol_To_String_Literal (N);
954          Analyze (N);
955       end if;
956    end Analyze_Operator_Symbol;
957
958    -----------------------------------
959    -- Analyze_Parameter_Association --
960    -----------------------------------
961
962    procedure Analyze_Parameter_Association (N : Node_Id) is
963    begin
964       Analyze (Explicit_Actual_Parameter (N));
965    end Analyze_Parameter_Association;
966
967    ----------------------------
968    -- Analyze_Procedure_Call --
969    ----------------------------
970
971    procedure Analyze_Procedure_Call (N : Node_Id) is
972       Loc     : constant Source_Ptr := Sloc (N);
973       P       : constant Node_Id    := Name (N);
974       Actuals : constant List_Id    := Parameter_Associations (N);
975       Actual  : Node_Id;
976       New_N   : Node_Id;
977
978       procedure Analyze_Call_And_Resolve;
979       --  Do Analyze and Resolve calls for procedure call
980
981       ------------------------------
982       -- Analyze_Call_And_Resolve --
983       ------------------------------
984
985       procedure Analyze_Call_And_Resolve is
986       begin
987          if Nkind (N) = N_Procedure_Call_Statement then
988             Analyze_Call (N);
989             Resolve (N, Standard_Void_Type);
990          else
991             Analyze (N);
992          end if;
993       end Analyze_Call_And_Resolve;
994
995    --  Start of processing for Analyze_Procedure_Call
996
997    begin
998       --  The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
999       --  a procedure call or an entry call. The prefix may denote an access
1000       --  to subprogram type, in which case an implicit dereference applies.
1001       --  If the prefix is an indexed component (without implicit defererence)
1002       --  then the construct denotes a call to a member of an entire family.
1003       --  If the prefix is a simple name, it may still denote a call to a
1004       --  parameterless member of an entry family. Resolution of these various
1005       --  interpretations is delicate.
1006
1007       Analyze (P);
1008
1009       --  If this is a call of the form Obj.Op, the call may have been
1010       --  analyzed and possibly rewritten into a block, in which case
1011       --  we are done.
1012
1013       if Analyzed (N) then
1014          return;
1015       end if;
1016
1017       --  If error analyzing prefix, then set Any_Type as result and return
1018
1019       if Etype (P) = Any_Type then
1020          Set_Etype (N, Any_Type);
1021          return;
1022       end if;
1023
1024       --  Otherwise analyze the parameters
1025
1026       if Present (Actuals) then
1027          Actual := First (Actuals);
1028
1029          while Present (Actual) loop
1030             Analyze (Actual);
1031             Check_Parameterless_Call (Actual);
1032             Next (Actual);
1033          end loop;
1034       end if;
1035
1036       --  Special processing for Elab_Spec and Elab_Body calls
1037
1038       if Nkind (P) = N_Attribute_Reference
1039         and then (Attribute_Name (P) = Name_Elab_Spec
1040                    or else Attribute_Name (P) = Name_Elab_Body)
1041       then
1042          if Present (Actuals) then
1043             Error_Msg_N
1044               ("no parameters allowed for this call", First (Actuals));
1045             return;
1046          end if;
1047
1048          Set_Etype (N, Standard_Void_Type);
1049          Set_Analyzed (N);
1050
1051       elsif Is_Entity_Name (P)
1052         and then Is_Record_Type (Etype (Entity (P)))
1053         and then Remote_AST_I_Dereference (P)
1054       then
1055          return;
1056
1057       elsif Is_Entity_Name (P)
1058         and then Ekind (Entity (P)) /= E_Entry_Family
1059       then
1060          if Is_Access_Type (Etype (P))
1061            and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1062            and then No (Actuals)
1063            and then Comes_From_Source (N)
1064          then
1065             Error_Msg_N ("missing explicit dereference in call", N);
1066          end if;
1067
1068          Analyze_Call_And_Resolve;
1069
1070       --  If the prefix is the simple name of an entry family, this is
1071       --  a parameterless call from within the task body itself.
1072
1073       elsif Is_Entity_Name (P)
1074         and then Nkind (P) = N_Identifier
1075         and then Ekind (Entity (P)) = E_Entry_Family
1076         and then Present (Actuals)
1077         and then No (Next (First (Actuals)))
1078       then
1079          --  Can be call to parameterless entry family. What appears to be the
1080          --  sole argument is in fact the entry index. Rewrite prefix of node
1081          --  accordingly. Source representation is unchanged by this
1082          --  transformation.
1083
1084          New_N :=
1085            Make_Indexed_Component (Loc,
1086              Prefix =>
1087                Make_Selected_Component (Loc,
1088                  Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
1089                  Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
1090              Expressions => Actuals);
1091          Set_Name (N, New_N);
1092          Set_Etype (New_N, Standard_Void_Type);
1093          Set_Parameter_Associations (N, No_List);
1094          Analyze_Call_And_Resolve;
1095
1096       elsif Nkind (P) = N_Explicit_Dereference then
1097          if Ekind (Etype (P)) = E_Subprogram_Type then
1098             Analyze_Call_And_Resolve;
1099          else
1100             Error_Msg_N ("expect access to procedure in call", P);
1101          end if;
1102
1103       --  The name can be a selected component or an indexed component that
1104       --  yields an access to subprogram. Such a prefix is legal if the call
1105       --  has parameter associations.
1106
1107       elsif Is_Access_Type (Etype (P))
1108         and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1109       then
1110          if Present (Actuals) then
1111             Analyze_Call_And_Resolve;
1112          else
1113             Error_Msg_N ("missing explicit dereference in call ", N);
1114          end if;
1115
1116       --  If not an access to subprogram, then the prefix must resolve to the
1117       --  name of an entry, entry family, or protected operation.
1118
1119       --  For the case of a simple entry call, P is a selected component where
1120       --  the prefix is the task and the selector name is the entry. A call to
1121       --  a protected procedure will have the same syntax. If the protected
1122       --  object contains overloaded operations, the entity may appear as a
1123       --  function, the context will select the operation whose type is Void.
1124
1125       elsif Nkind (P) = N_Selected_Component
1126         and then (Ekind (Entity (Selector_Name (P))) = E_Entry
1127                     or else
1128                   Ekind (Entity (Selector_Name (P))) = E_Procedure
1129                     or else
1130                   Ekind (Entity (Selector_Name (P))) = E_Function)
1131       then
1132          Analyze_Call_And_Resolve;
1133
1134       elsif Nkind (P) = N_Selected_Component
1135         and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
1136         and then Present (Actuals)
1137         and then No (Next (First (Actuals)))
1138       then
1139          --  Can be call to parameterless entry family. What appears to be the
1140          --  sole argument is in fact the entry index. Rewrite prefix of node
1141          --  accordingly. Source representation is unchanged by this
1142          --  transformation.
1143
1144          New_N :=
1145            Make_Indexed_Component (Loc,
1146              Prefix => New_Copy (P),
1147              Expressions => Actuals);
1148          Set_Name (N, New_N);
1149          Set_Etype (New_N, Standard_Void_Type);
1150          Set_Parameter_Associations (N, No_List);
1151          Analyze_Call_And_Resolve;
1152
1153       --  For the case of a reference to an element of an entry family, P is
1154       --  an indexed component whose prefix is a selected component (task and
1155       --  entry family), and whose index is the entry family index.
1156
1157       elsif Nkind (P) = N_Indexed_Component
1158         and then Nkind (Prefix (P)) = N_Selected_Component
1159         and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
1160       then
1161          Analyze_Call_And_Resolve;
1162
1163       --  If the prefix is the name of an entry family, it is a call from
1164       --  within the task body itself.
1165
1166       elsif Nkind (P) = N_Indexed_Component
1167         and then Nkind (Prefix (P)) = N_Identifier
1168         and then Ekind (Entity (Prefix (P))) = E_Entry_Family
1169       then
1170          New_N :=
1171            Make_Selected_Component (Loc,
1172              Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
1173              Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
1174          Rewrite (Prefix (P), New_N);
1175          Analyze (P);
1176          Analyze_Call_And_Resolve;
1177
1178       --  Anything else is an error
1179
1180       else
1181          Error_Msg_N ("invalid procedure or entry call", N);
1182       end if;
1183    end Analyze_Procedure_Call;
1184
1185    -------------------------------------
1186    -- Analyze_Simple_Return_Statement --
1187    -------------------------------------
1188
1189    procedure Analyze_Simple_Return_Statement (N : Node_Id) is
1190    begin
1191       if Present (Expression (N)) then
1192          Mark_Coextensions (N, Expression (N));
1193       end if;
1194
1195       Analyze_Return_Statement (N);
1196    end Analyze_Simple_Return_Statement;
1197
1198    -------------------------
1199    -- Analyze_Return_Type --
1200    -------------------------
1201
1202    procedure Analyze_Return_Type (N : Node_Id) is
1203       Designator : constant Entity_Id := Defining_Entity (N);
1204       Typ        : Entity_Id := Empty;
1205
1206    begin
1207       --  Normal case where result definition does not indicate an error
1208
1209       if Result_Definition (N) /= Error then
1210          if Nkind (Result_Definition (N)) = N_Access_Definition then
1211             Typ := Access_Definition (N, Result_Definition (N));
1212             Set_Parent (Typ, Result_Definition (N));
1213             Set_Is_Local_Anonymous_Access (Typ);
1214             Set_Etype (Designator, Typ);
1215
1216          --  Subtype_Mark case
1217
1218          else
1219             Find_Type (Result_Definition (N));
1220             Typ := Entity (Result_Definition (N));
1221             Set_Etype (Designator, Typ);
1222
1223             if Ekind (Typ) = E_Incomplete_Type
1224               and then Is_Value_Type (Typ)
1225             then
1226                null;
1227
1228             elsif Ekind (Typ) = E_Incomplete_Type
1229               or else (Is_Class_Wide_Type (Typ)
1230                          and then
1231                            Ekind (Root_Type (Typ)) = E_Incomplete_Type)
1232             then
1233                Error_Msg_N
1234                  ("invalid use of incomplete type", Result_Definition (N));
1235             end if;
1236          end if;
1237
1238          --  Ada 2005 (AI-231): Ensure proper usage of null exclusion
1239
1240          Null_Exclusion_Static_Checks (N);
1241
1242       --  Case where result definition does indicate an error
1243
1244       else
1245          Set_Etype (Designator, Any_Type);
1246       end if;
1247    end Analyze_Return_Type;
1248
1249    -----------------------------
1250    -- Analyze_Subprogram_Body --
1251    -----------------------------
1252
1253    --  This procedure is called for regular subprogram bodies, generic bodies,
1254    --  and for subprogram stubs of both kinds. In the case of stubs, only the
1255    --  specification matters, and is used to create a proper declaration for
1256    --  the subprogram, or to perform conformance checks.
1257
1258    procedure Analyze_Subprogram_Body (N : Node_Id) is
1259       Loc          : constant Source_Ptr := Sloc (N);
1260       Body_Spec    : constant Node_Id    := Specification (N);
1261       Body_Id      : Entity_Id           := Defining_Entity (Body_Spec);
1262       Prev_Id      : constant Entity_Id  := Current_Entity_In_Scope (Body_Id);
1263       Body_Deleted : constant Boolean    := False;
1264       Conformant   : Boolean;
1265       HSS          : Node_Id;
1266       Missing_Ret  : Boolean;
1267       P_Ent        : Entity_Id;
1268       Prot_Typ     : Entity_Id := Empty;
1269       Spec_Id      : Entity_Id;
1270       Spec_Decl    : Node_Id   := Empty;
1271
1272       Last_Real_Spec_Entity : Entity_Id := Empty;
1273       --  When we analyze a separate spec, the entity chain ends up containing
1274       --  the formals, as well as any itypes generated during analysis of the
1275       --  default expressions for parameters, or the arguments of associated
1276       --  precondition/postcondition pragmas (which are analyzed in the context
1277       --  of the spec since they have visibility on formals).
1278       --
1279       --  These entities belong with the spec and not the body. However we do
1280       --  the analysis of the body in the context of the spec (again to obtain
1281       --  visibility to the formals), and all the entities generated during
1282       --  this analysis end up also chained to the entity chain of the spec.
1283       --  But they really belong to the body, and there is circuitry to move
1284       --  them from the spec to the body.
1285       --
1286       --  However, when we do this move, we don't want to move the real spec
1287       --  entities (first para above) to the body. The Last_Real_Spec_Entity
1288       --  variable points to the last real spec entity, so we only move those
1289       --  chained beyond that point. It is initialized to Empty to deal with
1290       --  the case where there is no separate spec.
1291
1292       procedure Check_Anonymous_Return;
1293       --  (Ada 2005): if a function returns an access type that denotes a task,
1294       --  or a type that contains tasks, we must create a master entity for
1295       --  the anonymous type, which typically will be used in an allocator
1296       --  in the body of the function.
1297
1298       procedure Check_Inline_Pragma (Spec : in out Node_Id);
1299       --  Look ahead to recognize a pragma that may appear after the body.
1300       --  If there is a previous spec, check that it appears in the same
1301       --  declarative part. If the pragma is Inline_Always, perform inlining
1302       --  unconditionally, otherwise only if Front_End_Inlining is requested.
1303       --  If the body acts as a spec, and inlining is required, we create a
1304       --  subprogram declaration for it, in order to attach the body to inline.
1305       --  If pragma does not appear after the body, check whether there is
1306       --  an inline pragma before any local declarations.
1307
1308       procedure Set_Trivial_Subprogram (N : Node_Id);
1309       --  Sets the Is_Trivial_Subprogram flag in both spec and body of the
1310       --  subprogram whose body is being analyzed. N is the statement node
1311       --  causing the flag to be set, if the following statement is a return
1312       --  of an entity, we mark the entity as set in source to suppress any
1313       --  warning on the stylized use of function stubs with a dummy return.
1314
1315       procedure Verify_Overriding_Indicator;
1316       --  If there was a previous spec, the entity has been entered in the
1317       --  current scope previously. If the body itself carries an overriding
1318       --  indicator, check that it is consistent with the known status of the
1319       --  entity.
1320
1321       ----------------------------
1322       -- Check_Anonymous_Return --
1323       ----------------------------
1324
1325       procedure Check_Anonymous_Return is
1326          Decl : Node_Id;
1327          Scop : Entity_Id;
1328
1329       begin
1330          if Present (Spec_Id) then
1331             Scop := Spec_Id;
1332          else
1333             Scop := Body_Id;
1334          end if;
1335
1336          if Ekind (Scop) = E_Function
1337            and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type
1338            and then Has_Task (Designated_Type (Etype (Scop)))
1339            and then Expander_Active
1340          then
1341             Decl :=
1342               Make_Object_Declaration (Loc,
1343                 Defining_Identifier =>
1344                   Make_Defining_Identifier (Loc, Name_uMaster),
1345                 Constant_Present => True,
1346                 Object_Definition =>
1347                   New_Reference_To (RTE (RE_Master_Id), Loc),
1348                 Expression =>
1349                   Make_Explicit_Dereference (Loc,
1350                     New_Reference_To (RTE (RE_Current_Master), Loc)));
1351
1352             if Present (Declarations (N)) then
1353                Prepend (Decl, Declarations (N));
1354             else
1355                Set_Declarations (N, New_List (Decl));
1356             end if;
1357
1358             Set_Master_Id (Etype (Scop), Defining_Identifier (Decl));
1359             Set_Has_Master_Entity (Scop);
1360          end if;
1361       end Check_Anonymous_Return;
1362
1363       -------------------------
1364       -- Check_Inline_Pragma --
1365       -------------------------
1366
1367       procedure Check_Inline_Pragma (Spec : in out Node_Id) is
1368          Prag  : Node_Id;
1369          Plist : List_Id;
1370
1371          function Is_Inline_Pragma (N : Node_Id) return Boolean;
1372          --  Simple predicate, used twice.
1373
1374          -----------------------
1375          --  Is_Inline_Pragma --
1376          -----------------------
1377
1378          function Is_Inline_Pragma (N : Node_Id) return Boolean is
1379          begin
1380             return
1381               Nkind (N) = N_Pragma
1382                 and then
1383                    (Pragma_Name (N) = Name_Inline_Always
1384                      or else
1385                       (Front_End_Inlining
1386                         and then Pragma_Name (N) = Name_Inline))
1387                 and then
1388                    Chars
1389                      (Expression (First (Pragma_Argument_Associations (N))))
1390                         = Chars (Body_Id);
1391          end Is_Inline_Pragma;
1392
1393       --  Start of processing for Check_Inline_Pragma
1394
1395       begin
1396          if not Expander_Active then
1397             return;
1398          end if;
1399
1400          if Is_List_Member (N)
1401            and then Present (Next (N))
1402            and then Is_Inline_Pragma (Next (N))
1403          then
1404             Prag := Next (N);
1405
1406          elsif Nkind (N) /= N_Subprogram_Body_Stub
1407            and then Present (Declarations (N))
1408            and then Is_Inline_Pragma (First (Declarations (N)))
1409          then
1410             Prag := First (Declarations (N));
1411
1412          else
1413             Prag := Empty;
1414          end if;
1415
1416          if Present (Prag) then
1417             if Present (Spec_Id) then
1418                if List_Containing (N) =
1419                  List_Containing (Unit_Declaration_Node (Spec_Id))
1420                then
1421                   Analyze (Prag);
1422                end if;
1423
1424             else
1425                --  Create a subprogram declaration, to make treatment uniform
1426
1427                declare
1428                   Subp : constant Entity_Id :=
1429                     Make_Defining_Identifier (Loc, Chars (Body_Id));
1430                   Decl : constant Node_Id :=
1431                     Make_Subprogram_Declaration (Loc,
1432                       Specification =>  New_Copy_Tree (Specification (N)));
1433                begin
1434                   Set_Defining_Unit_Name (Specification (Decl), Subp);
1435
1436                   if Present (First_Formal (Body_Id)) then
1437                      Plist := Copy_Parameter_List (Body_Id);
1438                      Set_Parameter_Specifications
1439                        (Specification (Decl), Plist);
1440                   end if;
1441
1442                   Insert_Before (N, Decl);
1443                   Analyze (Decl);
1444                   Analyze (Prag);
1445                   Set_Has_Pragma_Inline (Subp);
1446
1447                   if Pragma_Name (Prag) = Name_Inline_Always then
1448                      Set_Is_Inlined (Subp);
1449                      Set_Has_Pragma_Inline_Always (Subp);
1450                   end if;
1451
1452                   Spec := Subp;
1453                end;
1454             end if;
1455          end if;
1456       end Check_Inline_Pragma;
1457
1458       ----------------------------
1459       -- Set_Trivial_Subprogram --
1460       ----------------------------
1461
1462       procedure Set_Trivial_Subprogram (N : Node_Id) is
1463          Nxt : constant Node_Id := Next (N);
1464
1465       begin
1466          Set_Is_Trivial_Subprogram (Body_Id);
1467
1468          if Present (Spec_Id) then
1469             Set_Is_Trivial_Subprogram (Spec_Id);
1470          end if;
1471
1472          if Present (Nxt)
1473            and then Nkind (Nxt) = N_Simple_Return_Statement
1474            and then No (Next (Nxt))
1475            and then Present (Expression (Nxt))
1476            and then Is_Entity_Name (Expression (Nxt))
1477          then
1478             Set_Never_Set_In_Source (Entity (Expression (Nxt)), False);
1479          end if;
1480       end Set_Trivial_Subprogram;
1481
1482       ---------------------------------
1483       -- Verify_Overriding_Indicator --
1484       ---------------------------------
1485
1486       procedure Verify_Overriding_Indicator is
1487       begin
1488          if Must_Override (Body_Spec) then
1489             if Nkind (Spec_Id) = N_Defining_Operator_Symbol
1490               and then  Operator_Matches_Spec (Spec_Id, Spec_Id)
1491             then
1492                null;
1493
1494             elsif not Is_Overriding_Operation (Spec_Id) then
1495                Error_Msg_NE
1496                  ("subprogram& is not overriding", Body_Spec, Spec_Id);
1497             end if;
1498
1499          elsif Must_Not_Override (Body_Spec) then
1500             if Is_Overriding_Operation (Spec_Id) then
1501                Error_Msg_NE
1502                  ("subprogram& overrides inherited operation",
1503                   Body_Spec, Spec_Id);
1504
1505             elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol
1506               and then  Operator_Matches_Spec (Spec_Id, Spec_Id)
1507             then
1508                Error_Msg_NE
1509                  ("subprogram & overrides predefined operator ",
1510                     Body_Spec, Spec_Id);
1511
1512             --  If this is not a primitive operation the overriding indicator
1513             --  is altogether illegal.
1514
1515             elsif not Is_Primitive (Spec_Id) then
1516                Error_Msg_N ("overriding indicator only allowed " &
1517                 "if subprogram is primitive",
1518                 Body_Spec);
1519             end if;
1520          end if;
1521       end Verify_Overriding_Indicator;
1522
1523    --  Start of processing for Analyze_Subprogram_Body
1524
1525    begin
1526       if Debug_Flag_C then
1527          Write_Str ("====  Compiling subprogram body ");
1528          Write_Name (Chars (Body_Id));
1529          Write_Str (" from ");
1530          Write_Location (Loc);
1531          Write_Eol;
1532       end if;
1533
1534       Trace_Scope (N, Body_Id, " Analyze subprogram: ");
1535
1536       --  Generic subprograms are handled separately. They always have a
1537       --  generic specification. Determine whether current scope has a
1538       --  previous declaration.
1539
1540       --  If the subprogram body is defined within an instance of the same
1541       --  name, the instance appears as a package renaming, and will be hidden
1542       --  within the subprogram.
1543
1544       if Present (Prev_Id)
1545         and then not Is_Overloadable (Prev_Id)
1546         and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
1547                    or else Comes_From_Source (Prev_Id))
1548       then
1549          if Is_Generic_Subprogram (Prev_Id) then
1550             Spec_Id := Prev_Id;
1551             Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
1552             Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
1553
1554             Analyze_Generic_Subprogram_Body (N, Spec_Id);
1555             return;
1556
1557          else
1558             --  Previous entity conflicts with subprogram name. Attempting to
1559             --  enter name will post error.
1560
1561             Enter_Name (Body_Id);
1562             return;
1563          end if;
1564
1565       --  Non-generic case, find the subprogram declaration, if one was seen,
1566       --  or enter new overloaded entity in the current scope. If the
1567       --  Current_Entity is the Body_Id itself, the unit is being analyzed as
1568       --  part of the context of one of its subunits. No need to redo the
1569       --  analysis.
1570
1571       elsif Prev_Id = Body_Id
1572         and then Has_Completion (Body_Id)
1573       then
1574          return;
1575
1576       else
1577          Body_Id := Analyze_Subprogram_Specification (Body_Spec);
1578
1579          if Nkind (N) = N_Subprogram_Body_Stub
1580            or else No (Corresponding_Spec (N))
1581          then
1582             Spec_Id := Find_Corresponding_Spec (N);
1583
1584             --  If this is a duplicate body, no point in analyzing it
1585
1586             if Error_Posted (N) then
1587                return;
1588             end if;
1589
1590             --  A subprogram body should cause freezing of its own declaration,
1591             --  but if there was no previous explicit declaration, then the
1592             --  subprogram will get frozen too late (there may be code within
1593             --  the body that depends on the subprogram having been frozen,
1594             --  such as uses of extra formals), so we force it to be frozen
1595             --  here. Same holds if the body and spec are compilation units.
1596
1597             if No (Spec_Id) then
1598                Freeze_Before (N, Body_Id);
1599
1600             elsif Nkind (Parent (N)) = N_Compilation_Unit then
1601                Freeze_Before (N, Spec_Id);
1602             end if;
1603          else
1604             Spec_Id := Corresponding_Spec (N);
1605          end if;
1606       end if;
1607
1608       --  Do not inline any subprogram that contains nested subprograms, since
1609       --  the backend inlining circuit seems to generate uninitialized
1610       --  references in this case. We know this happens in the case of front
1611       --  end ZCX support, but it also appears it can happen in other cases as
1612       --  well. The backend often rejects attempts to inline in the case of
1613       --  nested procedures anyway, so little if anything is lost by this.
1614       --  Note that this is test is for the benefit of the back-end. There is
1615       --  a separate test for front-end inlining that also rejects nested
1616       --  subprograms.
1617
1618       --  Do not do this test if errors have been detected, because in some
1619       --  error cases, this code blows up, and we don't need it anyway if
1620       --  there have been errors, since we won't get to the linker anyway.
1621
1622       if Comes_From_Source (Body_Id)
1623         and then Serious_Errors_Detected = 0
1624       then
1625          P_Ent := Body_Id;
1626          loop
1627             P_Ent := Scope (P_Ent);
1628             exit when No (P_Ent) or else P_Ent = Standard_Standard;
1629
1630             if Is_Subprogram (P_Ent) then
1631                Set_Is_Inlined (P_Ent, False);
1632
1633                if Comes_From_Source (P_Ent)
1634                  and then Has_Pragma_Inline (P_Ent)
1635                then
1636                   Cannot_Inline
1637                     ("cannot inline& (nested subprogram)?",
1638                      N, P_Ent);
1639                end if;
1640             end if;
1641          end loop;
1642       end if;
1643
1644       Check_Inline_Pragma (Spec_Id);
1645
1646       --  Case of fully private operation in the body of the protected type.
1647       --  We must create a declaration for the subprogram, in order to attach
1648       --  the protected subprogram that will be used in internal calls.
1649
1650       if No (Spec_Id)
1651         and then Comes_From_Source (N)
1652         and then Is_Protected_Type (Current_Scope)
1653       then
1654          declare
1655             Decl     : Node_Id;
1656             Plist    : List_Id;
1657             Formal   : Entity_Id;
1658             New_Spec : Node_Id;
1659
1660          begin
1661             Formal := First_Formal (Body_Id);
1662
1663             --  The protected operation always has at least one formal, namely
1664             --  the object itself, but it is only placed in the parameter list
1665             --  if expansion is enabled.
1666
1667             if Present (Formal)
1668               or else Expander_Active
1669             then
1670                Plist := Copy_Parameter_List (Body_Id);
1671             else
1672                Plist := No_List;
1673             end if;
1674
1675             if Nkind (Body_Spec) = N_Procedure_Specification then
1676                New_Spec :=
1677                  Make_Procedure_Specification (Loc,
1678                     Defining_Unit_Name =>
1679                       Make_Defining_Identifier (Sloc (Body_Id),
1680                         Chars => Chars (Body_Id)),
1681                     Parameter_Specifications => Plist);
1682             else
1683                New_Spec :=
1684                  Make_Function_Specification (Loc,
1685                     Defining_Unit_Name =>
1686                       Make_Defining_Identifier (Sloc (Body_Id),
1687                         Chars => Chars (Body_Id)),
1688                     Parameter_Specifications => Plist,
1689                     Result_Definition =>
1690                       New_Occurrence_Of (Etype (Body_Id), Loc));
1691             end if;
1692
1693             Decl :=
1694               Make_Subprogram_Declaration (Loc,
1695                 Specification => New_Spec);
1696             Insert_Before (N, Decl);
1697             Spec_Id := Defining_Unit_Name (New_Spec);
1698
1699             --  Indicate that the entity comes from source, to ensure that
1700             --  cross-reference information is properly generated. The body
1701             --  itself is rewritten during expansion, and the body entity will
1702             --  not appear in calls to the operation.
1703
1704             Set_Comes_From_Source (Spec_Id, True);
1705             Analyze (Decl);
1706             Set_Has_Completion (Spec_Id);
1707             Set_Convention (Spec_Id, Convention_Protected);
1708          end;
1709
1710       elsif Present (Spec_Id) then
1711          Spec_Decl := Unit_Declaration_Node (Spec_Id);
1712          Verify_Overriding_Indicator;
1713
1714          --  In general, the spec will be frozen when we start analyzing the
1715          --  body. However, for internally generated operations, such as
1716          --  wrapper functions for inherited operations with controlling
1717          --  results, the spec may not have been frozen by the time we
1718          --  expand the freeze actions that include the bodies. In particular,
1719          --  extra formals for accessibility or for return-in-place may need
1720          --  to be generated. Freeze nodes, if any, are inserted before the
1721          --  current body.
1722
1723          if not Is_Frozen (Spec_Id)
1724            and then Expander_Active
1725          then
1726             --  Force the generation of its freezing node to ensure proper
1727             --  management of access types in the backend.
1728
1729             --  This is definitely needed for some cases, but it is not clear
1730             --  why, to be investigated further???
1731
1732             Set_Has_Delayed_Freeze (Spec_Id);
1733             Insert_Actions (N, Freeze_Entity (Spec_Id, Loc));
1734          end if;
1735       end if;
1736
1737       --  Place subprogram on scope stack, and make formals visible. If there
1738       --  is a spec, the visible entity remains that of the spec.
1739
1740       if Present (Spec_Id) then
1741          Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
1742
1743          if Is_Child_Unit (Spec_Id) then
1744             Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False);
1745          end if;
1746
1747          if Style_Check then
1748             Style.Check_Identifier (Body_Id, Spec_Id);
1749          end if;
1750
1751          Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
1752          Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
1753
1754          if Is_Abstract_Subprogram (Spec_Id) then
1755             Error_Msg_N ("an abstract subprogram cannot have a body", N);
1756             return;
1757
1758          else
1759             Set_Convention (Body_Id, Convention (Spec_Id));
1760             Set_Has_Completion (Spec_Id);
1761
1762             if Is_Protected_Type (Scope (Spec_Id)) then
1763                Prot_Typ := Scope (Spec_Id);
1764             end if;
1765
1766             --  If this is a body generated for a renaming, do not check for
1767             --  full conformance. The check is redundant, because the spec of
1768             --  the body is a copy of the spec in the renaming declaration,
1769             --  and the test can lead to spurious errors on nested defaults.
1770
1771             if Present (Spec_Decl)
1772               and then not Comes_From_Source (N)
1773               and then
1774                 (Nkind (Original_Node (Spec_Decl)) =
1775                                         N_Subprogram_Renaming_Declaration
1776                    or else (Present (Corresponding_Body (Spec_Decl))
1777                               and then
1778                                 Nkind (Unit_Declaration_Node
1779                                         (Corresponding_Body (Spec_Decl))) =
1780                                            N_Subprogram_Renaming_Declaration))
1781             then
1782                Conformant := True;
1783
1784             else
1785                Check_Conformance
1786                  (Body_Id, Spec_Id,
1787                   Fully_Conformant, True, Conformant, Body_Id);
1788             end if;
1789
1790             --  If the body is not fully conformant, we have to decide if we
1791             --  should analyze it or not. If it has a really messed up profile
1792             --  then we probably should not analyze it, since we will get too
1793             --  many bogus messages.
1794
1795             --  Our decision is to go ahead in the non-fully conformant case
1796             --  only if it is at least mode conformant with the spec. Note
1797             --  that the call to Check_Fully_Conformant has issued the proper
1798             --  error messages to complain about the lack of conformance.
1799
1800             if not Conformant
1801               and then not Mode_Conformant (Body_Id, Spec_Id)
1802             then
1803                return;
1804             end if;
1805          end if;
1806
1807          if Spec_Id /= Body_Id then
1808             Reference_Body_Formals (Spec_Id, Body_Id);
1809          end if;
1810
1811          if Nkind (N) /= N_Subprogram_Body_Stub then
1812             Set_Corresponding_Spec (N, Spec_Id);
1813
1814             --  Ada 2005 (AI-345): If the operation is a primitive operation
1815             --  of a concurrent type, the type of the first parameter has been
1816             --  replaced with the corresponding record, which is the proper
1817             --  run-time structure to use. However, within the body there may
1818             --  be uses of the formals that depend on primitive operations
1819             --  of the type (in particular calls in prefixed form) for which
1820             --  we need the original concurrent type. The operation may have
1821             --  several controlling formals, so the replacement must be done
1822             --  for all of them.
1823
1824             if Comes_From_Source (Spec_Id)
1825               and then Present (First_Entity (Spec_Id))
1826               and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
1827               and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
1828               and then
1829                 Present (Abstract_Interfaces (Etype (First_Entity (Spec_Id))))
1830               and then
1831                 Present
1832                   (Corresponding_Concurrent_Type
1833                      (Etype (First_Entity (Spec_Id))))
1834             then
1835                declare
1836                   Typ  : constant Entity_Id := Etype (First_Entity (Spec_Id));
1837                   Form : Entity_Id;
1838
1839                begin
1840                   Form := First_Formal (Spec_Id);
1841                   while Present (Form) loop
1842                      if Etype (Form) = Typ then
1843                         Set_Etype (Form, Corresponding_Concurrent_Type (Typ));
1844                      end if;
1845
1846                      Next_Formal (Form);
1847                   end loop;
1848                end;
1849             end if;
1850
1851             --  Make the formals visible, and place subprogram on scope stack.
1852             --  This is also the point at which we set Last_Real_Spec_Entity
1853             --  to mark the entities which will not be moved to the body.
1854
1855             Install_Formals (Spec_Id);
1856             Last_Real_Spec_Entity := Last_Entity (Spec_Id);
1857             Push_Scope (Spec_Id);
1858
1859             --  Make sure that the subprogram is immediately visible. For
1860             --  child units that have no separate spec this is indispensable.
1861             --  Otherwise it is safe albeit redundant.
1862
1863             Set_Is_Immediately_Visible (Spec_Id);
1864          end if;
1865
1866          Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
1867          Set_Ekind (Body_Id, E_Subprogram_Body);
1868          Set_Scope (Body_Id, Scope (Spec_Id));
1869          Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
1870
1871       --  Case of subprogram body with no previous spec
1872
1873       else
1874          if Style_Check
1875            and then Comes_From_Source (Body_Id)
1876            and then not Suppress_Style_Checks (Body_Id)
1877            and then not In_Instance
1878          then
1879             Style.Body_With_No_Spec (N);
1880          end if;
1881
1882          New_Overloaded_Entity (Body_Id);
1883
1884          if Nkind (N) /= N_Subprogram_Body_Stub then
1885             Set_Acts_As_Spec (N);
1886             Generate_Definition (Body_Id);
1887             Generate_Reference
1888               (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
1889             Generate_Reference_To_Formals (Body_Id);
1890             Install_Formals (Body_Id);
1891             Push_Scope (Body_Id);
1892          end if;
1893       end if;
1894
1895       --  If the return type is an anonymous access type whose designated type
1896       --  is the limited view of a class-wide type and the non-limited view is
1897       --  available, update the return type accordingly.
1898
1899       if Ada_Version >= Ada_05
1900         and then Comes_From_Source (N)
1901       then
1902          declare
1903             Etyp : Entity_Id;
1904             Rtyp : Entity_Id;
1905
1906          begin
1907             Rtyp := Etype (Current_Scope);
1908
1909             if Ekind (Rtyp) = E_Anonymous_Access_Type then
1910                Etyp := Directly_Designated_Type (Rtyp);
1911
1912                if Is_Class_Wide_Type (Etyp)
1913                  and then From_With_Type (Etyp)
1914                then
1915                   Set_Directly_Designated_Type
1916                     (Etype (Current_Scope), Available_View (Etyp));
1917                end if;
1918             end if;
1919          end;
1920       end if;
1921
1922       --  If this is the proper body of a stub, we must verify that the stub
1923       --  conforms to the body, and to the previous spec if one was present.
1924       --  we know already that the body conforms to that spec. This test is
1925       --  only required for subprograms that come from source.
1926
1927       if Nkind (Parent (N)) = N_Subunit
1928         and then Comes_From_Source (N)
1929         and then not Error_Posted (Body_Id)
1930         and then Nkind (Corresponding_Stub (Parent (N))) =
1931                                                 N_Subprogram_Body_Stub
1932       then
1933          declare
1934             Old_Id : constant Entity_Id :=
1935                        Defining_Entity
1936                          (Specification (Corresponding_Stub (Parent (N))));
1937
1938             Conformant : Boolean := False;
1939
1940          begin
1941             if No (Spec_Id) then
1942                Check_Fully_Conformant (Body_Id, Old_Id);
1943
1944             else
1945                Check_Conformance
1946                  (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
1947
1948                if not Conformant then
1949
1950                   --  The stub was taken to be a new declaration. Indicate
1951                   --  that it lacks a body.
1952
1953                   Set_Has_Completion (Old_Id, False);
1954                end if;
1955             end if;
1956          end;
1957       end if;
1958
1959       Set_Has_Completion (Body_Id);
1960       Check_Eliminated (Body_Id);
1961
1962       if Nkind (N) = N_Subprogram_Body_Stub then
1963          return;
1964
1965       elsif Present (Spec_Id)
1966         and then Expander_Active
1967         and then
1968           (Has_Pragma_Inline_Always (Spec_Id)
1969              or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
1970       then
1971          Build_Body_To_Inline (N, Spec_Id);
1972       end if;
1973
1974       --  Ada 2005 (AI-262): In library subprogram bodies, after the analysis
1975       --  if its specification we have to install the private withed units.
1976       --  This holds for child units as well.
1977
1978       if Is_Compilation_Unit (Body_Id)
1979         or else Nkind (Parent (N)) = N_Compilation_Unit
1980       then
1981          Install_Private_With_Clauses (Body_Id);
1982       end if;
1983
1984       Check_Anonymous_Return;
1985
1986       --  Set the Protected_Formal field of each extra formal of the protected
1987       --  subprogram to reference the corresponding extra formal of the
1988       --  subprogram that implements it. For regular formals this occurs when
1989       --  the protected subprogram's declaration is expanded, but the extra
1990       --  formals don't get created until the subprogram is frozen. We need to
1991       --  do this before analyzing the protected subprogram's body so that any
1992       --  references to the original subprogram's extra formals will be changed
1993       --  refer to the implementing subprogram's formals (see Expand_Formal).
1994
1995       if Present (Spec_Id)
1996         and then Is_Protected_Type (Scope (Spec_Id))
1997         and then Present (Protected_Body_Subprogram (Spec_Id))
1998       then
1999          declare
2000             Impl_Subp       : constant Entity_Id :=
2001                                 Protected_Body_Subprogram (Spec_Id);
2002             Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id);
2003             Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp);
2004          begin
2005             while Present (Prot_Ext_Formal) loop
2006                pragma Assert (Present (Impl_Ext_Formal));
2007                Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
2008                Next_Formal_With_Extras (Prot_Ext_Formal);
2009                Next_Formal_With_Extras (Impl_Ext_Formal);
2010             end loop;
2011          end;
2012       end if;
2013
2014       --  Now we can go on to analyze the body
2015
2016       HSS := Handled_Statement_Sequence (N);
2017       Set_Actual_Subtypes (N, Current_Scope);
2018
2019       --  Deal with preconditions and postconditions
2020
2021       Process_PPCs (N, Spec_Id, Body_Id);
2022
2023       --  Add a declaration for the Protection objcect, renaming declarations
2024       --  for discriminals and privals and finally a declaration for the entry
2025       --  family index (if applicable). This form of early expansion is done
2026       --  when the Expander is active because Install_Private_Data_Declarations
2027       --  references entities which were created during regular expansion.
2028
2029       if Expander_Active
2030         and then Comes_From_Source (N)
2031         and then Present (Prot_Typ)
2032         and then Present (Spec_Id)
2033         and then not Is_Eliminated (Spec_Id)
2034       then
2035          Install_Private_Data_Declarations
2036            (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N));
2037       end if;
2038
2039       --  Analyze the declarations (this call will analyze the precondition
2040       --  Check pragmas we prepended to the list, as well as the declaration
2041       --  of the _Postconditions procedure).
2042
2043       Analyze_Declarations (Declarations (N));
2044
2045       --  Check completion, and analyze the statements
2046
2047       Check_Completion;
2048       Analyze (HSS);
2049
2050       --  Deal with end of scope processing for the body
2051
2052       Process_End_Label (HSS, 't', Current_Scope);
2053       End_Scope;
2054       Check_Subprogram_Order (N);
2055       Set_Analyzed (Body_Id);
2056
2057       --  If we have a separate spec, then the analysis of the declarations
2058       --  caused the entities in the body to be chained to the spec id, but
2059       --  we want them chained to the body id. Only the formal parameters
2060       --  end up chained to the spec id in this case.
2061
2062       if Present (Spec_Id) then
2063
2064          --  We must conform to the categorization of our spec
2065
2066          Validate_Categorization_Dependency (N, Spec_Id);
2067
2068          --  And if this is a child unit, the parent units must conform
2069
2070          if Is_Child_Unit (Spec_Id) then
2071             Validate_Categorization_Dependency
2072               (Unit_Declaration_Node (Spec_Id), Spec_Id);
2073          end if;
2074
2075          --  Here is where we move entities from the spec to the body
2076
2077          --  Case where there are entities that stay with the spec
2078
2079          if Present (Last_Real_Spec_Entity) then
2080
2081             --  No body entities (happens when the only real spec entities
2082             --  come from precondition and postcondition pragmas)
2083
2084             if No (Last_Entity (Body_Id)) then
2085                Set_First_Entity
2086                  (Body_Id, Next_Entity (Last_Real_Spec_Entity));
2087
2088             --  Body entities present (formals), so chain stuff past them
2089
2090             else
2091                Set_Next_Entity
2092                  (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity));
2093             end if;
2094
2095             Set_Next_Entity (Last_Real_Spec_Entity, Empty);
2096             Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
2097             Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity);
2098
2099          --  Case where there are no spec entities, in this case there can
2100          --  be no body entities either, so just move everything.
2101
2102          else
2103             pragma Assert (No (Last_Entity (Body_Id)));
2104             Set_First_Entity (Body_Id, First_Entity (Spec_Id));
2105             Set_Last_Entity  (Body_Id, Last_Entity (Spec_Id));
2106             Set_First_Entity (Spec_Id, Empty);
2107             Set_Last_Entity  (Spec_Id, Empty);
2108          end if;
2109       end if;
2110
2111       --  If function, check return statements
2112
2113       if Nkind (Body_Spec) = N_Function_Specification then
2114          declare
2115             Id : Entity_Id;
2116
2117          begin
2118             if Present (Spec_Id) then
2119                Id := Spec_Id;
2120             else
2121                Id := Body_Id;
2122             end if;
2123
2124             if Return_Present (Id) then
2125                Check_Returns (HSS, 'F', Missing_Ret);
2126
2127                if Missing_Ret then
2128                   Set_Has_Missing_Return (Id);
2129                end if;
2130
2131             elsif not Is_Machine_Code_Subprogram (Id)
2132               and then not Body_Deleted
2133             then
2134                Error_Msg_N ("missing RETURN statement in function body", N);
2135             end if;
2136          end;
2137
2138       --  If procedure with No_Return, check returns
2139
2140       elsif Nkind (Body_Spec) = N_Procedure_Specification
2141         and then Present (Spec_Id)
2142         and then No_Return (Spec_Id)
2143       then
2144          Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
2145       end if;
2146
2147       --  Now we are going to check for variables that are never modified in
2148       --  the body of the procedure. But first we deal with a special case
2149       --  where we want to modify this check. If the body of the subprogram
2150       --  starts with a raise statement or its equivalent, or if the body
2151       --  consists entirely of a null statement, then it is pretty obvious
2152       --  that it is OK to not reference the parameters. For example, this
2153       --  might be the following common idiom for a stubbed function:
2154       --  statement of the procedure raises an exception. In particular this
2155       --  deals with the common idiom of a stubbed function, which might
2156       --  appear as something like
2157
2158       --     function F (A : Integer) return Some_Type;
2159       --        X : Some_Type;
2160       --     begin
2161       --        raise Program_Error;
2162       --        return X;
2163       --     end F;
2164
2165       --  Here the purpose of X is simply to satisfy the annoying requirement
2166       --  in Ada that there be at least one return, and we certainly do not
2167       --  want to go posting warnings on X that it is not initialized! On
2168       --  the other hand, if X is entirely unreferenced that should still
2169       --  get a warning.
2170
2171       --  What we do is to detect these cases, and if we find them, flag the
2172       --  subprogram as being Is_Trivial_Subprogram and then use that flag to
2173       --  suppress unwanted warnings. For the case of the function stub above
2174       --  we have a special test to set X as apparently assigned to suppress
2175       --  the warning.
2176
2177       declare
2178          Stm : Node_Id;
2179
2180       begin
2181          --  Skip initial labels (for one thing this occurs when we are in
2182          --  front end ZCX mode, but in any case it is irrelevant), and also
2183          --  initial Push_xxx_Error_Label nodes, which are also irrelevant.
2184
2185          Stm := First (Statements (HSS));
2186          while Nkind (Stm) = N_Label
2187            or else Nkind (Stm) in N_Push_xxx_Label
2188          loop
2189             Next (Stm);
2190          end loop;
2191
2192          --  Do the test on the original statement before expansion
2193
2194          declare
2195             Ostm : constant Node_Id := Original_Node (Stm);
2196
2197          begin
2198             --  If explicit raise statement, turn on flag
2199
2200             if Nkind (Ostm) = N_Raise_Statement then
2201                Set_Trivial_Subprogram (Stm);
2202
2203             --  If null statement, and no following statemennts, turn on flag
2204
2205             elsif Nkind (Stm) = N_Null_Statement
2206               and then Comes_From_Source (Stm)
2207               and then No (Next (Stm))
2208             then
2209                Set_Trivial_Subprogram (Stm);
2210
2211             --  Check for explicit call cases which likely raise an exception
2212
2213             elsif Nkind (Ostm) = N_Procedure_Call_Statement then
2214                if Is_Entity_Name (Name (Ostm)) then
2215                   declare
2216                      Ent : constant Entity_Id := Entity (Name (Ostm));
2217
2218                   begin
2219                      --  If the procedure is marked No_Return, then likely it
2220                      --  raises an exception, but in any case it is not coming
2221                      --  back here, so turn on the flag.
2222
2223                      if Ekind (Ent) = E_Procedure
2224                        and then No_Return (Ent)
2225                      then
2226                         Set_Trivial_Subprogram (Stm);
2227
2228                      --  If the procedure name is Raise_Exception, then also
2229                      --  assume that it raises an exception. The main target
2230                      --  here is Ada.Exceptions.Raise_Exception, but this name
2231                      --  is pretty evocative in any context! Note that the
2232                      --  procedure in Ada.Exceptions is not marked No_Return
2233                      --  because of the annoying case of the null exception Id
2234                      --  when operating in Ada 95 mode.
2235
2236                      elsif Chars (Ent) = Name_Raise_Exception then
2237                         Set_Trivial_Subprogram (Stm);
2238                      end if;
2239                   end;
2240                end if;
2241             end if;
2242          end;
2243       end;
2244
2245       --  Check for variables that are never modified
2246
2247       declare
2248          E1, E2 : Entity_Id;
2249
2250       begin
2251          --  If there is a separate spec, then transfer Never_Set_In_Source
2252          --  flags from out parameters to the corresponding entities in the
2253          --  body. The reason we do that is we want to post error flags on
2254          --  the body entities, not the spec entities.
2255
2256          if Present (Spec_Id) then
2257             E1 := First_Entity (Spec_Id);
2258             while Present (E1) loop
2259                if Ekind (E1) = E_Out_Parameter then
2260                   E2 := First_Entity (Body_Id);
2261                   while Present (E2) loop
2262                      exit when Chars (E1) = Chars (E2);
2263                      Next_Entity (E2);
2264                   end loop;
2265
2266                   if Present (E2) then
2267                      Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
2268                   end if;
2269                end if;
2270
2271                Next_Entity (E1);
2272             end loop;
2273          end if;
2274
2275          --  Check references in body unless it was deleted. Note that the
2276          --  check of Body_Deleted here is not just for efficiency, it is
2277          --  necessary to avoid junk warnings on formal parameters.
2278
2279          if not Body_Deleted then
2280             Check_References (Body_Id);
2281          end if;
2282       end;
2283    end Analyze_Subprogram_Body;
2284
2285    ------------------------------------
2286    -- Analyze_Subprogram_Declaration --
2287    ------------------------------------
2288
2289    procedure Analyze_Subprogram_Declaration (N : Node_Id) is
2290       Designator : constant Entity_Id :=
2291                      Analyze_Subprogram_Specification (Specification (N));
2292       Scop       : constant Entity_Id := Current_Scope;
2293
2294    --  Start of processing for Analyze_Subprogram_Declaration
2295
2296    begin
2297       Generate_Definition (Designator);
2298
2299       --  Check for RCI unit subprogram declarations for illegal inlined
2300       --  subprograms and subprograms having access parameter or limited
2301       --  parameter without Read and Write attributes (RM E.2.3(12-13)).
2302
2303       Validate_RCI_Subprogram_Declaration (N);
2304
2305       Trace_Scope
2306         (N,
2307          Defining_Entity (N),
2308          " Analyze subprogram spec: ");
2309
2310       if Debug_Flag_C then
2311          Write_Str ("====  Compiling subprogram spec ");
2312          Write_Name (Chars (Designator));
2313          Write_Str (" from ");
2314          Write_Location (Sloc (N));
2315          Write_Eol;
2316       end if;
2317
2318       New_Overloaded_Entity (Designator);
2319       Check_Delayed_Subprogram (Designator);
2320
2321       --  Ada 2005 (AI-251): Abstract interface primitives must be abstract
2322       --  or null.
2323
2324       if Ada_Version >= Ada_05
2325         and then Comes_From_Source (N)
2326         and then Is_Dispatching_Operation (Designator)
2327       then
2328          declare
2329             E    : Entity_Id;
2330             Etyp : Entity_Id;
2331
2332          begin
2333             if Has_Controlling_Result (Designator) then
2334                Etyp := Etype (Designator);
2335
2336             else
2337                E := First_Entity (Designator);
2338                while Present (E)
2339                  and then Is_Formal (E)
2340                  and then not Is_Controlling_Formal (E)
2341                loop
2342                   Next_Entity (E);
2343                end loop;
2344
2345                Etyp := Etype (E);
2346             end if;
2347
2348             if Is_Access_Type (Etyp) then
2349                Etyp := Directly_Designated_Type (Etyp);
2350             end if;
2351
2352             if Is_Interface (Etyp)
2353               and then not Is_Abstract_Subprogram (Designator)
2354               and then not (Ekind (Designator) = E_Procedure
2355                               and then Null_Present (Specification (N)))
2356             then
2357                Error_Msg_Name_1 := Chars (Defining_Entity (N));
2358                Error_Msg_N
2359                  ("(Ada 2005) interface subprogram % must be abstract or null",
2360                   N);
2361             end if;
2362          end;
2363       end if;
2364
2365       --  What is the following code for, it used to be
2366
2367       --  ???   Set_Suppress_Elaboration_Checks
2368       --  ???     (Designator, Elaboration_Checks_Suppressed (Designator));
2369
2370       --  The following seems equivalent, but a bit dubious
2371
2372       if Elaboration_Checks_Suppressed (Designator) then
2373          Set_Kill_Elaboration_Checks (Designator);
2374       end if;
2375
2376       if Scop /= Standard_Standard
2377         and then not Is_Child_Unit (Designator)
2378       then
2379          Set_Categorization_From_Scope (Designator, Scop);
2380       else
2381          --  For a compilation unit, check for library-unit pragmas
2382
2383          Push_Scope (Designator);
2384          Set_Categorization_From_Pragmas (N);
2385          Validate_Categorization_Dependency (N, Designator);
2386          Pop_Scope;
2387       end if;
2388
2389       --  For a compilation unit, set body required. This flag will only be
2390       --  reset if a valid Import or Interface pragma is processed later on.
2391
2392       if Nkind (Parent (N)) = N_Compilation_Unit then
2393          Set_Body_Required (Parent (N), True);
2394
2395          if Ada_Version >= Ada_05
2396            and then Nkind (Specification (N)) = N_Procedure_Specification
2397            and then Null_Present (Specification (N))
2398          then
2399             Error_Msg_N
2400               ("null procedure cannot be declared at library level", N);
2401          end if;
2402       end if;
2403
2404       Generate_Reference_To_Formals (Designator);
2405       Check_Eliminated (Designator);
2406
2407       --  Ada 2005: if procedure is declared with "is null" qualifier,
2408       --  it requires no body.
2409
2410       if Nkind (Specification (N)) = N_Procedure_Specification
2411         and then Null_Present (Specification (N))
2412       then
2413          Set_Has_Completion (Designator);
2414          Set_Is_Inlined (Designator);
2415
2416          if Is_Protected_Type (Current_Scope) then
2417             Error_Msg_N
2418               ("protected operation cannot be a null procedure", N);
2419          end if;
2420       end if;
2421    end Analyze_Subprogram_Declaration;
2422
2423    --------------------------------------
2424    -- Analyze_Subprogram_Specification --
2425    --------------------------------------
2426
2427    --  Reminder: N here really is a subprogram specification (not a subprogram
2428    --  declaration). This procedure is called to analyze the specification in
2429    --  both subprogram bodies and subprogram declarations (specs).
2430
2431    function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
2432       Designator : constant Entity_Id := Defining_Entity (N);
2433       Formals    : constant List_Id   := Parameter_Specifications (N);
2434       Formal     : Entity_Id;
2435       Formal_Typ : Entity_Id;
2436
2437    --  Start of processing for Analyze_Subprogram_Specification
2438
2439    begin
2440       Generate_Definition (Designator);
2441
2442       if Nkind (N) = N_Function_Specification then
2443          Set_Ekind (Designator, E_Function);
2444          Set_Mechanism (Designator, Default_Mechanism);
2445
2446       else
2447          Set_Ekind (Designator, E_Procedure);
2448          Set_Etype (Designator, Standard_Void_Type);
2449       end if;
2450
2451       --  Introduce new scope for analysis of the formals and the return type
2452
2453       Set_Scope (Designator, Current_Scope);
2454
2455       if Present (Formals) then
2456          Push_Scope (Designator);
2457          Process_Formals (Formals, N);
2458
2459          --  Ada 2005 (AI-345): Allow the overriding of interface primitives
2460          --  by subprograms which belong to a concurrent type implementing an
2461          --  interface. Set the parameter type of each controlling formal to
2462          --  the corresponding record type.
2463
2464          if Ada_Version >= Ada_05 then
2465             Formal := First_Formal (Designator);
2466             while Present (Formal) loop
2467                Formal_Typ := Etype (Formal);
2468
2469                if (Ekind (Formal_Typ) = E_Protected_Type
2470                      or else Ekind (Formal_Typ) = E_Task_Type)
2471                  and then Present (Corresponding_Record_Type (Formal_Typ))
2472                  and then Present (Abstract_Interfaces
2473                                   (Corresponding_Record_Type (Formal_Typ)))
2474                then
2475                   Set_Etype (Formal,
2476                     Corresponding_Record_Type (Formal_Typ));
2477                end if;
2478
2479                Formal := Next_Formal (Formal);
2480             end loop;
2481          end if;
2482
2483          End_Scope;
2484
2485       elsif Nkind (N) = N_Function_Specification then
2486          Analyze_Return_Type (N);
2487       end if;
2488
2489       if Nkind (N) = N_Function_Specification then
2490          if Nkind (Designator) = N_Defining_Operator_Symbol then
2491             Valid_Operator_Definition (Designator);
2492          end if;
2493
2494          May_Need_Actuals (Designator);
2495
2496          --  Ada 2005 (AI-251): In case of primitives associated with abstract
2497          --  interface types the following error message will be reported later
2498          --  (see Analyze_Subprogram_Declaration).
2499
2500          if Is_Abstract_Type (Etype (Designator))
2501            and then not Is_Interface (Etype (Designator))
2502            and then Nkind (Parent (N)) /=
2503                       N_Abstract_Subprogram_Declaration
2504            and then
2505              (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration
2506                 and then
2507                   (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
2508                      or else not Is_Entity_Name (Name (Parent (N)))
2509                      or else not Is_Abstract_Subprogram
2510                                     (Entity (Name (Parent (N)))))
2511          then
2512             Error_Msg_N
2513               ("function that returns abstract type must be abstract", N);
2514          end if;
2515       end if;
2516
2517       return Designator;
2518    end Analyze_Subprogram_Specification;
2519
2520    --------------------------
2521    -- Build_Body_To_Inline --
2522    --------------------------
2523
2524    procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
2525       Decl            : constant Node_Id := Unit_Declaration_Node (Subp);
2526       Original_Body   : Node_Id;
2527       Body_To_Analyze : Node_Id;
2528       Max_Size        : constant := 10;
2529       Stat_Count      : Integer := 0;
2530
2531       function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
2532       --  Check for declarations that make inlining not worthwhile
2533
2534       function Has_Excluded_Statement   (Stats : List_Id) return Boolean;
2535       --  Check for statements that make inlining not worthwhile: any tasking
2536       --  statement, nested at any level. Keep track of total number of
2537       --  elementary statements, as a measure of acceptable size.
2538
2539       function Has_Pending_Instantiation return Boolean;
2540       --  If some enclosing body contains instantiations that appear before the
2541       --  corresponding generic body, the enclosing body has a freeze node so
2542       --  that it can be elaborated after the generic itself. This might
2543       --  conflict with subsequent inlinings, so that it is unsafe to try to
2544       --  inline in such a case.
2545
2546       function Has_Single_Return return Boolean;
2547       --  In general we cannot inline functions that return unconstrained type.
2548       --  However, we can handle such functions if all return statements return
2549       --  a local variable that is the only declaration in the body of the
2550       --  function. In that case the call can be replaced by that local
2551       --  variable as is done for other inlined calls.
2552
2553       procedure Remove_Pragmas;
2554       --  A pragma Unreferenced or pragma Unmodified that mentions a formal
2555       --  parameter has no meaning when the body is inlined and the formals
2556       --  are rewritten. Remove it from body to inline. The analysis of the
2557       --  non-inlined body will handle the pragma properly.
2558
2559       function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
2560       --  If the body of the subprogram includes a call that returns an
2561       --  unconstrained type, the secondary stack is involved, and it
2562       --  is not worth inlining.
2563
2564       ------------------------------
2565       -- Has_Excluded_Declaration --
2566       ------------------------------
2567
2568       function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
2569          D : Node_Id;
2570
2571          function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
2572          --  Nested subprograms make a given body ineligible for inlining, but
2573          --  we make an exception for instantiations of unchecked conversion.
2574          --  The body has not been analyzed yet, so check the name, and verify
2575          --  that the visible entity with that name is the predefined unit.
2576
2577          -----------------------------
2578          -- Is_Unchecked_Conversion --
2579          -----------------------------
2580
2581          function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
2582             Id   : constant Node_Id := Name (D);
2583             Conv : Entity_Id;
2584
2585          begin
2586             if Nkind (Id) = N_Identifier
2587               and then Chars (Id) = Name_Unchecked_Conversion
2588             then
2589                Conv := Current_Entity (Id);
2590
2591             elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
2592               and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
2593             then
2594                Conv := Current_Entity (Selector_Name (Id));
2595             else
2596                return False;
2597             end if;
2598
2599             return Present (Conv)
2600               and then Is_Predefined_File_Name
2601                          (Unit_File_Name (Get_Source_Unit (Conv)))
2602               and then Is_Intrinsic_Subprogram (Conv);
2603          end Is_Unchecked_Conversion;
2604
2605       --  Start of processing for Has_Excluded_Declaration
2606
2607       begin
2608          D := First (Decls);
2609          while Present (D) loop
2610             if (Nkind (D) = N_Function_Instantiation
2611                   and then not Is_Unchecked_Conversion (D))
2612               or else Nkind_In (D, N_Protected_Type_Declaration,
2613                                    N_Package_Declaration,
2614                                    N_Package_Instantiation,
2615                                    N_Subprogram_Body,
2616                                    N_Procedure_Instantiation,
2617                                    N_Task_Type_Declaration)
2618             then
2619                Cannot_Inline
2620                  ("cannot inline & (non-allowed declaration)?", D, Subp);
2621                return True;
2622             end if;
2623
2624             Next (D);
2625          end loop;
2626
2627          return False;
2628       end Has_Excluded_Declaration;
2629
2630       ----------------------------
2631       -- Has_Excluded_Statement --
2632       ----------------------------
2633
2634       function Has_Excluded_Statement (Stats : List_Id) return Boolean is
2635          S : Node_Id;
2636          E : Node_Id;
2637
2638       begin
2639          S := First (Stats);
2640          while Present (S) loop
2641             Stat_Count := Stat_Count + 1;
2642
2643             if Nkind_In (S, N_Abort_Statement,
2644                             N_Asynchronous_Select,
2645                             N_Conditional_Entry_Call,
2646                             N_Delay_Relative_Statement,
2647                             N_Delay_Until_Statement,
2648                             N_Selective_Accept,
2649                             N_Timed_Entry_Call)
2650             then
2651                Cannot_Inline
2652                  ("cannot inline & (non-allowed statement)?", S, Subp);
2653                return True;
2654
2655             elsif Nkind (S) = N_Block_Statement then
2656                if Present (Declarations (S))
2657                  and then Has_Excluded_Declaration (Declarations (S))
2658                then
2659                   return True;
2660
2661                elsif Present (Handled_Statement_Sequence (S))
2662                   and then
2663                     (Present
2664                       (Exception_Handlers (Handled_Statement_Sequence (S)))
2665                      or else
2666                        Has_Excluded_Statement
2667                          (Statements (Handled_Statement_Sequence (S))))
2668                then
2669                   return True;
2670                end if;
2671
2672             elsif Nkind (S) = N_Case_Statement then
2673                E := First (Alternatives (S));
2674                while Present (E) loop
2675                   if Has_Excluded_Statement (Statements (E)) then
2676                      return True;
2677                   end if;
2678
2679                   Next (E);
2680                end loop;
2681
2682             elsif Nkind (S) = N_If_Statement then
2683                if Has_Excluded_Statement (Then_Statements (S)) then
2684                   return True;
2685                end if;
2686
2687                if Present (Elsif_Parts (S)) then
2688                   E := First (Elsif_Parts (S));
2689                   while Present (E) loop
2690                      if Has_Excluded_Statement (Then_Statements (E)) then
2691                         return True;
2692                      end if;
2693                      Next (E);
2694                   end loop;
2695                end if;
2696
2697                if Present (Else_Statements (S))
2698                  and then Has_Excluded_Statement (Else_Statements (S))
2699                then
2700                   return True;
2701                end if;
2702
2703             elsif Nkind (S) = N_Loop_Statement
2704               and then Has_Excluded_Statement (Statements (S))
2705             then
2706                return True;
2707             end if;
2708
2709             Next (S);
2710          end loop;
2711
2712          return False;
2713       end Has_Excluded_Statement;
2714
2715       -------------------------------
2716       -- Has_Pending_Instantiation --
2717       -------------------------------
2718
2719       function Has_Pending_Instantiation return Boolean is
2720          S : Entity_Id;
2721
2722       begin
2723          S := Current_Scope;
2724          while Present (S) loop
2725             if Is_Compilation_Unit (S)
2726               or else Is_Child_Unit (S)
2727             then
2728                return False;
2729             elsif Ekind (S) = E_Package
2730               and then Has_Forward_Instantiation (S)
2731             then
2732                return True;
2733             end if;
2734
2735             S := Scope (S);
2736          end loop;
2737
2738          return False;
2739       end Has_Pending_Instantiation;
2740
2741       ------------------------
2742       --  Has_Single_Return --
2743       ------------------------
2744
2745       function Has_Single_Return return Boolean is
2746          Return_Statement : Node_Id := Empty;
2747
2748          function Check_Return (N : Node_Id) return Traverse_Result;
2749
2750          ------------------
2751          -- Check_Return --
2752          ------------------
2753
2754          function Check_Return (N : Node_Id) return Traverse_Result is
2755          begin
2756             if Nkind (N) = N_Simple_Return_Statement then
2757                if Present (Expression (N))
2758                  and then Is_Entity_Name (Expression (N))
2759                then
2760                   if No (Return_Statement) then
2761                      Return_Statement := N;
2762                      return OK;
2763
2764                   elsif Chars (Expression (N)) =
2765                         Chars (Expression (Return_Statement))
2766                   then
2767                      return OK;
2768
2769                   else
2770                      return Abandon;
2771                   end if;
2772
2773                else
2774                   --  Expression has wrong form
2775
2776                   return Abandon;
2777                end if;
2778
2779             else
2780                return OK;
2781             end if;
2782          end Check_Return;
2783
2784          function Check_All_Returns is new Traverse_Func (Check_Return);
2785
2786       --  Start of processing for Has_Single_Return
2787
2788       begin
2789          return Check_All_Returns (N) = OK
2790            and then Present (Declarations (N))
2791            and then Present (First (Declarations (N)))
2792            and then Chars (Expression (Return_Statement)) =
2793                     Chars (Defining_Identifier (First (Declarations (N))));
2794       end Has_Single_Return;
2795
2796       --------------------
2797       -- Remove_Pragmas --
2798       --------------------
2799
2800       procedure Remove_Pragmas is
2801          Decl : Node_Id;
2802          Nxt  : Node_Id;
2803
2804       begin
2805          Decl := First (Declarations (Body_To_Analyze));
2806          while Present (Decl) loop
2807             Nxt := Next (Decl);
2808
2809             if Nkind (Decl) = N_Pragma
2810               and then (Pragma_Name (Decl) = Name_Unreferenced
2811                           or else
2812                         Pragma_Name (Decl) = Name_Unmodified)
2813             then
2814                Remove (Decl);
2815             end if;
2816
2817             Decl := Nxt;
2818          end loop;
2819       end Remove_Pragmas;
2820
2821       --------------------------
2822       -- Uses_Secondary_Stack --
2823       --------------------------
2824
2825       function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
2826          function Check_Call (N : Node_Id) return Traverse_Result;
2827          --  Look for function calls that return an unconstrained type
2828
2829          ----------------
2830          -- Check_Call --
2831          ----------------
2832
2833          function Check_Call (N : Node_Id) return Traverse_Result is
2834          begin
2835             if Nkind (N) = N_Function_Call
2836               and then Is_Entity_Name (Name (N))
2837               and then Is_Composite_Type (Etype (Entity (Name (N))))
2838               and then not Is_Constrained (Etype (Entity (Name (N))))
2839             then
2840                Cannot_Inline
2841                  ("cannot inline & (call returns unconstrained type)?",
2842                     N, Subp);
2843                return Abandon;
2844             else
2845                return OK;
2846             end if;
2847          end Check_Call;
2848
2849          function Check_Calls is new Traverse_Func (Check_Call);
2850
2851       begin
2852          return Check_Calls (Bod) = Abandon;
2853       end Uses_Secondary_Stack;
2854
2855    --  Start of processing for Build_Body_To_Inline
2856
2857    begin
2858       if Nkind (Decl) = N_Subprogram_Declaration
2859         and then Present (Body_To_Inline (Decl))
2860       then
2861          return;    --  Done already.
2862
2863       --  Functions that return unconstrained composite types require
2864       --  secondary stack handling, and cannot currently be inlined, unless
2865       --  all return statements return a local variable that is the first
2866       --  local declaration in the body.
2867
2868       elsif Ekind (Subp) = E_Function
2869         and then not Is_Scalar_Type (Etype (Subp))
2870         and then not Is_Access_Type (Etype (Subp))
2871         and then not Is_Constrained (Etype (Subp))
2872       then
2873          if not Has_Single_Return then
2874             Cannot_Inline
2875               ("cannot inline & (unconstrained return type)?", N, Subp);
2876             return;
2877          end if;
2878
2879       --  Ditto for functions that return controlled types, where controlled
2880       --  actions interfere in complex ways with inlining.
2881
2882       elsif Ekind (Subp) = E_Function
2883         and then Controlled_Type (Etype (Subp))
2884       then
2885          Cannot_Inline
2886            ("cannot inline & (controlled return type)?", N, Subp);
2887          return;
2888       end if;
2889
2890       if Present (Declarations (N))
2891         and then Has_Excluded_Declaration (Declarations (N))
2892       then
2893          return;
2894       end if;
2895
2896       if Present (Handled_Statement_Sequence (N)) then
2897          if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
2898             Cannot_Inline
2899               ("cannot inline& (exception handler)?",
2900                First (Exception_Handlers (Handled_Statement_Sequence (N))),
2901                Subp);
2902             return;
2903          elsif
2904            Has_Excluded_Statement
2905              (Statements (Handled_Statement_Sequence (N)))
2906          then
2907             return;
2908          end if;
2909       end if;
2910
2911       --  We do not inline a subprogram  that is too large, unless it is
2912       --  marked Inline_Always. This pragma does not suppress the other
2913       --  checks on inlining (forbidden declarations, handlers, etc).
2914
2915       if Stat_Count > Max_Size
2916         and then not Has_Pragma_Inline_Always (Subp)
2917       then
2918          Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
2919          return;
2920       end if;
2921
2922       if Has_Pending_Instantiation then
2923          Cannot_Inline
2924            ("cannot inline& (forward instance within enclosing body)?",
2925              N, Subp);
2926          return;
2927       end if;
2928
2929       --  Within an instance, the body to inline must be treated as a nested
2930       --  generic, so that the proper global references are preserved.
2931
2932       --  Note that we do not do this at the library level, because it is not
2933       --  needed, and furthermore this causes trouble if front end inlining
2934       --  is activated (-gnatN).
2935
2936       if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
2937          Save_Env (Scope (Current_Scope), Scope (Current_Scope));
2938          Original_Body := Copy_Generic_Node (N, Empty, True);
2939       else
2940          Original_Body := Copy_Separate_Tree (N);
2941       end if;
2942
2943       --  We need to capture references to the formals in order to substitute
2944       --  the actuals at the point of inlining, i.e. instantiation. To treat
2945       --  the formals as globals to the body to inline, we nest it within
2946       --  a dummy parameterless subprogram, declared within the real one.
2947       --  To avoid generating an internal name (which is never public, and
2948       --  which affects serial numbers of other generated names), we use
2949       --  an internal symbol that cannot conflict with user declarations.
2950
2951       Set_Parameter_Specifications (Specification (Original_Body), No_List);
2952       Set_Defining_Unit_Name
2953         (Specification (Original_Body),
2954           Make_Defining_Identifier (Sloc (N), Name_uParent));
2955       Set_Corresponding_Spec (Original_Body, Empty);
2956
2957       Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
2958
2959       --  Set return type of function, which is also global and does not need
2960       --  to be resolved.
2961
2962       if Ekind (Subp) = E_Function then
2963          Set_Result_Definition (Specification (Body_To_Analyze),
2964            New_Occurrence_Of (Etype (Subp), Sloc (N)));
2965       end if;
2966
2967       if No (Declarations (N)) then
2968          Set_Declarations (N, New_List (Body_To_Analyze));
2969       else
2970          Append (Body_To_Analyze, Declarations (N));
2971       end if;
2972
2973       Expander_Mode_Save_And_Set (False);
2974       Remove_Pragmas;
2975
2976       Analyze (Body_To_Analyze);
2977       Push_Scope (Defining_Entity (Body_To_Analyze));
2978       Save_Global_References (Original_Body);
2979       End_Scope;
2980       Remove (Body_To_Analyze);
2981
2982       Expander_Mode_Restore;
2983
2984       --  Restore environment if previously saved
2985
2986       if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
2987          Restore_Env;
2988       end if;
2989
2990       --  If secondary stk used there is no point in inlining. We have
2991       --  already issued the warning in this case, so nothing to do.
2992
2993       if Uses_Secondary_Stack (Body_To_Analyze) then
2994          return;
2995       end if;
2996
2997       Set_Body_To_Inline (Decl, Original_Body);
2998       Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
2999       Set_Is_Inlined (Subp);
3000    end Build_Body_To_Inline;
3001
3002    -------------------
3003    -- Cannot_Inline --
3004    -------------------
3005
3006    procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is
3007    begin
3008       --  Do not emit warning if this is a predefined unit which is not
3009       --  the main unit. With validity checks enabled, some predefined
3010       --  subprograms may contain nested subprograms and become ineligible
3011       --  for inlining.
3012
3013       if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
3014         and then not In_Extended_Main_Source_Unit (Subp)
3015       then
3016          null;
3017
3018       elsif Has_Pragma_Inline_Always (Subp) then
3019
3020          --  Remove last character (question mark) to make this into an error,
3021          --  because the Inline_Always pragma cannot be obeyed.
3022
3023          Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
3024
3025       elsif Ineffective_Inline_Warnings then
3026          Error_Msg_NE (Msg, N, Subp);
3027       end if;
3028    end Cannot_Inline;
3029
3030    -----------------------
3031    -- Check_Conformance --
3032    -----------------------
3033
3034    procedure Check_Conformance
3035      (New_Id                   : Entity_Id;
3036       Old_Id                   : Entity_Id;
3037       Ctype                    : Conformance_Type;
3038       Errmsg                   : Boolean;
3039       Conforms                 : out Boolean;
3040       Err_Loc                  : Node_Id := Empty;
3041       Get_Inst                 : Boolean := False;
3042       Skip_Controlling_Formals : Boolean := False)
3043    is
3044       procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
3045       --  Post error message for conformance error on given node. Two messages
3046       --  are output. The first points to the previous declaration with a
3047       --  general "no conformance" message. The second is the detailed reason,
3048       --  supplied as Msg. The parameter N provide information for a possible
3049       --  & insertion in the message, and also provides the location for
3050       --  posting the message in the absence of a specified Err_Loc location.
3051
3052       -----------------------
3053       -- Conformance_Error --
3054       -----------------------
3055
3056       procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
3057          Enode : Node_Id;
3058
3059       begin
3060          Conforms := False;
3061
3062          if Errmsg then
3063             if No (Err_Loc) then
3064                Enode := N;
3065             else
3066                Enode := Err_Loc;
3067             end if;
3068
3069             Error_Msg_Sloc := Sloc (Old_Id);
3070
3071             case Ctype is
3072                when Type_Conformant =>
3073                   Error_Msg_N
3074                     ("not type conformant with declaration#!", Enode);
3075
3076                when Mode_Conformant =>
3077                   if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3078                      Error_Msg_N
3079                        ("not mode conformant with operation inherited#!",
3080                          Enode);
3081                   else
3082                      Error_Msg_N
3083                        ("not mode conformant with declaration#!", Enode);
3084                   end if;
3085
3086                when Subtype_Conformant =>
3087                   if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3088                      Error_Msg_N
3089                        ("not subtype conformant with operation inherited#!",
3090                          Enode);
3091                   else
3092                      Error_Msg_N
3093                        ("not subtype conformant with declaration#!", Enode);
3094                   end if;
3095
3096                when Fully_Conformant =>
3097                   if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3098                      Error_Msg_N
3099                        ("not fully conformant with operation inherited#!",
3100                          Enode);
3101                   else
3102                      Error_Msg_N
3103                        ("not fully conformant with declaration#!", Enode);
3104                   end if;
3105             end case;
3106
3107             Error_Msg_NE (Msg, Enode, N);
3108          end if;
3109       end Conformance_Error;
3110
3111       --  Local Variables
3112
3113       Old_Type           : constant Entity_Id := Etype (Old_Id);
3114       New_Type           : constant Entity_Id := Etype (New_Id);
3115       Old_Formal         : Entity_Id;
3116       New_Formal         : Entity_Id;
3117       Access_Types_Match : Boolean;
3118       Old_Formal_Base    : Entity_Id;
3119       New_Formal_Base    : Entity_Id;
3120
3121    --  Start of processing for Check_Conformance
3122
3123    begin
3124       Conforms := True;
3125
3126       --  We need a special case for operators, since they don't appear
3127       --  explicitly.
3128
3129       if Ctype = Type_Conformant then
3130          if Ekind (New_Id) = E_Operator
3131            and then Operator_Matches_Spec (New_Id, Old_Id)
3132          then
3133             return;
3134          end if;
3135       end if;
3136
3137       --  If both are functions/operators, check return types conform
3138
3139       if Old_Type /= Standard_Void_Type
3140         and then New_Type /= Standard_Void_Type
3141       then
3142          if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
3143             Conformance_Error ("\return type does not match!", New_Id);
3144             return;
3145          end if;
3146
3147          --  Ada 2005 (AI-231): In case of anonymous access types check the
3148          --  null-exclusion and access-to-constant attributes match.
3149
3150          if Ada_Version >= Ada_05
3151            and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
3152            and then
3153              (Can_Never_Be_Null (Old_Type)
3154                 /= Can_Never_Be_Null (New_Type)
3155               or else Is_Access_Constant (Etype (Old_Type))
3156                         /= Is_Access_Constant (Etype (New_Type)))
3157          then
3158             Conformance_Error ("\return type does not match!", New_Id);
3159             return;
3160          end if;
3161
3162       --  If either is a function/operator and the other isn't, error
3163
3164       elsif Old_Type /= Standard_Void_Type
3165         or else New_Type /= Standard_Void_Type
3166       then
3167          Conformance_Error ("\functions can only match functions!", New_Id);
3168          return;
3169       end if;
3170
3171       --  In subtype conformant case, conventions must match (RM 6.3.1(16)).
3172       --  If this is a renaming as body, refine error message to indicate that
3173       --  the conflict is with the original declaration. If the entity is not
3174       --  frozen, the conventions don't have to match, the one of the renamed
3175       --  entity is inherited.
3176
3177       if Ctype >= Subtype_Conformant then
3178          if Convention (Old_Id) /= Convention (New_Id) then
3179
3180             if not Is_Frozen (New_Id) then
3181                null;
3182
3183             elsif Present (Err_Loc)
3184               and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
3185               and then Present (Corresponding_Spec (Err_Loc))
3186             then
3187                Error_Msg_Name_1 := Chars (New_Id);
3188                Error_Msg_Name_2 :=
3189                  Name_Ada + Convention_Id'Pos (Convention (New_Id));
3190
3191                Conformance_Error ("\prior declaration for% has convention %!");
3192
3193             else
3194                Conformance_Error ("\calling conventions do not match!");
3195             end if;
3196
3197             return;
3198
3199          elsif Is_Formal_Subprogram (Old_Id)
3200            or else Is_Formal_Subprogram (New_Id)
3201          then
3202             Conformance_Error ("\formal subprograms not allowed!");
3203             return;
3204          end if;
3205       end if;
3206
3207       --  Deal with parameters
3208
3209       --  Note: we use the entity information, rather than going directly
3210       --  to the specification in the tree. This is not only simpler, but
3211       --  absolutely necessary for some cases of conformance tests between
3212       --  operators, where the declaration tree simply does not exist!
3213
3214       Old_Formal := First_Formal (Old_Id);
3215       New_Formal := First_Formal (New_Id);
3216
3217       while Present (Old_Formal) and then Present (New_Formal) loop
3218          if Is_Controlling_Formal (Old_Formal)
3219            and then Is_Controlling_Formal (New_Formal)
3220            and then Skip_Controlling_Formals
3221          then
3222             goto Skip_Controlling_Formal;
3223          end if;
3224
3225          if Ctype = Fully_Conformant then
3226
3227             --  Names must match. Error message is more accurate if we do
3228             --  this before checking that the types of the formals match.
3229
3230             if Chars (Old_Formal) /= Chars (New_Formal) then
3231                Conformance_Error ("\name & does not match!", New_Formal);
3232
3233                --  Set error posted flag on new formal as well to stop
3234                --  junk cascaded messages in some cases.
3235
3236                Set_Error_Posted (New_Formal);
3237                return;
3238             end if;
3239          end if;
3240
3241          --  Ada 2005 (AI-423): Possible access [sub]type and itype match. This
3242          --  case occurs whenever a subprogram is being renamed and one of its
3243          --  parameters imposes a null exclusion. For example:
3244
3245          --     type T is null record;
3246          --     type Acc_T is access T;
3247          --     subtype Acc_T_Sub is Acc_T;
3248
3249          --     procedure P     (Obj : not null Acc_T_Sub);  --  itype
3250          --     procedure Ren_P (Obj :          Acc_T_Sub)   --  subtype
3251          --       renames P;
3252
3253          Old_Formal_Base := Etype (Old_Formal);
3254          New_Formal_Base := Etype (New_Formal);
3255
3256          if Get_Inst then
3257             Old_Formal_Base := Get_Instance_Of (Old_Formal_Base);
3258             New_Formal_Base := Get_Instance_Of (New_Formal_Base);
3259          end if;
3260
3261          Access_Types_Match := Ada_Version >= Ada_05
3262
3263             --  Ensure that this rule is only applied when New_Id is a
3264             --  renaming of Old_Id.
3265
3266            and then Nkind (Parent (Parent (New_Id))) =
3267                       N_Subprogram_Renaming_Declaration
3268            and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity
3269            and then Present (Entity (Name (Parent (Parent (New_Id)))))
3270            and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
3271
3272             --  Now handle the allowed access-type case
3273
3274            and then Is_Access_Type (Old_Formal_Base)
3275            and then Is_Access_Type (New_Formal_Base)
3276
3277             --  The type kinds must match. The only exception occurs with
3278             --  multiple generics of the form: