OSDN Git Service

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