1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                               I N L I N E                                --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2018, 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
26with Aspects;  use Aspects;
27with Atree;    use Atree;
28with Debug;    use Debug;
29with Einfo;    use Einfo;
30with Elists;   use Elists;
31with Errout;   use Errout;
32with Expander; use Expander;
33with Exp_Ch6;  use Exp_Ch6;
34with Exp_Ch7;  use Exp_Ch7;
35with Exp_Tss;  use Exp_Tss;
36with Exp_Util; use Exp_Util;
37with Fname;    use Fname;
38with Fname.UF; use Fname.UF;
39with Lib;      use Lib;
40with Namet;    use Namet;
41with Nmake;    use Nmake;
42with Nlists;   use Nlists;
43with Output;   use Output;
44with Sem_Aux;  use Sem_Aux;
45with Sem_Ch8;  use Sem_Ch8;
46with Sem_Ch10; use Sem_Ch10;
47with Sem_Ch12; use Sem_Ch12;
48with Sem_Prag; use Sem_Prag;
49with Sem_Util; use Sem_Util;
50with Sinfo;    use Sinfo;
51with Sinput;   use Sinput;
52with Snames;   use Snames;
53with Stand;    use Stand;
54with Uname;    use Uname;
55with Tbuild;   use Tbuild;
56
57package body Inline is
58
59   Check_Inlining_Restrictions : constant Boolean := True;
60   --  In the following cases the frontend rejects inlining because they
61   --  are not handled well by the backend. This variable facilitates
62   --  disabling these restrictions to evaluate future versions of the
63   --  GCC backend in which some of the restrictions may be supported.
64   --
65   --   - subprograms that have:
66   --      - nested subprograms
67   --      - instantiations
68   --      - package declarations
69   --      - task or protected object declarations
70   --      - some of the following statements:
71   --          - abort
72   --          - asynchronous-select
73   --          - conditional-entry-call
74   --          - delay-relative
75   --          - delay-until
76   --          - selective-accept
77   --          - timed-entry-call
78
79   Inlined_Calls : Elist_Id;
80   --  List of frontend inlined calls
81
82   Backend_Calls : Elist_Id;
83   --  List of inline calls passed to the backend
84
85   Backend_Inlined_Subps : Elist_Id;
86   --  List of subprograms inlined by the backend
87
88   Backend_Not_Inlined_Subps : Elist_Id;
89   --  List of subprograms that cannot be inlined by the backend
90
91   --------------------
92   -- Inlined Bodies --
93   --------------------
94
95   --  Inlined functions are actually placed in line by the backend if the
96   --  corresponding bodies are available (i.e. compiled). Whenever we find
97   --  a call to an inlined subprogram, we add the name of the enclosing
98   --  compilation unit to a worklist. After all compilation, and after
99   --  expansion of generic bodies, we traverse the list of pending bodies
100   --  and compile them as well.
101
102   package Inlined_Bodies is new Table.Table (
103     Table_Component_Type => Entity_Id,
104     Table_Index_Type     => Int,
105     Table_Low_Bound      => 0,
106     Table_Initial        => Alloc.Inlined_Bodies_Initial,
107     Table_Increment      => Alloc.Inlined_Bodies_Increment,
108     Table_Name           => "Inlined_Bodies");
109
110   -----------------------
111   -- Inline Processing --
112   -----------------------
113
114   --  For each call to an inlined subprogram, we make entries in a table
115   --  that stores caller and callee, and indicates the call direction from
116   --  one to the other. We also record the compilation unit that contains
117   --  the callee. After analyzing the bodies of all such compilation units,
118   --  we compute the transitive closure of inlined subprograms called from
119   --  the main compilation unit and make it available to the code generator
120   --  in no particular order, thus allowing cycles in the call graph.
121
122   Last_Inlined : Entity_Id := Empty;
123
124   --  For each entry in the table we keep a list of successors in topological
125   --  order, i.e. callers of the current subprogram.
126
127   type Subp_Index is new Nat;
128   No_Subp : constant Subp_Index := 0;
129
130   --  The subprogram entities are hashed into the Inlined table
131
132   Num_Hash_Headers : constant := 512;
133
134   Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
135                                                          of Subp_Index;
136
137   type Succ_Index is new Nat;
138   No_Succ : constant Succ_Index := 0;
139
140   type Succ_Info is record
141      Subp : Subp_Index;
142      Next : Succ_Index;
143   end record;
144
145   --  The following table stores list elements for the successor lists. These
146   --  lists cannot be chained directly through entries in the Inlined table,
147   --  because a given subprogram can appear in several such lists.
148
149   package Successors is new Table.Table (
150      Table_Component_Type => Succ_Info,
151      Table_Index_Type     => Succ_Index,
152      Table_Low_Bound      => 1,
153      Table_Initial        => Alloc.Successors_Initial,
154      Table_Increment      => Alloc.Successors_Increment,
155      Table_Name           => "Successors");
156
157   type Subp_Info is record
158      Name        : Entity_Id  := Empty;
159      Next        : Subp_Index := No_Subp;
160      First_Succ  : Succ_Index := No_Succ;
161      Main_Call   : Boolean    := False;
162      Processed   : Boolean    := False;
163   end record;
164
165   package Inlined is new Table.Table (
166      Table_Component_Type => Subp_Info,
167      Table_Index_Type     => Subp_Index,
168      Table_Low_Bound      => 1,
169      Table_Initial        => Alloc.Inlined_Initial,
170      Table_Increment      => Alloc.Inlined_Increment,
171      Table_Name           => "Inlined");
172
173   -----------------------
174   -- Local Subprograms --
175   -----------------------
176
177   procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty);
178   --  Make two entries in Inlined table, for an inlined subprogram being
179   --  called, and for the inlined subprogram that contains the call. If
180   --  the call is in the main compilation unit, Caller is Empty.
181
182   procedure Add_Inlined_Subprogram (E : Entity_Id);
183   --  Add subprogram E to the list of inlined subprogram for the unit
184
185   function Add_Subp (E : Entity_Id) return Subp_Index;
186   --  Make entry in Inlined table for subprogram E, or return table index
187   --  that already holds E.
188
189   function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
190   pragma Inline (Get_Code_Unit_Entity);
191   --  Return the entity node for the unit containing E. Always return the spec
192   --  for a package.
193
194   function Has_Initialized_Type (E : Entity_Id) return Boolean;
195   --  If a candidate for inlining contains type declarations for types with
196   --  nontrivial initialization procedures, they are not worth inlining.
197
198   function Has_Single_Return (N : Node_Id) return Boolean;
199   --  In general we cannot inline functions that return unconstrained type.
200   --  However, we can handle such functions if all return statements return a
201   --  local variable that is the only declaration in the body of the function.
202   --  In that case the call can be replaced by that local variable as is done
203   --  for other inlined calls.
204
205   function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean;
206   --  Return True if E is in the main unit or its spec or in a subunit
207
208   function Is_Nested (E : Entity_Id) return Boolean;
209   --  If the function is nested inside some other function, it will always
210   --  be compiled if that function is, so don't add it to the inline list.
211   --  We cannot compile a nested function outside the scope of the containing
212   --  function anyway. This is also the case if the function is defined in a
213   --  task body or within an entry (for example, an initialization procedure).
214
215   procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id);
216   --  Remove all aspects and/or pragmas that have no meaning in inlined body
217   --  Body_Decl. The analysis of these items is performed on the non-inlined
218   --  body. The items currently removed are:
219   --    Contract_Cases
220   --    Global
221   --    Depends
222   --    Postcondition
223   --    Precondition
224   --    Refined_Global
225   --    Refined_Depends
226   --    Refined_Post
227   --    Test_Case
228   --    Unmodified
229   --    Unreferenced
230
231   ------------------------------
232   -- Deferred Cleanup Actions --
233   ------------------------------
234
235   --  The cleanup actions for scopes that contain instantiations is delayed
236   --  until after expansion of those instantiations, because they may contain
237   --  finalizable objects or tasks that affect the cleanup code. A scope
238   --  that contains instantiations only needs to be finalized once, even
239   --  if it contains more than one instance. We keep a list of scopes
240   --  that must still be finalized, and call cleanup_actions after all
241   --  the instantiations have been completed.
242
243   To_Clean : Elist_Id;
244
245   procedure Add_Scope_To_Clean (Inst : Entity_Id);
246   --  Build set of scopes on which cleanup actions must be performed
247
248   procedure Cleanup_Scopes;
249   --  Complete cleanup actions on scopes that need it
250
251   --------------
252   -- Add_Call --
253   --------------
254
255   procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
256      P1 : constant Subp_Index := Add_Subp (Called);
257      P2 : Subp_Index;
258      J  : Succ_Index;
259
260   begin
261      if Present (Caller) then
262         P2 := Add_Subp (Caller);
263
264         --  Add P1 to the list of successors of P2, if not already there.
265         --  Note that P2 may contain more than one call to P1, and only
266         --  one needs to be recorded.
267
268         J := Inlined.Table (P2).First_Succ;
269         while J /= No_Succ loop
270            if Successors.Table (J).Subp = P1 then
271               return;
272            end if;
273
274            J := Successors.Table (J).Next;
275         end loop;
276
277         --  On exit, make a successor entry for P1
278
279         Successors.Increment_Last;
280         Successors.Table (Successors.Last).Subp := P1;
281         Successors.Table (Successors.Last).Next :=
282                             Inlined.Table (P2).First_Succ;
283         Inlined.Table (P2).First_Succ := Successors.Last;
284      else
285         Inlined.Table (P1).Main_Call := True;
286      end if;
287   end Add_Call;
288
289   ----------------------
290   -- Add_Inlined_Body --
291   ----------------------
292
293   procedure Add_Inlined_Body (E : Entity_Id; N : Node_Id) is
294
295      type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package);
296      --  Level of inlining for the call: Dont_Inline means no inlining,
297      --  Inline_Call means that only the call is considered for inlining,
298      --  Inline_Package means that the call is considered for inlining and
299      --  its package compiled and scanned for more inlining opportunities.
300
301      function Is_Non_Loading_Expression_Function
302        (Id : Entity_Id) return Boolean;
303      --  Determine whether arbitrary entity Id denotes a subprogram which is
304      --  either
305      --
306      --    * An expression function
307      --
308      --    * A function completed by an expression function where both the
309      --      spec and body are in the same context.
310
311      function Must_Inline return Inline_Level_Type;
312      --  Inlining is only done if the call statement N is in the main unit,
313      --  or within the body of another inlined subprogram.
314
315      ----------------------------------------
316      -- Is_Non_Loading_Expression_Function --
317      ----------------------------------------
318
319      function Is_Non_Loading_Expression_Function
320        (Id : Entity_Id) return Boolean
321      is
322         Body_Decl : Node_Id;
323         Body_Id   : Entity_Id;
324         Spec_Decl : Node_Id;
325
326      begin
327         --  A stand-alone expression function is transformed into a spec-body
328         --  pair in-place. Since both the spec and body are in the same list,
329         --  the inlining of such an expression function does not need to load
330         --  anything extra.
331
332         if Is_Expression_Function (Id) then
333            return True;
334
335         --  A function may be completed by an expression function
336
337         elsif Ekind (Id) = E_Function then
338            Spec_Decl := Unit_Declaration_Node (Id);
339
340            if Nkind (Spec_Decl) = N_Subprogram_Declaration then
341               Body_Id := Corresponding_Body (Spec_Decl);
342
343               if Present (Body_Id) then
344                  Body_Decl := Unit_Declaration_Node (Body_Id);
345
346                  --  The inlining of a completing expression function does
347                  --  not need to load anything extra when both the spec and
348                  --  body are in the same context.
349
350                  return
351                    Was_Expression_Function (Body_Decl)
352                      and then Parent (Spec_Decl) = Parent (Body_Decl);
353               end if;
354            end if;
355         end if;
356
357         return False;
358      end Is_Non_Loading_Expression_Function;
359
360      -----------------
361      -- Must_Inline --
362      -----------------
363
364      function Must_Inline return Inline_Level_Type is
365         Scop : Entity_Id;
366         Comp : Node_Id;
367
368      begin
369         --  Check if call is in main unit
370
371         Scop := Current_Scope;
372
373         --  Do not try to inline if scope is standard. This could happen, for
374         --  example, for a call to Add_Global_Declaration, and it causes
375         --  trouble to try to inline at this level.
376
377         if Scop = Standard_Standard then
378            return Dont_Inline;
379         end if;
380
381         --  Otherwise lookup scope stack to outer scope
382
383         while Scope (Scop) /= Standard_Standard
384           and then not Is_Child_Unit (Scop)
385         loop
386            Scop := Scope (Scop);
387         end loop;
388
389         Comp := Parent (Scop);
390         while Nkind (Comp) /= N_Compilation_Unit loop
391            Comp := Parent (Comp);
392         end loop;
393
394         --  If the call is in the main unit, inline the call and compile the
395         --  package of the subprogram to find more calls to be inlined.
396
397         if Comp = Cunit (Main_Unit)
398           or else Comp = Library_Unit (Cunit (Main_Unit))
399         then
400            Add_Call (E);
401            return Inline_Package;
402         end if;
403
404         --  The call is not in the main unit. See if it is in some subprogram
405         --  that can be inlined outside its unit. If so, inline the call and,
406         --  if the inlining level is set to 1, stop there; otherwise also
407         --  compile the package as above.
408
409         Scop := Current_Scope;
410         while Scope (Scop) /= Standard_Standard
411           and then not Is_Child_Unit (Scop)
412         loop
413            if Is_Overloadable (Scop)
414              and then Is_Inlined (Scop)
415              and then not Is_Nested (Scop)
416            then
417               Add_Call (E, Scop);
418
419               if Inline_Level = 1 then
420                  return Inline_Call;
421               else
422                  return Inline_Package;
423               end if;
424            end if;
425
426            Scop := Scope (Scop);
427         end loop;
428
429         return Dont_Inline;
430      end Must_Inline;
431
432      Level : Inline_Level_Type;
433
434   --  Start of processing for Add_Inlined_Body
435
436   begin
437      Append_New_Elmt (N, To => Backend_Calls);
438
439      --  Skip subprograms that cannot be inlined outside their unit
440
441      if Is_Abstract_Subprogram (E)
442        or else Convention (E) = Convention_Protected
443        or else Is_Nested (E)
444      then
445         return;
446      end if;
447
448      --  Find out whether the call must be inlined. Unless the result is
449      --  Dont_Inline, Must_Inline also creates an edge for the call in the
450      --  callgraph; however, it will not be activated until after Is_Called
451      --  is set on the subprogram.
452
453      Level := Must_Inline;
454
455      if Level = Dont_Inline then
456         return;
457      end if;
458
459      --  If the call was generated by the compiler and is to a subprogram in
460      --  a run-time unit, we need to suppress debugging information for it,
461      --  so that the code that is eventually inlined will not affect the
462      --  debugging of the program. We do not do it if the call comes from
463      --  source because, even if the call is inlined, the user may expect it
464      --  to be present in the debugging information.
465
466      if not Comes_From_Source (N)
467        and then In_Extended_Main_Source_Unit (N)
468        and then Is_Predefined_Unit (Get_Source_Unit (E))
469      then
470         Set_Needs_Debug_Info (E, False);
471      end if;
472
473      --  If the subprogram is an expression function, or is completed by one
474      --  where both the spec and body are in the same context, then there is
475      --  no need to load any package body since the body of the function is
476      --  in the spec.
477
478      if Is_Non_Loading_Expression_Function (E) then
479         Set_Is_Called (E);
480         return;
481      end if;
482
483      --  Find unit containing E, and add to list of inlined bodies if needed.
484      --  If the body is already present, no need to load any other unit. This
485      --  is the case for an initialization procedure, which appears in the
486      --  package declaration that contains the type. It is also the case if
487      --  the body has already been analyzed. Finally, if the unit enclosing
488      --  E is an instance, the instance body will be analyzed in any case,
489      --  and there is no need to add the enclosing unit (whose body might not
490      --  be available).
491
492      --  Library-level functions must be handled specially, because there is
493      --  no enclosing package to retrieve. In this case, it is the body of
494      --  the function that will have to be loaded.
495
496      declare
497         Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
498
499      begin
500         if Pack = E then
501            Set_Is_Called (E);
502            Inlined_Bodies.Increment_Last;
503            Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
504
505         elsif Ekind (Pack) = E_Package then
506            Set_Is_Called (E);
507
508            if Is_Generic_Instance (Pack) then
509               null;
510
511            --  Do not inline the package if the subprogram is an init proc
512            --  or other internally generated subprogram, because in that
513            --  case the subprogram body appears in the same unit that
514            --  declares the type, and that body is visible to the back end.
515            --  Do not inline it either if it is in the main unit.
516            --  Extend the -gnatn2 processing to -gnatn1 for Inline_Always
517            --  calls if the back-end takes care of inlining the call.
518            --  Note that Level in Inline_Package | Inline_Call here.
519
520            elsif ((Level = Inline_Call
521                      and then Has_Pragma_Inline_Always (E)
522                      and then Back_End_Inlining)
523                    or else Level = Inline_Package)
524              and then not Is_Inlined (Pack)
525              and then not Is_Internal (E)
526              and then not In_Main_Unit_Or_Subunit (Pack)
527            then
528               Set_Is_Inlined (Pack);
529               Inlined_Bodies.Increment_Last;
530               Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
531            end if;
532         end if;
533
534         --  Ensure that Analyze_Inlined_Bodies will be invoked after
535         --  completing the analysis of the current unit.
536
537         Inline_Processing_Required := True;
538      end;
539   end Add_Inlined_Body;
540
541   ----------------------------
542   -- Add_Inlined_Subprogram --
543   ----------------------------
544
545   procedure Add_Inlined_Subprogram (E : Entity_Id) is
546      Decl : constant Node_Id   := Parent (Declaration_Node (E));
547      Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
548
549      procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id);
550      --  Append Subp to the list of subprograms inlined by the backend
551
552      procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
553      --  Append Subp to the list of subprograms that cannot be inlined by
554      --  the backend.
555
556      -----------------------------------------
557      -- Register_Backend_Inlined_Subprogram --
558      -----------------------------------------
559
560      procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
561      begin
562         Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
563      end Register_Backend_Inlined_Subprogram;
564
565      ---------------------------------------------
566      -- Register_Backend_Not_Inlined_Subprogram --
567      ---------------------------------------------
568
569      procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
570      begin
571         Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
572      end Register_Backend_Not_Inlined_Subprogram;
573
574   --  Start of processing for Add_Inlined_Subprogram
575
576   begin
577      --  If the subprogram is to be inlined, and if its unit is known to be
578      --  inlined or is an instance whose body will be analyzed anyway or the
579      --  subprogram was generated as a body by the compiler (for example an
580      --  initialization procedure) or its declaration was provided along with
581      --  the body (for example an expression function), and if it is declared
582      --  at the library level not in the main unit, and if it can be inlined
583      --  by the back-end, then insert it in the list of inlined subprograms.
584
585      if Is_Inlined (E)
586        and then (Is_Inlined (Pack)
587                   or else Is_Generic_Instance (Pack)
588                   or else Nkind (Decl) = N_Subprogram_Body
589                   or else Present (Corresponding_Body (Decl)))
590        and then not In_Main_Unit_Or_Subunit (E)
591        and then not Is_Nested (E)
592        and then not Has_Initialized_Type (E)
593      then
594         Register_Backend_Inlined_Subprogram (E);
595
596         if No (Last_Inlined) then
597            Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
598         else
599            Set_Next_Inlined_Subprogram (Last_Inlined, E);
600         end if;
601
602         Last_Inlined := E;
603
604      else
605         Register_Backend_Not_Inlined_Subprogram (E);
606      end if;
607   end Add_Inlined_Subprogram;
608
609   ------------------------
610   -- Add_Scope_To_Clean --
611   ------------------------
612
613   procedure Add_Scope_To_Clean (Inst : Entity_Id) is
614      Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
615      Elmt : Elmt_Id;
616
617   begin
618      --  If the instance appears in a library-level package declaration,
619      --  all finalization is global, and nothing needs doing here.
620
621      if Scop = Standard_Standard then
622         return;
623      end if;
624
625      --  If the instance is within a generic unit, no finalization code
626      --  can be generated. Note that at this point all bodies have been
627      --  analyzed, and the scope stack itself is not present, and the flag
628      --  Inside_A_Generic is not set.
629
630      declare
631         S : Entity_Id;
632
633      begin
634         S := Scope (Inst);
635         while Present (S) and then S /= Standard_Standard loop
636            if Is_Generic_Unit (S) then
637               return;
638            end if;
639
640            S := Scope (S);
641         end loop;
642      end;
643
644      Elmt := First_Elmt (To_Clean);
645      while Present (Elmt) loop
646         if Node (Elmt) = Scop then
647            return;
648         end if;
649
650         Elmt := Next_Elmt (Elmt);
651      end loop;
652
653      Append_Elmt (Scop, To_Clean);
654   end Add_Scope_To_Clean;
655
656   --------------
657   -- Add_Subp --
658   --------------
659
660   function Add_Subp (E : Entity_Id) return Subp_Index is
661      Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
662      J     : Subp_Index;
663
664      procedure New_Entry;
665      --  Initialize entry in Inlined table
666
667      procedure New_Entry is
668      begin
669         Inlined.Increment_Last;
670         Inlined.Table (Inlined.Last).Name        := E;
671         Inlined.Table (Inlined.Last).Next        := No_Subp;
672         Inlined.Table (Inlined.Last).First_Succ  := No_Succ;
673         Inlined.Table (Inlined.Last).Main_Call   := False;
674         Inlined.Table (Inlined.Last).Processed   := False;
675      end New_Entry;
676
677   --  Start of processing for Add_Subp
678
679   begin
680      if Hash_Headers (Index) = No_Subp then
681         New_Entry;
682         Hash_Headers (Index) := Inlined.Last;
683         return Inlined.Last;
684
685      else
686         J := Hash_Headers (Index);
687         while J /= No_Subp loop
688            if Inlined.Table (J).Name = E then
689               return J;
690            else
691               Index := J;
692               J := Inlined.Table (J).Next;
693            end if;
694         end loop;
695
696         --  On exit, subprogram was not found. Enter in table. Index is
697         --  the current last entry on the hash chain.
698
699         New_Entry;
700         Inlined.Table (Index).Next := Inlined.Last;
701         return Inlined.Last;
702      end if;
703   end Add_Subp;
704
705   ----------------------------
706   -- Analyze_Inlined_Bodies --
707   ----------------------------
708
709   procedure Analyze_Inlined_Bodies is
710      Comp_Unit : Node_Id;
711      J         : Int;
712      Pack      : Entity_Id;
713      Subp      : Subp_Index;
714      S         : Succ_Index;
715
716      type Pending_Index is new Nat;
717
718      package Pending_Inlined is new Table.Table (
719         Table_Component_Type => Subp_Index,
720         Table_Index_Type     => Pending_Index,
721         Table_Low_Bound      => 1,
722         Table_Initial        => Alloc.Inlined_Initial,
723         Table_Increment      => Alloc.Inlined_Increment,
724         Table_Name           => "Pending_Inlined");
725      --  The workpile used to compute the transitive closure
726
727   --  Start of processing for Analyze_Inlined_Bodies
728
729   begin
730      if Serious_Errors_Detected = 0 then
731         Push_Scope (Standard_Standard);
732
733         J := 0;
734         while J <= Inlined_Bodies.Last
735           and then Serious_Errors_Detected = 0
736         loop
737            Pack := Inlined_Bodies.Table (J);
738            while Present (Pack)
739              and then Scope (Pack) /= Standard_Standard
740              and then not Is_Child_Unit (Pack)
741            loop
742               Pack := Scope (Pack);
743            end loop;
744
745            Comp_Unit := Parent (Pack);
746            while Present (Comp_Unit)
747              and then Nkind (Comp_Unit) /= N_Compilation_Unit
748            loop
749               Comp_Unit := Parent (Comp_Unit);
750            end loop;
751
752            --  Load the body if it exists and contains inlineable entities,
753            --  unless it is the main unit, or is an instance whose body has
754            --  already been analyzed.
755
756            if Present (Comp_Unit)
757              and then Comp_Unit /= Cunit (Main_Unit)
758              and then Body_Required (Comp_Unit)
759              and then
760                (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
761                  or else
762                    (No (Corresponding_Body (Unit (Comp_Unit)))
763                      and then Body_Needed_For_Inlining
764                                 (Defining_Entity (Unit (Comp_Unit)))))
765            then
766               declare
767                  Bname : constant Unit_Name_Type :=
768                            Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
769
770                  OK : Boolean;
771
772               begin
773                  if not Is_Loaded (Bname) then
774                     Style_Check := False;
775                     Load_Needed_Body (Comp_Unit, OK);
776
777                     if not OK then
778
779                        --  Warn that a body was not available for inlining
780                        --  by the back-end.
781
782                        Error_Msg_Unit_1 := Bname;
783                        Error_Msg_N
784                          ("one or more inlined subprograms accessed in $!??",
785                           Comp_Unit);
786                        Error_Msg_File_1 :=
787                          Get_File_Name (Bname, Subunit => False);
788                        Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
789                     end if;
790                  end if;
791               end;
792            end if;
793
794            J := J + 1;
795
796            if J > Inlined_Bodies.Last then
797
798               --  The analysis of required bodies may have produced additional
799               --  generic instantiations. To obtain further inlining, we need
800               --  to perform another round of generic body instantiations.
801
802               Instantiate_Bodies;
803
804               --  Symmetrically, the instantiation of required generic bodies
805               --  may have caused additional bodies to be inlined. To obtain
806               --  further inlining, we keep looping over the inlined bodies.
807            end if;
808         end loop;
809
810         --  The list of inlined subprograms is an overestimate, because it
811         --  includes inlined functions called from functions that are compiled
812         --  as part of an inlined package, but are not themselves called. An
813         --  accurate computation of just those subprograms that are needed
814         --  requires that we perform a transitive closure over the call graph,
815         --  starting from calls in the main compilation unit.
816
817         for Index in Inlined.First .. Inlined.Last loop
818            if not Is_Called (Inlined.Table (Index).Name) then
819
820               --  This means that Add_Inlined_Body added the subprogram to the
821               --  table but wasn't able to handle its code unit. Do nothing.
822
823               Inlined.Table (Index).Processed := True;
824
825            elsif Inlined.Table (Index).Main_Call then
826               Pending_Inlined.Increment_Last;
827               Pending_Inlined.Table (Pending_Inlined.Last) := Index;
828               Inlined.Table (Index).Processed := True;
829
830            else
831               Set_Is_Called (Inlined.Table (Index).Name, False);
832            end if;
833         end loop;
834
835         --  Iterate over the workpile until it is emptied, propagating the
836         --  Is_Called flag to the successors of the processed subprogram.
837
838         while Pending_Inlined.Last >= Pending_Inlined.First loop
839            Subp := Pending_Inlined.Table (Pending_Inlined.Last);
840            Pending_Inlined.Decrement_Last;
841
842            S := Inlined.Table (Subp).First_Succ;
843
844            while S /= No_Succ loop
845               Subp := Successors.Table (S).Subp;
846
847               if not Inlined.Table (Subp).Processed then
848                  Set_Is_Called (Inlined.Table (Subp).Name);
849                  Pending_Inlined.Increment_Last;
850                  Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
851                  Inlined.Table (Subp).Processed := True;
852               end if;
853
854               S := Successors.Table (S).Next;
855            end loop;
856         end loop;
857
858         --  Finally add the called subprograms to the list of inlined
859         --  subprograms for the unit.
860
861         for Index in Inlined.First .. Inlined.Last loop
862            if Is_Called (Inlined.Table (Index).Name) then
863               Add_Inlined_Subprogram (Inlined.Table (Index).Name);
864            end if;
865         end loop;
866
867         Pop_Scope;
868      end if;
869   end Analyze_Inlined_Bodies;
870
871   --------------------------
872   -- Build_Body_To_Inline --
873   --------------------------
874
875   procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
876      Decl            : constant Node_Id := Unit_Declaration_Node (Spec_Id);
877      Analysis_Status : constant Boolean := Full_Analysis;
878      Original_Body   : Node_Id;
879      Body_To_Analyze : Node_Id;
880      Max_Size        : constant := 10;
881
882      function Has_Pending_Instantiation return Boolean;
883      --  If some enclosing body contains instantiations that appear before
884      --  the corresponding generic body, the enclosing body has a freeze node
885      --  so that it can be elaborated after the generic itself. This might
886      --  conflict with subsequent inlinings, so that it is unsafe to try to
887      --  inline in such a case.
888
889      function Has_Single_Return_In_GNATprove_Mode return Boolean;
890      --  This function is called only in GNATprove mode, and it returns
891      --  True if the subprogram has no return statement or a single return
892      --  statement as last statement. It returns False for subprogram with
893      --  a single return as last statement inside one or more blocks, as
894      --  inlining would generate gotos in that case as well (although the
895      --  goto is useless in that case).
896
897      function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
898      --  If the body of the subprogram includes a call that returns an
899      --  unconstrained type, the secondary stack is involved, and it
900      --  is not worth inlining.
901
902      -------------------------------
903      -- Has_Pending_Instantiation --
904      -------------------------------
905
906      function Has_Pending_Instantiation return Boolean is
907         S : Entity_Id;
908
909      begin
910         S := Current_Scope;
911         while Present (S) loop
912            if Is_Compilation_Unit (S)
913              or else Is_Child_Unit (S)
914            then
915               return False;
916
917            elsif Ekind (S) = E_Package
918              and then Has_Forward_Instantiation (S)
919            then
920               return True;
921            end if;
922
923            S := Scope (S);
924         end loop;
925
926         return False;
927      end Has_Pending_Instantiation;
928
929      -----------------------------------------
930      -- Has_Single_Return_In_GNATprove_Mode --
931      -----------------------------------------
932
933      function Has_Single_Return_In_GNATprove_Mode return Boolean is
934         Body_To_Inline : constant Node_Id := N;
935         Last_Statement : Node_Id := Empty;
936
937         function Check_Return (N : Node_Id) return Traverse_Result;
938         --  Returns OK on node N if this is not a return statement different
939         --  from the last statement in the subprogram.
940
941         ------------------
942         -- Check_Return --
943         ------------------
944
945         function Check_Return (N : Node_Id) return Traverse_Result is
946         begin
947            case Nkind (N) is
948               when N_Extended_Return_Statement
949                  | N_Simple_Return_Statement
950               =>
951                  if N = Last_Statement then
952                     return OK;
953                  else
954                     return Abandon;
955                  end if;
956
957               --  Skip locally declared subprogram bodies inside the body to
958               --  inline, as the return statements inside those do not count.
959
960               when N_Subprogram_Body =>
961                  if N = Body_To_Inline then
962                     return OK;
963                  else
964                     return Skip;
965                  end if;
966
967               when others =>
968                  return OK;
969            end case;
970         end Check_Return;
971
972         function Check_All_Returns is new Traverse_Func (Check_Return);
973
974      --  Start of processing for Has_Single_Return_In_GNATprove_Mode
975
976      begin
977         --  Retrieve the last statement
978
979         Last_Statement := Last (Statements (Handled_Statement_Sequence (N)));
980
981         --  Check that the last statement is the only possible return
982         --  statement in the subprogram.
983
984         return Check_All_Returns (N) = OK;
985      end Has_Single_Return_In_GNATprove_Mode;
986
987      --------------------------
988      -- Uses_Secondary_Stack --
989      --------------------------
990
991      function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
992         function Check_Call (N : Node_Id) return Traverse_Result;
993         --  Look for function calls that return an unconstrained type
994
995         ----------------
996         -- Check_Call --
997         ----------------
998
999         function Check_Call (N : Node_Id) return Traverse_Result is
1000         begin
1001            if Nkind (N) = N_Function_Call
1002              and then Is_Entity_Name (Name (N))
1003              and then Is_Composite_Type (Etype (Entity (Name (N))))
1004              and then not Is_Constrained (Etype (Entity (Name (N))))
1005            then
1006               Cannot_Inline
1007                 ("cannot inline & (call returns unconstrained type)?",
1008                  N, Spec_Id);
1009               return Abandon;
1010            else
1011               return OK;
1012            end if;
1013         end Check_Call;
1014
1015         function Check_Calls is new Traverse_Func (Check_Call);
1016
1017      begin
1018         return Check_Calls (Bod) = Abandon;
1019      end Uses_Secondary_Stack;
1020
1021   --  Start of processing for Build_Body_To_Inline
1022
1023   begin
1024      --  Return immediately if done already
1025
1026      if Nkind (Decl) = N_Subprogram_Declaration
1027        and then Present (Body_To_Inline (Decl))
1028      then
1029         return;
1030
1031      --  Subprograms that have return statements in the middle of the body are
1032      --  inlined with gotos. GNATprove does not currently support gotos, so
1033      --  we prevent such inlining.
1034
1035      elsif GNATprove_Mode
1036        and then not Has_Single_Return_In_GNATprove_Mode
1037      then
1038         Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
1039         return;
1040
1041      --  Functions that return unconstrained composite types require
1042      --  secondary stack handling, and cannot currently be inlined, unless
1043      --  all return statements return a local variable that is the first
1044      --  local declaration in the body.
1045
1046      elsif Ekind (Spec_Id) = E_Function
1047        and then not Is_Scalar_Type (Etype (Spec_Id))
1048        and then not Is_Access_Type (Etype (Spec_Id))
1049        and then not Is_Constrained (Etype (Spec_Id))
1050      then
1051         if not Has_Single_Return (N) then
1052            Cannot_Inline
1053              ("cannot inline & (unconstrained return type)?", N, Spec_Id);
1054            return;
1055         end if;
1056
1057      --  Ditto for functions that return controlled types, where controlled
1058      --  actions interfere in complex ways with inlining.
1059
1060      elsif Ekind (Spec_Id) = E_Function
1061        and then Needs_Finalization (Etype (Spec_Id))
1062      then
1063         Cannot_Inline
1064           ("cannot inline & (controlled return type)?", N, Spec_Id);
1065         return;
1066      end if;
1067
1068      if Present (Declarations (N))
1069        and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
1070      then
1071         return;
1072      end if;
1073
1074      if Present (Handled_Statement_Sequence (N)) then
1075         if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1076            Cannot_Inline
1077              ("cannot inline& (exception handler)?",
1078               First (Exception_Handlers (Handled_Statement_Sequence (N))),
1079               Spec_Id);
1080            return;
1081
1082         elsif Has_Excluded_Statement
1083                 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
1084         then
1085            return;
1086         end if;
1087      end if;
1088
1089      --  We do not inline a subprogram that is too large, unless it is marked
1090      --  Inline_Always or we are in GNATprove mode. This pragma does not
1091      --  suppress the other checks on inlining (forbidden declarations,
1092      --  handlers, etc).
1093
1094      if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode)
1095        and then List_Length
1096                   (Statements (Handled_Statement_Sequence (N))) > Max_Size
1097      then
1098         Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id);
1099         return;
1100      end if;
1101
1102      if Has_Pending_Instantiation then
1103         Cannot_Inline
1104           ("cannot inline& (forward instance within enclosing body)?",
1105             N, Spec_Id);
1106         return;
1107      end if;
1108
1109      --  Within an instance, the body to inline must be treated as a nested
1110      --  generic, so that the proper global references are preserved.
1111
1112      --  Note that we do not do this at the library level, because it is not
1113      --  needed, and furthermore this causes trouble if front-end inlining
1114      --  is activated (-gnatN).
1115
1116      if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1117         Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1118         Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True);
1119      else
1120         Original_Body := Copy_Separate_Tree (N);
1121      end if;
1122
1123      --  We need to capture references to the formals in order to substitute
1124      --  the actuals at the point of inlining, i.e. instantiation. To treat
1125      --  the formals as globals to the body to inline, we nest it within a
1126      --  dummy parameterless subprogram, declared within the real one. To
1127      --  avoid generating an internal name (which is never public, and which
1128      --  affects serial numbers of other generated names), we use an internal
1129      --  symbol that cannot conflict with user declarations.
1130
1131      Set_Parameter_Specifications (Specification (Original_Body), No_List);
1132      Set_Defining_Unit_Name
1133        (Specification (Original_Body),
1134         Make_Defining_Identifier (Sloc (N), Name_uParent));
1135      Set_Corresponding_Spec (Original_Body, Empty);
1136
1137      --  Remove all aspects/pragmas that have no meaning in an inlined body
1138
1139      Remove_Aspects_And_Pragmas (Original_Body);
1140
1141      Body_To_Analyze :=
1142        Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
1143
1144      --  Set return type of function, which is also global and does not need
1145      --  to be resolved.
1146
1147      if Ekind (Spec_Id) = E_Function then
1148         Set_Result_Definition
1149           (Specification (Body_To_Analyze),
1150            New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1151      end if;
1152
1153      if No (Declarations (N)) then
1154         Set_Declarations (N, New_List (Body_To_Analyze));
1155      else
1156         Append (Body_To_Analyze, Declarations (N));
1157      end if;
1158
1159      --  The body to inline is pre-analyzed. In GNATprove mode we must disable
1160      --  full analysis as well so that light expansion does not take place
1161      --  either, and name resolution is unaffected.
1162
1163      Expander_Mode_Save_And_Set (False);
1164      Full_Analysis := False;
1165
1166      Analyze (Body_To_Analyze);
1167      Push_Scope (Defining_Entity (Body_To_Analyze));
1168      Save_Global_References (Original_Body);
1169      End_Scope;
1170      Remove (Body_To_Analyze);
1171
1172      Expander_Mode_Restore;
1173      Full_Analysis := Analysis_Status;
1174
1175      --  Restore environment if previously saved
1176
1177      if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1178         Restore_Env;
1179      end if;
1180
1181      --  If secondary stack is used, there is no point in inlining. We have
1182      --  already issued the warning in this case, so nothing to do.
1183
1184      if Uses_Secondary_Stack (Body_To_Analyze) then
1185         return;
1186      end if;
1187
1188      Set_Body_To_Inline (Decl, Original_Body);
1189      Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1190      Set_Is_Inlined (Spec_Id);
1191   end Build_Body_To_Inline;
1192
1193   -------------------------------------------
1194   -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1195   -------------------------------------------
1196
1197   function Call_Can_Be_Inlined_In_GNATprove_Mode
1198    (N    : Node_Id;
1199     Subp : Entity_Id) return Boolean
1200   is
1201      F : Entity_Id;
1202      A : Node_Id;
1203
1204   begin
1205      F := First_Formal (Subp);
1206      A := First_Actual (N);
1207      while Present (F) loop
1208         if Ekind (F) /= E_Out_Parameter
1209           and then not Same_Type (Etype (F), Etype (A))
1210           and then
1211             (Is_By_Reference_Type (Etype (A))
1212               or else Is_Limited_Type (Etype (A)))
1213         then
1214            return False;
1215         end if;
1216
1217         Next_Formal (F);
1218         Next_Actual (A);
1219      end loop;
1220
1221      return True;
1222   end Call_Can_Be_Inlined_In_GNATprove_Mode;
1223
1224   --------------------------------------
1225   -- Can_Be_Inlined_In_GNATprove_Mode --
1226   --------------------------------------
1227
1228   function Can_Be_Inlined_In_GNATprove_Mode
1229     (Spec_Id : Entity_Id;
1230      Body_Id : Entity_Id) return Boolean
1231   is
1232      function Has_Formal_With_Discriminant_Dependent_Fields
1233        (Id : Entity_Id) return Boolean;
1234      --  Returns true if the subprogram has at least one formal parameter of
1235      --  an unconstrained record type with per-object constraints on component
1236      --  types.
1237
1238      function Has_Some_Contract (Id : Entity_Id) return Boolean;
1239      --  Return True if subprogram Id has any contract. The presence of
1240      --  Extensions_Visible or Volatile_Function is also considered as a
1241      --  contract here.
1242
1243      function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
1244      --  Return True if subprogram Id defines a compilation unit
1245      --  Shouldn't this be in Sem_Aux???
1246
1247      function In_Package_Spec (Id : Entity_Id) return Boolean;
1248      --  Return True if subprogram Id is defined in the package specification,
1249      --  either its visible or private part.
1250
1251      ---------------------------------------------------
1252      -- Has_Formal_With_Discriminant_Dependent_Fields --
1253      ---------------------------------------------------
1254
1255      function Has_Formal_With_Discriminant_Dependent_Fields
1256        (Id : Entity_Id) return Boolean
1257      is
1258         function Has_Discriminant_Dependent_Component
1259           (Typ : Entity_Id) return Boolean;
1260         --  Determine whether unconstrained record type Typ has at least one
1261         --  component that depends on a discriminant.
1262
1263         ------------------------------------------
1264         -- Has_Discriminant_Dependent_Component --
1265         ------------------------------------------
1266
1267         function Has_Discriminant_Dependent_Component
1268           (Typ : Entity_Id) return Boolean
1269         is
1270            Comp : Entity_Id;
1271
1272         begin
1273            --  Inspect all components of the record type looking for one that
1274            --  depends on a discriminant.
1275
1276            Comp := First_Component (Typ);
1277            while Present (Comp) loop
1278               if Has_Discriminant_Dependent_Constraint (Comp) then
1279                  return True;
1280               end if;
1281
1282               Next_Component (Comp);
1283            end loop;
1284
1285            return False;
1286         end Has_Discriminant_Dependent_Component;
1287
1288         --  Local variables
1289
1290         Subp_Id    : constant Entity_Id := Ultimate_Alias (Id);
1291         Formal     : Entity_Id;
1292         Formal_Typ : Entity_Id;
1293
1294      --  Start of processing for
1295      --  Has_Formal_With_Discriminant_Dependent_Fields
1296
1297      begin
1298         --  Inspect all parameters of the subprogram looking for a formal
1299         --  of an unconstrained record type with at least one discriminant
1300         --  dependent component.
1301
1302         Formal := First_Formal (Subp_Id);
1303         while Present (Formal) loop
1304            Formal_Typ := Etype (Formal);
1305
1306            if Is_Record_Type (Formal_Typ)
1307              and then not Is_Constrained (Formal_Typ)
1308              and then Has_Discriminant_Dependent_Component (Formal_Typ)
1309            then
1310               return True;
1311            end if;
1312
1313            Next_Formal (Formal);
1314         end loop;
1315
1316         return False;
1317      end Has_Formal_With_Discriminant_Dependent_Fields;
1318
1319      -----------------------
1320      -- Has_Some_Contract --
1321      -----------------------
1322
1323      function Has_Some_Contract (Id : Entity_Id) return Boolean is
1324         Items : Node_Id;
1325
1326      begin
1327         --  A call to an expression function may precede the actual body which
1328         --  is inserted at the end of the enclosing declarations. Ensure that
1329         --  the related entity is decorated before inspecting the contract.
1330
1331         if Is_Subprogram_Or_Generic_Subprogram (Id) then
1332            Items := Contract (Id);
1333
1334            --  Note that Classifications is not Empty when Extensions_Visible
1335            --  or Volatile_Function is present, which causes such subprograms
1336            --  to be considered to have a contract here. This is fine as we
1337            --  want to avoid inlining these too.
1338
1339            return Present (Items)
1340              and then (Present (Pre_Post_Conditions (Items)) or else
1341                        Present (Contract_Test_Cases (Items)) or else
1342                        Present (Classifications     (Items)));
1343         end if;
1344
1345         return False;
1346      end Has_Some_Contract;
1347
1348      ---------------------
1349      -- In_Package_Spec --
1350      ---------------------
1351
1352      function In_Package_Spec (Id : Entity_Id) return Boolean is
1353         P : constant Node_Id := Parent (Subprogram_Spec (Id));
1354         --  Parent of the subprogram's declaration
1355
1356      begin
1357         return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
1358      end In_Package_Spec;
1359
1360      ------------------------
1361      -- Is_Unit_Subprogram --
1362      ------------------------
1363
1364      function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1365         Decl : Node_Id := Parent (Parent (Id));
1366      begin
1367         if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1368            Decl := Parent (Decl);
1369         end if;
1370
1371         return Nkind (Parent (Decl)) = N_Compilation_Unit;
1372      end Is_Unit_Subprogram;
1373
1374      --  Local declarations
1375
1376      Id : Entity_Id;
1377      --  Procedure or function entity for the subprogram
1378
1379   --  Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1380
1381   begin
1382      pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1383
1384      if Present (Spec_Id) then
1385         Id := Spec_Id;
1386      else
1387         Id := Body_Id;
1388      end if;
1389
1390      --  Only local subprograms without contracts are inlined in GNATprove
1391      --  mode, as these are the subprograms which a user is not interested in
1392      --  analyzing in isolation, but rather in the context of their call. This
1393      --  is a convenient convention, that could be changed for an explicit
1394      --  pragma/aspect one day.
1395
1396      --  In a number of special cases, inlining is not desirable or not
1397      --  possible, see below.
1398
1399      --  Do not inline unit-level subprograms
1400
1401      if Is_Unit_Subprogram (Id) then
1402         return False;
1403
1404      --  Do not inline subprograms declared in package specs, because they are
1405      --  not local, i.e. can be called either from anywhere (if declared in
1406      --  visible part) or from the child units (if declared in private part).
1407
1408      elsif In_Package_Spec (Id) then
1409         return False;
1410
1411      --  Do not inline subprograms declared in other units. This is important
1412      --  in particular for subprograms defined in the private part of a
1413      --  package spec, when analyzing one of its child packages, as otherwise
1414      --  we issue spurious messages about the impossibility to inline such
1415      --  calls.
1416
1417      elsif not In_Extended_Main_Code_Unit (Id) then
1418         return False;
1419
1420      --  Do not inline subprograms marked No_Return, possibly used for
1421      --  signaling errors, which GNATprove handles specially.
1422
1423      elsif No_Return (Id) then
1424         return False;
1425
1426      --  Do not inline subprograms that have a contract on the spec or the
1427      --  body. Use the contract(s) instead in GNATprove. This also prevents
1428      --  inlining of subprograms with Extensions_Visible or Volatile_Function.
1429
1430      elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1431               or else
1432            (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1433      then
1434         return False;
1435
1436      --  Do not inline expression functions, which are directly inlined at the
1437      --  prover level.
1438
1439      elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1440              or else
1441            (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1442      then
1443         return False;
1444
1445      --  Do not inline generic subprogram instances. The visibility rules of
1446      --  generic instances plays badly with inlining.
1447
1448      elsif Is_Generic_Instance (Spec_Id) then
1449         return False;
1450
1451      --  Only inline subprograms whose spec is marked SPARK_Mode On. For
1452      --  the subprogram body, a similar check is performed after the body
1453      --  is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1454
1455      elsif Present (Spec_Id)
1456        and then
1457          (No (SPARK_Pragma (Spec_Id))
1458            or else
1459           Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
1460      then
1461         return False;
1462
1463      --  Subprograms in generic instances are currently not inlined, to avoid
1464      --  problems with inlining of standard library subprograms.
1465
1466      elsif Instantiation_Location (Sloc (Id)) /= No_Location then
1467         return False;
1468
1469      --  Do not inline subprograms and entries defined inside protected types,
1470      --  which typically are not helper subprograms, which also avoids getting
1471      --  spurious messages on calls that cannot be inlined.
1472
1473      elsif Within_Protected_Type (Id) then
1474         return False;
1475
1476      --  Do not inline predicate functions (treated specially by GNATprove)
1477
1478      elsif Is_Predicate_Function (Id) then
1479         return False;
1480
1481      --  Do not inline subprograms with a parameter of an unconstrained
1482      --  record type if it has discrimiant dependent fields. Indeed, with
1483      --  such parameters, the frontend cannot always ensure type compliance
1484      --  in record component accesses (in particular with records containing
1485      --  packed arrays).
1486
1487      elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
1488         return False;
1489
1490      --  Otherwise, this is a subprogram declared inside the private part of a
1491      --  package, or inside a package body, or locally in a subprogram, and it
1492      --  does not have any contract. Inline it.
1493
1494      else
1495         return True;
1496      end if;
1497   end Can_Be_Inlined_In_GNATprove_Mode;
1498
1499   -------------------
1500   -- Cannot_Inline --
1501   -------------------
1502
1503   procedure Cannot_Inline
1504     (Msg        : String;
1505      N          : Node_Id;
1506      Subp       : Entity_Id;
1507      Is_Serious : Boolean := False)
1508   is
1509   begin
1510      --  In GNATprove mode, inlining is the technical means by which the
1511      --  higher-level goal of contextual analysis is reached, so issue
1512      --  messages about failure to apply contextual analysis to a
1513      --  subprogram, rather than failure to inline it.
1514
1515      if GNATprove_Mode
1516        and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1517      then
1518         declare
1519            Len1 : constant Positive :=
1520              String (String'("cannot inline"))'Length;
1521            Len2 : constant Positive :=
1522              String (String'("info: no contextual analysis of"))'Length;
1523
1524            New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1525
1526         begin
1527            New_Msg (1 .. Len2) := "info: no contextual analysis of";
1528            New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1529              Msg (Msg'First + Len1 .. Msg'Last);
1530            Cannot_Inline (New_Msg, N, Subp, Is_Serious);
1531            return;
1532         end;
1533      end if;
1534
1535      pragma Assert (Msg (Msg'Last) = '?');
1536
1537      --  Legacy front-end inlining model
1538
1539      if not Back_End_Inlining then
1540
1541         --  Do not emit warning if this is a predefined unit which is not
1542         --  the main unit. With validity checks enabled, some predefined
1543         --  subprograms may contain nested subprograms and become ineligible
1544         --  for inlining.
1545
1546         if Is_Predefined_Unit (Get_Source_Unit (Subp))
1547           and then not In_Extended_Main_Source_Unit (Subp)
1548         then
1549            null;
1550
1551         --  In GNATprove mode, issue a warning, and indicate that the
1552         --  subprogram is not always inlined by setting flag Is_Inlined_Always
1553         --  to False.
1554
1555         elsif GNATprove_Mode then
1556            Set_Is_Inlined_Always (Subp, False);
1557            Error_Msg_NE (Msg & "p?", N, Subp);
1558
1559         elsif Has_Pragma_Inline_Always (Subp) then
1560
1561            --  Remove last character (question mark) to make this into an
1562            --  error, because the Inline_Always pragma cannot be obeyed.
1563
1564            Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1565
1566         elsif Ineffective_Inline_Warnings then
1567            Error_Msg_NE (Msg & "p?", N, Subp);
1568         end if;
1569
1570      --  New semantics relying on back-end inlining
1571
1572      elsif Is_Serious then
1573
1574         --  Remove last character (question mark) to make this into an error.
1575
1576         Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1577
1578      --  In GNATprove mode, issue a warning, and indicate that the subprogram
1579      --  is not always inlined by setting flag Is_Inlined_Always to False.
1580
1581      elsif GNATprove_Mode then
1582         Set_Is_Inlined_Always (Subp, False);
1583         Error_Msg_NE (Msg & "p?", N, Subp);
1584
1585      else
1586
1587         --  Do not emit warning if this is a predefined unit which is not
1588         --  the main unit. This behavior is currently provided for backward
1589         --  compatibility but it will be removed when we enforce the
1590         --  strictness of the new rules.
1591
1592         if Is_Predefined_Unit (Get_Source_Unit (Subp))
1593           and then not In_Extended_Main_Source_Unit (Subp)
1594         then
1595            null;
1596
1597         elsif Has_Pragma_Inline_Always (Subp) then
1598
1599            --  Emit a warning if this is a call to a runtime subprogram
1600            --  which is located inside a generic. Previously this call
1601            --  was silently skipped.
1602
1603            if Is_Generic_Instance (Subp) then
1604               declare
1605                  Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
1606               begin
1607                  if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then
1608                     Set_Is_Inlined (Subp, False);
1609                     Error_Msg_NE (Msg & "p?", N, Subp);
1610                     return;
1611                  end if;
1612               end;
1613            end if;
1614
1615            --  Remove last character (question mark) to make this into an
1616            --  error, because the Inline_Always pragma cannot be obeyed.
1617
1618            Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1619
1620         else
1621            Set_Is_Inlined (Subp, False);
1622
1623            if Ineffective_Inline_Warnings then
1624               Error_Msg_NE (Msg & "p?", N, Subp);
1625            end if;
1626         end if;
1627      end if;
1628   end Cannot_Inline;
1629
1630   --------------------------------------------
1631   -- Check_And_Split_Unconstrained_Function --
1632   --------------------------------------------
1633
1634   procedure Check_And_Split_Unconstrained_Function
1635     (N       : Node_Id;
1636      Spec_Id : Entity_Id;
1637      Body_Id : Entity_Id)
1638   is
1639      procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
1640      --  Use generic machinery to build an unexpanded body for the subprogram.
1641      --  This body is subsequently used for inline expansions at call sites.
1642
1643      function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
1644      --  Return true if we generate code for the function body N, the function
1645      --  body N has no local declarations and its unique statement is a single
1646      --  extended return statement with a handled statements sequence.
1647
1648      procedure Split_Unconstrained_Function
1649        (N       : Node_Id;
1650         Spec_Id : Entity_Id);
1651      --  N is an inlined function body that returns an unconstrained type and
1652      --  has a single extended return statement. Split N in two subprograms:
1653      --  a procedure P' and a function F'. The formals of P' duplicate the
1654      --  formals of N plus an extra formal which is used to return a value;
1655      --  its body is composed by the declarations and list of statements
1656      --  of the extended return statement of N.
1657
1658      --------------------------
1659      -- Build_Body_To_Inline --
1660      --------------------------
1661
1662      procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1663         procedure Generate_Subprogram_Body
1664           (N              : Node_Id;
1665            Body_To_Inline : out Node_Id);
1666         --  Generate a parameterless duplicate of subprogram body N. Note that
1667         --  occurrences of pragmas referencing the formals are removed since
1668         --  they have no meaning when the body is inlined and the formals are
1669         --  rewritten (the analysis of the non-inlined body will handle these
1670         --  pragmas).  A new internal name is associated with Body_To_Inline.
1671
1672         -----------------------------
1673         -- Generate_Body_To_Inline --
1674         -----------------------------
1675
1676         procedure Generate_Subprogram_Body
1677           (N              : Node_Id;
1678            Body_To_Inline : out Node_Id)
1679         is
1680         begin
1681            --  Within an instance, the body to inline must be treated as a
1682            --  nested generic so that proper global references are preserved.
1683
1684            --  Note that we do not do this at the library level, because it
1685            --  is not needed, and furthermore this causes trouble if front
1686            --  end inlining is activated (-gnatN).
1687
1688            if In_Instance
1689              and then Scope (Current_Scope) /= Standard_Standard
1690            then
1691               Body_To_Inline :=
1692                 Copy_Generic_Node (N, Empty, Instantiating => True);
1693            else
1694               Body_To_Inline := Copy_Separate_Tree (N);
1695            end if;
1696
1697            --  Remove aspects/pragmas that have no meaning in an inlined body
1698
1699            Remove_Aspects_And_Pragmas (Body_To_Inline);
1700
1701            --  We need to capture references to the formals in order
1702            --  to substitute the actuals at the point of inlining, i.e.
1703            --  instantiation. To treat the formals as globals to the body to
1704            --  inline, we nest it within a dummy parameterless subprogram,
1705            --  declared within the real one.
1706
1707            Set_Parameter_Specifications
1708              (Specification (Body_To_Inline), No_List);
1709
1710            --  A new internal name is associated with Body_To_Inline to avoid
1711            --  conflicts when the non-inlined body N is analyzed.
1712
1713            Set_Defining_Unit_Name (Specification (Body_To_Inline),
1714               Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P')));
1715            Set_Corresponding_Spec (Body_To_Inline, Empty);
1716         end Generate_Subprogram_Body;
1717
1718         --  Local variables
1719
1720         Decl            : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1721         Original_Body   : Node_Id;
1722         Body_To_Analyze : Node_Id;
1723
1724      begin
1725         pragma Assert (Current_Scope = Spec_Id);
1726
1727         --  Within an instance, the body to inline must be treated as a nested
1728         --  generic, so that the proper global references are preserved. We
1729         --  do not do this at the library level, because it is not needed, and
1730         --  furthermore this causes trouble if front-end inlining is activated
1731         --  (-gnatN).
1732
1733         if In_Instance
1734           and then Scope (Current_Scope) /= Standard_Standard
1735         then
1736            Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1737         end if;
1738
1739         --  Capture references to formals in order to substitute the actuals
1740         --  at the point of inlining or instantiation. To treat the formals
1741         --  as globals to the body to inline, nest the body within a dummy
1742         --  parameterless subprogram, declared within the real one.
1743
1744         Generate_Subprogram_Body (N, Original_Body);
1745         Body_To_Analyze :=
1746           Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
1747
1748         --  Set return type of function, which is also global and does not
1749         --  need to be resolved.
1750
1751         if Ekind (Spec_Id) = E_Function then
1752            Set_Result_Definition (Specification (Body_To_Analyze),
1753              New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1754         end if;
1755
1756         if No (Declarations (N)) then
1757            Set_Declarations (N, New_List (Body_To_Analyze));
1758         else
1759            Append_To (Declarations (N), Body_To_Analyze);
1760         end if;
1761
1762         Preanalyze (Body_To_Analyze);
1763
1764         Push_Scope (Defining_Entity (Body_To_Analyze));
1765         Save_Global_References (Original_Body);
1766         End_Scope;
1767         Remove (Body_To_Analyze);
1768
1769         --  Restore environment if previously saved
1770
1771         if In_Instance
1772           and then Scope (Current_Scope) /= Standard_Standard
1773         then
1774            Restore_Env;
1775         end if;
1776
1777         pragma Assert (No (Body_To_Inline (Decl)));
1778         Set_Body_To_Inline (Decl, Original_Body);
1779         Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1780      end Build_Body_To_Inline;
1781
1782      --------------------------------------
1783      -- Can_Split_Unconstrained_Function --
1784      --------------------------------------
1785
1786      function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is
1787         Ret_Node : constant Node_Id :=
1788                      First (Statements (Handled_Statement_Sequence (N)));
1789         D : Node_Id;
1790
1791      begin
1792         --  No user defined declarations allowed in the function except inside
1793         --  the unique return statement; implicit labels are the only allowed
1794         --  declarations.
1795
1796         if not Is_Empty_List (Declarations (N)) then
1797            D := First (Declarations (N));
1798            while Present (D) loop
1799               if Nkind (D) /= N_Implicit_Label_Declaration then
1800                  return False;
1801               end if;
1802
1803               Next (D);
1804            end loop;
1805         end if;
1806
1807         --  We only split the inlined function when we are generating the code
1808         --  of its body; otherwise we leave duplicated split subprograms in
1809         --  the tree which (if referenced) generate wrong references at link
1810         --  time.
1811
1812         return In_Extended_Main_Code_Unit (N)
1813           and then Present (Ret_Node)
1814           and then Nkind (Ret_Node) = N_Extended_Return_Statement
1815           and then No (Next (Ret_Node))
1816           and then Present (Handled_Statement_Sequence (Ret_Node));
1817      end Can_Split_Unconstrained_Function;
1818
1819      ----------------------------------
1820      -- Split_Unconstrained_Function --
1821      ----------------------------------
1822
1823      procedure Split_Unconstrained_Function
1824        (N        : Node_Id;
1825         Spec_Id  : Entity_Id)
1826      is
1827         Loc      : constant Source_Ptr := Sloc (N);
1828         Ret_Node : constant Node_Id :=
1829                      First (Statements (Handled_Statement_Sequence (N)));
1830         Ret_Obj  : constant Node_Id :=
1831                      First (Return_Object_Declarations (Ret_Node));
1832
1833         procedure Build_Procedure
1834           (Proc_Id   : out Entity_Id;
1835            Decl_List : out List_Id);
1836         --  Build a procedure containing the statements found in the extended
1837         --  return statement of the unconstrained function body N.
1838
1839         ---------------------
1840         -- Build_Procedure --
1841         ---------------------
1842
1843         procedure Build_Procedure
1844           (Proc_Id   : out Entity_Id;
1845            Decl_List : out List_Id)
1846         is
1847            Formal         : Entity_Id;
1848            Formal_List    : constant List_Id := New_List;
1849            Proc_Spec      : Node_Id;
1850            Proc_Body      : Node_Id;
1851            Subp_Name      : constant Name_Id := New_Internal_Name ('F');
1852            Body_Decl_List : List_Id := No_List;
1853            Param_Type     : Node_Id;
1854
1855         begin
1856            if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then
1857               Param_Type :=
1858                 New_Copy (Object_Definition (Ret_Obj));
1859            else
1860               Param_Type :=
1861                 New_Copy (Subtype_Mark (Object_Definition (Ret_Obj)));
1862            end if;
1863
1864            Append_To (Formal_List,
1865              Make_Parameter_Specification (Loc,
1866                Defining_Identifier    =>
1867                  Make_Defining_Identifier (Loc,
1868                    Chars => Chars (Defining_Identifier (Ret_Obj))),
1869                In_Present             => False,
1870                Out_Present            => True,
1871                Null_Exclusion_Present => False,
1872                Parameter_Type         => Param_Type));
1873
1874            Formal := First_Formal (Spec_Id);
1875
1876            --  Note that we copy the parameter type rather than creating
1877            --  a reference to it, because it may be a class-wide entity
1878            --  that will not be retrieved by name.
1879
1880            while Present (Formal) loop
1881               Append_To (Formal_List,
1882                 Make_Parameter_Specification (Loc,
1883                   Defining_Identifier    =>
1884                     Make_Defining_Identifier (Sloc (Formal),
1885                       Chars => Chars (Formal)),
1886                   In_Present             => In_Present (Parent (Formal)),
1887                   Out_Present            => Out_Present (Parent (Formal)),
1888                   Null_Exclusion_Present =>
1889                     Null_Exclusion_Present (Parent (Formal)),
1890                   Parameter_Type         =>
1891                     New_Copy_Tree (Parameter_Type (Parent (Formal))),
1892                   Expression             =>
1893                     Copy_Separate_Tree (Expression (Parent (Formal)))));
1894
1895               Next_Formal (Formal);
1896            end loop;
1897
1898            Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
1899
1900            Proc_Spec :=
1901              Make_Procedure_Specification (Loc,
1902                Defining_Unit_Name       => Proc_Id,
1903                Parameter_Specifications => Formal_List);
1904
1905            Decl_List := New_List;
1906
1907            Append_To (Decl_List,
1908              Make_Subprogram_Declaration (Loc, Proc_Spec));
1909
1910            --  Can_Convert_Unconstrained_Function checked that the function
1911            --  has no local declarations except implicit label declarations.
1912            --  Copy these declarations to the built procedure.
1913
1914            if Present (Declarations (N)) then
1915               Body_Decl_List := New_List;
1916
1917               declare
1918                  D     : Node_Id;
1919                  New_D : Node_Id;
1920
1921               begin
1922                  D := First (Declarations (N));
1923                  while Present (D) loop
1924                     pragma Assert (Nkind (D) = N_Implicit_Label_Declaration);
1925
1926                     New_D :=
1927                       Make_Implicit_Label_Declaration (Loc,
1928                         Make_Defining_Identifier (Loc,
1929                           Chars => Chars (Defining_Identifier (D))),
1930                         Label_Construct => Empty);
1931                     Append_To (Body_Decl_List, New_D);
1932
1933                     Next (D);
1934                  end loop;
1935               end;
1936            end if;
1937
1938            pragma Assert (Present (Handled_Statement_Sequence (Ret_Node)));
1939
1940            Proc_Body :=
1941              Make_Subprogram_Body (Loc,
1942                Specification => Copy_Separate_Tree (Proc_Spec),
1943                Declarations  => Body_Decl_List,
1944                Handled_Statement_Sequence =>
1945                  Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node)));
1946
1947            Set_Defining_Unit_Name (Specification (Proc_Body),
1948               Make_Defining_Identifier (Loc, Subp_Name));
1949
1950            Append_To (Decl_List, Proc_Body);
1951         end Build_Procedure;
1952
1953         --  Local variables
1954
1955         New_Obj   : constant Node_Id := Copy_Separate_Tree (Ret_Obj);
1956         Blk_Stmt  : Node_Id;
1957         Proc_Id   : Entity_Id;
1958         Proc_Call : Node_Id;
1959
1960      --  Start of processing for Split_Unconstrained_Function
1961
1962      begin
1963         --  Build the associated procedure, analyze it and insert it before
1964         --  the function body N.
1965
1966         declare
1967            Scope     : constant Entity_Id := Current_Scope;
1968            Decl_List : List_Id;
1969         begin
1970            Pop_Scope;
1971            Build_Procedure (Proc_Id, Decl_List);
1972            Insert_Actions (N, Decl_List);
1973            Set_Is_Inlined (Proc_Id);
1974            Push_Scope (Scope);
1975         end;
1976
1977         --  Build the call to the generated procedure
1978
1979         declare
1980            Actual_List : constant List_Id := New_List;
1981            Formal      : Entity_Id;
1982
1983         begin
1984            Append_To (Actual_List,
1985              New_Occurrence_Of (Defining_Identifier (New_Obj), Loc));
1986
1987            Formal := First_Formal (Spec_Id);
1988            while Present (Formal) loop
1989               Append_To (Actual_List, New_Occurrence_Of (Formal, Loc));
1990
1991               --  Avoid spurious warning on unreferenced formals
1992
1993               Set_Referenced (Formal);
1994               Next_Formal (Formal);
1995            end loop;
1996
1997            Proc_Call :=
1998              Make_Procedure_Call_Statement (Loc,
1999                Name                   => New_Occurrence_Of (Proc_Id, Loc),
2000                Parameter_Associations => Actual_List);
2001         end;
2002
2003         --  Generate:
2004
2005         --    declare
2006         --       New_Obj : ...
2007         --    begin
2008         --       Proc (New_Obj, ...);
2009         --       return New_Obj;
2010         --    end;
2011
2012         Blk_Stmt :=
2013           Make_Block_Statement (Loc,
2014             Declarations               => New_List (New_Obj),
2015             Handled_Statement_Sequence =>
2016               Make_Handled_Sequence_Of_Statements (Loc,
2017                 Statements => New_List (
2018
2019                   Proc_Call,
2020
2021                   Make_Simple_Return_Statement (Loc,
2022                     Expression =>
2023                       New_Occurrence_Of
2024                         (Defining_Identifier (New_Obj), Loc)))));
2025
2026         Rewrite (Ret_Node, Blk_Stmt);
2027      end Split_Unconstrained_Function;
2028
2029      --  Local variables
2030
2031      Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2032
2033   --  Start of processing for Check_And_Split_Unconstrained_Function
2034
2035   begin
2036      pragma Assert (Back_End_Inlining
2037        and then Ekind (Spec_Id) = E_Function
2038        and then Returns_Unconstrained_Type (Spec_Id)
2039        and then Comes_From_Source (Body_Id)
2040        and then (Has_Pragma_Inline_Always (Spec_Id)
2041                    or else Optimization_Level > 0));
2042
2043      --  This routine must not be used in GNATprove mode since GNATprove
2044      --  relies on frontend inlining
2045
2046      pragma Assert (not GNATprove_Mode);
2047
2048      --  No need to split the function if we cannot generate the code
2049
2050      if Serious_Errors_Detected /= 0 then
2051         return;
2052      end if;
2053
2054      --  No action needed in stubs since the attribute Body_To_Inline
2055      --  is not available
2056
2057      if Nkind (Decl) = N_Subprogram_Body_Stub then
2058         return;
2059
2060      --  Cannot build the body to inline if the attribute is already set.
2061      --  This attribute may have been set if this is a subprogram renaming
2062      --  declarations (see Freeze.Build_Renamed_Body).
2063
2064      elsif Present (Body_To_Inline (Decl)) then
2065         return;
2066
2067      --  Check excluded declarations
2068
2069      elsif Present (Declarations (N))
2070        and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
2071      then
2072         return;
2073
2074      --  Check excluded statements. There is no need to protect us against
2075      --  exception handlers since they are supported by the GCC backend.
2076
2077      elsif Present (Handled_Statement_Sequence (N))
2078        and then Has_Excluded_Statement
2079                   (Spec_Id, Statements (Handled_Statement_Sequence (N)))
2080      then
2081         return;
2082      end if;
2083
2084      --  Build the body to inline only if really needed
2085
2086      if Can_Split_Unconstrained_Function (N) then
2087         Split_Unconstrained_Function (N, Spec_Id);
2088         Build_Body_To_Inline (N, Spec_Id);
2089         Set_Is_Inlined (Spec_Id);
2090      end if;
2091   end Check_And_Split_Unconstrained_Function;
2092
2093   -------------------------------------
2094   -- Check_Package_Body_For_Inlining --
2095   -------------------------------------
2096
2097   procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
2098      Bname : Unit_Name_Type;
2099      E     : Entity_Id;
2100      OK    : Boolean;
2101
2102   begin
2103      --  Legacy implementation (relying on frontend inlining)
2104
2105      if not Back_End_Inlining
2106        and then Is_Compilation_Unit (P)
2107        and then not Is_Generic_Instance (P)
2108      then
2109         Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
2110
2111         E := First_Entity (P);
2112         while Present (E) loop
2113            if Has_Pragma_Inline_Always (E)
2114              or else (Has_Pragma_Inline (E) and Front_End_Inlining)
2115            then
2116               if not Is_Loaded (Bname) then
2117                  Load_Needed_Body (N, OK);
2118
2119                  if OK then
2120
2121                     --  Check we are not trying to inline a parent whose body
2122                     --  depends on a child, when we are compiling the body of
2123                     --  the child. Otherwise we have a potential elaboration
2124                     --  circularity with inlined subprograms and with
2125                     --  Taft-Amendment types.
2126
2127                     declare
2128                        Comp        : Node_Id;      --  Body just compiled
2129                        Child_Spec  : Entity_Id;    --  Spec of main unit
2130                        Ent         : Entity_Id;    --  For iteration
2131                        With_Clause : Node_Id;      --  Context of body.
2132
2133                     begin
2134                        if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
2135                          and then Present (Body_Entity (P))
2136                        then
2137                           Child_Spec :=
2138                             Defining_Entity
2139                               ((Unit (Library_Unit (Cunit (Main_Unit)))));
2140
2141                           Comp :=
2142                             Parent (Unit_Declaration_Node (Body_Entity (P)));
2143
2144                           --  Check whether the context of the body just
2145                           --  compiled includes a child of itself, and that
2146                           --  child is the spec of the main compilation.
2147
2148                           With_Clause := First (Context_Items (Comp));
2149                           while Present (With_Clause) loop
2150                              if Nkind (With_Clause) = N_With_Clause
2151                                and then
2152                                  Scope (Entity (Name (With_Clause))) = P
2153                                and then
2154                                  Entity (Name (With_Clause)) = Child_Spec
2155                              then
2156                                 Error_Msg_Node_2 := Child_Spec;
2157                                 Error_Msg_NE
2158                                   ("body of & depends on child unit&??",
2159                                    With_Clause, P);
2160                                 Error_Msg_N
2161                                   ("\subprograms in body cannot be inlined??",
2162                                    With_Clause);
2163
2164                                 --  Disable further inlining from this unit,
2165                                 --  and keep Taft-amendment types incomplete.
2166
2167                                 Ent := First_Entity (P);
2168                                 while Present (Ent) loop
2169                                    if Is_Type (Ent)
2170                                      and then Has_Completion_In_Body (Ent)
2171                                    then
2172                                       Set_Full_View (Ent, Empty);
2173
2174                                    elsif Is_Subprogram (Ent) then
2175                                       Set_Is_Inlined (Ent, False);
2176                                    end if;
2177
2178                                    Next_Entity (Ent);
2179                                 end loop;
2180
2181                                 return;
2182                              end if;
2183
2184                              Next (With_Clause);
2185                           end loop;
2186                        end if;
2187                     end;
2188
2189                  elsif Ineffective_Inline_Warnings then
2190                     Error_Msg_Unit_1 := Bname;
2191                     Error_Msg_N
2192                       ("unable to inline subprograms defined in $??", P);
2193                     Error_Msg_N ("\body not found??", P);
2194                     return;
2195                  end if;
2196               end if;
2197
2198               return;
2199            end if;
2200
2201            Next_Entity (E);
2202         end loop;
2203      end if;
2204   end Check_Package_Body_For_Inlining;
2205
2206   --------------------
2207   -- Cleanup_Scopes --
2208   --------------------
2209
2210   procedure Cleanup_Scopes is
2211      Elmt : Elmt_Id;
2212      Decl : Node_Id;
2213      Scop : Entity_Id;
2214
2215   begin
2216      Elmt := First_Elmt (To_Clean);
2217      while Present (Elmt) loop
2218         Scop := Node (Elmt);
2219
2220         if Ekind (Scop) = E_Entry then
2221            Scop := Protected_Body_Subprogram (Scop);
2222
2223         elsif Is_Subprogram (Scop)
2224           and then Is_Protected_Type (Scope (Scop))
2225           and then Present (Protected_Body_Subprogram (Scop))
2226         then
2227            --  If a protected operation contains an instance, its cleanup
2228            --  operations have been delayed, and the subprogram has been
2229            --  rewritten in the expansion of the enclosing protected body. It
2230            --  is the corresponding subprogram that may require the cleanup
2231            --  operations, so propagate the information that triggers cleanup
2232            --  activity.
2233
2234            Set_Uses_Sec_Stack
2235              (Protected_Body_Subprogram (Scop),
2236                Uses_Sec_Stack (Scop));
2237
2238            Scop := Protected_Body_Subprogram (Scop);
2239         end if;
2240
2241         if Ekind (Scop) = E_Block then
2242            Decl := Parent (Block_Node (Scop));
2243
2244         else
2245            Decl := Unit_Declaration_Node (Scop);
2246
2247            if Nkind_In (Decl, N_Subprogram_Declaration,
2248                               N_Task_Type_Declaration,
2249                               N_Subprogram_Body_Stub)
2250            then
2251               Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
2252            end if;
2253         end if;
2254
2255         Push_Scope (Scop);
2256         Expand_Cleanup_Actions (Decl);
2257         End_Scope;
2258
2259         Elmt := Next_Elmt (Elmt);
2260      end loop;
2261   end Cleanup_Scopes;
2262
2263   -------------------------
2264   -- Expand_Inlined_Call --
2265   -------------------------
2266
2267   procedure Expand_Inlined_Call
2268    (N         : Node_Id;
2269     Subp      : Entity_Id;
2270     Orig_Subp : Entity_Id)
2271   is
2272      Loc       : constant Source_Ptr := Sloc (N);
2273      Is_Predef : constant Boolean :=
2274                    Is_Predefined_Unit (Get_Source_Unit (Subp));
2275      Orig_Bod  : constant Node_Id :=
2276                    Body_To_Inline (Unit_Declaration_Node (Subp));
2277
2278      Blk      : Node_Id;
2279      Decl     : Node_Id;
2280      Decls    : constant List_Id := New_List;
2281      Exit_Lab : Entity_Id        := Empty;
2282      F        : Entity_Id;
2283      A        : Node_Id;
2284      Lab_Decl : Node_Id          := Empty;
2285      Lab_Id   : Node_Id;
2286      New_A    : Node_Id;
2287      Num_Ret  : Nat              := 0;
2288      Ret_Type : Entity_Id;
2289
2290      Targ : Node_Id := Empty;
2291      --  The target of the call. If context is an assignment statement then
2292      --  this is the left-hand side of the assignment, else it is a temporary
2293      --  to which the return value is assigned prior to rewriting the call.
2294
2295      Targ1 : Node_Id := Empty;
2296      --  A separate target used when the return type is unconstrained
2297
2298      Temp     : Entity_Id;
2299      Temp_Typ : Entity_Id;
2300
2301      Return_Object : Entity_Id := Empty;
2302      --  Entity in declaration in an extended_return_statement
2303
2304      Is_Unc      : Boolean;
2305      Is_Unc_Decl : Boolean;
2306      --  If the type returned by the function is unconstrained and the call
2307      --  can be inlined, special processing is required.
2308
2309      procedure Declare_Postconditions_Result;
2310      --  When generating C code, declare _Result, which may be used in the
2311      --  inlined _Postconditions procedure to verify the return value.
2312
2313      procedure Make_Exit_Label;
2314      --  Build declaration for exit label to be used in Return statements,
2315      --  sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2316      --  declaration). Does nothing if Exit_Lab already set.
2317
2318      function Process_Formals (N : Node_Id) return Traverse_Result;
2319      --  Replace occurrence of a formal with the corresponding actual, or the
2320      --  thunk generated for it. Replace a return statement with an assignment
2321      --  to the target of the call, with appropriate conversions if needed.
2322
2323      function Process_Sloc (Nod : Node_Id) return Traverse_Result;
2324      --  If the call being expanded is that of an internal subprogram, set the
2325      --  sloc of the generated block to that of the call itself, so that the
2326      --  expansion is skipped by the "next" command in gdb. Same processing
2327      --  for a subprogram in a predefined file, e.g. Ada.Tags. If
2328      --  Debug_Generated_Code is true, suppress this change to simplify our
2329      --  own development. Same in GNATprove mode, to ensure that warnings and
2330      --  diagnostics point to the proper location.
2331
2332      procedure Reset_Dispatching_Calls (N : Node_Id);
2333      --  In subtree N search for occurrences of dispatching calls that use the
2334      --  Ada 2005 Object.Operation notation and the object is a formal of the
2335      --  inlined subprogram. Reset the entity associated with Operation in all
2336      --  the found occurrences.
2337
2338      procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
2339      --  If the function body is a single expression, replace call with
2340      --  expression, else insert block appropriately.
2341
2342      procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
2343      --  If procedure body has no local variables, inline body without
2344      --  creating block, otherwise rewrite call with block.
2345
2346      function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
2347      --  Determine whether a formal parameter is used only once in Orig_Bod
2348
2349      -----------------------------------
2350      -- Declare_Postconditions_Result --
2351      -----------------------------------
2352
2353      procedure Declare_Postconditions_Result is
2354         Enclosing_Subp : constant Entity_Id := Scope (Subp);
2355
2356      begin
2357         pragma Assert
2358           (Modify_Tree_For_C
2359             and then Is_Subprogram (Enclosing_Subp)
2360             and then Present (Postconditions_Proc (Enclosing_Subp)));
2361
2362         if Ekind (Enclosing_Subp) = E_Function then
2363            if Nkind (First (Parameter_Associations (N))) in
2364                 N_Numeric_Or_String_Literal
2365            then
2366               Append_To (Declarations (Blk),
2367                 Make_Object_Declaration (Loc,
2368                   Defining_Identifier =>
2369                     Make_Defining_Identifier (Loc, Name_uResult),
2370                   Constant_Present    => True,
2371                   Object_Definition   =>
2372                     New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2373                   Expression          =>
2374                     New_Copy_Tree (First (Parameter_Associations (N)))));
2375            else
2376               Append_To (Declarations (Blk),
2377                 Make_Object_Renaming_Declaration (Loc,
2378                   Defining_Identifier =>
2379                     Make_Defining_Identifier (Loc, Name_uResult),
2380                   Subtype_Mark        =>
2381                     New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2382                   Name                =>
2383                     New_Copy_Tree (First (Parameter_Associations (N)))));
2384            end if;
2385         end if;
2386      end Declare_Postconditions_Result;
2387
2388      ---------------------
2389      -- Make_Exit_Label --
2390      ---------------------
2391
2392      procedure Make_Exit_Label is
2393         Lab_Ent : Entity_Id;
2394      begin
2395         if No (Exit_Lab) then
2396            Lab_Ent := Make_Temporary (Loc, 'L');
2397            Lab_Id  := New_Occurrence_Of (Lab_Ent, Loc);
2398            Exit_Lab := Make_Label (Loc, Lab_Id);
2399            Lab_Decl :=
2400              Make_Implicit_Label_Declaration (Loc,
2401                Defining_Identifier => Lab_Ent,
2402                Label_Construct     => Exit_Lab);
2403         end if;
2404      end Make_Exit_Label;
2405
2406      ---------------------
2407      -- Process_Formals --
2408      ---------------------
2409
2410      function Process_Formals (N : Node_Id) return Traverse_Result is
2411         A   : Entity_Id;
2412         E   : Entity_Id;
2413         Ret : Node_Id;
2414
2415      begin
2416         if Is_Entity_Name (N) and then Present (Entity (N)) then
2417            E := Entity (N);
2418
2419            if Is_Formal (E) and then Scope (E) = Subp then
2420               A := Renamed_Object (E);
2421
2422               --  Rewrite the occurrence of the formal into an occurrence of
2423               --  the actual. Also establish visibility on the proper view of
2424               --  the actual's subtype for the body's context (if the actual's
2425               --  subtype is private at the call point but its full view is
2426               --  visible to the body, then the inlined tree here must be
2427               --  analyzed with the full view).
2428
2429               if Is_Entity_Name (A) then
2430                  Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N)));
2431                  Check_Private_View (N);
2432
2433               elsif Nkind (A) = N_Defining_Identifier then
2434                  Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
2435                  Check_Private_View (N);
2436
2437               --  Numeric literal
2438
2439               else
2440                  Rewrite (N, New_Copy (A));
2441               end if;
2442            end if;
2443
2444            return Skip;
2445
2446         elsif Is_Entity_Name (N)
2447           and then Present (Return_Object)
2448           and then Chars (N) = Chars (Return_Object)
2449         then
2450            --  Occurrence within an extended return statement. The return
2451            --  object is local to the body been inlined, and thus the generic
2452            --  copy is not analyzed yet, so we match by name, and replace it
2453            --  with target of call.
2454
2455            if Nkind (Targ) = N_Defining_Identifier then
2456               Rewrite (N, New_Occurrence_Of (Targ, Loc));
2457            else
2458               Rewrite (N, New_Copy_Tree (Targ));
2459            end if;
2460
2461            return Skip;
2462
2463         elsif Nkind (N) = N_Simple_Return_Statement then
2464            if No (Expression (N)) then
2465               Num_Ret := Num_Ret + 1;
2466               Make_Exit_Label;
2467               Rewrite (N,
2468                 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2469
2470            else
2471               if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
2472                 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
2473               then
2474                  --  Function body is a single expression. No need for
2475                  --  exit label.
2476
2477                  null;
2478
2479               else
2480                  Num_Ret := Num_Ret + 1;
2481                  Make_Exit_Label;
2482               end if;
2483
2484               --  Because of the presence of private types, the views of the
2485               --  expression and the context may be different, so place an
2486               --  unchecked conversion to the context type to avoid spurious
2487               --  errors, e.g. when the expression is a numeric literal and
2488               --  the context is private. If the expression is an aggregate,
2489               --  use a qualified expression, because an aggregate is not a
2490               --  legal argument of a conversion. Ditto for numeric literals
2491               --  and attributes that yield a universal type, because those
2492               --  must be resolved to a specific type.
2493
2494               if Nkind_In (Expression (N), N_Aggregate, N_Null)
2495                 or else Yields_Universal_Type (Expression (N))
2496               then
2497                  Ret :=
2498                    Make_Qualified_Expression (Sloc (N),
2499                      Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2500                      Expression   => Relocate_Node (Expression (N)));
2501               else
2502                  Ret :=
2503                    Unchecked_Convert_To
2504                      (Ret_Type, Relocate_Node (Expression (N)));
2505               end if;
2506
2507               if Nkind (Targ) = N_Defining_Identifier then
2508                  Rewrite (N,
2509                    Make_Assignment_Statement (Loc,
2510                      Name       => New_Occurrence_Of (Targ, Loc),
2511                      Expression => Ret));
2512               else
2513                  Rewrite (N,
2514                    Make_Assignment_Statement (Loc,
2515                      Name       => New_Copy (Targ),
2516                      Expression => Ret));
2517               end if;
2518
2519               Set_Assignment_OK (Name (N));
2520
2521               if Present (Exit_Lab) then
2522                  Insert_After (N,
2523                    Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2524               end if;
2525            end if;
2526
2527            return OK;
2528
2529         --  An extended return becomes a block whose first statement is the
2530         --  assignment of the initial expression of the return object to the
2531         --  target of the call itself.
2532
2533         elsif Nkind (N) = N_Extended_Return_Statement then
2534            declare
2535               Return_Decl : constant Entity_Id :=
2536                               First (Return_Object_Declarations (N));
2537               Assign      : Node_Id;
2538
2539            begin
2540               Return_Object := Defining_Identifier (Return_Decl);
2541
2542               if Present (Expression (Return_Decl)) then
2543                  if Nkind (Targ) = N_Defining_Identifier then
2544                     Assign :=
2545                       Make_Assignment_Statement (Loc,
2546                         Name       => New_Occurrence_Of (Targ, Loc),
2547                         Expression => Expression (Return_Decl));
2548                  else
2549                     Assign :=
2550                       Make_Assignment_Statement (Loc,
2551                         Name       => New_Copy (Targ),
2552                         Expression => Expression (Return_Decl));
2553                  end if;
2554
2555                  Set_Assignment_OK (Name (Assign));
2556
2557                  if No (Handled_Statement_Sequence (N)) then
2558                     Set_Handled_Statement_Sequence (N,
2559                       Make_Handled_Sequence_Of_Statements (Loc,
2560                         Statements => New_List));
2561                  end if;
2562
2563                  Prepend (Assign,
2564                    Statements (Handled_Statement_Sequence (N)));
2565               end if;
2566
2567               Rewrite (N,
2568                 Make_Block_Statement (Loc,
2569                    Handled_Statement_Sequence =>
2570                      Handled_Statement_Sequence (N)));
2571
2572               return OK;
2573            end;
2574
2575         --  Remove pragma Unreferenced since it may refer to formals that
2576         --  are not visible in the inlined body, and in any case we will
2577         --  not be posting warnings on the inlined body so it is unneeded.
2578
2579         elsif Nkind (N) = N_Pragma
2580           and then Pragma_Name (N) = Name_Unreferenced
2581         then
2582            Rewrite (N, Make_Null_Statement (Sloc (N)));
2583            return OK;
2584
2585         else
2586            return OK;
2587         end if;
2588      end Process_Formals;
2589
2590      procedure Replace_Formals is new Traverse_Proc (Process_Formals);
2591
2592      ------------------
2593      -- Process_Sloc --
2594      ------------------
2595
2596      function Process_Sloc (Nod : Node_Id) return Traverse_Result is
2597      begin
2598         if not Debug_Generated_Code then
2599            Set_Sloc (Nod, Sloc (N));
2600            Set_Comes_From_Source (Nod, False);
2601         end if;
2602
2603         return OK;
2604      end Process_Sloc;
2605
2606      procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
2607
2608      ------------------------------
2609      --  Reset_Dispatching_Calls --
2610      ------------------------------
2611
2612      procedure Reset_Dispatching_Calls (N : Node_Id) is
2613
2614         function Do_Reset (N : Node_Id) return Traverse_Result;
2615         --  Comment required ???
2616
2617         --------------
2618         -- Do_Reset --
2619         --------------
2620
2621         function Do_Reset (N : Node_Id) return Traverse_Result is
2622         begin
2623            if Nkind (N) = N_Procedure_Call_Statement
2624              and then Nkind (Name (N)) = N_Selected_Component
2625              and then Nkind (Prefix (Name (N))) = N_Identifier
2626              and then Is_Formal (Entity (Prefix (Name (N))))
2627              and then Is_Dispatching_Operation
2628                         (Entity (Selector_Name (Name (N))))
2629            then
2630               Set_Entity (Selector_Name (Name (N)), Empty);
2631            end if;
2632
2633            return OK;
2634         end Do_Reset;
2635
2636         function Do_Reset_Calls is new Traverse_Func (Do_Reset);
2637
2638         --  Local variables
2639
2640         Dummy : constant Traverse_Result := Do_Reset_Calls (N);
2641         pragma Unreferenced (Dummy);
2642
2643         --  Start of processing for Reset_Dispatching_Calls
2644
2645      begin
2646         null;
2647      end Reset_Dispatching_Calls;
2648
2649      ---------------------------
2650      -- Rewrite_Function_Call --
2651      ---------------------------
2652
2653      procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
2654         HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2655         Fst : constant Node_Id := First (Statements (HSS));
2656
2657      begin
2658         --  Optimize simple case: function body is a single return statement,
2659         --  which has been expanded into an assignment.
2660
2661         if Is_Empty_List (Declarations (Blk))
2662           and then Nkind (Fst) = N_Assignment_Statement
2663           and then No (Next (Fst))
2664         then
2665            --  The function call may have been rewritten as the temporary
2666            --  that holds the result of the call, in which case remove the
2667            --  now useless declaration.
2668
2669            if Nkind (N) = N_Identifier
2670              and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2671            then
2672               Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
2673            end if;
2674
2675            Rewrite (N, Expression (Fst));
2676
2677         elsif Nkind (N) = N_Identifier
2678           and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2679         then
2680            --  The block assigns the result of the call to the temporary
2681
2682            Insert_After (Parent (Entity (N)), Blk);
2683
2684         --  If the context is an assignment, and the left-hand side is free of
2685         --  side-effects, the replacement is also safe.
2686         --  Can this be generalized further???
2687
2688         elsif Nkind (Parent (N)) = N_Assignment_Statement
2689           and then
2690            (Is_Entity_Name (Name (Parent (N)))
2691              or else
2692                (Nkind (Name (Parent (N))) = N_Explicit_Dereference
2693                  and then Is_Entity_Name (Prefix (Name (Parent (N)))))
2694
2695              or else
2696                (Nkind (Name (Parent (N))) = N_Selected_Component
2697                  and then Is_Entity_Name (Prefix (Name (Parent (N))))))
2698         then
2699            --  Replace assignment with the block
2700
2701            declare
2702               Original_Assignment : constant Node_Id := Parent (N);
2703
2704            begin
2705               --  Preserve the original assignment node to keep the complete
2706               --  assignment subtree consistent enough for Analyze_Assignment
2707               --  to proceed (specifically, the original Lhs node must still
2708               --  have an assignment statement as its parent).
2709
2710               --  We cannot rely on Original_Node to go back from the block
2711               --  node to the assignment node, because the assignment might
2712               --  already be a rewrite substitution.
2713
2714               Discard_Node (Relocate_Node (Original_Assignment));
2715               Rewrite (Original_Assignment, Blk);
2716            end;
2717
2718         elsif Nkind (Parent (N)) = N_Object_Declaration then
2719
2720            --  A call to a function which returns an unconstrained type
2721            --  found in the expression initializing an object-declaration is
2722            --  expanded into a procedure call which must be added after the
2723            --  object declaration.
2724
2725            if Is_Unc_Decl and Back_End_Inlining then
2726               Insert_Action_After (Parent (N), Blk);
2727            else
2728               Set_Expression (Parent (N), Empty);
2729               Insert_After (Parent (N), Blk);
2730            end if;
2731
2732         elsif Is_Unc and then not Back_End_Inlining then
2733            Insert_Before (Parent (N), Blk);
2734         end if;
2735      end Rewrite_Function_Call;
2736
2737      ----------------------------
2738      -- Rewrite_Procedure_Call --
2739      ----------------------------
2740
2741      procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
2742         HSS  : constant Node_Id := Handled_Statement_Sequence (Blk);
2743
2744      begin
2745         --  If there is a transient scope for N, this will be the scope of the
2746         --  actions for N, and the statements in Blk need to be within this
2747         --  scope. For example, they need to have visibility on the constant
2748         --  declarations created for the formals.
2749
2750         --  If N needs no transient scope, and if there are no declarations in
2751         --  the inlined body, we can do a little optimization and insert the
2752         --  statements for the body directly after N, and rewrite N to a
2753         --  null statement, instead of rewriting N into a full-blown block
2754         --  statement.
2755
2756         if not Scope_Is_Transient
2757           and then Is_Empty_List (Declarations (Blk))
2758         then
2759            Insert_List_After (N, Statements (HSS));
2760            Rewrite (N, Make_Null_Statement (Loc));
2761         else
2762            Rewrite (N, Blk);
2763         end if;
2764      end Rewrite_Procedure_Call;
2765
2766      -------------------------
2767      -- Formal_Is_Used_Once --
2768      -------------------------
2769
2770      function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
2771         Use_Counter : Int := 0;
2772
2773         function Count_Uses (N : Node_Id) return Traverse_Result;
2774         --  Traverse the tree and count the uses of the formal parameter.
2775         --  In this case, for optimization purposes, we do not need to
2776         --  continue the traversal once more than one use is encountered.
2777
2778         ----------------
2779         -- Count_Uses --
2780         ----------------
2781
2782         function Count_Uses (N : Node_Id) return Traverse_Result is
2783         begin
2784            --  The original node is an identifier
2785
2786            if Nkind (N) = N_Identifier
2787              and then Present (Entity (N))
2788
2789               --  Original node's entity points to the one in the copied body
2790
2791              and then Nkind (Entity (N)) = N_Identifier
2792              and then Present (Entity (Entity (N)))
2793
2794               --  The entity of the copied node is the formal parameter
2795
2796              and then Entity (Entity (N)) = Formal
2797            then
2798               Use_Counter := Use_Counter + 1;
2799
2800               if Use_Counter > 1 then
2801
2802                  --  Denote more than one use and abandon the traversal
2803
2804                  Use_Counter := 2;
2805                  return Abandon;
2806
2807               end if;
2808            end if;
2809
2810            return OK;
2811         end Count_Uses;
2812
2813         procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
2814
2815      --  Start of processing for Formal_Is_Used_Once
2816
2817      begin
2818         Count_Formal_Uses (Orig_Bod);
2819         return Use_Counter = 1;
2820      end Formal_Is_Used_Once;
2821
2822   --  Start of processing for Expand_Inlined_Call
2823
2824   begin
2825      --  Initializations for old/new semantics
2826
2827      if not Back_End_Inlining then
2828         Is_Unc      := Is_Array_Type (Etype (Subp))
2829                          and then not Is_Constrained (Etype (Subp));
2830         Is_Unc_Decl := False;
2831      else
2832         Is_Unc      := Returns_Unconstrained_Type (Subp)
2833                          and then Optimization_Level > 0;
2834         Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration
2835                          and then Is_Unc;
2836      end if;
2837
2838      --  Check for an illegal attempt to inline a recursive procedure. If the
2839      --  subprogram has parameters this is detected when trying to supply a
2840      --  binding for parameters that already have one. For parameterless
2841      --  subprograms this must be done explicitly.
2842
2843      if In_Open_Scopes (Subp) then
2844         Cannot_Inline
2845           ("cannot inline call to recursive subprogram?", N, Subp);
2846         Set_Is_Inlined (Subp, False);
2847         return;
2848
2849      --  Skip inlining if this is not a true inlining since the attribute
2850      --  Body_To_Inline is also set for renamings (see sinfo.ads). For a
2851      --  true inlining, Orig_Bod has code rather than being an entity.
2852
2853      elsif Nkind (Orig_Bod) in N_Entity then
2854         return;
2855
2856      --  Skip inlining if the function returns an unconstrained type using
2857      --  an extended return statement since this part of the new inlining
2858      --  model which is not yet supported by the current implementation. ???
2859
2860      elsif Is_Unc
2861        and then
2862          Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
2863            N_Extended_Return_Statement
2864        and then not Back_End_Inlining
2865      then
2866         return;
2867      end if;
2868
2869      if Nkind (Orig_Bod) = N_Defining_Identifier
2870        or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
2871      then
2872         --  Subprogram is renaming_as_body. Calls occurring after the renaming
2873         --  can be replaced with calls to the renamed entity directly, because
2874         --  the subprograms are subtype conformant. If the renamed subprogram
2875         --  is an inherited operation, we must redo the expansion because
2876         --  implicit conversions may be needed. Similarly, if the renamed
2877         --  entity is inlined, expand the call for further optimizations.
2878
2879         Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
2880
2881         if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then
2882            Expand_Call (N);
2883         end if;
2884
2885         return;
2886      end if;
2887
2888      --  Register the call in the list of inlined calls
2889
2890      Append_New_Elmt (N, To => Inlined_Calls);
2891
2892      --  Use generic machinery to copy body of inlined subprogram, as if it
2893      --  were an instantiation, resetting source locations appropriately, so
2894      --  that nested inlined calls appear in the main unit.
2895
2896      Save_Env (Subp, Empty);
2897      Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
2898
2899      --  Old semantics
2900
2901      if not Back_End_Inlining then
2902         declare
2903            Bod : Node_Id;
2904
2905         begin
2906            Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2907            Blk :=
2908              Make_Block_Statement (Loc,
2909                Declarations               => Declarations (Bod),
2910                Handled_Statement_Sequence =>
2911                  Handled_Statement_Sequence (Bod));
2912
2913            if No (Declarations (Bod)) then
2914               Set_Declarations (Blk, New_List);
2915            end if;
2916
2917            --  When generating C code, declare _Result, which may be used to
2918            --  verify the return value.
2919
2920            if Modify_Tree_For_C
2921              and then Nkind (N) = N_Procedure_Call_Statement
2922              and then Chars (Name (N)) = Name_uPostconditions
2923            then
2924               Declare_Postconditions_Result;
2925            end if;
2926
2927            --  For the unconstrained case, capture the name of the local
2928            --  variable that holds the result. This must be the first
2929            --  declaration in the block, because its bounds cannot depend
2930            --  on local variables. Otherwise there is no way to declare the
2931            --  result outside of the block. Needless to say, in general the
2932            --  bounds will depend on the actuals in the call.
2933
2934            --  If the context is an assignment statement, as is the case
2935            --  for the expansion of an extended return, the left-hand side
2936            --  provides bounds even if the return type is unconstrained.
2937
2938            if Is_Unc then
2939               declare
2940                  First_Decl : Node_Id;
2941
2942               begin
2943                  First_Decl := First (Declarations (Blk));
2944
2945                  if Nkind (First_Decl) /= N_Object_Declaration then
2946                     return;
2947                  end if;
2948
2949                  if Nkind (Parent (N)) /= N_Assignment_Statement then
2950                     Targ1 := Defining_Identifier (First_Decl);
2951                  else
2952                     Targ1 := Name (Parent (N));
2953                  end if;
2954               end;
2955            end if;
2956         end;
2957
2958      --  New semantics
2959
2960      else
2961         declare
2962            Bod : Node_Id;
2963
2964         begin
2965            --  General case
2966
2967            if not Is_Unc then
2968               Bod :=
2969                 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2970               Blk :=
2971                 Make_Block_Statement (Loc,
2972                   Declarations               => Declarations (Bod),
2973                   Handled_Statement_Sequence =>
2974                     Handled_Statement_Sequence (Bod));
2975
2976            --  Inline a call to a function that returns an unconstrained type.
2977            --  The semantic analyzer checked that frontend-inlined functions
2978            --  returning unconstrained types have no declarations and have
2979            --  a single extended return statement. As part of its processing
2980            --  the function was split into two subprograms: a procedure P' and
2981            --  a function F' that has a block with a call to procedure P' (see
2982            --  Split_Unconstrained_Function).
2983
2984            else
2985               pragma Assert
2986                 (Nkind
2987                   (First
2988                     (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
2989                                                         N_Block_Statement);
2990
2991               declare
2992                  Blk_Stmt    : constant Node_Id :=
2993                    First (Statements (Handled_Statement_Sequence (Orig_Bod)));
2994                  First_Stmt  : constant Node_Id :=
2995                    First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
2996                  Second_Stmt : constant Node_Id := Next (First_Stmt);
2997
2998               begin
2999                  pragma Assert
3000                    (Nkind (First_Stmt) = N_Procedure_Call_Statement
3001                      and then Nkind (Second_Stmt) = N_Simple_Return_Statement
3002                      and then No (Next (Second_Stmt)));
3003
3004                  Bod :=
3005                    Copy_Generic_Node
3006                      (First
3007                        (Statements (Handled_Statement_Sequence (Orig_Bod))),
3008                       Empty, Instantiating => True);
3009                  Blk := Bod;
3010
3011                  --  Capture the name of the local variable that holds the
3012                  --  result. This must be the first declaration in the block,
3013                  --  because its bounds cannot depend on local variables.
3014                  --  Otherwise there is no way to declare the result outside
3015                  --  of the block. Needless to say, in general the bounds will
3016                  --  depend on the actuals in the call.
3017
3018                  if Nkind (Parent (N)) /= N_Assignment_Statement then
3019                     Targ1 := Defining_Identifier (First (Declarations (Blk)));
3020
3021                  --  If the context is an assignment statement, as is the case
3022                  --  for the expansion of an extended return, the left-hand
3023                  --  side provides bounds even if the return type is
3024                  --  unconstrained.
3025
3026                  else
3027                     Targ1 := Name (Parent (N));
3028                  end if;
3029               end;
3030            end if;
3031
3032            if No (Declarations (Bod)) then
3033               Set_Declarations (Blk, New_List);
3034            end if;
3035         end;
3036      end if;
3037
3038      --  If this is a derived function, establish the proper return type
3039
3040      if Present (Orig_Subp) and then Orig_Subp /= Subp then
3041         Ret_Type := Etype (Orig_Subp);
3042      else
3043         Ret_Type := Etype (Subp);
3044      end if;
3045
3046      --  Create temporaries for the actuals that are expressions, or that are
3047      --  scalars and require copying to preserve semantics.
3048
3049      F := First_Formal (Subp);
3050      A := First_Actual (N);
3051      while Present (F) loop
3052         if Present (Renamed_Object (F)) then
3053
3054            --  If expander is active, it is an error to try to inline a
3055            --  recursive program. In GNATprove mode, just indicate that the
3056            --  inlining will not happen, and mark the subprogram as not always
3057            --  inlined.
3058
3059            if GNATprove_Mode then
3060               Cannot_Inline
3061                 ("cannot inline call to recursive subprogram?", N, Subp);
3062               Set_Is_Inlined_Always (Subp, False);
3063            else
3064               Error_Msg_N
3065                 ("cannot inline call to recursive subprogram", N);
3066            end if;
3067
3068            return;
3069         end if;
3070
3071         --  Reset Last_Assignment for any parameters of mode out or in out, to
3072         --  prevent spurious warnings about overwriting for assignments to the
3073         --  formal in the inlined code.
3074
3075         if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
3076            Set_Last_Assignment (Entity (A), Empty);
3077         end if;
3078
3079         --  If the argument may be a controlling argument in a call within
3080         --  the inlined body, we must preserve its classwide nature to insure
3081         --  that dynamic dispatching take place subsequently. If the formal
3082         --  has a constraint it must be preserved to retain the semantics of
3083         --  the body.
3084
3085         if Is_Class_Wide_Type (Etype (F))
3086           or else (Is_Access_Type (Etype (F))
3087                     and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
3088         then
3089            Temp_Typ := Etype (F);
3090
3091         elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3092           and then Etype (F) /= Base_Type (Etype (F))
3093           and then Is_Constrained (Etype (F))
3094         then
3095            Temp_Typ := Etype (F);
3096
3097         else
3098            Temp_Typ := Etype (A);
3099         end if;
3100
3101         --  If the actual is a simple name or a literal, no need to
3102         --  create a temporary, object can be used directly.
3103
3104         --  If the actual is a literal and the formal has its address taken,
3105         --  we cannot pass the literal itself as an argument, so its value
3106         --  must be captured in a temporary. Skip this optimization in
3107         --  GNATprove mode, to make sure any check on a type conversion
3108         --  will be issued.
3109
3110         if (Is_Entity_Name (A)
3111              and then
3112                (not Is_Scalar_Type (Etype (A))
3113                  or else Ekind (Entity (A)) = E_Enumeration_Literal)
3114              and then not GNATprove_Mode)
3115
3116         --  When the actual is an identifier and the corresponding formal is
3117         --  used only once in the original body, the formal can be substituted
3118         --  directly with the actual parameter. Skip this optimization in
3119         --  GNATprove mode, to make sure any check on a type conversion
3120         --  will be issued.
3121
3122           or else
3123             (Nkind (A) = N_Identifier
3124               and then Formal_Is_Used_Once (F)
3125               and then not GNATprove_Mode)
3126
3127           or else
3128             (Nkind_In (A, N_Real_Literal,
3129                           N_Integer_Literal,
3130                           N_Character_Literal)
3131               and then not Address_Taken (F))
3132         then
3133            if Etype (F) /= Etype (A) then
3134               Set_Renamed_Object
3135                 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3136            else
3137               Set_Renamed_Object (F, A);
3138            end if;
3139
3140         else
3141            Temp := Make_Temporary (Loc, 'C');
3142
3143            --  If the actual for an in/in-out parameter is a view conversion,
3144            --  make it into an unchecked conversion, given that an untagged
3145            --  type conversion is not a proper object for a renaming.
3146
3147            --  In-out conversions that involve real conversions have already
3148            --  been transformed in Expand_Actuals.
3149
3150            if Nkind (A) = N_Type_Conversion
3151              and then Ekind (F) /= E_In_Parameter
3152            then
3153               New_A :=
3154                 Make_Unchecked_Type_Conversion (Loc,
3155                   Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
3156                   Expression   => Relocate_Node (Expression (A)));
3157
3158            --  In GNATprove mode, keep the most precise type of the actual for
3159            --  the temporary variable, when the formal type is unconstrained.
3160            --  Otherwise, the AST may contain unexpected assignment statements
3161            --  to a temporary variable of unconstrained type renaming a local
3162            --  variable of constrained type, which is not expected by
3163            --  GNATprove.
3164
3165            elsif Etype (F) /= Etype (A)
3166              and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
3167            then
3168               New_A    := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3169               Temp_Typ := Etype (F);
3170
3171            else
3172               New_A := Relocate_Node (A);
3173            end if;
3174
3175            Set_Sloc (New_A, Sloc (N));
3176
3177            --  If the actual has a by-reference type, it cannot be copied,
3178            --  so its value is captured in a renaming declaration. Otherwise
3179            --  declare a local constant initialized with the actual.
3180
3181            --  We also use a renaming declaration for expressions of an array
3182            --  type that is not bit-packed, both for efficiency reasons and to
3183            --  respect the semantics of the call: in most cases the original
3184            --  call will pass the parameter by reference, and thus the inlined
3185            --  code will have the same semantics.
3186
3187            --  Finally, we need a renaming declaration in the case of limited
3188            --  types for which initialization cannot be by copy either.
3189
3190            if Ekind (F) = E_In_Parameter
3191              and then not Is_By_Reference_Type (Etype (A))
3192              and then not Is_Limited_Type (Etype (A))
3193              and then
3194                (not Is_Array_Type (Etype (A))
3195                  or else not Is_Object_Reference (A)
3196                  or else Is_Bit_Packed_Array (Etype (A)))
3197            then
3198               Decl :=
3199                 Make_Object_Declaration (Loc,
3200                   Defining_Identifier => Temp,
3201                   Constant_Present    => True,
3202                   Object_Definition   => New_Occurrence_Of (Temp_Typ, Loc),
3203                   Expression          => New_A);
3204
3205            else
3206               --  In GNATprove mode, make an explicit copy of input
3207               --  parameters when formal and actual types differ, to make
3208               --  sure any check on the type conversion will be issued.
3209               --  The legality of the copy is ensured by calling first
3210               --  Call_Can_Be_Inlined_In_GNATprove_Mode.
3211
3212               if GNATprove_Mode
3213                 and then Ekind (F) /= E_Out_Parameter
3214                 and then not Same_Type (Etype (F), Etype (A))
3215               then
3216                  pragma Assert (not (Is_By_Reference_Type (Etype (A))));
3217                  pragma Assert (not (Is_Limited_Type (Etype (A))));
3218
3219                  Append_To (Decls,
3220                    Make_Object_Declaration (Loc,
3221                      Defining_Identifier => Make_Temporary (Loc, 'C'),
3222                      Constant_Present    => True,
3223                      Object_Definition   => New_Occurrence_Of (Temp_Typ, Loc),
3224                      Expression          => New_Copy_Tree (New_A)));
3225               end if;
3226
3227               Decl :=
3228                 Make_Object_Renaming_Declaration (Loc,
3229                   Defining_Identifier => Temp,
3230                   Subtype_Mark        => New_Occurrence_Of (Temp_Typ, Loc),
3231                   Name                => New_A);
3232            end if;
3233
3234            Append (Decl, Decls);
3235            Set_Renamed_Object (F, Temp);
3236         end if;
3237
3238         Next_Formal (F);
3239         Next_Actual (A);
3240      end loop;
3241
3242      --  Establish target of function call. If context is not assignment or
3243      --  declaration, create a temporary as a target. The declaration for the
3244      --  temporary may be subsequently optimized away if the body is a single
3245      --  expression, or if the left-hand side of the assignment is simple
3246      --  enough, i.e. an entity or an explicit dereference of one.
3247
3248      if Ekind (Subp) = E_Function then
3249         if Nkind (Parent (N)) = N_Assignment_Statement
3250           and then Is_Entity_Name (Name (Parent (N)))
3251         then
3252            Targ := Name (Parent (N));
3253
3254         elsif Nkind (Parent (N)) = N_Assignment_Statement
3255           and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3256           and then Is_Entity_Name (Prefix (Name (Parent (N))))
3257         then
3258            Targ := Name (Parent (N));
3259
3260         elsif Nkind (Parent (N)) = N_Assignment_Statement
3261           and then Nkind (Name (Parent (N))) = N_Selected_Component
3262           and then Is_Entity_Name (Prefix (Name (Parent (N))))
3263         then
3264            Targ := New_Copy_Tree (Name (Parent (N)));
3265
3266         elsif Nkind (Parent (N)) = N_Object_Declaration
3267           and then Is_Limited_Type (Etype (Subp))
3268         then
3269            Targ := Defining_Identifier (Parent (N));
3270
3271         --  New semantics: In an object declaration avoid an extra copy
3272         --  of the result of a call to an inlined function that returns
3273         --  an unconstrained type
3274
3275         elsif Back_End_Inlining
3276           and then Nkind (Parent (N)) = N_Object_Declaration
3277           and then Is_Unc
3278         then
3279            Targ := Defining_Identifier (Parent (N));
3280
3281         else
3282            --  Replace call with temporary and create its declaration
3283
3284            Temp := Make_Temporary (Loc, 'C');
3285            Set_Is_Internal (Temp);
3286
3287            --  For the unconstrained case, the generated temporary has the
3288            --  same constrained declaration as the result variable. It may
3289            --  eventually be possible to remove that temporary and use the
3290            --  result variable directly.
3291
3292            if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement
3293            then
3294               Decl :=
3295                 Make_Object_Declaration (Loc,
3296                   Defining_Identifier => Temp,
3297                   Object_Definition   =>
3298                     New_Copy_Tree (Object_Definition (Parent (Targ1))));
3299
3300               Replace_Formals (Decl);
3301
3302            else
3303               Decl :=
3304                 Make_Object_Declaration (Loc,
3305                   Defining_Identifier => Temp,
3306                   Object_Definition   => New_Occurrence_Of (Ret_Type, Loc));
3307
3308               Set_Etype (Temp, Ret_Type);
3309            end if;
3310
3311            Set_No_Initialization (Decl);
3312            Append (Decl, Decls);
3313            Rewrite (N, New_Occurrence_Of (Temp, Loc));
3314            Targ := Temp;
3315         end if;
3316      end if;
3317
3318      Insert_Actions (N, Decls);
3319
3320      if Is_Unc_Decl then
3321
3322         --  Special management for inlining a call to a function that returns
3323         --  an unconstrained type and initializes an object declaration: we
3324         --  avoid generating undesired extra calls and goto statements.
3325
3326         --     Given:
3327         --                 function Func (...) return String is
3328         --                 begin
3329         --                    declare
3330         --                       Result : String (1 .. 4);
3331         --                    begin
3332         --                       Proc (Result, ...);
3333         --                       return Result;
3334         --                    end;
3335         --                 end Func;
3336
3337         --                 Result : String := Func (...);
3338
3339         --     Replace this object declaration by:
3340
3341         --                 Result : String (1 .. 4);
3342         --                 Proc (Result, ...);
3343
3344         Remove_Homonym (Targ);
3345
3346         Decl :=
3347           Make_Object_Declaration
3348             (Loc,
3349              Defining_Identifier => Targ,
3350              Object_Definition   =>
3351                New_Copy_Tree (Object_Definition (Parent (Targ1))));
3352         Replace_Formals (Decl);
3353         Rewrite (Parent (N), Decl);
3354         Analyze (Parent (N));
3355
3356         --  Avoid spurious warnings since we know that this declaration is
3357         --  referenced by the procedure call.
3358
3359         Set_Never_Set_In_Source (Targ, False);
3360
3361         --  Remove the local declaration of the extended return stmt from the
3362         --  inlined code
3363
3364         Remove (Parent (Targ1));
3365
3366         --  Update the reference to the result (since we have rewriten the
3367         --  object declaration)
3368
3369         declare
3370            Blk_Call_Stmt : Node_Id;
3371
3372         begin
3373            --  Capture the call to the procedure
3374
3375            Blk_Call_Stmt :=
3376              First (Statements (Handled_Statement_Sequence (Blk)));
3377            pragma Assert
3378              (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement);
3379
3380            Remove (First (Parameter_Associations (Blk_Call_Stmt)));
3381            Prepend_To (Parameter_Associations (Blk_Call_Stmt),
3382              New_Occurrence_Of (Targ, Loc));
3383         end;
3384
3385         --  Remove the return statement
3386
3387         pragma Assert
3388           (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3389                                                   N_Simple_Return_Statement);
3390
3391         Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3392      end if;
3393
3394      --  Traverse the tree and replace formals with actuals or their thunks.
3395      --  Attach block to tree before analysis and rewriting.
3396
3397      Replace_Formals (Blk);
3398      Set_Parent (Blk, N);
3399
3400      if GNATprove_Mode then
3401         null;
3402
3403      elsif not Comes_From_Source (Subp) or else Is_Predef then
3404         Reset_Slocs (Blk);
3405      end if;
3406
3407      if Is_Unc_Decl then
3408
3409         --  No action needed since return statement has been already removed
3410
3411         null;
3412
3413      elsif Present (Exit_Lab) then
3414
3415         --  If there's a single return statement at the end of the subprogram,
3416         --  the corresponding goto statement and the corresponding label are
3417         --  useless.
3418
3419         if Num_Ret = 1
3420           and then
3421             Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3422                                                            N_Goto_Statement
3423         then
3424            Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3425         else
3426            Append (Lab_Decl, (Declarations (Blk)));
3427            Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
3428         end if;
3429      end if;
3430
3431      --  Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3432      --  on conflicting private views that Gigi would ignore. If this is a
3433      --  predefined unit, analyze with checks off, as is done in the non-
3434      --  inlined run-time units.
3435
3436      declare
3437         I_Flag : constant Boolean := In_Inlined_Body;
3438
3439      begin
3440         In_Inlined_Body := True;
3441
3442         if Is_Predef then
3443            declare
3444               Style : constant Boolean := Style_Check;
3445
3446            begin
3447               Style_Check := False;
3448
3449               --  Search for dispatching calls that use the Object.Operation
3450               --  notation using an Object that is a parameter of the inlined
3451               --  function. We reset the decoration of Operation to force
3452               --  the reanalysis of the inlined dispatching call because
3453               --  the actual object has been inlined.
3454
3455               Reset_Dispatching_Calls (Blk);
3456
3457               Analyze (Blk, Suppress => All_Checks);
3458               Style_Check := Style;
3459            end;
3460
3461         else
3462            Analyze (Blk);
3463         end if;
3464
3465         In_Inlined_Body := I_Flag;
3466      end;
3467
3468      if Ekind (Subp) = E_Procedure then
3469         Rewrite_Procedure_Call (N, Blk);
3470
3471      else
3472         Rewrite_Function_Call (N, Blk);
3473
3474         if Is_Unc_Decl then
3475            null;
3476
3477         --  For the unconstrained case, the replacement of the call has been
3478         --  made prior to the complete analysis of the generated declarations.
3479         --  Propagate the proper type now.
3480
3481         elsif Is_Unc then
3482            if Nkind (N) = N_Identifier then
3483               Set_Etype (N, Etype (Entity (N)));
3484            else
3485               Set_Etype (N, Etype (Targ1));
3486            end if;
3487         end if;
3488      end if;
3489
3490      Restore_Env;
3491
3492      --  Cleanup mapping between formals and actuals for other expansions
3493
3494      F := First_Formal (Subp);
3495      while Present (F) loop
3496         Set_Renamed_Object (F, Empty);
3497         Next_Formal (F);
3498      end loop;
3499   end Expand_Inlined_Call;
3500
3501   --------------------------
3502   -- Get_Code_Unit_Entity --
3503   --------------------------
3504
3505   function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
3506      Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
3507
3508   begin
3509      if Ekind (Unit) = E_Package_Body then
3510         Unit := Spec_Entity (Unit);
3511      end if;
3512
3513      return Unit;
3514   end Get_Code_Unit_Entity;
3515
3516   ------------------------------
3517   -- Has_Excluded_Declaration --
3518   ------------------------------
3519
3520   function Has_Excluded_Declaration
3521     (Subp  : Entity_Id;
3522      Decls : List_Id) return Boolean
3523   is
3524      D : Node_Id;
3525
3526      function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
3527      --  Nested subprograms make a given body ineligible for inlining, but
3528      --  we make an exception for instantiations of unchecked conversion.
3529      --  The body has not been analyzed yet, so check the name, and verify
3530      --  that the visible entity with that name is the predefined unit.
3531
3532      -----------------------------
3533      -- Is_Unchecked_Conversion --
3534      -----------------------------
3535
3536      function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
3537         Id   : constant Node_Id := Name (D);
3538         Conv : Entity_Id;
3539
3540      begin
3541         if Nkind (Id) = N_Identifier
3542           and then Chars (Id) = Name_Unchecked_Conversion
3543         then
3544            Conv := Current_Entity (Id);
3545
3546         elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
3547           and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
3548         then
3549            Conv := Current_Entity (Selector_Name (Id));
3550         else
3551            return False;
3552         end if;
3553
3554         return Present (Conv)
3555           and then Is_Predefined_Unit (Get_Source_Unit (Conv))
3556           and then Is_Intrinsic_Subprogram (Conv);
3557      end Is_Unchecked_Conversion;
3558
3559   --  Start of processing for Has_Excluded_Declaration
3560
3561   begin
3562      --  No action needed if the check is not needed
3563
3564      if not Check_Inlining_Restrictions then
3565         return False;
3566      end if;
3567
3568      D := First (Decls);
3569      while Present (D) loop
3570
3571         --  First declarations universally excluded
3572
3573         if Nkind (D) = N_Package_Declaration then
3574            Cannot_Inline
3575              ("cannot inline & (nested package declaration)?", D, Subp);
3576            return True;
3577
3578         elsif Nkind (D) = N_Package_Instantiation then
3579            Cannot_Inline
3580              ("cannot inline & (nested package instantiation)?", D, Subp);
3581            return True;
3582         end if;
3583
3584         --  Then declarations excluded only for front-end inlining
3585
3586         if Back_End_Inlining then
3587            null;
3588
3589         elsif Nkind (D) = N_Task_Type_Declaration
3590           or else Nkind (D) = N_Single_Task_Declaration
3591         then
3592            Cannot_Inline
3593              ("cannot inline & (nested task type declaration)?", D, Subp);
3594            return True;
3595
3596         elsif Nkind (D) = N_Protected_Type_Declaration
3597           or else Nkind (D) = N_Single_Protected_Declaration
3598         then
3599            Cannot_Inline
3600              ("cannot inline & (nested protected type declaration)?",
3601               D, Subp);
3602            return True;
3603
3604         elsif Nkind (D) = N_Subprogram_Body then
3605            Cannot_Inline
3606              ("cannot inline & (nested subprogram)?", D, Subp);
3607            return True;
3608
3609         elsif Nkind (D) = N_Function_Instantiation
3610           and then not Is_Unchecked_Conversion (D)
3611         then
3612            Cannot_Inline
3613              ("cannot inline & (nested function instantiation)?", D, Subp);
3614            return True;
3615
3616         elsif Nkind (D) = N_Procedure_Instantiation then
3617            Cannot_Inline
3618              ("cannot inline & (nested procedure instantiation)?", D, Subp);
3619            return True;
3620
3621         --  Subtype declarations with predicates will generate predicate
3622         --  functions, i.e. nested subprogram bodies, so inlining is not
3623         --  possible.
3624
3625         elsif Nkind (D) = N_Subtype_Declaration
3626           and then Present (Aspect_Specifications (D))
3627         then
3628            declare
3629               A    : Node_Id;
3630               A_Id : Aspect_Id;
3631
3632            begin
3633               A := First (Aspect_Specifications (D));
3634               while Present (A) loop
3635                  A_Id := Get_Aspect_Id (Chars (Identifier (A)));
3636
3637                  if A_Id = Aspect_Predicate
3638                    or else A_Id = Aspect_Static_Predicate
3639                    or else A_Id = Aspect_Dynamic_Predicate
3640                  then
3641                     Cannot_Inline
3642                       ("cannot inline & (subtype declaration with "
3643                        & "predicate)?", D, Subp);
3644                     return True;
3645                  end if;
3646
3647                  Next (A);
3648               end loop;
3649            end;
3650         end if;
3651
3652         Next (D);
3653      end loop;
3654
3655      return False;
3656   end Has_Excluded_Declaration;
3657
3658   ----------------------------
3659   -- Has_Excluded_Statement --
3660   ----------------------------
3661
3662   function Has_Excluded_Statement
3663     (Subp  : Entity_Id;
3664      Stats : List_Id) return Boolean
3665   is
3666      S : Node_Id;
3667      E : Node_Id;
3668
3669   begin
3670      --  No action needed if the check is not needed
3671
3672      if not Check_Inlining_Restrictions then
3673         return False;
3674      end if;
3675
3676      S := First (Stats);
3677      while Present (S) loop
3678         if Nkind_In (S, N_Abort_Statement,
3679                         N_Asynchronous_Select,
3680                         N_Conditional_Entry_Call,
3681                         N_Delay_Relative_Statement,
3682                         N_Delay_Until_Statement,
3683                         N_Selective_Accept,
3684                         N_Timed_Entry_Call)
3685         then
3686            Cannot_Inline
3687              ("cannot inline & (non-allowed statement)?", S, Subp);
3688            return True;
3689
3690         elsif Nkind (S) = N_Block_Statement then
3691            if Present (Declarations (S))
3692              and then Has_Excluded_Declaration (Subp, Declarations (S))
3693            then
3694               return True;
3695
3696            elsif Present (Handled_Statement_Sequence (S)) then
3697               if not Back_End_Inlining
3698                 and then
3699                   Present
3700                     (Exception_Handlers (Handled_Statement_Sequence (S)))
3701               then
3702                  Cannot_Inline
3703                    ("cannot inline& (exception handler)?",
3704                     First (Exception_Handlers
3705                              (Handled_Statement_Sequence (S))),
3706                     Subp);
3707                  return True;
3708
3709               elsif Has_Excluded_Statement
3710                       (Subp, Statements (Handled_Statement_Sequence (S)))
3711               then
3712                  return True;
3713               end if;
3714            end if;
3715
3716         elsif Nkind (S) = N_Case_Statement then
3717            E := First (Alternatives (S));
3718            while Present (E) loop
3719               if Has_Excluded_Statement (Subp, Statements (E)) then
3720                  return True;
3721               end if;
3722
3723               Next (E);
3724            end loop;
3725
3726         elsif Nkind (S) = N_If_Statement then
3727            if Has_Excluded_Statement (Subp, Then_Statements (S)) then
3728               return True;
3729            end if;
3730
3731            if Present (Elsif_Parts (S)) then
3732               E := First (Elsif_Parts (S));
3733               while Present (E) loop
3734                  if Has_Excluded_Statement (Subp, Then_Statements (E)) then
3735                     return True;
3736                  end if;
3737
3738                  Next (E);
3739               end loop;
3740            end if;
3741
3742            if Present (Else_Statements (S))
3743              and then Has_Excluded_Statement (Subp, Else_Statements (S))
3744            then
3745               return True;
3746            end if;
3747
3748         elsif Nkind (S) = N_Loop_Statement
3749           and then Has_Excluded_Statement (Subp, Statements (S))
3750         then
3751            return True;
3752
3753         elsif Nkind (S) = N_Extended_Return_Statement then
3754            if Present (Handled_Statement_Sequence (S))
3755              and then
3756                Has_Excluded_Statement
3757                  (Subp, Statements (Handled_Statement_Sequence (S)))
3758            then
3759               return True;
3760
3761            elsif not Back_End_Inlining
3762              and then Present (Handled_Statement_Sequence (S))
3763              and then
3764                Present (Exception_Handlers
3765                          (Handled_Statement_Sequence (S)))
3766            then
3767               Cannot_Inline
3768                 ("cannot inline& (exception handler)?",
3769                  First (Exception_Handlers (Handled_Statement_Sequence (S))),
3770                  Subp);
3771               return True;
3772            end if;
3773         end if;
3774
3775         Next (S);
3776      end loop;
3777
3778      return False;
3779   end Has_Excluded_Statement;
3780
3781   --------------------------
3782   -- Has_Initialized_Type --
3783   --------------------------
3784
3785   function Has_Initialized_Type (E : Entity_Id) return Boolean is
3786      E_Body : constant Node_Id := Subprogram_Body (E);
3787      Decl   : Node_Id;
3788
3789   begin
3790      if No (E_Body) then        --  imported subprogram
3791         return False;
3792
3793      else
3794         Decl := First (Declarations (E_Body));
3795         while Present (Decl) loop
3796            if Nkind (Decl) = N_Full_Type_Declaration
3797              and then Present (Init_Proc (Defining_Identifier (Decl)))
3798            then
3799               return True;
3800            end if;
3801
3802            Next (Decl);
3803         end loop;
3804      end if;
3805
3806      return False;
3807   end Has_Initialized_Type;
3808
3809   -----------------------
3810   -- Has_Single_Return --
3811   -----------------------
3812
3813   function Has_Single_Return (N : Node_Id) return Boolean is
3814      Return_Statement : Node_Id := Empty;
3815
3816      function Check_Return (N : Node_Id) return Traverse_Result;
3817
3818      ------------------
3819      -- Check_Return --
3820      ------------------
3821
3822      function Check_Return (N : Node_Id) return Traverse_Result is
3823      begin
3824         if Nkind (N) = N_Simple_Return_Statement then
3825            if Present (Expression (N))
3826              and then Is_Entity_Name (Expression (N))
3827            then
3828               if No (Return_Statement) then
3829                  Return_Statement := N;
3830                  return OK;
3831
3832               elsif Chars (Expression (N)) =
3833                     Chars (Expression (Return_Statement))
3834               then
3835                  return OK;
3836
3837               else
3838                  return Abandon;
3839               end if;
3840
3841            --  A return statement within an extended return is a noop
3842            --  after inlining.
3843
3844            elsif No (Expression (N))
3845              and then
3846                Nkind (Parent (Parent (N))) = N_Extended_Return_Statement
3847            then
3848               return OK;
3849
3850            else
3851               --  Expression has wrong form
3852
3853               return Abandon;
3854            end if;
3855
3856         --  We can only inline a build-in-place function if it has a single
3857         --  extended return.
3858
3859         elsif Nkind (N) = N_Extended_Return_Statement then
3860            if No (Return_Statement) then
3861               Return_Statement := N;
3862               return OK;
3863
3864            else
3865               return Abandon;
3866            end if;
3867
3868         else
3869            return OK;
3870         end if;
3871      end Check_Return;
3872
3873      function Check_All_Returns is new Traverse_Func (Check_Return);
3874
3875   --  Start of processing for Has_Single_Return
3876
3877   begin
3878      if Check_All_Returns (N) /= OK then
3879         return False;
3880
3881      elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
3882         return True;
3883
3884      else
3885         return Present (Declarations (N))
3886           and then Present (First (Declarations (N)))
3887           and then Chars (Expression (Return_Statement)) =
3888                    Chars (Defining_Identifier (First (Declarations (N))));
3889      end if;
3890   end Has_Single_Return;
3891
3892   -----------------------------
3893   -- In_Main_Unit_Or_Subunit --
3894   -----------------------------
3895
3896   function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is
3897      Comp : Node_Id := Cunit (Get_Code_Unit (E));
3898
3899   begin
3900      --  Check whether the subprogram or package to inline is within the main
3901      --  unit or its spec or within a subunit. In either case there are no
3902      --  additional bodies to process. If the subprogram appears in a parent
3903      --  of the current unit, the check on whether inlining is possible is
3904      --  done in Analyze_Inlined_Bodies.
3905
3906      while Nkind (Unit (Comp)) = N_Subunit loop
3907         Comp := Library_Unit (Comp);
3908      end loop;
3909
3910      return Comp = Cunit (Main_Unit)
3911        or else Comp = Library_Unit (Cunit (Main_Unit));
3912   end In_Main_Unit_Or_Subunit;
3913
3914   ----------------
3915   -- Initialize --
3916   ----------------
3917
3918   procedure Initialize is
3919   begin
3920      Pending_Descriptor.Init;
3921      Pending_Instantiations.Init;
3922      Inlined_Bodies.Init;
3923      Successors.Init;
3924      Inlined.Init;
3925
3926      for J in Hash_Headers'Range loop
3927         Hash_Headers (J) := No_Subp;
3928      end loop;
3929
3930      Inlined_Calls := No_Elist;
3931      Backend_Calls := No_Elist;
3932      Backend_Inlined_Subps := No_Elist;
3933      Backend_Not_Inlined_Subps := No_Elist;
3934   end Initialize;
3935
3936   ------------------------
3937   -- Instantiate_Bodies --
3938   ------------------------
3939
3940   --  Generic bodies contain all the non-local references, so an
3941   --  instantiation does not need any more context than Standard
3942   --  itself, even if the instantiation appears in an inner scope.
3943   --  Generic associations have verified that the contract model is
3944   --  satisfied, so that any error that may occur in the analysis of
3945   --  the body is an internal error.
3946
3947   procedure Instantiate_Bodies is
3948      J    : Nat;
3949      Info : Pending_Body_Info;
3950
3951   begin
3952      if Serious_Errors_Detected = 0 then
3953         Expander_Active := (Operating_Mode = Opt.Generate_Code);
3954         Push_Scope (Standard_Standard);
3955         To_Clean := New_Elmt_List;
3956
3957         if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
3958            Start_Generic;
3959         end if;
3960
3961         --  A body instantiation may generate additional instantiations, so
3962         --  the following loop must scan to the end of a possibly expanding
3963         --  set (that's why we can't simply use a FOR loop here).
3964
3965         J := 0;
3966         while J <= Pending_Instantiations.Last
3967           and then Serious_Errors_Detected = 0
3968         loop
3969            Info := Pending_Instantiations.Table (J);
3970
3971            --  If the instantiation node is absent, it has been removed
3972            --  as part of unreachable code.
3973
3974            if No (Info.Inst_Node) then
3975               null;
3976
3977            elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
3978               Instantiate_Package_Body (Info);
3979               Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
3980
3981            else
3982               Instantiate_Subprogram_Body (Info);
3983            end if;
3984
3985            J := J + 1;
3986         end loop;
3987
3988         --  Reset the table of instantiations. Additional instantiations
3989         --  may be added through inlining, when additional bodies are
3990         --  analyzed.
3991
3992         Pending_Instantiations.Init;
3993
3994         --  We can now complete the cleanup actions of scopes that contain
3995         --  pending instantiations (skipped for generic units, since we
3996         --  never need any cleanups in generic units).
3997
3998         if Expander_Active
3999           and then not Is_Generic_Unit (Main_Unit_Entity)
4000         then
4001            Cleanup_Scopes;
4002         elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
4003            End_Generic;
4004         end if;
4005
4006         Pop_Scope;
4007      end if;
4008   end Instantiate_Bodies;
4009
4010   ---------------
4011   -- Is_Nested --
4012   ---------------
4013
4014   function Is_Nested (E : Entity_Id) return Boolean is
4015      Scop : Entity_Id;
4016
4017   begin
4018      Scop := Scope (E);
4019      while Scop /= Standard_Standard loop
4020         if Ekind (Scop) in Subprogram_Kind then
4021            return True;
4022
4023         elsif Ekind (Scop) = E_Task_Type
4024           or else Ekind (Scop) = E_Entry
4025           or else Ekind (Scop) = E_Entry_Family
4026         then
4027            return True;
4028         end if;
4029
4030         Scop := Scope (Scop);
4031      end loop;
4032
4033      return False;
4034   end Is_Nested;
4035
4036   ------------------------
4037   -- List_Inlining_Info --
4038   ------------------------
4039
4040   procedure List_Inlining_Info is
4041      Elmt  : Elmt_Id;
4042      Nod   : Node_Id;
4043      Count : Nat;
4044
4045   begin
4046      if not Debug_Flag_Dot_J then
4047         return;
4048      end if;
4049
4050      --  Generate listing of calls inlined by the frontend
4051
4052      if Present (Inlined_Calls) then
4053         Count := 0;
4054         Elmt  := First_Elmt (Inlined_Calls);
4055         while Present (Elmt) loop
4056            Nod := Node (Elmt);
4057
4058            if In_Extended_Main_Code_Unit (Nod) then
4059               Count := Count + 1;
4060
4061               if Count = 1 then
4062                  Write_Str ("List of calls inlined by the frontend");
4063                  Write_Eol;
4064               end if;
4065
4066               Write_Str ("  ");
4067               Write_Int (Count);
4068               Write_Str (":");
4069               Write_Location (Sloc (Nod));
4070               Write_Str (":");
4071               Output.Write_Eol;
4072            end if;
4073
4074            Next_Elmt (Elmt);
4075         end loop;
4076      end if;
4077
4078      --  Generate listing of calls passed to the backend
4079
4080      if Present (Backend_Calls) then
4081         Count := 0;
4082
4083         Elmt := First_Elmt (Backend_Calls);
4084         while Present (Elmt) loop
4085            Nod := Node (Elmt);
4086
4087            if In_Extended_Main_Code_Unit (Nod) then
4088               Count := Count + 1;
4089
4090               if Count = 1 then
4091                  Write_Str ("List of inlined calls passed to the backend");
4092                  Write_Eol;
4093               end if;
4094
4095               Write_Str ("  ");
4096               Write_Int (Count);
4097               Write_Str (":");
4098               Write_Location (Sloc (Nod));
4099               Output.Write_Eol;
4100            end if;
4101
4102            Next_Elmt (Elmt);
4103         end loop;
4104      end if;
4105
4106      --  Generate listing of subprograms passed to the backend
4107
4108      if Present (Backend_Inlined_Subps) and then Back_End_Inlining then
4109         Count := 0;
4110
4111         Elmt := First_Elmt (Backend_Inlined_Subps);
4112         while Present (Elmt) loop
4113            Nod := Node (Elmt);
4114
4115            Count := Count + 1;
4116
4117            if Count = 1 then
4118               Write_Str
4119                 ("List of inlined subprograms passed to the backend");
4120               Write_Eol;
4121            end if;
4122
4123            Write_Str ("  ");
4124            Write_Int (Count);
4125            Write_Str (":");
4126            Write_Name (Chars (Nod));
4127            Write_Str (" (");
4128            Write_Location (Sloc (Nod));
4129            Write_Str (")");
4130            Output.Write_Eol;
4131
4132            Next_Elmt (Elmt);
4133         end loop;
4134      end if;
4135
4136      --  Generate listing of subprograms that cannot be inlined by the backend
4137
4138      if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then
4139         Count := 0;
4140
4141         Elmt := First_Elmt (Backend_Not_Inlined_Subps);
4142         while Present (Elmt) loop
4143            Nod := Node (Elmt);
4144
4145            Count := Count + 1;
4146
4147            if Count = 1 then
4148               Write_Str
4149                 ("List of subprograms that cannot be inlined by the backend");
4150               Write_Eol;
4151            end if;
4152
4153            Write_Str ("  ");
4154            Write_Int (Count);
4155            Write_Str (":");
4156            Write_Name (Chars (Nod));
4157            Write_Str (" (");
4158            Write_Location (Sloc (Nod));
4159            Write_Str (")");
4160            Output.Write_Eol;
4161
4162            Next_Elmt (Elmt);
4163         end loop;
4164      end if;
4165   end List_Inlining_Info;
4166
4167   ----------
4168   -- Lock --
4169   ----------
4170
4171   procedure Lock is
4172   begin
4173      Pending_Instantiations.Release;
4174      Pending_Instantiations.Locked := True;
4175      Inlined_Bodies.Release;
4176      Inlined_Bodies.Locked := True;
4177      Successors.Release;
4178      Successors.Locked := True;
4179      Inlined.Release;
4180      Inlined.Locked := True;
4181   end Lock;
4182
4183   --------------------------------
4184   -- Remove_Aspects_And_Pragmas --
4185   --------------------------------
4186
4187   procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is
4188      procedure Remove_Items (List : List_Id);
4189      --  Remove all useless aspects/pragmas from a particular list
4190
4191      ------------------
4192      -- Remove_Items --
4193      ------------------
4194
4195      procedure Remove_Items (List : List_Id) is
4196         Item      : Node_Id;
4197         Item_Id   : Node_Id;
4198         Next_Item : Node_Id;
4199
4200      begin
4201         --  Traverse the list looking for an aspect specification or a pragma
4202
4203         Item := First (List);
4204         while Present (Item) loop
4205            Next_Item := Next (Item);
4206
4207            if Nkind (Item) = N_Aspect_Specification then
4208               Item_Id := Identifier (Item);
4209            elsif Nkind (Item) = N_Pragma then
4210               Item_Id := Pragma_Identifier (Item);
4211            else
4212               Item_Id := Empty;
4213            end if;
4214
4215            if Present (Item_Id)
4216              and then Nam_In (Chars (Item_Id), Name_Contract_Cases,
4217                                                Name_Global,
4218                                                Name_Depends,
4219                                                Name_Postcondition,
4220                                                Name_Precondition,
4221                                                Name_Refined_Global,
4222                                                Name_Refined_Depends,
4223                                                Name_Refined_Post,
4224                                                Name_Test_Case,
4225                                                Name_Unmodified,
4226                                                Name_Unreferenced,
4227                                                Name_Unused)
4228            then
4229               Remove (Item);
4230            end if;
4231
4232            Item := Next_Item;
4233         end loop;
4234      end Remove_Items;
4235
4236   --  Start of processing for Remove_Aspects_And_Pragmas
4237
4238   begin
4239      Remove_Items (Aspect_Specifications (Body_Decl));
4240      Remove_Items (Declarations          (Body_Decl));
4241
4242      --  Pragmas Unmodified, Unreferenced, and Unused may additionally appear
4243      --  in the body of the subprogram.
4244
4245      Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl)));
4246   end Remove_Aspects_And_Pragmas;
4247
4248   --------------------------
4249   -- Remove_Dead_Instance --
4250   --------------------------
4251
4252   procedure Remove_Dead_Instance (N : Node_Id) is
4253      J : Int;
4254
4255   begin
4256      J := 0;
4257      while J <= Pending_Instantiations.Last loop
4258         if Pending_Instantiations.Table (J).Inst_Node = N then
4259            Pending_Instantiations.Table (J).Inst_Node := Empty;
4260            return;
4261         end if;
4262
4263         J := J + 1;
4264      end loop;
4265   end Remove_Dead_Instance;
4266
4267end Inline;
4268